OpenCores
URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-stable/] [gcc-4.5.1/] [gcc/] [ada/] [sem_ch6.adb] - Blame information for rev 826

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 281 jeremybenn
------------------------------------------------------------------------------
2
--                                                                          --
3
--                         GNAT COMPILER COMPONENTS                         --
4
--                                                                          --
5
--                              S E M _ C H 6                               --
6
--                                                                          --
7
--                                 B o d y                                  --
8
--                                                                          --
9
--          Copyright (C) 1992-2009, Free Software Foundation, Inc.         --
10
--                                                                          --
11
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
12
-- terms of the  GNU General Public License as published  by the Free Soft- --
13
-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
14
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
15
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
16
-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
17
-- for  more details.  You should have  received  a copy of the GNU General --
18
-- Public License  distributed with GNAT; see file COPYING3.  If not, go to --
19
-- http://www.gnu.org/licenses for a complete copy of the license.          --
20
--                                                                          --
21
-- GNAT was originally developed  by the GNAT team at  New York University. --
22
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
23
--                                                                          --
24
------------------------------------------------------------------------------
25
 
26
with Atree;    use Atree;
27
with Checks;   use Checks;
28
with Debug;    use Debug;
29
with Einfo;    use Einfo;
30
with Elists;   use Elists;
31
with Errout;   use Errout;
32
with Expander; use Expander;
33
with Exp_Ch6;  use Exp_Ch6;
34
with Exp_Ch7;  use Exp_Ch7;
35
with Exp_Ch9;  use Exp_Ch9;
36
with Exp_Disp; use Exp_Disp;
37
with Exp_Tss;  use Exp_Tss;
38
with Exp_Util; use Exp_Util;
39
with Fname;    use Fname;
40
with Freeze;   use Freeze;
41
with Itypes;   use Itypes;
42
with Lib.Xref; use Lib.Xref;
43
with Layout;   use Layout;
44
with Namet;    use Namet;
45
with Lib;      use Lib;
46
with Nlists;   use Nlists;
47
with Nmake;    use Nmake;
48
with Opt;      use Opt;
49
with Output;   use Output;
50
with Restrict; use Restrict;
51
with Rident;   use Rident;
52
with Rtsfind;  use Rtsfind;
53
with Sem;      use Sem;
54
with Sem_Aux;  use Sem_Aux;
55
with Sem_Cat;  use Sem_Cat;
56
with Sem_Ch3;  use Sem_Ch3;
57
with Sem_Ch4;  use Sem_Ch4;
58
with Sem_Ch5;  use Sem_Ch5;
59
with Sem_Ch8;  use Sem_Ch8;
60
with Sem_Ch10; use Sem_Ch10;
61
with Sem_Ch12; use Sem_Ch12;
62
with Sem_Disp; use Sem_Disp;
63
with Sem_Dist; use Sem_Dist;
64
with Sem_Elim; use Sem_Elim;
65
with Sem_Eval; use Sem_Eval;
66
with Sem_Mech; use Sem_Mech;
67
with Sem_Prag; use Sem_Prag;
68
with Sem_Res;  use Sem_Res;
69
with Sem_Util; use Sem_Util;
70
with Sem_Type; use Sem_Type;
71
with Sem_Warn; use Sem_Warn;
72
with Sinput;   use Sinput;
73
with Stand;    use Stand;
74
with Sinfo;    use Sinfo;
75
with Sinfo.CN; use Sinfo.CN;
76
with Snames;   use Snames;
77
with Stringt;  use Stringt;
78
with Style;
79
with Stylesw;  use Stylesw;
80
with Tbuild;   use Tbuild;
81
with Uintp;    use Uintp;
82
with Urealp;   use Urealp;
83
with Validsw;  use Validsw;
84
 
85
package body Sem_Ch6 is
86
 
87
   May_Hide_Profile : Boolean := False;
88
   --  This flag is used to indicate that two formals in two subprograms being
89
   --  checked for conformance differ only in that one is an access parameter
90
   --  while the other is of a general access type with the same designated
91
   --  type. In this case, if the rest of the signatures match, a call to
92
   --  either subprogram may be ambiguous, which is worth a warning. The flag
93
   --  is set in Compatible_Types, and the warning emitted in
94
   --  New_Overloaded_Entity.
95
 
96
   -----------------------
97
   -- Local Subprograms --
98
   -----------------------
99
 
100
   procedure Analyze_Return_Statement (N : Node_Id);
101
   --  Common processing for simple_ and extended_return_statements
102
 
103
   procedure Analyze_Function_Return (N : Node_Id);
104
   --  Subsidiary to Analyze_Return_Statement. Called when the return statement
105
   --  applies to a [generic] function.
106
 
107
   procedure Analyze_Return_Type (N : Node_Id);
108
   --  Subsidiary to Process_Formals: analyze subtype mark in function
109
   --  specification, in a context where the formals are visible and hide
110
   --  outer homographs.
111
 
112
   procedure Analyze_Subprogram_Body_Helper (N : Node_Id);
113
   --  Does all the real work of Analyze_Subprogram_Body
114
 
115
   procedure Analyze_Generic_Subprogram_Body (N : Node_Id; Gen_Id : Entity_Id);
116
   --  Analyze a generic subprogram body. N is the body to be analyzed, and
117
   --  Gen_Id is the defining entity Id for the corresponding spec.
118
 
119
   procedure Build_Body_To_Inline (N : Node_Id; Subp : Entity_Id);
120
   --  If a subprogram has pragma Inline and inlining is active, use generic
121
   --  machinery to build an unexpanded body for the subprogram. This body is
122
   --  subsequently used for inline expansions at call sites. If subprogram can
123
   --  be inlined (depending on size and nature of local declarations) this
124
   --  function returns true. Otherwise subprogram body is treated normally.
125
   --  If proper warnings are enabled and the subprogram contains a construct
126
   --  that cannot be inlined, the offending construct is flagged accordingly.
127
 
128
   procedure Check_Conformance
129
     (New_Id                   : Entity_Id;
130
      Old_Id                   : Entity_Id;
131
      Ctype                    : Conformance_Type;
132
      Errmsg                   : Boolean;
133
      Conforms                 : out Boolean;
134
      Err_Loc                  : Node_Id := Empty;
135
      Get_Inst                 : Boolean := False;
136
      Skip_Controlling_Formals : Boolean := False);
137
   --  Given two entities, this procedure checks that the profiles associated
138
   --  with these entities meet the conformance criterion given by the third
139
   --  parameter. If they conform, Conforms is set True and control returns
140
   --  to the caller. If they do not conform, Conforms is set to False, and
141
   --  in addition, if Errmsg is True on the call, proper messages are output
142
   --  to complain about the conformance failure. If Err_Loc is non_Empty
143
   --  the error messages are placed on Err_Loc, if Err_Loc is empty, then
144
   --  error messages are placed on the appropriate part of the construct
145
   --  denoted by New_Id. If Get_Inst is true, then this is a mode conformance
146
   --  against a formal access-to-subprogram type so Get_Instance_Of must
147
   --  be called.
148
 
149
   procedure Check_Subprogram_Order (N : Node_Id);
150
   --  N is the N_Subprogram_Body node for a subprogram. This routine applies
151
   --  the alpha ordering rule for N if this ordering requirement applicable.
152
 
153
   procedure Check_Returns
154
     (HSS  : Node_Id;
155
      Mode : Character;
156
      Err  : out Boolean;
157
      Proc : Entity_Id := Empty);
158
   --  Called to check for missing return statements in a function body, or for
159
   --  returns present in a procedure body which has No_Return set. HSS is the
160
   --  handled statement sequence for the subprogram body. This procedure
161
   --  checks all flow paths to make sure they either have return (Mode = 'F',
162
   --  used for functions) or do not have a return (Mode = 'P', used for
163
   --  No_Return procedures). The flag Err is set if there are any control
164
   --  paths not explicitly terminated by a return in the function case, and is
165
   --  True otherwise. Proc is the entity for the procedure case and is used
166
   --  in posting the warning message.
167
 
168
   procedure Enter_Overloaded_Entity (S : Entity_Id);
169
   --  This procedure makes S, a new overloaded entity, into the first visible
170
   --  entity with that name.
171
 
172
   procedure Install_Entity (E : Entity_Id);
173
   --  Make single entity visible. Used for generic formals as well
174
 
175
   function Is_Non_Overriding_Operation
176
     (Prev_E : Entity_Id;
177
      New_E  : Entity_Id) return Boolean;
178
   --  Enforce the rule given in 12.3(18): a private operation in an instance
179
   --  overrides an inherited operation only if the corresponding operation
180
   --  was overriding in the generic. This can happen for primitive operations
181
   --  of types derived (in the generic unit) from formal private or formal
182
   --  derived types.
183
 
184
   procedure Make_Inequality_Operator (S : Entity_Id);
185
   --  Create the declaration for an inequality operator that is implicitly
186
   --  created by a user-defined equality operator that yields a boolean.
187
 
188
   procedure May_Need_Actuals (Fun : Entity_Id);
189
   --  Flag functions that can be called without parameters, i.e. those that
190
   --  have no parameters, or those for which defaults exist for all parameters
191
 
192
   procedure Process_PPCs
193
     (N       : Node_Id;
194
      Spec_Id : Entity_Id;
195
      Body_Id : Entity_Id);
196
   --  Called from Analyze[_Generic]_Subprogram_Body to deal with scanning post
197
   --  conditions for the body and assembling and inserting the _postconditions
198
   --  procedure. N is the node for the subprogram body and Body_Id/Spec_Id are
199
   --  the entities for the body and separate spec (if there is no separate
200
   --  spec, Spec_Id is Empty).
201
 
202
   procedure Set_Formal_Validity (Formal_Id : Entity_Id);
203
   --  Formal_Id is an formal parameter entity. This procedure deals with
204
   --  setting the proper validity status for this entity, which depends on
205
   --  the kind of parameter and the validity checking mode.
206
 
207
   ------------------------------
208
   -- Analyze_Return_Statement --
209
   ------------------------------
210
 
211
   procedure Analyze_Return_Statement (N : Node_Id) is
212
 
213
      pragma Assert (Nkind_In (N, N_Simple_Return_Statement,
214
                                  N_Extended_Return_Statement));
215
 
216
      Returns_Object : constant Boolean :=
217
                         Nkind (N) = N_Extended_Return_Statement
218
                           or else
219
                            (Nkind (N) = N_Simple_Return_Statement
220
                              and then Present (Expression (N)));
221
      --  True if we're returning something; that is, "return <expression>;"
222
      --  or "return Result : T [:= ...]". False for "return;". Used for error
223
      --  checking: If Returns_Object is True, N should apply to a function
224
      --  body; otherwise N should apply to a procedure body, entry body,
225
      --  accept statement, or extended return statement.
226
 
227
      function Find_What_It_Applies_To return Entity_Id;
228
      --  Find the entity representing the innermost enclosing body, accept
229
      --  statement, or extended return statement. If the result is a callable
230
      --  construct or extended return statement, then this will be the value
231
      --  of the Return_Applies_To attribute. Otherwise, the program is
232
      --  illegal. See RM-6.5(4/2).
233
 
234
      -----------------------------
235
      -- Find_What_It_Applies_To --
236
      -----------------------------
237
 
238
      function Find_What_It_Applies_To return Entity_Id is
239
         Result : Entity_Id := Empty;
240
 
241
      begin
242
         --  Loop outward through the Scope_Stack, skipping blocks and loops
243
 
244
         for J in reverse 0 .. Scope_Stack.Last loop
245
            Result := Scope_Stack.Table (J).Entity;
246
            exit when Ekind (Result) /= E_Block and then
247
                      Ekind (Result) /= E_Loop;
248
         end loop;
249
 
250
         pragma Assert (Present (Result));
251
         return Result;
252
      end Find_What_It_Applies_To;
253
 
254
      --  Local declarations
255
 
256
      Scope_Id   : constant Entity_Id   := Find_What_It_Applies_To;
257
      Kind       : constant Entity_Kind := Ekind (Scope_Id);
258
      Loc        : constant Source_Ptr  := Sloc (N);
259
      Stm_Entity : constant Entity_Id   :=
260
                     New_Internal_Entity
261
                       (E_Return_Statement, Current_Scope, Loc, 'R');
262
 
263
   --  Start of processing for Analyze_Return_Statement
264
 
265
   begin
266
      Set_Return_Statement_Entity (N, Stm_Entity);
267
 
268
      Set_Etype (Stm_Entity, Standard_Void_Type);
269
      Set_Return_Applies_To (Stm_Entity, Scope_Id);
270
 
271
      --  Place Return entity on scope stack, to simplify enforcement of 6.5
272
      --  (4/2): an inner return statement will apply to this extended return.
273
 
274
      if Nkind (N) = N_Extended_Return_Statement then
275
         Push_Scope (Stm_Entity);
276
      end if;
277
 
278
      --  Check that pragma No_Return is obeyed. Don't complain about the
279
      --  implicitly-generated return that is placed at the end.
280
 
281
      if No_Return (Scope_Id) and then Comes_From_Source (N) then
282
         Error_Msg_N ("RETURN statement not allowed (No_Return)", N);
283
      end if;
284
 
285
      --  Warn on any unassigned OUT parameters if in procedure
286
 
287
      if Ekind (Scope_Id) = E_Procedure then
288
         Warn_On_Unassigned_Out_Parameter (N, Scope_Id);
289
      end if;
290
 
291
      --  Check that functions return objects, and other things do not
292
 
293
      if Kind = E_Function or else Kind = E_Generic_Function then
294
         if not Returns_Object then
295
            Error_Msg_N ("missing expression in return from function", N);
296
         end if;
297
 
298
      elsif Kind = E_Procedure or else Kind = E_Generic_Procedure then
299
         if Returns_Object then
300
            Error_Msg_N ("procedure cannot return value (use function)", N);
301
         end if;
302
 
303
      elsif Kind = E_Entry or else Kind = E_Entry_Family then
304
         if Returns_Object then
305
            if Is_Protected_Type (Scope (Scope_Id)) then
306
               Error_Msg_N ("entry body cannot return value", N);
307
            else
308
               Error_Msg_N ("accept statement cannot return value", N);
309
            end if;
310
         end if;
311
 
312
      elsif Kind = E_Return_Statement then
313
 
314
         --  We are nested within another return statement, which must be an
315
         --  extended_return_statement.
316
 
317
         if Returns_Object then
318
            Error_Msg_N
319
              ("extended_return_statement cannot return value; " &
320
               "use `""RETURN;""`", N);
321
         end if;
322
 
323
      else
324
         Error_Msg_N ("illegal context for return statement", N);
325
      end if;
326
 
327
      if Kind = E_Function or else Kind = E_Generic_Function then
328
         Analyze_Function_Return (N);
329
      end if;
330
 
331
      if Nkind (N) = N_Extended_Return_Statement then
332
         End_Scope;
333
      end if;
334
 
335
      Kill_Current_Values (Last_Assignment_Only => True);
336
      Check_Unreachable_Code (N);
337
   end Analyze_Return_Statement;
338
 
339
   ---------------------------------------------
340
   -- Analyze_Abstract_Subprogram_Declaration --
341
   ---------------------------------------------
342
 
343
   procedure Analyze_Abstract_Subprogram_Declaration (N : Node_Id) is
344
      Designator : constant Entity_Id :=
345
                     Analyze_Subprogram_Specification (Specification (N));
346
      Scop       : constant Entity_Id := Current_Scope;
347
 
348
   begin
349
      Generate_Definition (Designator);
350
      Set_Is_Abstract_Subprogram (Designator);
351
      New_Overloaded_Entity (Designator);
352
      Check_Delayed_Subprogram (Designator);
353
 
354
      Set_Categorization_From_Scope (Designator, Scop);
355
 
356
      if Ekind (Scope (Designator)) = E_Protected_Type then
357
         Error_Msg_N
358
           ("abstract subprogram not allowed in protected type", N);
359
 
360
      --  Issue a warning if the abstract subprogram is neither a dispatching
361
      --  operation nor an operation that overrides an inherited subprogram or
362
      --  predefined operator, since this most likely indicates a mistake.
363
 
364
      elsif Warn_On_Redundant_Constructs
365
        and then not Is_Dispatching_Operation (Designator)
366
        and then not Is_Overriding_Operation (Designator)
367
        and then (not Is_Operator_Symbol_Name (Chars (Designator))
368
                   or else Scop /= Scope (Etype (First_Formal (Designator))))
369
      then
370
         Error_Msg_N
371
           ("?abstract subprogram is not dispatching or overriding", N);
372
      end if;
373
 
374
      Generate_Reference_To_Formals (Designator);
375
      Check_Eliminated (Designator);
376
   end Analyze_Abstract_Subprogram_Declaration;
377
 
378
   ----------------------------------------
379
   -- Analyze_Extended_Return_Statement  --
380
   ----------------------------------------
381
 
382
   procedure Analyze_Extended_Return_Statement (N : Node_Id) is
383
   begin
384
      Analyze_Return_Statement (N);
385
   end Analyze_Extended_Return_Statement;
386
 
387
   ----------------------------
388
   -- Analyze_Function_Call  --
389
   ----------------------------
390
 
391
   procedure Analyze_Function_Call (N : Node_Id) is
392
      P      : constant Node_Id := Name (N);
393
      L      : constant List_Id := Parameter_Associations (N);
394
      Actual : Node_Id;
395
 
396
   begin
397
      Analyze (P);
398
 
399
      --  A call of the form A.B (X) may be an Ada05 call, which is rewritten
400
      --  as B (A, X). If the rewriting is successful, the call has been
401
      --  analyzed and we just return.
402
 
403
      if Nkind (P) = N_Selected_Component
404
        and then Name (N) /= P
405
        and then Is_Rewrite_Substitution (N)
406
        and then Present (Etype (N))
407
      then
408
         return;
409
      end if;
410
 
411
      --  If error analyzing name, then set Any_Type as result type and return
412
 
413
      if Etype (P) = Any_Type then
414
         Set_Etype (N, Any_Type);
415
         return;
416
      end if;
417
 
418
      --  Otherwise analyze the parameters
419
 
420
      if Present (L) then
421
         Actual := First (L);
422
         while Present (Actual) loop
423
            Analyze (Actual);
424
            Check_Parameterless_Call (Actual);
425
            Next (Actual);
426
         end loop;
427
      end if;
428
 
429
      Analyze_Call (N);
430
   end Analyze_Function_Call;
431
 
432
   -----------------------------
433
   -- Analyze_Function_Return --
434
   -----------------------------
435
 
436
   procedure Analyze_Function_Return (N : Node_Id) is
437
      Loc        : constant Source_Ptr  := Sloc (N);
438
      Stm_Entity : constant Entity_Id   := Return_Statement_Entity (N);
439
      Scope_Id   : constant Entity_Id   := Return_Applies_To (Stm_Entity);
440
 
441
      R_Type : constant Entity_Id := Etype (Scope_Id);
442
      --  Function result subtype
443
 
444
      procedure Check_Limited_Return (Expr : Node_Id);
445
      --  Check the appropriate (Ada 95 or Ada 2005) rules for returning
446
      --  limited types. Used only for simple return statements.
447
      --  Expr is the expression returned.
448
 
449
      procedure Check_Return_Subtype_Indication (Obj_Decl : Node_Id);
450
      --  Check that the return_subtype_indication properly matches the result
451
      --  subtype of the function, as required by RM-6.5(5.1/2-5.3/2).
452
 
453
      --------------------------
454
      -- Check_Limited_Return --
455
      --------------------------
456
 
457
      procedure Check_Limited_Return (Expr : Node_Id) is
458
      begin
459
         --  Ada 2005 (AI-318-02): Return-by-reference types have been
460
         --  removed and replaced by anonymous access results. This is an
461
         --  incompatibility with Ada 95. Not clear whether this should be
462
         --  enforced yet or perhaps controllable with special switch. ???
463
 
464
         if Is_Limited_Type (R_Type)
465
           and then Comes_From_Source (N)
466
           and then not In_Instance_Body
467
           and then not OK_For_Limited_Init_In_05 (R_Type, Expr)
468
         then
469
            --  Error in Ada 2005
470
 
471
            if Ada_Version >= Ada_05
472
              and then not Debug_Flag_Dot_L
473
              and then not GNAT_Mode
474
            then
475
               Error_Msg_N
476
                 ("(Ada 2005) cannot copy object of a limited type " &
477
                  "(RM-2005 6.5(5.5/2))", Expr);
478
               if Is_Inherently_Limited_Type (R_Type) then
479
                  Error_Msg_N
480
                    ("\return by reference not permitted in Ada 2005", Expr);
481
               end if;
482
 
483
            --  Warn in Ada 95 mode, to give folks a heads up about this
484
            --  incompatibility.
485
 
486
            --  In GNAT mode, this is just a warning, to allow it to be
487
            --  evilly turned off. Otherwise it is a real error.
488
 
489
            elsif Warn_On_Ada_2005_Compatibility or GNAT_Mode then
490
               if Is_Inherently_Limited_Type (R_Type) then
491
                  Error_Msg_N
492
                    ("return by reference not permitted in Ada 2005 " &
493
                     "(RM-2005 6.5(5.5/2))?", Expr);
494
               else
495
                  Error_Msg_N
496
                    ("cannot copy object of a limited type in Ada 2005 " &
497
                     "(RM-2005 6.5(5.5/2))?", Expr);
498
               end if;
499
 
500
            --  Ada 95 mode, compatibility warnings disabled
501
 
502
            else
503
               return; --  skip continuation messages below
504
            end if;
505
 
506
            Error_Msg_N
507
              ("\consider switching to return of access type", Expr);
508
            Explain_Limited_Type (R_Type, Expr);
509
         end if;
510
      end Check_Limited_Return;
511
 
512
      -------------------------------------
513
      -- Check_Return_Subtype_Indication --
514
      -------------------------------------
515
 
516
      procedure Check_Return_Subtype_Indication (Obj_Decl : Node_Id) is
517
         Return_Obj  : constant Node_Id   := Defining_Identifier (Obj_Decl);
518
         R_Stm_Type  : constant Entity_Id := Etype (Return_Obj);
519
         --  Subtype given in the extended return statement;
520
         --  this must match R_Type.
521
 
522
         Subtype_Ind : constant Node_Id :=
523
                         Object_Definition (Original_Node (Obj_Decl));
524
 
525
         R_Type_Is_Anon_Access :
526
           constant Boolean :=
527
             Ekind (R_Type) = E_Anonymous_Access_Subprogram_Type
528
               or else
529
             Ekind (R_Type) = E_Anonymous_Access_Protected_Subprogram_Type
530
               or else
531
             Ekind (R_Type) = E_Anonymous_Access_Type;
532
         --  True if return type of the function is an anonymous access type
533
         --  Can't we make Is_Anonymous_Access_Type in einfo ???
534
 
535
         R_Stm_Type_Is_Anon_Access :
536
           constant Boolean :=
537
             Ekind (R_Stm_Type) = E_Anonymous_Access_Subprogram_Type
538
               or else
539
             Ekind (R_Stm_Type) = E_Anonymous_Access_Protected_Subprogram_Type
540
               or else
541
             Ekind (R_Stm_Type) = E_Anonymous_Access_Type;
542
         --  True if type of the return object is an anonymous access type
543
 
544
      begin
545
         --  First, avoid cascade errors:
546
 
547
         if Error_Posted (Obj_Decl) or else Error_Posted (Subtype_Ind) then
548
            return;
549
         end if;
550
 
551
         --  "return access T" case; check that the return statement also has
552
         --  "access T", and that the subtypes statically match:
553
         --   if this is an access to subprogram the signatures must match.
554
 
555
         if R_Type_Is_Anon_Access then
556
            if R_Stm_Type_Is_Anon_Access then
557
               if
558
                 Ekind (Designated_Type (R_Stm_Type)) /= E_Subprogram_Type
559
               then
560
                  if Base_Type (Designated_Type (R_Stm_Type)) /=
561
                     Base_Type (Designated_Type (R_Type))
562
                    or else not Subtypes_Statically_Match (R_Stm_Type, R_Type)
563
                  then
564
                     Error_Msg_N
565
                      ("subtype must statically match function result subtype",
566
                       Subtype_Mark (Subtype_Ind));
567
                  end if;
568
 
569
               else
570
                  --  For two anonymous access to subprogram types, the
571
                  --  types themselves must be type conformant.
572
 
573
                  if not Conforming_Types
574
                    (R_Stm_Type, R_Type, Fully_Conformant)
575
                  then
576
                     Error_Msg_N
577
                      ("subtype must statically match function result subtype",
578
                         Subtype_Ind);
579
                  end if;
580
               end if;
581
 
582
            else
583
               Error_Msg_N ("must use anonymous access type", Subtype_Ind);
584
            end if;
585
 
586
         --  Subtype indication case: check that the return object's type is
587
         --  covered by the result type, and that the subtypes statically match
588
         --  when the result subtype is constrained. Also handle record types
589
         --  with unknown discriminants for which we have built the underlying
590
         --  record view. Coverage is needed to allow specific-type return
591
         --  objects when the result type is class-wide (see AI05-32).
592
 
593
         elsif Covers (Base_Type (R_Type), Base_Type (R_Stm_Type))
594
           or else (Is_Underlying_Record_View (Base_Type (R_Stm_Type))
595
                     and then
596
                       Covers
597
                         (Base_Type (R_Type),
598
                          Underlying_Record_View (Base_Type (R_Stm_Type))))
599
         then
600
            --  A null exclusion may be present on the return type, on the
601
            --  function specification, on the object declaration or on the
602
            --  subtype itself.
603
 
604
            if Is_Access_Type (R_Type)
605
              and then
606
               (Can_Never_Be_Null (R_Type)
607
                 or else Null_Exclusion_Present (Parent (Scope_Id))) /=
608
                                              Can_Never_Be_Null (R_Stm_Type)
609
            then
610
               Error_Msg_N
611
                 ("subtype must statically match function result subtype",
612
                  Subtype_Ind);
613
            end if;
614
 
615
            if Is_Constrained (R_Type) then
616
               if not Subtypes_Statically_Match (R_Stm_Type, R_Type) then
617
                  Error_Msg_N
618
                    ("subtype must statically match function result subtype",
619
                     Subtype_Ind);
620
               end if;
621
            end if;
622
 
623
         elsif Etype (Base_Type (R_Type)) = R_Stm_Type
624
           and then Is_Null_Extension (Base_Type (R_Type))
625
         then
626
            null;
627
 
628
         else
629
            Error_Msg_N
630
              ("wrong type for return_subtype_indication", Subtype_Ind);
631
         end if;
632
      end Check_Return_Subtype_Indication;
633
 
634
      ---------------------
635
      -- Local Variables --
636
      ---------------------
637
 
638
      Expr : Node_Id;
639
 
640
   --  Start of processing for Analyze_Function_Return
641
 
642
   begin
643
      Set_Return_Present (Scope_Id);
644
 
645
      if Nkind (N) = N_Simple_Return_Statement then
646
         Expr := Expression (N);
647
         Analyze_And_Resolve (Expr, R_Type);
648
         Check_Limited_Return (Expr);
649
 
650
      else
651
         --  Analyze parts specific to extended_return_statement:
652
 
653
         declare
654
            Obj_Decl : constant Node_Id :=
655
                         Last (Return_Object_Declarations (N));
656
 
657
            HSS : constant Node_Id := Handled_Statement_Sequence (N);
658
 
659
         begin
660
            Expr := Expression (Obj_Decl);
661
 
662
            --  Note: The check for OK_For_Limited_Init will happen in
663
            --  Analyze_Object_Declaration; we treat it as a normal
664
            --  object declaration.
665
 
666
            Set_Is_Return_Object (Defining_Identifier (Obj_Decl));
667
            Analyze (Obj_Decl);
668
 
669
            Check_Return_Subtype_Indication (Obj_Decl);
670
 
671
            if Present (HSS) then
672
               Analyze (HSS);
673
 
674
               if Present (Exception_Handlers (HSS)) then
675
 
676
                  --  ???Has_Nested_Block_With_Handler needs to be set.
677
                  --  Probably by creating an actual N_Block_Statement.
678
                  --  Probably in Expand.
679
 
680
                  null;
681
               end if;
682
            end if;
683
 
684
            --  Mark the return object as referenced, since the return is an
685
            --  implicit reference of the object.
686
 
687
            Set_Referenced (Defining_Identifier (Obj_Decl));
688
 
689
            Check_References (Stm_Entity);
690
         end;
691
      end if;
692
 
693
      --  Case of Expr present
694
 
695
      if Present (Expr)
696
 
697
         --  Defend against previous errors
698
 
699
        and then Nkind (Expr) /= N_Empty
700
        and then Present (Etype (Expr))
701
      then
702
         --  Apply constraint check. Note that this is done before the implicit
703
         --  conversion of the expression done for anonymous access types to
704
         --  ensure correct generation of the null-excluding check associated
705
         --  with null-excluding expressions found in return statements.
706
 
707
         Apply_Constraint_Check (Expr, R_Type);
708
 
709
         --  Ada 2005 (AI-318-02): When the result type is an anonymous access
710
         --  type, apply an implicit conversion of the expression to that type
711
         --  to force appropriate static and run-time accessibility checks.
712
 
713
         if Ada_Version >= Ada_05
714
           and then Ekind (R_Type) = E_Anonymous_Access_Type
715
         then
716
            Rewrite (Expr, Convert_To (R_Type, Relocate_Node (Expr)));
717
            Analyze_And_Resolve (Expr, R_Type);
718
         end if;
719
 
720
         --  If the result type is class-wide, then check that the return
721
         --  expression's type is not declared at a deeper level than the
722
         --  function (RM05-6.5(5.6/2)).
723
 
724
         if Ada_Version >= Ada_05
725
           and then Is_Class_Wide_Type (R_Type)
726
         then
727
            if Type_Access_Level (Etype (Expr)) >
728
                 Subprogram_Access_Level (Scope_Id)
729
            then
730
               Error_Msg_N
731
                 ("level of return expression type is deeper than " &
732
                  "class-wide function!", Expr);
733
            end if;
734
         end if;
735
 
736
         --  Check incorrect use of dynamically tagged expression
737
 
738
         if Is_Tagged_Type (R_Type) then
739
            Check_Dynamically_Tagged_Expression
740
              (Expr => Expr,
741
               Typ  => R_Type,
742
               Related_Nod => N);
743
         end if;
744
 
745
         --  ??? A real run-time accessibility check is needed in cases
746
         --  involving dereferences of access parameters. For now we just
747
         --  check the static cases.
748
 
749
         if (Ada_Version < Ada_05 or else Debug_Flag_Dot_L)
750
           and then Is_Inherently_Limited_Type (Etype (Scope_Id))
751
           and then Object_Access_Level (Expr) >
752
                      Subprogram_Access_Level (Scope_Id)
753
         then
754
            Rewrite (N,
755
              Make_Raise_Program_Error (Loc,
756
                Reason => PE_Accessibility_Check_Failed));
757
            Analyze (N);
758
 
759
            Error_Msg_N
760
              ("cannot return a local value by reference?", N);
761
            Error_Msg_NE
762
              ("\& will be raised at run time?",
763
               N, Standard_Program_Error);
764
         end if;
765
 
766
         if Known_Null (Expr)
767
           and then Nkind (Parent (Scope_Id)) = N_Function_Specification
768
           and then Null_Exclusion_Present (Parent (Scope_Id))
769
         then
770
            Apply_Compile_Time_Constraint_Error
771
              (N      => Expr,
772
               Msg    => "(Ada 2005) null not allowed for "
773
                         & "null-excluding return?",
774
               Reason => CE_Null_Not_Allowed);
775
         end if;
776
      end if;
777
   end Analyze_Function_Return;
778
 
779
   -------------------------------------
780
   -- Analyze_Generic_Subprogram_Body --
781
   -------------------------------------
782
 
783
   procedure Analyze_Generic_Subprogram_Body
784
     (N      : Node_Id;
785
      Gen_Id : Entity_Id)
786
   is
787
      Gen_Decl : constant Node_Id     := Unit_Declaration_Node (Gen_Id);
788
      Kind     : constant Entity_Kind := Ekind (Gen_Id);
789
      Body_Id  : Entity_Id;
790
      New_N    : Node_Id;
791
      Spec     : Node_Id;
792
 
793
   begin
794
      --  Copy body and disable expansion while analyzing the generic For a
795
      --  stub, do not copy the stub (which would load the proper body), this
796
      --  will be done when the proper body is analyzed.
797
 
798
      if Nkind (N) /= N_Subprogram_Body_Stub then
799
         New_N := Copy_Generic_Node (N, Empty, Instantiating => False);
800
         Rewrite (N, New_N);
801
         Start_Generic;
802
      end if;
803
 
804
      Spec := Specification (N);
805
 
806
      --  Within the body of the generic, the subprogram is callable, and
807
      --  behaves like the corresponding non-generic unit.
808
 
809
      Body_Id := Defining_Entity (Spec);
810
 
811
      if Kind = E_Generic_Procedure
812
        and then Nkind (Spec) /= N_Procedure_Specification
813
      then
814
         Error_Msg_N ("invalid body for generic procedure ", Body_Id);
815
         return;
816
 
817
      elsif Kind = E_Generic_Function
818
        and then Nkind (Spec) /= N_Function_Specification
819
      then
820
         Error_Msg_N ("invalid body for generic function ", Body_Id);
821
         return;
822
      end if;
823
 
824
      Set_Corresponding_Body (Gen_Decl, Body_Id);
825
 
826
      if Has_Completion (Gen_Id)
827
        and then Nkind (Parent (N)) /= N_Subunit
828
      then
829
         Error_Msg_N ("duplicate generic body", N);
830
         return;
831
      else
832
         Set_Has_Completion (Gen_Id);
833
      end if;
834
 
835
      if Nkind (N) = N_Subprogram_Body_Stub then
836
         Set_Ekind (Defining_Entity (Specification (N)), Kind);
837
      else
838
         Set_Corresponding_Spec (N, Gen_Id);
839
      end if;
840
 
841
      if Nkind (Parent (N)) = N_Compilation_Unit then
842
         Set_Cunit_Entity (Current_Sem_Unit, Defining_Entity (N));
843
      end if;
844
 
845
      --  Make generic parameters immediately visible in the body. They are
846
      --  needed to process the formals declarations. Then make the formals
847
      --  visible in a separate step.
848
 
849
      Push_Scope (Gen_Id);
850
 
851
      declare
852
         E         : Entity_Id;
853
         First_Ent : Entity_Id;
854
 
855
      begin
856
         First_Ent := First_Entity (Gen_Id);
857
 
858
         E := First_Ent;
859
         while Present (E) and then not Is_Formal (E) loop
860
            Install_Entity (E);
861
            Next_Entity (E);
862
         end loop;
863
 
864
         Set_Use (Generic_Formal_Declarations (Gen_Decl));
865
 
866
         --  Now generic formals are visible, and the specification can be
867
         --  analyzed, for subsequent conformance check.
868
 
869
         Body_Id := Analyze_Subprogram_Specification (Spec);
870
 
871
         --  Make formal parameters visible
872
 
873
         if Present (E) then
874
 
875
            --  E is the first formal parameter, we loop through the formals
876
            --  installing them so that they will be visible.
877
 
878
            Set_First_Entity (Gen_Id, E);
879
            while Present (E) loop
880
               Install_Entity (E);
881
               Next_Formal (E);
882
            end loop;
883
         end if;
884
 
885
         --  Visible generic entity is callable within its own body
886
 
887
         Set_Ekind          (Gen_Id,  Ekind (Body_Id));
888
         Set_Ekind          (Body_Id, E_Subprogram_Body);
889
         Set_Convention     (Body_Id, Convention (Gen_Id));
890
         Set_Is_Obsolescent (Body_Id, Is_Obsolescent (Gen_Id));
891
         Set_Scope          (Body_Id, Scope (Gen_Id));
892
         Check_Fully_Conformant (Body_Id, Gen_Id, Body_Id);
893
 
894
         if Nkind (N) = N_Subprogram_Body_Stub then
895
 
896
            --  No body to analyze, so restore state of generic unit
897
 
898
            Set_Ekind (Gen_Id, Kind);
899
            Set_Ekind (Body_Id, Kind);
900
 
901
            if Present (First_Ent) then
902
               Set_First_Entity (Gen_Id, First_Ent);
903
            end if;
904
 
905
            End_Scope;
906
            return;
907
         end if;
908
 
909
         --  If this is a compilation unit, it must be made visible explicitly,
910
         --  because the compilation of the declaration, unlike other library
911
         --  unit declarations, does not. If it is not a unit, the following
912
         --  is redundant but harmless.
913
 
914
         Set_Is_Immediately_Visible (Gen_Id);
915
         Reference_Body_Formals (Gen_Id, Body_Id);
916
 
917
         if Is_Child_Unit (Gen_Id) then
918
            Generate_Reference (Gen_Id, Scope (Gen_Id), 'k', False);
919
         end if;
920
 
921
         Set_Actual_Subtypes (N, Current_Scope);
922
         Process_PPCs (N, Gen_Id, Body_Id);
923
 
924
         --  If the generic unit carries pre- or post-conditions, copy them
925
         --  to the original generic tree, so that they are properly added
926
         --  to any instantiation.
927
 
928
         declare
929
            Orig : constant Node_Id := Original_Node (N);
930
            Cond : Node_Id;
931
 
932
         begin
933
            Cond := First (Declarations (N));
934
            while Present (Cond) loop
935
               if Nkind (Cond) = N_Pragma
936
                 and then Pragma_Name (Cond) = Name_Check
937
               then
938
                  Prepend (New_Copy_Tree (Cond), Declarations (Orig));
939
 
940
               elsif Nkind (Cond) = N_Pragma
941
                 and then Pragma_Name (Cond) = Name_Postcondition
942
               then
943
                  Set_Ekind (Defining_Entity (Orig), Ekind (Gen_Id));
944
                  Prepend (New_Copy_Tree (Cond), Declarations (Orig));
945
               else
946
                  exit;
947
               end if;
948
 
949
               Next (Cond);
950
            end loop;
951
         end;
952
 
953
         Analyze_Declarations (Declarations (N));
954
         Check_Completion;
955
         Analyze (Handled_Statement_Sequence (N));
956
 
957
         Save_Global_References (Original_Node (N));
958
 
959
         --  Prior to exiting the scope, include generic formals again (if any
960
         --  are present) in the set of local entities.
961
 
962
         if Present (First_Ent) then
963
            Set_First_Entity (Gen_Id, First_Ent);
964
         end if;
965
 
966
         Check_References (Gen_Id);
967
      end;
968
 
969
      Process_End_Label (Handled_Statement_Sequence (N), 't', Current_Scope);
970
      End_Scope;
971
      Check_Subprogram_Order (N);
972
 
973
      --  Outside of its body, unit is generic again
974
 
975
      Set_Ekind (Gen_Id, Kind);
976
      Generate_Reference (Gen_Id, Body_Id, 'b', Set_Ref => False);
977
 
978
      if Style_Check then
979
         Style.Check_Identifier (Body_Id, Gen_Id);
980
      end if;
981
      End_Generic;
982
   end Analyze_Generic_Subprogram_Body;
983
 
984
   -----------------------------
985
   -- Analyze_Operator_Symbol --
986
   -----------------------------
987
 
988
   --  An operator symbol such as "+" or "and" may appear in context where the
989
   --  literal denotes an entity name, such as "+"(x, y) or in context when it
990
   --  is just a string, as in (conjunction = "or"). In these cases the parser
991
   --  generates this node, and the semantics does the disambiguation. Other
992
   --  such case are actuals in an instantiation, the generic unit in an
993
   --  instantiation, and pragma arguments.
994
 
995
   procedure Analyze_Operator_Symbol (N : Node_Id) is
996
      Par : constant Node_Id := Parent (N);
997
 
998
   begin
999
      if        (Nkind (Par) = N_Function_Call
1000
                   and then N = Name (Par))
1001
        or else  Nkind (Par) = N_Function_Instantiation
1002
        or else (Nkind (Par) = N_Indexed_Component
1003
                   and then N = Prefix (Par))
1004
        or else (Nkind (Par) = N_Pragma_Argument_Association
1005
                   and then not Is_Pragma_String_Literal (Par))
1006
        or else  Nkind (Par) = N_Subprogram_Renaming_Declaration
1007
        or else (Nkind (Par) = N_Attribute_Reference
1008
                  and then Attribute_Name (Par) /= Name_Value)
1009
      then
1010
         Find_Direct_Name (N);
1011
 
1012
      else
1013
         Change_Operator_Symbol_To_String_Literal (N);
1014
         Analyze (N);
1015
      end if;
1016
   end Analyze_Operator_Symbol;
1017
 
1018
   -----------------------------------
1019
   -- Analyze_Parameter_Association --
1020
   -----------------------------------
1021
 
1022
   procedure Analyze_Parameter_Association (N : Node_Id) is
1023
   begin
1024
      Analyze (Explicit_Actual_Parameter (N));
1025
   end Analyze_Parameter_Association;
1026
 
1027
   ----------------------------
1028
   -- Analyze_Procedure_Call --
1029
   ----------------------------
1030
 
1031
   procedure Analyze_Procedure_Call (N : Node_Id) is
1032
      Loc     : constant Source_Ptr := Sloc (N);
1033
      P       : constant Node_Id    := Name (N);
1034
      Actuals : constant List_Id    := Parameter_Associations (N);
1035
      Actual  : Node_Id;
1036
      New_N   : Node_Id;
1037
 
1038
      procedure Analyze_Call_And_Resolve;
1039
      --  Do Analyze and Resolve calls for procedure call
1040
 
1041
      ------------------------------
1042
      -- Analyze_Call_And_Resolve --
1043
      ------------------------------
1044
 
1045
      procedure Analyze_Call_And_Resolve is
1046
      begin
1047
         if Nkind (N) = N_Procedure_Call_Statement then
1048
            Analyze_Call (N);
1049
            Resolve (N, Standard_Void_Type);
1050
         else
1051
            Analyze (N);
1052
         end if;
1053
      end Analyze_Call_And_Resolve;
1054
 
1055
   --  Start of processing for Analyze_Procedure_Call
1056
 
1057
   begin
1058
      --  The syntactic construct: PREFIX ACTUAL_PARAMETER_PART can denote
1059
      --  a procedure call or an entry call. The prefix may denote an access
1060
      --  to subprogram type, in which case an implicit dereference applies.
1061
      --  If the prefix is an indexed component (without implicit dereference)
1062
      --  then the construct denotes a call to a member of an entire family.
1063
      --  If the prefix is a simple name, it may still denote a call to a
1064
      --  parameterless member of an entry family. Resolution of these various
1065
      --  interpretations is delicate.
1066
 
1067
      Analyze (P);
1068
 
1069
      --  If this is a call of the form Obj.Op, the call may have been
1070
      --  analyzed and possibly rewritten into a block, in which case
1071
      --  we are done.
1072
 
1073
      if Analyzed (N) then
1074
         return;
1075
      end if;
1076
 
1077
      --  If error analyzing prefix, then set Any_Type as result and return
1078
 
1079
      if Etype (P) = Any_Type then
1080
         Set_Etype (N, Any_Type);
1081
         return;
1082
      end if;
1083
 
1084
      --  Otherwise analyze the parameters
1085
 
1086
      if Present (Actuals) then
1087
         Actual := First (Actuals);
1088
 
1089
         while Present (Actual) loop
1090
            Analyze (Actual);
1091
            Check_Parameterless_Call (Actual);
1092
            Next (Actual);
1093
         end loop;
1094
      end if;
1095
 
1096
      --  Special processing for Elab_Spec and Elab_Body calls
1097
 
1098
      if Nkind (P) = N_Attribute_Reference
1099
        and then (Attribute_Name (P) = Name_Elab_Spec
1100
                   or else Attribute_Name (P) = Name_Elab_Body)
1101
      then
1102
         if Present (Actuals) then
1103
            Error_Msg_N
1104
              ("no parameters allowed for this call", First (Actuals));
1105
            return;
1106
         end if;
1107
 
1108
         Set_Etype (N, Standard_Void_Type);
1109
         Set_Analyzed (N);
1110
 
1111
      elsif Is_Entity_Name (P)
1112
        and then Is_Record_Type (Etype (Entity (P)))
1113
        and then Remote_AST_I_Dereference (P)
1114
      then
1115
         return;
1116
 
1117
      elsif Is_Entity_Name (P)
1118
        and then Ekind (Entity (P)) /= E_Entry_Family
1119
      then
1120
         if Is_Access_Type (Etype (P))
1121
           and then Ekind (Designated_Type (Etype (P))) = E_Subprogram_Type
1122
           and then No (Actuals)
1123
           and then Comes_From_Source (N)
1124
         then
1125
            Error_Msg_N ("missing explicit dereference in call", N);
1126
         end if;
1127
 
1128
         Analyze_Call_And_Resolve;
1129
 
1130
      --  If the prefix is the simple name of an entry family, this is
1131
      --  a parameterless call from within the task body itself.
1132
 
1133
      elsif Is_Entity_Name (P)
1134
        and then Nkind (P) = N_Identifier
1135
        and then Ekind (Entity (P)) = E_Entry_Family
1136
        and then Present (Actuals)
1137
        and then No (Next (First (Actuals)))
1138
      then
1139
         --  Can be call to parameterless entry family. What appears to be the
1140
         --  sole argument is in fact the entry index. Rewrite prefix of node
1141
         --  accordingly. Source representation is unchanged by this
1142
         --  transformation.
1143
 
1144
         New_N :=
1145
           Make_Indexed_Component (Loc,
1146
             Prefix =>
1147
               Make_Selected_Component (Loc,
1148
                 Prefix => New_Occurrence_Of (Scope (Entity (P)), Loc),
1149
                 Selector_Name => New_Occurrence_Of (Entity (P), Loc)),
1150
             Expressions => Actuals);
1151
         Set_Name (N, New_N);
1152
         Set_Etype (New_N, Standard_Void_Type);
1153
         Set_Parameter_Associations (N, No_List);
1154
         Analyze_Call_And_Resolve;
1155
 
1156
      elsif Nkind (P) = N_Explicit_Dereference then
1157
         if Ekind (Etype (P)) = E_Subprogram_Type then
1158
            Analyze_Call_And_Resolve;
1159
         else
1160
            Error_Msg_N ("expect access to procedure in call", P);
1161
         end if;
1162
 
1163
      --  The name can be a selected component or an indexed component that
1164
      --  yields an access to subprogram. Such a prefix is legal if the call
1165
      --  has parameter associations.
1166
 
1167
      elsif Is_Access_Type (Etype (P))
1168
        and then Ekind (Designated_Type (Etype (P))) = E_Subprogram_Type
1169
      then
1170
         if Present (Actuals) then
1171
            Analyze_Call_And_Resolve;
1172
         else
1173
            Error_Msg_N ("missing explicit dereference in call ", N);
1174
         end if;
1175
 
1176
      --  If not an access to subprogram, then the prefix must resolve to the
1177
      --  name of an entry, entry family, or protected operation.
1178
 
1179
      --  For the case of a simple entry call, P is a selected component where
1180
      --  the prefix is the task and the selector name is the entry. A call to
1181
      --  a protected procedure will have the same syntax. If the protected
1182
      --  object contains overloaded operations, the entity may appear as a
1183
      --  function, the context will select the operation whose type is Void.
1184
 
1185
      elsif Nkind (P) = N_Selected_Component
1186
        and then (Ekind (Entity (Selector_Name (P))) = E_Entry
1187
                    or else
1188
                  Ekind (Entity (Selector_Name (P))) = E_Procedure
1189
                    or else
1190
                  Ekind (Entity (Selector_Name (P))) = E_Function)
1191
      then
1192
         Analyze_Call_And_Resolve;
1193
 
1194
      elsif Nkind (P) = N_Selected_Component
1195
        and then Ekind (Entity (Selector_Name (P))) = E_Entry_Family
1196
        and then Present (Actuals)
1197
        and then No (Next (First (Actuals)))
1198
      then
1199
         --  Can be call to parameterless entry family. What appears to be the
1200
         --  sole argument is in fact the entry index. Rewrite prefix of node
1201
         --  accordingly. Source representation is unchanged by this
1202
         --  transformation.
1203
 
1204
         New_N :=
1205
           Make_Indexed_Component (Loc,
1206
             Prefix => New_Copy (P),
1207
             Expressions => Actuals);
1208
         Set_Name (N, New_N);
1209
         Set_Etype (New_N, Standard_Void_Type);
1210
         Set_Parameter_Associations (N, No_List);
1211
         Analyze_Call_And_Resolve;
1212
 
1213
      --  For the case of a reference to an element of an entry family, P is
1214
      --  an indexed component whose prefix is a selected component (task and
1215
      --  entry family), and whose index is the entry family index.
1216
 
1217
      elsif Nkind (P) = N_Indexed_Component
1218
        and then Nkind (Prefix (P)) = N_Selected_Component
1219
        and then Ekind (Entity (Selector_Name (Prefix (P)))) = E_Entry_Family
1220
      then
1221
         Analyze_Call_And_Resolve;
1222
 
1223
      --  If the prefix is the name of an entry family, it is a call from
1224
      --  within the task body itself.
1225
 
1226
      elsif Nkind (P) = N_Indexed_Component
1227
        and then Nkind (Prefix (P)) = N_Identifier
1228
        and then Ekind (Entity (Prefix (P))) = E_Entry_Family
1229
      then
1230
         New_N :=
1231
           Make_Selected_Component (Loc,
1232
             Prefix => New_Occurrence_Of (Scope (Entity (Prefix (P))), Loc),
1233
             Selector_Name => New_Occurrence_Of (Entity (Prefix (P)), Loc));
1234
         Rewrite (Prefix (P), New_N);
1235
         Analyze (P);
1236
         Analyze_Call_And_Resolve;
1237
 
1238
      --  Anything else is an error
1239
 
1240
      else
1241
         Error_Msg_N ("invalid procedure or entry call", N);
1242
      end if;
1243
   end Analyze_Procedure_Call;
1244
 
1245
   -------------------------------------
1246
   -- Analyze_Simple_Return_Statement --
1247
   -------------------------------------
1248
 
1249
   procedure Analyze_Simple_Return_Statement (N : Node_Id) is
1250
   begin
1251
      if Present (Expression (N)) then
1252
         Mark_Coextensions (N, Expression (N));
1253
      end if;
1254
 
1255
      Analyze_Return_Statement (N);
1256
   end Analyze_Simple_Return_Statement;
1257
 
1258
   -------------------------
1259
   -- Analyze_Return_Type --
1260
   -------------------------
1261
 
1262
   procedure Analyze_Return_Type (N : Node_Id) is
1263
      Designator : constant Entity_Id := Defining_Entity (N);
1264
      Typ        : Entity_Id := Empty;
1265
 
1266
   begin
1267
      --  Normal case where result definition does not indicate an error
1268
 
1269
      if Result_Definition (N) /= Error then
1270
         if Nkind (Result_Definition (N)) = N_Access_Definition then
1271
 
1272
            --  Ada 2005 (AI-254): Handle anonymous access to subprograms
1273
 
1274
            declare
1275
               AD : constant Node_Id :=
1276
                      Access_To_Subprogram_Definition (Result_Definition (N));
1277
            begin
1278
               if Present (AD) and then Protected_Present (AD) then
1279
                  Typ := Replace_Anonymous_Access_To_Protected_Subprogram (N);
1280
               else
1281
                  Typ := Access_Definition (N, Result_Definition (N));
1282
               end if;
1283
            end;
1284
 
1285
            Set_Parent (Typ, Result_Definition (N));
1286
            Set_Is_Local_Anonymous_Access (Typ);
1287
            Set_Etype (Designator, Typ);
1288
 
1289
            --  Ada 2005 (AI-231): Ensure proper usage of null exclusion
1290
 
1291
            Null_Exclusion_Static_Checks (N);
1292
 
1293
         --  Subtype_Mark case
1294
 
1295
         else
1296
            Find_Type (Result_Definition (N));
1297
            Typ := Entity (Result_Definition (N));
1298
            Set_Etype (Designator, Typ);
1299
 
1300
            --  Ada 2005 (AI-231): Ensure proper usage of null exclusion
1301
 
1302
            Null_Exclusion_Static_Checks (N);
1303
 
1304
            --  If a null exclusion is imposed on the result type, then create
1305
            --  a null-excluding itype (an access subtype) and use it as the
1306
            --  function's Etype. Note that the null exclusion checks are done
1307
            --  right before this, because they don't get applied to types that
1308
            --  do not come from source.
1309
 
1310
            if Is_Access_Type (Typ)
1311
              and then Null_Exclusion_Present (N)
1312
            then
1313
               Set_Etype  (Designator,
1314
                 Create_Null_Excluding_Itype
1315
                  (T           => Typ,
1316
                   Related_Nod => N,
1317
                   Scope_Id    => Scope (Current_Scope)));
1318
 
1319
               --  The new subtype must be elaborated before use because
1320
               --  it is visible outside of the function. However its base
1321
               --  type may not be frozen yet, so the reference that will
1322
               --  force elaboration must be attached to the freezing of
1323
               --  the base type.
1324
 
1325
               --  If the return specification appears on a proper body,
1326
               --  the subtype will have been created already on the spec.
1327
 
1328
               if Is_Frozen (Typ) then
1329
                  if Nkind (Parent (N)) = N_Subprogram_Body
1330
                    and then Nkind (Parent (Parent (N))) = N_Subunit
1331
                  then
1332
                     null;
1333
                  else
1334
                     Build_Itype_Reference (Etype (Designator), Parent (N));
1335
                  end if;
1336
 
1337
               else
1338
                  Ensure_Freeze_Node (Typ);
1339
 
1340
                  declare
1341
                     IR : constant Node_Id := Make_Itype_Reference (Sloc (N));
1342
                  begin
1343
                     Set_Itype (IR, Etype (Designator));
1344
                     Append_Freeze_Actions (Typ, New_List (IR));
1345
                  end;
1346
               end if;
1347
 
1348
            else
1349
               Set_Etype (Designator, Typ);
1350
            end if;
1351
 
1352
            if Ekind (Typ) = E_Incomplete_Type
1353
              and then Is_Value_Type (Typ)
1354
            then
1355
               null;
1356
 
1357
            elsif Ekind (Typ) = E_Incomplete_Type
1358
              or else (Is_Class_Wide_Type (Typ)
1359
                         and then
1360
                           Ekind (Root_Type (Typ)) = E_Incomplete_Type)
1361
            then
1362
               Error_Msg_NE
1363
                 ("invalid use of incomplete type&", Designator, Typ);
1364
            end if;
1365
         end if;
1366
 
1367
      --  Case where result definition does indicate an error
1368
 
1369
      else
1370
         Set_Etype (Designator, Any_Type);
1371
      end if;
1372
   end Analyze_Return_Type;
1373
 
1374
   -----------------------------
1375
   -- Analyze_Subprogram_Body --
1376
   -----------------------------
1377
 
1378
   procedure Analyze_Subprogram_Body (N : Node_Id) is
1379
      Loc       : constant Source_Ptr := Sloc (N);
1380
      Body_Spec : constant Node_Id    := Specification (N);
1381
      Body_Id   : constant Entity_Id  := Defining_Entity (Body_Spec);
1382
 
1383
   begin
1384
      if Debug_Flag_C then
1385
         Write_Str ("==> subprogram body ");
1386
         Write_Name (Chars (Body_Id));
1387
         Write_Str (" from ");
1388
         Write_Location (Loc);
1389
         Write_Eol;
1390
         Indent;
1391
      end if;
1392
 
1393
      Trace_Scope (N, Body_Id, " Analyze subprogram: ");
1394
 
1395
      --  The real work is split out into the helper, so it can do "return;"
1396
      --  without skipping the debug output:
1397
 
1398
      Analyze_Subprogram_Body_Helper (N);
1399
 
1400
      if Debug_Flag_C then
1401
         Outdent;
1402
         Write_Str ("<== subprogram body ");
1403
         Write_Name (Chars (Body_Id));
1404
         Write_Str (" from ");
1405
         Write_Location (Loc);
1406
         Write_Eol;
1407
      end if;
1408
   end Analyze_Subprogram_Body;
1409
 
1410
   ------------------------------------
1411
   -- Analyze_Subprogram_Body_Helper --
1412
   ------------------------------------
1413
 
1414
   --  This procedure is called for regular subprogram bodies, generic bodies,
1415
   --  and for subprogram stubs of both kinds. In the case of stubs, only the
1416
   --  specification matters, and is used to create a proper declaration for
1417
   --  the subprogram, or to perform conformance checks.
1418
 
1419
   procedure Analyze_Subprogram_Body_Helper (N : Node_Id) is
1420
      Loc          : constant Source_Ptr := Sloc (N);
1421
      Body_Deleted : constant Boolean    := False;
1422
      Body_Spec    : constant Node_Id    := Specification (N);
1423
      Body_Id      : Entity_Id           := Defining_Entity (Body_Spec);
1424
      Prev_Id      : constant Entity_Id  := Current_Entity_In_Scope (Body_Id);
1425
      Conformant   : Boolean;
1426
      HSS          : Node_Id;
1427
      Missing_Ret  : Boolean;
1428
      P_Ent        : Entity_Id;
1429
      Prot_Typ     : Entity_Id := Empty;
1430
      Spec_Id      : Entity_Id;
1431
      Spec_Decl    : Node_Id   := Empty;
1432
 
1433
      Last_Real_Spec_Entity : Entity_Id := Empty;
1434
      --  When we analyze a separate spec, the entity chain ends up containing
1435
      --  the formals, as well as any itypes generated during analysis of the
1436
      --  default expressions for parameters, or the arguments of associated
1437
      --  precondition/postcondition pragmas (which are analyzed in the context
1438
      --  of the spec since they have visibility on formals).
1439
      --
1440
      --  These entities belong with the spec and not the body. However we do
1441
      --  the analysis of the body in the context of the spec (again to obtain
1442
      --  visibility to the formals), and all the entities generated during
1443
      --  this analysis end up also chained to the entity chain of the spec.
1444
      --  But they really belong to the body, and there is circuitry to move
1445
      --  them from the spec to the body.
1446
      --
1447
      --  However, when we do this move, we don't want to move the real spec
1448
      --  entities (first para above) to the body. The Last_Real_Spec_Entity
1449
      --  variable points to the last real spec entity, so we only move those
1450
      --  chained beyond that point. It is initialized to Empty to deal with
1451
      --  the case where there is no separate spec.
1452
 
1453
      procedure Check_Anonymous_Return;
1454
      --  Ada 2005: if a function returns an access type that denotes a task,
1455
      --  or a type that contains tasks, we must create a master entity for
1456
      --  the anonymous type, which typically will be used in an allocator
1457
      --  in the body of the function.
1458
 
1459
      procedure Check_Inline_Pragma (Spec : in out Node_Id);
1460
      --  Look ahead to recognize a pragma that may appear after the body.
1461
      --  If there is a previous spec, check that it appears in the same
1462
      --  declarative part. If the pragma is Inline_Always, perform inlining
1463
      --  unconditionally, otherwise only if Front_End_Inlining is requested.
1464
      --  If the body acts as a spec, and inlining is required, we create a
1465
      --  subprogram declaration for it, in order to attach the body to inline.
1466
      --  If pragma does not appear after the body, check whether there is
1467
      --  an inline pragma before any local declarations.
1468
 
1469
      function Disambiguate_Spec return Entity_Id;
1470
      --  When a primitive is declared between the private view and the full
1471
      --  view of a concurrent type which implements an interface, a special
1472
      --  mechanism is used to find the corresponding spec of the primitive
1473
      --  body.
1474
 
1475
      function Is_Private_Concurrent_Primitive
1476
        (Subp_Id : Entity_Id) return Boolean;
1477
      --  Determine whether subprogram Subp_Id is a primitive of a concurrent
1478
      --  type that implements an interface and has a private view.
1479
 
1480
      procedure Set_Trivial_Subprogram (N : Node_Id);
1481
      --  Sets the Is_Trivial_Subprogram flag in both spec and body of the
1482
      --  subprogram whose body is being analyzed. N is the statement node
1483
      --  causing the flag to be set, if the following statement is a return
1484
      --  of an entity, we mark the entity as set in source to suppress any
1485
      --  warning on the stylized use of function stubs with a dummy return.
1486
 
1487
      procedure Verify_Overriding_Indicator;
1488
      --  If there was a previous spec, the entity has been entered in the
1489
      --  current scope previously. If the body itself carries an overriding
1490
      --  indicator, check that it is consistent with the known status of the
1491
      --  entity.
1492
 
1493
      ----------------------------
1494
      -- Check_Anonymous_Return --
1495
      ----------------------------
1496
 
1497
      procedure Check_Anonymous_Return is
1498
         Decl : Node_Id;
1499
         Par  : Node_Id;
1500
         Scop : Entity_Id;
1501
 
1502
      begin
1503
         if Present (Spec_Id) then
1504
            Scop := Spec_Id;
1505
         else
1506
            Scop := Body_Id;
1507
         end if;
1508
 
1509
         if Ekind (Scop) = E_Function
1510
           and then Ekind (Etype (Scop)) = E_Anonymous_Access_Type
1511
           and then not Is_Thunk (Scop)
1512
           and then (Has_Task (Designated_Type (Etype (Scop)))
1513
                      or else
1514
                       (Is_Class_Wide_Type (Designated_Type (Etype (Scop)))
1515
                          and then
1516
                        Is_Limited_Record (Designated_Type (Etype (Scop)))))
1517
           and then Expander_Active
1518
 
1519
            --  Avoid cases with no tasking support
1520
 
1521
           and then RTE_Available (RE_Current_Master)
1522
           and then not Restriction_Active (No_Task_Hierarchy)
1523
         then
1524
            Decl :=
1525
              Make_Object_Declaration (Loc,
1526
                Defining_Identifier =>
1527
                  Make_Defining_Identifier (Loc, Name_uMaster),
1528
                Constant_Present => True,
1529
                Object_Definition =>
1530
                  New_Reference_To (RTE (RE_Master_Id), Loc),
1531
                Expression =>
1532
                  Make_Explicit_Dereference (Loc,
1533
                    New_Reference_To (RTE (RE_Current_Master), Loc)));
1534
 
1535
            if Present (Declarations (N)) then
1536
               Prepend (Decl, Declarations (N));
1537
            else
1538
               Set_Declarations (N, New_List (Decl));
1539
            end if;
1540
 
1541
            Set_Master_Id (Etype (Scop), Defining_Identifier (Decl));
1542
            Set_Has_Master_Entity (Scop);
1543
 
1544
            --  Now mark the containing scope as a task master
1545
 
1546
            Par := N;
1547
            while Nkind (Par) /= N_Compilation_Unit loop
1548
               Par := Parent (Par);
1549
               pragma Assert (Present (Par));
1550
 
1551
               --  If we fall off the top, we are at the outer level, and
1552
               --  the environment task is our effective master, so nothing
1553
               --  to mark.
1554
 
1555
               if Nkind_In
1556
                   (Par, N_Task_Body, N_Block_Statement, N_Subprogram_Body)
1557
               then
1558
                  Set_Is_Task_Master (Par, True);
1559
                  exit;
1560
               end if;
1561
            end loop;
1562
         end if;
1563
      end Check_Anonymous_Return;
1564
 
1565
      -------------------------
1566
      -- Check_Inline_Pragma --
1567
      -------------------------
1568
 
1569
      procedure Check_Inline_Pragma (Spec : in out Node_Id) is
1570
         Prag  : Node_Id;
1571
         Plist : List_Id;
1572
 
1573
         function Is_Inline_Pragma (N : Node_Id) return Boolean;
1574
         --  True when N is a pragma Inline or Inline_Always that applies
1575
         --  to this subprogram.
1576
 
1577
         -----------------------
1578
         --  Is_Inline_Pragma --
1579
         -----------------------
1580
 
1581
         function Is_Inline_Pragma (N : Node_Id) return Boolean is
1582
         begin
1583
            return
1584
              Nkind (N) = N_Pragma
1585
                and then
1586
                   (Pragma_Name (N) = Name_Inline_Always
1587
                     or else
1588
                      (Front_End_Inlining
1589
                        and then Pragma_Name (N) = Name_Inline))
1590
                and then
1591
                   Chars
1592
                     (Expression (First (Pragma_Argument_Associations (N))))
1593
                        = Chars (Body_Id);
1594
         end Is_Inline_Pragma;
1595
 
1596
      --  Start of processing for Check_Inline_Pragma
1597
 
1598
      begin
1599
         if not Expander_Active then
1600
            return;
1601
         end if;
1602
 
1603
         if Is_List_Member (N)
1604
           and then Present (Next (N))
1605
           and then Is_Inline_Pragma (Next (N))
1606
         then
1607
            Prag := Next (N);
1608
 
1609
         elsif Nkind (N) /= N_Subprogram_Body_Stub
1610
           and then Present (Declarations (N))
1611
           and then Is_Inline_Pragma (First (Declarations (N)))
1612
         then
1613
            Prag := First (Declarations (N));
1614
 
1615
         else
1616
            Prag := Empty;
1617
         end if;
1618
 
1619
         if Present (Prag) then
1620
            if Present (Spec_Id) then
1621
               if List_Containing (N) =
1622
                 List_Containing (Unit_Declaration_Node (Spec_Id))
1623
               then
1624
                  Analyze (Prag);
1625
               end if;
1626
 
1627
            else
1628
               --  Create a subprogram declaration, to make treatment uniform
1629
 
1630
               declare
1631
                  Subp : constant Entity_Id :=
1632
                    Make_Defining_Identifier (Loc, Chars (Body_Id));
1633
                  Decl : constant Node_Id :=
1634
                    Make_Subprogram_Declaration (Loc,
1635
                      Specification =>  New_Copy_Tree (Specification (N)));
1636
               begin
1637
                  Set_Defining_Unit_Name (Specification (Decl), Subp);
1638
 
1639
                  if Present (First_Formal (Body_Id)) then
1640
                     Plist := Copy_Parameter_List (Body_Id);
1641
                     Set_Parameter_Specifications
1642
                       (Specification (Decl), Plist);
1643
                  end if;
1644
 
1645
                  Insert_Before (N, Decl);
1646
                  Analyze (Decl);
1647
                  Analyze (Prag);
1648
                  Set_Has_Pragma_Inline (Subp);
1649
 
1650
                  if Pragma_Name (Prag) = Name_Inline_Always then
1651
                     Set_Is_Inlined (Subp);
1652
                     Set_Has_Pragma_Inline_Always (Subp);
1653
                  end if;
1654
 
1655
                  Spec := Subp;
1656
               end;
1657
            end if;
1658
         end if;
1659
      end Check_Inline_Pragma;
1660
 
1661
      -----------------------
1662
      -- Disambiguate_Spec --
1663
      -----------------------
1664
 
1665
      function Disambiguate_Spec return Entity_Id is
1666
         Priv_Spec : Entity_Id;
1667
         Spec_N    : Entity_Id;
1668
 
1669
         procedure Replace_Types (To_Corresponding : Boolean);
1670
         --  Depending on the flag, replace the type of formal parameters of
1671
         --  Body_Id if it is a concurrent type implementing interfaces with
1672
         --  the corresponding record type or the other way around.
1673
 
1674
         procedure Replace_Types (To_Corresponding : Boolean) is
1675
            Formal     : Entity_Id;
1676
            Formal_Typ : Entity_Id;
1677
 
1678
         begin
1679
            Formal := First_Formal (Body_Id);
1680
            while Present (Formal) loop
1681
               Formal_Typ := Etype (Formal);
1682
 
1683
               --  From concurrent type to corresponding record
1684
 
1685
               if To_Corresponding then
1686
                  if Is_Concurrent_Type (Formal_Typ)
1687
                    and then Present (Corresponding_Record_Type (Formal_Typ))
1688
                    and then Present (Interfaces (
1689
                               Corresponding_Record_Type (Formal_Typ)))
1690
                  then
1691
                     Set_Etype (Formal,
1692
                       Corresponding_Record_Type (Formal_Typ));
1693
                  end if;
1694
 
1695
               --  From corresponding record to concurrent type
1696
 
1697
               else
1698
                  if Is_Concurrent_Record_Type (Formal_Typ)
1699
                    and then Present (Interfaces (Formal_Typ))
1700
                  then
1701
                     Set_Etype (Formal,
1702
                       Corresponding_Concurrent_Type (Formal_Typ));
1703
                  end if;
1704
               end if;
1705
 
1706
               Next_Formal (Formal);
1707
            end loop;
1708
         end Replace_Types;
1709
 
1710
      --  Start of processing for Disambiguate_Spec
1711
 
1712
      begin
1713
         --  Try to retrieve the specification of the body as is. All error
1714
         --  messages are suppressed because the body may not have a spec in
1715
         --  its current state.
1716
 
1717
         Spec_N := Find_Corresponding_Spec (N, False);
1718
 
1719
         --  It is possible that this is the body of a primitive declared
1720
         --  between a private and a full view of a concurrent type. The
1721
         --  controlling parameter of the spec carries the concurrent type,
1722
         --  not the corresponding record type as transformed by Analyze_
1723
         --  Subprogram_Specification. In such cases, we undo the change
1724
         --  made by the analysis of the specification and try to find the
1725
         --  spec again.
1726
 
1727
         --  Note that wrappers already have their corresponding specs and
1728
         --  bodies set during their creation, so if the candidate spec is
1729
         --  a wrapper, then we definitely need to swap all types to their
1730
         --  original concurrent status.
1731
 
1732
         if No (Spec_N)
1733
           or else Is_Primitive_Wrapper (Spec_N)
1734
         then
1735
            --  Restore all references of corresponding record types to the
1736
            --  original concurrent types.
1737
 
1738
            Replace_Types (To_Corresponding => False);
1739
            Priv_Spec := Find_Corresponding_Spec (N, False);
1740
 
1741
            --  The current body truly belongs to a primitive declared between
1742
            --  a private and a full view. We leave the modified body as is,
1743
            --  and return the true spec.
1744
 
1745
            if Present (Priv_Spec)
1746
              and then Is_Private_Primitive (Priv_Spec)
1747
            then
1748
               return Priv_Spec;
1749
            end if;
1750
 
1751
            --  In case that this is some sort of error, restore the original
1752
            --  state of the body.
1753
 
1754
            Replace_Types (To_Corresponding => True);
1755
         end if;
1756
 
1757
         return Spec_N;
1758
      end Disambiguate_Spec;
1759
 
1760
      -------------------------------------
1761
      -- Is_Private_Concurrent_Primitive --
1762
      -------------------------------------
1763
 
1764
      function Is_Private_Concurrent_Primitive
1765
        (Subp_Id : Entity_Id) return Boolean
1766
      is
1767
         Formal_Typ : Entity_Id;
1768
 
1769
      begin
1770
         if Present (First_Formal (Subp_Id)) then
1771
            Formal_Typ := Etype (First_Formal (Subp_Id));
1772
 
1773
            if Is_Concurrent_Record_Type (Formal_Typ) then
1774
               Formal_Typ := Corresponding_Concurrent_Type (Formal_Typ);
1775
            end if;
1776
 
1777
            --  The type of the first formal is a concurrent tagged type with
1778
            --  a private view.
1779
 
1780
            return
1781
              Is_Concurrent_Type (Formal_Typ)
1782
                and then Is_Tagged_Type (Formal_Typ)
1783
                and then Has_Private_Declaration (Formal_Typ);
1784
         end if;
1785
 
1786
         return False;
1787
      end Is_Private_Concurrent_Primitive;
1788
 
1789
      ----------------------------
1790
      -- Set_Trivial_Subprogram --
1791
      ----------------------------
1792
 
1793
      procedure Set_Trivial_Subprogram (N : Node_Id) is
1794
         Nxt : constant Node_Id := Next (N);
1795
 
1796
      begin
1797
         Set_Is_Trivial_Subprogram (Body_Id);
1798
 
1799
         if Present (Spec_Id) then
1800
            Set_Is_Trivial_Subprogram (Spec_Id);
1801
         end if;
1802
 
1803
         if Present (Nxt)
1804
           and then Nkind (Nxt) = N_Simple_Return_Statement
1805
           and then No (Next (Nxt))
1806
           and then Present (Expression (Nxt))
1807
           and then Is_Entity_Name (Expression (Nxt))
1808
         then
1809
            Set_Never_Set_In_Source (Entity (Expression (Nxt)), False);
1810
         end if;
1811
      end Set_Trivial_Subprogram;
1812
 
1813
      ---------------------------------
1814
      -- Verify_Overriding_Indicator --
1815
      ---------------------------------
1816
 
1817
      procedure Verify_Overriding_Indicator is
1818
      begin
1819
         if Must_Override (Body_Spec) then
1820
            if Nkind (Spec_Id) = N_Defining_Operator_Symbol
1821
              and then  Operator_Matches_Spec (Spec_Id, Spec_Id)
1822
            then
1823
               null;
1824
 
1825
            elsif not Is_Overriding_Operation (Spec_Id) then
1826
               Error_Msg_NE
1827
                 ("subprogram& is not overriding", Body_Spec, Spec_Id);
1828
            end if;
1829
 
1830
         elsif Must_Not_Override (Body_Spec) then
1831
            if Is_Overriding_Operation (Spec_Id) then
1832
               Error_Msg_NE
1833
                 ("subprogram& overrides inherited operation",
1834
                  Body_Spec, Spec_Id);
1835
 
1836
            elsif Nkind (Spec_Id) = N_Defining_Operator_Symbol
1837
              and then  Operator_Matches_Spec (Spec_Id, Spec_Id)
1838
            then
1839
               Error_Msg_NE
1840
                 ("subprogram & overrides predefined operator ",
1841
                    Body_Spec, Spec_Id);
1842
 
1843
            --  If this is not a primitive operation or protected subprogram,
1844
            --  then the overriding indicator is altogether illegal.
1845
 
1846
            elsif not Is_Primitive (Spec_Id)
1847
              and then Ekind (Scope (Spec_Id)) /= E_Protected_Type
1848
            then
1849
               Error_Msg_N ("overriding indicator only allowed " &
1850
                "if subprogram is primitive",
1851
                Body_Spec);
1852
            end if;
1853
 
1854
         elsif Style_Check --  ??? incorrect use of Style_Check!
1855
           and then Is_Overriding_Operation (Spec_Id)
1856
         then
1857
            pragma Assert (Unit_Declaration_Node (Body_Id) = N);
1858
            Style.Missing_Overriding (N, Body_Id);
1859
         end if;
1860
      end Verify_Overriding_Indicator;
1861
 
1862
   --  Start of processing for Analyze_Subprogram_Body_Helper
1863
 
1864
   begin
1865
      --  Generic subprograms are handled separately. They always have a
1866
      --  generic specification. Determine whether current scope has a
1867
      --  previous declaration.
1868
 
1869
      --  If the subprogram body is defined within an instance of the same
1870
      --  name, the instance appears as a package renaming, and will be hidden
1871
      --  within the subprogram.
1872
 
1873
      if Present (Prev_Id)
1874
        and then not Is_Overloadable (Prev_Id)
1875
        and then (Nkind (Parent (Prev_Id)) /= N_Package_Renaming_Declaration
1876
                   or else Comes_From_Source (Prev_Id))
1877
      then
1878
         if Is_Generic_Subprogram (Prev_Id) then
1879
            Spec_Id := Prev_Id;
1880
            Set_Is_Compilation_Unit (Body_Id, Is_Compilation_Unit (Spec_Id));
1881
            Set_Is_Child_Unit       (Body_Id, Is_Child_Unit       (Spec_Id));
1882
 
1883
            Analyze_Generic_Subprogram_Body (N, Spec_Id);
1884
            return;
1885
 
1886
         else
1887
            --  Previous entity conflicts with subprogram name. Attempting to
1888
            --  enter name will post error.
1889
 
1890
            Enter_Name (Body_Id);
1891
            return;
1892
         end if;
1893
 
1894
      --  Non-generic case, find the subprogram declaration, if one was seen,
1895
      --  or enter new overloaded entity in the current scope. If the
1896
      --  Current_Entity is the Body_Id itself, the unit is being analyzed as
1897
      --  part of the context of one of its subunits. No need to redo the
1898
      --  analysis.
1899
 
1900
      elsif Prev_Id = Body_Id
1901
        and then Has_Completion (Body_Id)
1902
      then
1903
         return;
1904
 
1905
      else
1906
         Body_Id := Analyze_Subprogram_Specification (Body_Spec);
1907
 
1908
         if Nkind (N) = N_Subprogram_Body_Stub
1909
           or else No (Corresponding_Spec (N))
1910
         then
1911
            if Is_Private_Concurrent_Primitive (Body_Id) then
1912
               Spec_Id := Disambiguate_Spec;
1913
            else
1914
               Spec_Id := Find_Corresponding_Spec (N);
1915
            end if;
1916
 
1917
            --  If this is a duplicate body, no point in analyzing it
1918
 
1919
            if Error_Posted (N) then
1920
               return;
1921
            end if;
1922
 
1923
            --  A subprogram body should cause freezing of its own declaration,
1924
            --  but if there was no previous explicit declaration, then the
1925
            --  subprogram will get frozen too late (there may be code within
1926
            --  the body that depends on the subprogram having been frozen,
1927
            --  such as uses of extra formals), so we force it to be frozen
1928
            --  here. Same holds if the body and spec are compilation units.
1929
            --  Finally, if the return type is an anonymous access to protected
1930
            --  subprogram, it must be frozen before the body because its
1931
            --  expansion has generated an equivalent type that is used when
1932
            --  elaborating the body.
1933
 
1934
            if No (Spec_Id) then
1935
               Freeze_Before (N, Body_Id);
1936
 
1937
            elsif Nkind (Parent (N)) = N_Compilation_Unit then
1938
               Freeze_Before (N, Spec_Id);
1939
 
1940
            elsif Is_Access_Subprogram_Type (Etype (Body_Id)) then
1941
               Freeze_Before (N, Etype (Body_Id));
1942
            end if;
1943
 
1944
         else
1945
            Spec_Id := Corresponding_Spec (N);
1946
         end if;
1947
      end if;
1948
 
1949
      --  Do not inline any subprogram that contains nested subprograms, since
1950
      --  the backend inlining circuit seems to generate uninitialized
1951
      --  references in this case. We know this happens in the case of front
1952
      --  end ZCX support, but it also appears it can happen in other cases as
1953
      --  well. The backend often rejects attempts to inline in the case of
1954
      --  nested procedures anyway, so little if anything is lost by this.
1955
      --  Note that this is test is for the benefit of the back-end. There is
1956
      --  a separate test for front-end inlining that also rejects nested
1957
      --  subprograms.
1958
 
1959
      --  Do not do this test if errors have been detected, because in some
1960
      --  error cases, this code blows up, and we don't need it anyway if
1961
      --  there have been errors, since we won't get to the linker anyway.
1962
 
1963
      if Comes_From_Source (Body_Id)
1964
        and then Serious_Errors_Detected = 0
1965
      then
1966
         P_Ent := Body_Id;
1967
         loop
1968
            P_Ent := Scope (P_Ent);
1969
            exit when No (P_Ent) or else P_Ent = Standard_Standard;
1970
 
1971
            if Is_Subprogram (P_Ent) then
1972
               Set_Is_Inlined (P_Ent, False);
1973
 
1974
               if Comes_From_Source (P_Ent)
1975
                 and then Has_Pragma_Inline (P_Ent)
1976
               then
1977
                  Cannot_Inline
1978
                    ("cannot inline& (nested subprogram)?",
1979
                     N, P_Ent);
1980
               end if;
1981
            end if;
1982
         end loop;
1983
      end if;
1984
 
1985
      Check_Inline_Pragma (Spec_Id);
1986
 
1987
      --  Deal with special case of a fully private operation in the body of
1988
      --  the protected type. We must create a declaration for the subprogram,
1989
      --  in order to attach the protected subprogram that will be used in
1990
      --  internal calls. We exclude compiler generated bodies from the
1991
      --  expander since the issue does not arise for those cases.
1992
 
1993
      if No (Spec_Id)
1994
        and then Comes_From_Source (N)
1995
        and then Is_Protected_Type (Current_Scope)
1996
      then
1997
         Spec_Id := Build_Private_Protected_Declaration (N);
1998
      end if;
1999
 
2000
      --  If a separate spec is present, then deal with freezing issues
2001
 
2002
      if Present (Spec_Id) then
2003
         Spec_Decl := Unit_Declaration_Node (Spec_Id);
2004
         Verify_Overriding_Indicator;
2005
 
2006
         --  In general, the spec will be frozen when we start analyzing the
2007
         --  body. However, for internally generated operations, such as
2008
         --  wrapper functions for inherited operations with controlling
2009
         --  results, the spec may not have been frozen by the time we
2010
         --  expand the freeze actions that include the bodies. In particular,
2011
         --  extra formals for accessibility or for return-in-place may need
2012
         --  to be generated. Freeze nodes, if any, are inserted before the
2013
         --  current body.
2014
 
2015
         if not Is_Frozen (Spec_Id)
2016
           and then Expander_Active
2017
         then
2018
            --  Force the generation of its freezing node to ensure proper
2019
            --  management of access types in the backend.
2020
 
2021
            --  This is definitely needed for some cases, but it is not clear
2022
            --  why, to be investigated further???
2023
 
2024
            Set_Has_Delayed_Freeze (Spec_Id);
2025
            Insert_Actions (N, Freeze_Entity (Spec_Id, Loc));
2026
         end if;
2027
      end if;
2028
 
2029
      --  Mark presence of postcondition proc in current scope
2030
 
2031
      if Chars (Body_Id) = Name_uPostconditions then
2032
         Set_Has_Postconditions (Current_Scope);
2033
      end if;
2034
 
2035
      --  Place subprogram on scope stack, and make formals visible. If there
2036
      --  is a spec, the visible entity remains that of the spec.
2037
 
2038
      if Present (Spec_Id) then
2039
         Generate_Reference (Spec_Id, Body_Id, 'b', Set_Ref => False);
2040
 
2041
         if Is_Child_Unit (Spec_Id) then
2042
            Generate_Reference (Spec_Id, Scope (Spec_Id), 'k', False);
2043
         end if;
2044
 
2045
         if Style_Check then
2046
            Style.Check_Identifier (Body_Id, Spec_Id);
2047
         end if;
2048
 
2049
         Set_Is_Compilation_Unit (Body_Id, Is_Compilation_Unit (Spec_Id));
2050
         Set_Is_Child_Unit       (Body_Id, Is_Child_Unit       (Spec_Id));
2051
 
2052
         if Is_Abstract_Subprogram (Spec_Id) then
2053
            Error_Msg_N ("an abstract subprogram cannot have a body", N);
2054
            return;
2055
 
2056
         else
2057
            Set_Convention (Body_Id, Convention (Spec_Id));
2058
            Set_Has_Completion (Spec_Id);
2059
 
2060
            if Is_Protected_Type (Scope (Spec_Id)) then
2061
               Prot_Typ := Scope (Spec_Id);
2062
            end if;
2063
 
2064
            --  If this is a body generated for a renaming, do not check for
2065
            --  full conformance. The check is redundant, because the spec of
2066
            --  the body is a copy of the spec in the renaming declaration,
2067
            --  and the test can lead to spurious errors on nested defaults.
2068
 
2069
            if Present (Spec_Decl)
2070
              and then not Comes_From_Source (N)
2071
              and then
2072
                (Nkind (Original_Node (Spec_Decl)) =
2073
                                        N_Subprogram_Renaming_Declaration
2074
                   or else (Present (Corresponding_Body (Spec_Decl))
2075
                              and then
2076
                                Nkind (Unit_Declaration_Node
2077
                                        (Corresponding_Body (Spec_Decl))) =
2078
                                           N_Subprogram_Renaming_Declaration))
2079
            then
2080
               Conformant := True;
2081
 
2082
            else
2083
               Check_Conformance
2084
                 (Body_Id, Spec_Id,
2085
                  Fully_Conformant, True, Conformant, Body_Id);
2086
            end if;
2087
 
2088
            --  If the body is not fully conformant, we have to decide if we
2089
            --  should analyze it or not. If it has a really messed up profile
2090
            --  then we probably should not analyze it, since we will get too
2091
            --  many bogus messages.
2092
 
2093
            --  Our decision is to go ahead in the non-fully conformant case
2094
            --  only if it is at least mode conformant with the spec. Note
2095
            --  that the call to Check_Fully_Conformant has issued the proper
2096
            --  error messages to complain about the lack of conformance.
2097
 
2098
            if not Conformant
2099
              and then not Mode_Conformant (Body_Id, Spec_Id)
2100
            then
2101
               return;
2102
            end if;
2103
         end if;
2104
 
2105
         if Spec_Id /= Body_Id then
2106
            Reference_Body_Formals (Spec_Id, Body_Id);
2107
         end if;
2108
 
2109
         if Nkind (N) /= N_Subprogram_Body_Stub then
2110
            Set_Corresponding_Spec (N, Spec_Id);
2111
 
2112
            --  Ada 2005 (AI-345): If the operation is a primitive operation
2113
            --  of a concurrent type, the type of the first parameter has been
2114
            --  replaced with the corresponding record, which is the proper
2115
            --  run-time structure to use. However, within the body there may
2116
            --  be uses of the formals that depend on primitive operations
2117
            --  of the type (in particular calls in prefixed form) for which
2118
            --  we need the original concurrent type. The operation may have
2119
            --  several controlling formals, so the replacement must be done
2120
            --  for all of them.
2121
 
2122
            if Comes_From_Source (Spec_Id)
2123
              and then Present (First_Entity (Spec_Id))
2124
              and then Ekind (Etype (First_Entity (Spec_Id))) = E_Record_Type
2125
              and then Is_Tagged_Type (Etype (First_Entity (Spec_Id)))
2126
              and then
2127
                Present (Interfaces (Etype (First_Entity (Spec_Id))))
2128
              and then
2129
                Present
2130
                  (Corresponding_Concurrent_Type
2131
                     (Etype (First_Entity (Spec_Id))))
2132
            then
2133
               declare
2134
                  Typ  : constant Entity_Id := Etype (First_Entity (Spec_Id));
2135
                  Form : Entity_Id;
2136
 
2137
               begin
2138
                  Form := First_Formal (Spec_Id);
2139
                  while Present (Form) loop
2140
                     if Etype (Form) = Typ then
2141
                        Set_Etype (Form, Corresponding_Concurrent_Type (Typ));
2142
                     end if;
2143
 
2144
                     Next_Formal (Form);
2145
                  end loop;
2146
               end;
2147
            end if;
2148
 
2149
            --  Make the formals visible, and place subprogram on scope stack.
2150
            --  This is also the point at which we set Last_Real_Spec_Entity
2151
            --  to mark the entities which will not be moved to the body.
2152
 
2153
            Install_Formals (Spec_Id);
2154
            Last_Real_Spec_Entity := Last_Entity (Spec_Id);
2155
            Push_Scope (Spec_Id);
2156
 
2157
            --  Make sure that the subprogram is immediately visible. For
2158
            --  child units that have no separate spec this is indispensable.
2159
            --  Otherwise it is safe albeit redundant.
2160
 
2161
            Set_Is_Immediately_Visible (Spec_Id);
2162
         end if;
2163
 
2164
         Set_Corresponding_Body (Unit_Declaration_Node (Spec_Id), Body_Id);
2165
         Set_Ekind (Body_Id, E_Subprogram_Body);
2166
         Set_Scope (Body_Id, Scope (Spec_Id));
2167
         Set_Is_Obsolescent (Body_Id, Is_Obsolescent (Spec_Id));
2168
 
2169
      --  Case of subprogram body with no previous spec
2170
 
2171
      else
2172
         if Style_Check
2173
           and then Comes_From_Source (Body_Id)
2174
           and then not Suppress_Style_Checks (Body_Id)
2175
           and then not In_Instance
2176
         then
2177
            Style.Body_With_No_Spec (N);
2178
         end if;
2179
 
2180
         New_Overloaded_Entity (Body_Id);
2181
 
2182
         if Nkind (N) /= N_Subprogram_Body_Stub then
2183
            Set_Acts_As_Spec (N);
2184
            Generate_Definition (Body_Id);
2185
            Generate_Reference
2186
              (Body_Id, Body_Id, 'b', Set_Ref => False, Force => True);
2187
            Generate_Reference_To_Formals (Body_Id);
2188
            Install_Formals (Body_Id);
2189
            Push_Scope (Body_Id);
2190
         end if;
2191
      end if;
2192
 
2193
      --  If the return type is an anonymous access type whose designated type
2194
      --  is the limited view of a class-wide type and the non-limited view is
2195
      --  available, update the return type accordingly.
2196
 
2197
      if Ada_Version >= Ada_05
2198
        and then Comes_From_Source (N)
2199
      then
2200
         declare
2201
            Etyp : Entity_Id;
2202
            Rtyp : Entity_Id;
2203
 
2204
         begin
2205
            Rtyp := Etype (Current_Scope);
2206
 
2207
            if Ekind (Rtyp) = E_Anonymous_Access_Type then
2208
               Etyp := Directly_Designated_Type (Rtyp);
2209
 
2210
               if Is_Class_Wide_Type (Etyp)
2211
                 and then From_With_Type (Etyp)
2212
               then
2213
                  Set_Directly_Designated_Type
2214
                    (Etype (Current_Scope), Available_View (Etyp));
2215
               end if;
2216
            end if;
2217
         end;
2218
      end if;
2219
 
2220
      --  If this is the proper body of a stub, we must verify that the stub
2221
      --  conforms to the body, and to the previous spec if one was present.
2222
      --  we know already that the body conforms to that spec. This test is
2223
      --  only required for subprograms that come from source.
2224
 
2225
      if Nkind (Parent (N)) = N_Subunit
2226
        and then Comes_From_Source (N)
2227
        and then not Error_Posted (Body_Id)
2228
        and then Nkind (Corresponding_Stub (Parent (N))) =
2229
                                                N_Subprogram_Body_Stub
2230
      then
2231
         declare
2232
            Old_Id : constant Entity_Id :=
2233
                       Defining_Entity
2234
                         (Specification (Corresponding_Stub (Parent (N))));
2235
 
2236
            Conformant : Boolean := False;
2237
 
2238
         begin
2239
            if No (Spec_Id) then
2240
               Check_Fully_Conformant (Body_Id, Old_Id);
2241
 
2242
            else
2243
               Check_Conformance
2244
                 (Body_Id, Old_Id, Fully_Conformant, False, Conformant);
2245
 
2246
               if not Conformant then
2247
 
2248
                  --  The stub was taken to be a new declaration. Indicate
2249
                  --  that it lacks a body.
2250
 
2251
                  Set_Has_Completion (Old_Id, False);
2252
               end if;
2253
            end if;
2254
         end;
2255
      end if;
2256
 
2257
      Set_Has_Completion (Body_Id);
2258
      Check_Eliminated (Body_Id);
2259
 
2260
      if Nkind (N) = N_Subprogram_Body_Stub then
2261
         return;
2262
 
2263
      elsif Present (Spec_Id)
2264
        and then Expander_Active
2265
        and then
2266
          (Has_Pragma_Inline_Always (Spec_Id)
2267
             or else (Has_Pragma_Inline (Spec_Id) and Front_End_Inlining))
2268
      then
2269
         Build_Body_To_Inline (N, Spec_Id);
2270
      end if;
2271
 
2272
      --  Ada 2005 (AI-262): In library subprogram bodies, after the analysis
2273
      --  if its specification we have to install the private withed units.
2274
      --  This holds for child units as well.
2275
 
2276
      if Is_Compilation_Unit (Body_Id)
2277
        or else Nkind (Parent (N)) = N_Compilation_Unit
2278
      then
2279
         Install_Private_With_Clauses (Body_Id);
2280
      end if;
2281
 
2282
      Check_Anonymous_Return;
2283
 
2284
      --  Set the Protected_Formal field of each extra formal of the protected
2285
      --  subprogram to reference the corresponding extra formal of the
2286
      --  subprogram that implements it. For regular formals this occurs when
2287
      --  the protected subprogram's declaration is expanded, but the extra
2288
      --  formals don't get created until the subprogram is frozen. We need to
2289
      --  do this before analyzing the protected subprogram's body so that any
2290
      --  references to the original subprogram's extra formals will be changed
2291
      --  refer to the implementing subprogram's formals (see Expand_Formal).
2292
 
2293
      if Present (Spec_Id)
2294
        and then Is_Protected_Type (Scope (Spec_Id))
2295
        and then Present (Protected_Body_Subprogram (Spec_Id))
2296
      then
2297
         declare
2298
            Impl_Subp       : constant Entity_Id :=
2299
                                Protected_Body_Subprogram (Spec_Id);
2300
            Prot_Ext_Formal : Entity_Id := Extra_Formals (Spec_Id);
2301
            Impl_Ext_Formal : Entity_Id := Extra_Formals (Impl_Subp);
2302
         begin
2303
            while Present (Prot_Ext_Formal) loop
2304
               pragma Assert (Present (Impl_Ext_Formal));
2305
               Set_Protected_Formal (Prot_Ext_Formal, Impl_Ext_Formal);
2306
               Next_Formal_With_Extras (Prot_Ext_Formal);
2307
               Next_Formal_With_Extras (Impl_Ext_Formal);
2308
            end loop;
2309
         end;
2310
      end if;
2311
 
2312
      --  Now we can go on to analyze the body
2313
 
2314
      HSS := Handled_Statement_Sequence (N);
2315
      Set_Actual_Subtypes (N, Current_Scope);
2316
 
2317
      --  Deal with preconditions and postconditions
2318
 
2319
      Process_PPCs (N, Spec_Id, Body_Id);
2320
 
2321
      --  Add a declaration for the Protection object, renaming declarations
2322
      --  for discriminals and privals and finally a declaration for the entry
2323
      --  family index (if applicable). This form of early expansion is done
2324
      --  when the Expander is active because Install_Private_Data_Declarations
2325
      --  references entities which were created during regular expansion.
2326
 
2327
      if Expander_Active
2328
        and then Comes_From_Source (N)
2329
        and then Present (Prot_Typ)
2330
        and then Present (Spec_Id)
2331
        and then not Is_Eliminated (Spec_Id)
2332
      then
2333
         Install_Private_Data_Declarations
2334
           (Sloc (N), Spec_Id, Prot_Typ, N, Declarations (N));
2335
      end if;
2336
 
2337
      --  Analyze the declarations (this call will analyze the precondition
2338
      --  Check pragmas we prepended to the list, as well as the declaration
2339
      --  of the _Postconditions procedure).
2340
 
2341
      Analyze_Declarations (Declarations (N));
2342
 
2343
      --  Check completion, and analyze the statements
2344
 
2345
      Check_Completion;
2346
      Inspect_Deferred_Constant_Completion (Declarations (N));
2347
      Analyze (HSS);
2348
 
2349
      --  Deal with end of scope processing for the body
2350
 
2351
      Process_End_Label (HSS, 't', Current_Scope);
2352
      End_Scope;
2353
      Check_Subprogram_Order (N);
2354
      Set_Analyzed (Body_Id);
2355
 
2356
      --  If we have a separate spec, then the analysis of the declarations
2357
      --  caused the entities in the body to be chained to the spec id, but
2358
      --  we want them chained to the body id. Only the formal parameters
2359
      --  end up chained to the spec id in this case.
2360
 
2361
      if Present (Spec_Id) then
2362
 
2363
         --  We must conform to the categorization of our spec
2364
 
2365
         Validate_Categorization_Dependency (N, Spec_Id);
2366
 
2367
         --  And if this is a child unit, the parent units must conform
2368
 
2369
         if Is_Child_Unit (Spec_Id) then
2370
            Validate_Categorization_Dependency
2371
              (Unit_Declaration_Node (Spec_Id), Spec_Id);
2372
         end if;
2373
 
2374
         --  Here is where we move entities from the spec to the body
2375
 
2376
         --  Case where there are entities that stay with the spec
2377
 
2378
         if Present (Last_Real_Spec_Entity) then
2379
 
2380
            --  No body entities (happens when the only real spec entities
2381
            --  come from precondition and postcondition pragmas)
2382
 
2383
            if No (Last_Entity (Body_Id)) then
2384
               Set_First_Entity
2385
                 (Body_Id, Next_Entity (Last_Real_Spec_Entity));
2386
 
2387
            --  Body entities present (formals), so chain stuff past them
2388
 
2389
            else
2390
               Set_Next_Entity
2391
                 (Last_Entity (Body_Id), Next_Entity (Last_Real_Spec_Entity));
2392
            end if;
2393
 
2394
            Set_Next_Entity (Last_Real_Spec_Entity, Empty);
2395
            Set_Last_Entity (Body_Id, Last_Entity (Spec_Id));
2396
            Set_Last_Entity (Spec_Id, Last_Real_Spec_Entity);
2397
 
2398
         --  Case where there are no spec entities, in this case there can
2399
         --  be no body entities either, so just move everything.
2400
 
2401
         else
2402
            pragma Assert (No (Last_Entity (Body_Id)));
2403
            Set_First_Entity (Body_Id, First_Entity (Spec_Id));
2404
            Set_Last_Entity  (Body_Id, Last_Entity (Spec_Id));
2405
            Set_First_Entity (Spec_Id, Empty);
2406
            Set_Last_Entity  (Spec_Id, Empty);
2407
         end if;
2408
      end if;
2409
 
2410
      --  If function, check return statements
2411
 
2412
      if Nkind (Body_Spec) = N_Function_Specification then
2413
         declare
2414
            Id : Entity_Id;
2415
 
2416
         begin
2417
            if Present (Spec_Id) then
2418
               Id := Spec_Id;
2419
            else
2420
               Id := Body_Id;
2421
            end if;
2422
 
2423
            if Return_Present (Id) then
2424
               Check_Returns (HSS, 'F', Missing_Ret);
2425
 
2426
               if Missing_Ret then
2427
                  Set_Has_Missing_Return (Id);
2428
               end if;
2429
 
2430
            elsif not Is_Machine_Code_Subprogram (Id)
2431
              and then not Body_Deleted
2432
            then
2433
               Error_Msg_N ("missing RETURN statement in function body", N);
2434
            end if;
2435
         end;
2436
 
2437
      --  If procedure with No_Return, check returns
2438
 
2439
      elsif Nkind (Body_Spec) = N_Procedure_Specification
2440
        and then Present (Spec_Id)
2441
        and then No_Return (Spec_Id)
2442
      then
2443
         Check_Returns (HSS, 'P', Missing_Ret, Spec_Id);
2444
      end if;
2445
 
2446
      --  Now we are going to check for variables that are never modified in
2447
      --  the body of the procedure. But first we deal with a special case
2448
      --  where we want to modify this check. If the body of the subprogram
2449
      --  starts with a raise statement or its equivalent, or if the body
2450
      --  consists entirely of a null statement, then it is pretty obvious
2451
      --  that it is OK to not reference the parameters. For example, this
2452
      --  might be the following common idiom for a stubbed function:
2453
      --  statement of the procedure raises an exception. In particular this
2454
      --  deals with the common idiom of a stubbed function, which might
2455
      --  appear as something like
2456
 
2457
      --     function F (A : Integer) return Some_Type;
2458
      --        X : Some_Type;
2459
      --     begin
2460
      --        raise Program_Error;
2461
      --        return X;
2462
      --     end F;
2463
 
2464
      --  Here the purpose of X is simply to satisfy the annoying requirement
2465
      --  in Ada that there be at least one return, and we certainly do not
2466
      --  want to go posting warnings on X that it is not initialized! On
2467
      --  the other hand, if X is entirely unreferenced that should still
2468
      --  get a warning.
2469
 
2470
      --  What we do is to detect these cases, and if we find them, flag the
2471
      --  subprogram as being Is_Trivial_Subprogram and then use that flag to
2472
      --  suppress unwanted warnings. For the case of the function stub above
2473
      --  we have a special test to set X as apparently assigned to suppress
2474
      --  the warning.
2475
 
2476
      declare
2477
         Stm : Node_Id;
2478
 
2479
      begin
2480
         --  Skip initial labels (for one thing this occurs when we are in
2481
         --  front end ZCX mode, but in any case it is irrelevant), and also
2482
         --  initial Push_xxx_Error_Label nodes, which are also irrelevant.
2483
 
2484
         Stm := First (Statements (HSS));
2485
         while Nkind (Stm) = N_Label
2486
           or else Nkind (Stm) in N_Push_xxx_Label
2487
         loop
2488
            Next (Stm);
2489
         end loop;
2490
 
2491
         --  Do the test on the original statement before expansion
2492
 
2493
         declare
2494
            Ostm : constant Node_Id := Original_Node (Stm);
2495
 
2496
         begin
2497
            --  If explicit raise statement, turn on flag
2498
 
2499
            if Nkind (Ostm) = N_Raise_Statement then
2500
               Set_Trivial_Subprogram (Stm);
2501
 
2502
            --  If null statement, and no following statements, turn on flag
2503
 
2504
            elsif Nkind (Stm) = N_Null_Statement
2505
              and then Comes_From_Source (Stm)
2506
              and then No (Next (Stm))
2507
            then
2508
               Set_Trivial_Subprogram (Stm);
2509
 
2510
            --  Check for explicit call cases which likely raise an exception
2511
 
2512
            elsif Nkind (Ostm) = N_Procedure_Call_Statement then
2513
               if Is_Entity_Name (Name (Ostm)) then
2514
                  declare
2515
                     Ent : constant Entity_Id := Entity (Name (Ostm));
2516
 
2517
                  begin
2518
                     --  If the procedure is marked No_Return, then likely it
2519
                     --  raises an exception, but in any case it is not coming
2520
                     --  back here, so turn on the flag.
2521
 
2522
                     if Ekind (Ent) = E_Procedure
2523
                       and then No_Return (Ent)
2524
                     then
2525
                        Set_Trivial_Subprogram (Stm);
2526
                     end if;
2527
                  end;
2528
               end if;
2529
            end if;
2530
         end;
2531
      end;
2532
 
2533
      --  Check for variables that are never modified
2534
 
2535
      declare
2536
         E1, E2 : Entity_Id;
2537
 
2538
      begin
2539
         --  If there is a separate spec, then transfer Never_Set_In_Source
2540
         --  flags from out parameters to the corresponding entities in the
2541
         --  body. The reason we do that is we want to post error flags on
2542
         --  the body entities, not the spec entities.
2543
 
2544
         if Present (Spec_Id) then
2545
            E1 := First_Entity (Spec_Id);
2546
            while Present (E1) loop
2547
               if Ekind (E1) = E_Out_Parameter then
2548
                  E2 := First_Entity (Body_Id);
2549
                  while Present (E2) loop
2550
                     exit when Chars (E1) = Chars (E2);
2551
                     Next_Entity (E2);
2552
                  end loop;
2553
 
2554
                  if Present (E2) then
2555
                     Set_Never_Set_In_Source (E2, Never_Set_In_Source (E1));
2556
                  end if;
2557
               end if;
2558
 
2559
               Next_Entity (E1);
2560
            end loop;
2561
         end if;
2562
 
2563
         --  Check references in body unless it was deleted. Note that the
2564
         --  check of Body_Deleted here is not just for efficiency, it is
2565
         --  necessary to avoid junk warnings on formal parameters.
2566
 
2567
         if not Body_Deleted then
2568
            Check_References (Body_Id);
2569
         end if;
2570
      end;
2571
   end Analyze_Subprogram_Body_Helper;
2572
 
2573
   ------------------------------------
2574
   -- Analyze_Subprogram_Declaration --
2575
   ------------------------------------
2576
 
2577
   procedure Analyze_Subprogram_Declaration (N : Node_Id) is
2578
      Loc        : constant Source_Ptr := Sloc (N);
2579
      Designator : Entity_Id;
2580
      Form       : Node_Id;
2581
      Scop       : constant Entity_Id := Current_Scope;
2582
      Null_Body  : Node_Id := Empty;
2583
 
2584
   --  Start of processing for Analyze_Subprogram_Declaration
2585
 
2586
   begin
2587
      --  For a null procedure, capture the profile before analysis, for
2588
      --  expansion at the freeze point and at each point of call.
2589
      --  The body will only be used if the procedure has preconditions.
2590
      --  In that case the body is analyzed at the freeze point.
2591
 
2592
      if Nkind (Specification (N)) = N_Procedure_Specification
2593
        and then Null_Present (Specification (N))
2594
        and then Expander_Active
2595
      then
2596
         Null_Body :=
2597
           Make_Subprogram_Body (Loc,
2598
             Specification =>
2599
               New_Copy_Tree (Specification (N)),
2600
             Declarations =>
2601
               New_List,
2602
             Handled_Statement_Sequence =>
2603
               Make_Handled_Sequence_Of_Statements (Loc,
2604
                 Statements => New_List (Make_Null_Statement (Loc))));
2605
 
2606
         --  Create new entities for body and formals
2607
 
2608
         Set_Defining_Unit_Name (Specification (Null_Body),
2609
           Make_Defining_Identifier (Loc, Chars (Defining_Entity (N))));
2610
         Set_Corresponding_Body (N, Defining_Entity (Null_Body));
2611
 
2612
         Form := First (Parameter_Specifications (Specification (Null_Body)));
2613
         while Present (Form) loop
2614
            Set_Defining_Identifier (Form,
2615
              Make_Defining_Identifier (Loc,
2616
                Chars (Defining_Identifier (Form))));
2617
            Next (Form);
2618
         end loop;
2619
 
2620
         if Is_Protected_Type (Current_Scope) then
2621
            Error_Msg_N
2622
              ("protected operation cannot be a null procedure", N);
2623
         end if;
2624
      end if;
2625
 
2626
      Designator :=  Analyze_Subprogram_Specification (Specification (N));
2627
      Generate_Definition (Designator);
2628
 
2629
      if Debug_Flag_C then
2630
         Write_Str ("==> subprogram spec ");
2631
         Write_Name (Chars (Designator));
2632
         Write_Str (" from ");
2633
         Write_Location (Sloc (N));
2634
         Write_Eol;
2635
         Indent;
2636
      end if;
2637
 
2638
      if Nkind (Specification (N)) = N_Procedure_Specification
2639
        and then Null_Present (Specification (N))
2640
      then
2641
         Set_Has_Completion (Designator);
2642
 
2643
         if Present (Null_Body) then
2644
            Set_Corresponding_Body (N, Defining_Entity (Null_Body));
2645
            Set_Body_To_Inline (N, Null_Body);
2646
            Set_Is_Inlined (Designator);
2647
         end if;
2648
      end if;
2649
 
2650
      Validate_RCI_Subprogram_Declaration (N);
2651
      New_Overloaded_Entity (Designator);
2652
      Check_Delayed_Subprogram (Designator);
2653
 
2654
      --  If the type of the first formal of the current subprogram is a
2655
      --  nongeneric tagged private type, mark the subprogram as being a
2656
      --  private primitive. Ditto if this is a function with controlling
2657
      --  result, and the return type is currently private. In both cases,
2658
      --  the type of the controlling argument or result must be in the
2659
      --  current scope for the operation to be primitive.
2660
 
2661
      if Has_Controlling_Result (Designator)
2662
        and then Is_Private_Type (Etype (Designator))
2663
        and then Scope (Etype (Designator)) = Current_Scope
2664
        and then not Is_Generic_Actual_Type (Etype (Designator))
2665
      then
2666
         Set_Is_Private_Primitive (Designator);
2667
 
2668
      elsif Present (First_Formal (Designator)) then
2669
         declare
2670
            Formal_Typ : constant Entity_Id :=
2671
                           Etype (First_Formal (Designator));
2672
         begin
2673
            Set_Is_Private_Primitive (Designator,
2674
              Is_Tagged_Type (Formal_Typ)
2675
                and then Scope (Formal_Typ) = Current_Scope
2676
                and then Is_Private_Type (Formal_Typ)
2677
                and then not Is_Generic_Actual_Type (Formal_Typ));
2678
         end;
2679
      end if;
2680
 
2681
      --  Ada 2005 (AI-251): Abstract interface primitives must be abstract
2682
      --  or null.
2683
 
2684
      if Ada_Version >= Ada_05
2685
        and then Comes_From_Source (N)
2686
        and then Is_Dispatching_Operation (Designator)
2687
      then
2688
         declare
2689
            E    : Entity_Id;
2690
            Etyp : Entity_Id;
2691
 
2692
         begin
2693
            if Has_Controlling_Result (Designator) then
2694
               Etyp := Etype (Designator);
2695
 
2696
            else
2697
               E := First_Entity (Designator);
2698
               while Present (E)
2699
                 and then Is_Formal (E)
2700
                 and then not Is_Controlling_Formal (E)
2701
               loop
2702
                  Next_Entity (E);
2703
               end loop;
2704
 
2705
               Etyp := Etype (E);
2706
            end if;
2707
 
2708
            if Is_Access_Type (Etyp) then
2709
               Etyp := Directly_Designated_Type (Etyp);
2710
            end if;
2711
 
2712
            if Is_Interface (Etyp)
2713
              and then not Is_Abstract_Subprogram (Designator)
2714
              and then not (Ekind (Designator) = E_Procedure
2715
                              and then Null_Present (Specification (N)))
2716
            then
2717
               Error_Msg_Name_1 := Chars (Defining_Entity (N));
2718
               Error_Msg_N
2719
                 ("(Ada 2005) interface subprogram % must be abstract or null",
2720
                  N);
2721
            end if;
2722
         end;
2723
      end if;
2724
 
2725
      --  What is the following code for, it used to be
2726
 
2727
      --  ???   Set_Suppress_Elaboration_Checks
2728
      --  ???     (Designator, Elaboration_Checks_Suppressed (Designator));
2729
 
2730
      --  The following seems equivalent, but a bit dubious
2731
 
2732
      if Elaboration_Checks_Suppressed (Designator) then
2733
         Set_Kill_Elaboration_Checks (Designator);
2734
      end if;
2735
 
2736
      if Scop /= Standard_Standard
2737
        and then not Is_Child_Unit (Designator)
2738
      then
2739
         Set_Categorization_From_Scope (Designator, Scop);
2740
      else
2741
         --  For a compilation unit, check for library-unit pragmas
2742
 
2743
         Push_Scope (Designator);
2744
         Set_Categorization_From_Pragmas (N);
2745
         Validate_Categorization_Dependency (N, Designator);
2746
         Pop_Scope;
2747
      end if;
2748
 
2749
      --  For a compilation unit, set body required. This flag will only be
2750
      --  reset if a valid Import or Interface pragma is processed later on.
2751
 
2752
      if Nkind (Parent (N)) = N_Compilation_Unit then
2753
         Set_Body_Required (Parent (N), True);
2754
 
2755
         if Ada_Version >= Ada_05
2756
           and then Nkind (Specification (N)) = N_Procedure_Specification
2757
           and then Null_Present (Specification (N))
2758
         then
2759
            Error_Msg_N
2760
              ("null procedure cannot be declared at library level", N);
2761
         end if;
2762
      end if;
2763
 
2764
      Generate_Reference_To_Formals (Designator);
2765
      Check_Eliminated (Designator);
2766
 
2767
      if Debug_Flag_C then
2768
         Outdent;
2769
         Write_Str ("<== subprogram spec ");
2770
         Write_Name (Chars (Designator));
2771
         Write_Str (" from ");
2772
         Write_Location (Sloc (N));
2773
         Write_Eol;
2774
      end if;
2775
   end Analyze_Subprogram_Declaration;
2776
 
2777
   --------------------------------------
2778
   -- Analyze_Subprogram_Specification --
2779
   --------------------------------------
2780
 
2781
   --  Reminder: N here really is a subprogram specification (not a subprogram
2782
   --  declaration). This procedure is called to analyze the specification in
2783
   --  both subprogram bodies and subprogram declarations (specs).
2784
 
2785
   function Analyze_Subprogram_Specification (N : Node_Id) return Entity_Id is
2786
      Designator : constant Entity_Id := Defining_Entity (N);
2787
      Formals    : constant List_Id   := Parameter_Specifications (N);
2788
 
2789
   --  Start of processing for Analyze_Subprogram_Specification
2790
 
2791
   begin
2792
      Generate_Definition (Designator);
2793
 
2794
      if Nkind (N) = N_Function_Specification then
2795
         Set_Ekind (Designator, E_Function);
2796
         Set_Mechanism (Designator, Default_Mechanism);
2797
 
2798
      else
2799
         Set_Ekind (Designator, E_Procedure);
2800
         Set_Etype (Designator, Standard_Void_Type);
2801
      end if;
2802
 
2803
      --  Introduce new scope for analysis of the formals and the return type
2804
 
2805
      Set_Scope (Designator, Current_Scope);
2806
 
2807
      if Present (Formals) then
2808
         Push_Scope (Designator);
2809
         Process_Formals (Formals, N);
2810
 
2811
         --  Ada 2005 (AI-345): If this is an overriding operation of an
2812
         --  inherited interface operation, and the controlling type is
2813
         --  a synchronized type, replace the type with its corresponding
2814
         --  record, to match the proper signature of an overriding operation.
2815
         --  Same processing for an access parameter whose designated type is
2816
         --  derived from a synchronized interface.
2817
 
2818
         if Ada_Version >= Ada_05 then
2819
            declare
2820
               Formal     : Entity_Id;
2821
               Formal_Typ : Entity_Id;
2822
               Rec_Typ    : Entity_Id;
2823
               Desig_Typ  : Entity_Id;
2824
 
2825
            begin
2826
               Formal := First_Formal (Designator);
2827
               while Present (Formal) loop
2828
                  Formal_Typ := Etype (Formal);
2829
 
2830
                  if Is_Concurrent_Type (Formal_Typ)
2831
                    and then Present (Corresponding_Record_Type (Formal_Typ))
2832
                  then
2833
                     Rec_Typ := Corresponding_Record_Type (Formal_Typ);
2834
 
2835
                     if Present (Interfaces (Rec_Typ)) then
2836
                        Set_Etype (Formal, Rec_Typ);
2837
                     end if;
2838
 
2839
                  elsif Ekind (Formal_Typ) = E_Anonymous_Access_Type then
2840
                     Desig_Typ := Designated_Type (Formal_Typ);
2841
 
2842
                     if Is_Concurrent_Type (Desig_Typ)
2843
                       and then Present (Corresponding_Record_Type (Desig_Typ))
2844
                     then
2845
                        Rec_Typ := Corresponding_Record_Type (Desig_Typ);
2846
 
2847
                        if Present (Interfaces (Rec_Typ)) then
2848
                           Set_Directly_Designated_Type (Formal_Typ, Rec_Typ);
2849
                        end if;
2850
                     end if;
2851
                  end if;
2852
 
2853
                  Next_Formal (Formal);
2854
               end loop;
2855
            end;
2856
         end if;
2857
 
2858
         End_Scope;
2859
 
2860
      --  The subprogram scope is pushed and popped around the processing of
2861
      --  the return type for consistency with call above to Process_Formals
2862
      --  (which itself can call Analyze_Return_Type), and to ensure that any
2863
      --  itype created for the return type will be associated with the proper
2864
      --  scope.
2865
 
2866
      elsif Nkind (N) = N_Function_Specification then
2867
         Push_Scope (Designator);
2868
 
2869
         Analyze_Return_Type (N);
2870
 
2871
         End_Scope;
2872
      end if;
2873
 
2874
      if Nkind (N) = N_Function_Specification then
2875
         if Nkind (Designator) = N_Defining_Operator_Symbol then
2876
            Valid_Operator_Definition (Designator);
2877
         end if;
2878
 
2879
         May_Need_Actuals (Designator);
2880
 
2881
         --  Ada 2005 (AI-251): If the return type is abstract, verify that
2882
         --  the subprogram is abstract also. This does not apply to renaming
2883
         --  declarations, where abstractness is inherited.
2884
         --  In case of primitives associated with abstract interface types
2885
         --  the check is applied later (see Analyze_Subprogram_Declaration).
2886
 
2887
         if Is_Abstract_Type (Etype (Designator))
2888
           and then not Is_Interface (Etype (Designator))
2889
           and then Nkind (Parent (N)) /= N_Subprogram_Renaming_Declaration
2890
           and then Nkind (Parent (N)) /=
2891
                      N_Abstract_Subprogram_Declaration
2892
           and then
2893
             (Nkind (Parent (N))) /= N_Formal_Abstract_Subprogram_Declaration
2894
         then
2895
            Error_Msg_N
2896
              ("function that returns abstract type must be abstract", N);
2897
         end if;
2898
      end if;
2899
 
2900
      return Designator;
2901
   end Analyze_Subprogram_Specification;
2902
 
2903
   --------------------------
2904
   -- Build_Body_To_Inline --
2905
   --------------------------
2906
 
2907
   procedure Build_Body_To_Inline (N : Node_Id; Subp : Entity_Id) is
2908
      Decl            : constant Node_Id := Unit_Declaration_Node (Subp);
2909
      Original_Body   : Node_Id;
2910
      Body_To_Analyze : Node_Id;
2911
      Max_Size        : constant := 10;
2912
      Stat_Count      : Integer := 0;
2913
 
2914
      function Has_Excluded_Declaration (Decls : List_Id) return Boolean;
2915
      --  Check for declarations that make inlining not worthwhile
2916
 
2917
      function Has_Excluded_Statement   (Stats : List_Id) return Boolean;
2918
      --  Check for statements that make inlining not worthwhile: any tasking
2919
      --  statement, nested at any level. Keep track of total number of
2920
      --  elementary statements, as a measure of acceptable size.
2921
 
2922
      function Has_Pending_Instantiation return Boolean;
2923
      --  If some enclosing body contains instantiations that appear before the
2924
      --  corresponding generic body, the enclosing body has a freeze node so
2925
      --  that it can be elaborated after the generic itself. This might
2926
      --  conflict with subsequent inlinings, so that it is unsafe to try to
2927
      --  inline in such a case.
2928
 
2929
      function Has_Single_Return return Boolean;
2930
      --  In general we cannot inline functions that return unconstrained type.
2931
      --  However, we can handle such functions if all return statements return
2932
      --  a local variable that is the only declaration in the body of the
2933
      --  function. In that case the call can be replaced by that local
2934
      --  variable as is done for other inlined calls.
2935
 
2936
      procedure Remove_Pragmas;
2937
      --  A pragma Unreferenced or pragma Unmodified that mentions a formal
2938
      --  parameter has no meaning when the body is inlined and the formals
2939
      --  are rewritten. Remove it from body to inline. The analysis of the
2940
      --  non-inlined body will handle the pragma properly.
2941
 
2942
      function Uses_Secondary_Stack (Bod : Node_Id) return Boolean;
2943
      --  If the body of the subprogram includes a call that returns an
2944
      --  unconstrained type, the secondary stack is involved, and it
2945
      --  is not worth inlining.
2946
 
2947
      ------------------------------
2948
      -- Has_Excluded_Declaration --
2949
      ------------------------------
2950
 
2951
      function Has_Excluded_Declaration (Decls : List_Id) return Boolean is
2952
         D : Node_Id;
2953
 
2954
         function Is_Unchecked_Conversion (D : Node_Id) return Boolean;
2955
         --  Nested subprograms make a given body ineligible for inlining, but
2956
         --  we make an exception for instantiations of unchecked conversion.
2957
         --  The body has not been analyzed yet, so check the name, and verify
2958
         --  that the visible entity with that name is the predefined unit.
2959
 
2960
         -----------------------------
2961
         -- Is_Unchecked_Conversion --
2962
         -----------------------------
2963
 
2964
         function Is_Unchecked_Conversion (D : Node_Id) return Boolean is
2965
            Id   : constant Node_Id := Name (D);
2966
            Conv : Entity_Id;
2967
 
2968
         begin
2969
            if Nkind (Id) = N_Identifier
2970
              and then Chars (Id) = Name_Unchecked_Conversion
2971
            then
2972
               Conv := Current_Entity (Id);
2973
 
2974
            elsif Nkind_In (Id, N_Selected_Component, N_Expanded_Name)
2975
              and then Chars (Selector_Name (Id)) = Name_Unchecked_Conversion
2976
            then
2977
               Conv := Current_Entity (Selector_Name (Id));
2978
            else
2979
               return False;
2980
            end if;
2981
 
2982
            return Present (Conv)
2983
              and then Is_Predefined_File_Name
2984
                         (Unit_File_Name (Get_Source_Unit (Conv)))
2985
              and then Is_Intrinsic_Subprogram (Conv);
2986
         end Is_Unchecked_Conversion;
2987
 
2988
      --  Start of processing for Has_Excluded_Declaration
2989
 
2990
      begin
2991
         D := First (Decls);
2992
         while Present (D) loop
2993
            if (Nkind (D) = N_Function_Instantiation
2994
                  and then not Is_Unchecked_Conversion (D))
2995
              or else Nkind_In (D, N_Protected_Type_Declaration,
2996
                                   N_Package_Declaration,
2997
                                   N_Package_Instantiation,
2998
                                   N_Subprogram_Body,
2999
                                   N_Procedure_Instantiation,
3000
                                   N_Task_Type_Declaration)
3001
            then
3002
               Cannot_Inline
3003
                 ("cannot inline & (non-allowed declaration)?", D, Subp);
3004
               return True;
3005
            end if;
3006
 
3007
            Next (D);
3008
         end loop;
3009
 
3010
         return False;
3011
      end Has_Excluded_Declaration;
3012
 
3013
      ----------------------------
3014
      -- Has_Excluded_Statement --
3015
      ----------------------------
3016
 
3017
      function Has_Excluded_Statement (Stats : List_Id) return Boolean is
3018
         S : Node_Id;
3019
         E : Node_Id;
3020
 
3021
      begin
3022
         S := First (Stats);
3023
         while Present (S) loop
3024
            Stat_Count := Stat_Count + 1;
3025
 
3026
            if Nkind_In (S, N_Abort_Statement,
3027
                            N_Asynchronous_Select,
3028
                            N_Conditional_Entry_Call,
3029
                            N_Delay_Relative_Statement,
3030
                            N_Delay_Until_Statement,
3031
                            N_Selective_Accept,
3032
                            N_Timed_Entry_Call)
3033
            then
3034
               Cannot_Inline
3035
                 ("cannot inline & (non-allowed statement)?", S, Subp);
3036
               return True;
3037
 
3038
            elsif Nkind (S) = N_Block_Statement then
3039
               if Present (Declarations (S))
3040
                 and then Has_Excluded_Declaration (Declarations (S))
3041
               then
3042
                  return True;
3043
 
3044
               elsif Present (Handled_Statement_Sequence (S))
3045
                  and then
3046
                    (Present
3047
                      (Exception_Handlers (Handled_Statement_Sequence (S)))
3048
                     or else
3049
                       Has_Excluded_Statement
3050
                         (Statements (Handled_Statement_Sequence (S))))
3051
               then
3052
                  return True;
3053
               end if;
3054
 
3055
            elsif Nkind (S) = N_Case_Statement then
3056
               E := First (Alternatives (S));
3057
               while Present (E) loop
3058
                  if Has_Excluded_Statement (Statements (E)) then
3059
                     return True;
3060
                  end if;
3061
 
3062
                  Next (E);
3063
               end loop;
3064
 
3065
            elsif Nkind (S) = N_If_Statement then
3066
               if Has_Excluded_Statement (Then_Statements (S)) then
3067
                  return True;
3068
               end if;
3069
 
3070
               if Present (Elsif_Parts (S)) then
3071
                  E := First (Elsif_Parts (S));
3072
                  while Present (E) loop
3073
                     if Has_Excluded_Statement (Then_Statements (E)) then
3074
                        return True;
3075
                     end if;
3076
                     Next (E);
3077
                  end loop;
3078
               end if;
3079
 
3080
               if Present (Else_Statements (S))
3081
                 and then Has_Excluded_Statement (Else_Statements (S))
3082
               then
3083
                  return True;
3084
               end if;
3085
 
3086
            elsif Nkind (S) = N_Loop_Statement
3087
              and then Has_Excluded_Statement (Statements (S))
3088
            then
3089
               return True;
3090
            end if;
3091
 
3092
            Next (S);
3093
         end loop;
3094
 
3095
         return False;
3096
      end Has_Excluded_Statement;
3097
 
3098
      -------------------------------
3099
      -- Has_Pending_Instantiation --
3100
      -------------------------------
3101
 
3102
      function Has_Pending_Instantiation return Boolean is
3103
         S : Entity_Id;
3104
 
3105
      begin
3106
         S := Current_Scope;
3107
         while Present (S) loop
3108
            if Is_Compilation_Unit (S)
3109
              or else Is_Child_Unit (S)
3110
            then
3111
               return False;
3112
            elsif Ekind (S) = E_Package
3113
              and then Has_Forward_Instantiation (S)
3114
            then
3115
               return True;
3116
            end if;
3117
 
3118
            S := Scope (S);
3119
         end loop;
3120
 
3121
         return False;
3122
      end Has_Pending_Instantiation;
3123
 
3124
      ------------------------
3125
      --  Has_Single_Return --
3126
      ------------------------
3127
 
3128
      function Has_Single_Return return Boolean is
3129
         Return_Statement : Node_Id := Empty;
3130
 
3131
         function Check_Return (N : Node_Id) return Traverse_Result;
3132
 
3133
         ------------------
3134
         -- Check_Return --
3135
         ------------------
3136
 
3137
         function Check_Return (N : Node_Id) return Traverse_Result is
3138
         begin
3139
            if Nkind (N) = N_Simple_Return_Statement then
3140
               if Present (Expression (N))
3141
                 and then Is_Entity_Name (Expression (N))
3142
               then
3143
                  if No (Return_Statement) then
3144
                     Return_Statement := N;
3145
                     return OK;
3146
 
3147
                  elsif Chars (Expression (N)) =
3148
                        Chars (Expression (Return_Statement))
3149
                  then
3150
                     return OK;
3151
 
3152
                  else
3153
                     return Abandon;
3154
                  end if;
3155
 
3156
               else
3157
                  --  Expression has wrong form
3158
 
3159
                  return Abandon;
3160
               end if;
3161
 
3162
            else
3163
               return OK;
3164
            end if;
3165
         end Check_Return;
3166
 
3167
         function Check_All_Returns is new Traverse_Func (Check_Return);
3168
 
3169
      --  Start of processing for Has_Single_Return
3170
 
3171
      begin
3172
         return Check_All_Returns (N) = OK
3173
           and then Present (Declarations (N))
3174
           and then Present (First (Declarations (N)))
3175
           and then Chars (Expression (Return_Statement)) =
3176
                    Chars (Defining_Identifier (First (Declarations (N))));
3177
      end Has_Single_Return;
3178
 
3179
      --------------------
3180
      -- Remove_Pragmas --
3181
      --------------------
3182
 
3183
      procedure Remove_Pragmas is
3184
         Decl : Node_Id;
3185
         Nxt  : Node_Id;
3186
 
3187
      begin
3188
         Decl := First (Declarations (Body_To_Analyze));
3189
         while Present (Decl) loop
3190
            Nxt := Next (Decl);
3191
 
3192
            if Nkind (Decl) = N_Pragma
3193
              and then (Pragma_Name (Decl) = Name_Unreferenced
3194
                          or else
3195
                        Pragma_Name (Decl) = Name_Unmodified)
3196
            then
3197
               Remove (Decl);
3198
            end if;
3199
 
3200
            Decl := Nxt;
3201
         end loop;
3202
      end Remove_Pragmas;
3203
 
3204
      --------------------------
3205
      -- Uses_Secondary_Stack --
3206
      --------------------------
3207
 
3208
      function Uses_Secondary_Stack (Bod : Node_Id) return Boolean is
3209
         function Check_Call (N : Node_Id) return Traverse_Result;
3210
         --  Look for function calls that return an unconstrained type
3211
 
3212
         ----------------
3213
         -- Check_Call --
3214
         ----------------
3215
 
3216
         function Check_Call (N : Node_Id) return Traverse_Result is
3217
         begin
3218
            if Nkind (N) = N_Function_Call
3219
              and then Is_Entity_Name (Name (N))
3220
              and then Is_Composite_Type (Etype (Entity (Name (N))))
3221
              and then not Is_Constrained (Etype (Entity (Name (N))))
3222
            then
3223
               Cannot_Inline
3224
                 ("cannot inline & (call returns unconstrained type)?",
3225
                    N, Subp);
3226
               return Abandon;
3227
            else
3228
               return OK;
3229
            end if;
3230
         end Check_Call;
3231
 
3232
         function Check_Calls is new Traverse_Func (Check_Call);
3233
 
3234
      begin
3235
         return Check_Calls (Bod) = Abandon;
3236
      end Uses_Secondary_Stack;
3237
 
3238
   --  Start of processing for Build_Body_To_Inline
3239
 
3240
   begin
3241
      --  Return immediately if done already
3242
 
3243
      if Nkind (Decl) = N_Subprogram_Declaration
3244
        and then Present (Body_To_Inline (Decl))
3245
      then
3246
         return;
3247
 
3248
      --  Functions that return unconstrained composite types require
3249
      --  secondary stack handling, and cannot currently be inlined, unless
3250
      --  all return statements return a local variable that is the first
3251
      --  local declaration in the body.
3252
 
3253
      elsif Ekind (Subp) = E_Function
3254
        and then not Is_Scalar_Type (Etype (Subp))
3255
        and then not Is_Access_Type (Etype (Subp))
3256
        and then not Is_Constrained (Etype (Subp))
3257
      then
3258
         if not Has_Single_Return then
3259
            Cannot_Inline
3260
              ("cannot inline & (unconstrained return type)?", N, Subp);
3261
            return;
3262
         end if;
3263
 
3264
      --  Ditto for functions that return controlled types, where controlled
3265
      --  actions interfere in complex ways with inlining.
3266
 
3267
      elsif Ekind (Subp) = E_Function
3268
        and then Needs_Finalization (Etype (Subp))
3269
      then
3270
         Cannot_Inline
3271
           ("cannot inline & (controlled return type)?", N, Subp);
3272
         return;
3273
      end if;
3274
 
3275
      if Present (Declarations (N))
3276
        and then Has_Excluded_Declaration (Declarations (N))
3277
      then
3278
         return;
3279
      end if;
3280
 
3281
      if Present (Handled_Statement_Sequence (N)) then
3282
         if Present (Exception_Handlers (Handled_Statement_Sequence (N))) then
3283
            Cannot_Inline
3284
              ("cannot inline& (exception handler)?",
3285
               First (Exception_Handlers (Handled_Statement_Sequence (N))),
3286
               Subp);
3287
            return;
3288
         elsif
3289
           Has_Excluded_Statement
3290
             (Statements (Handled_Statement_Sequence (N)))
3291
         then
3292
            return;
3293
         end if;
3294
      end if;
3295
 
3296
      --  We do not inline a subprogram  that is too large, unless it is
3297
      --  marked Inline_Always. This pragma does not suppress the other
3298
      --  checks on inlining (forbidden declarations, handlers, etc).
3299
 
3300
      if Stat_Count > Max_Size
3301
        and then not Has_Pragma_Inline_Always (Subp)
3302
      then
3303
         Cannot_Inline ("cannot inline& (body too large)?", N, Subp);
3304
         return;
3305
      end if;
3306
 
3307
      if Has_Pending_Instantiation then
3308
         Cannot_Inline
3309
           ("cannot inline& (forward instance within enclosing body)?",
3310
             N, Subp);
3311
         return;
3312
      end if;
3313
 
3314
      --  Within an instance, the body to inline must be treated as a nested
3315
      --  generic, so that the proper global references are preserved.
3316
 
3317
      --  Note that we do not do this at the library level, because it is not
3318
      --  needed, and furthermore this causes trouble if front end inlining
3319
      --  is activated (-gnatN).
3320
 
3321
      if In_Instance and then Scope (Current_Scope) /= Standard_Standard then
3322
         Save_Env (Scope (Current_Scope), Scope (Current_Scope));
3323
         Original_Body := Copy_Generic_Node (N, Empty, True);
3324
      else
3325
         Original_Body := Copy_Separate_Tree (N);
3326
      end if;
3327
 
3328
      --  We need to capture references to the formals in order to substitute
3329
      --  the actuals at the point of inlining, i.e. instantiation. To treat
3330
      --  the formals as globals to the body to inline, we nest it within
3331
      --  a dummy parameterless subprogram, declared within the real one.
3332
      --  To avoid generating an internal name (which is never public, and
3333
      --  which affects serial numbers of other generated names), we use
3334
      --  an internal symbol that cannot conflict with user declarations.
3335
 
3336
      Set_Parameter_Specifications (Specification (Original_Body), No_List);
3337
      Set_Defining_Unit_Name
3338
        (Specification (Original_Body),
3339
          Make_Defining_Identifier (Sloc (N), Name_uParent));
3340
      Set_Corresponding_Spec (Original_Body, Empty);
3341
 
3342
      Body_To_Analyze := Copy_Generic_Node (Original_Body, Empty, False);
3343
 
3344
      --  Set return type of function, which is also global and does not need
3345
      --  to be resolved.
3346
 
3347
      if Ekind (Subp) = E_Function then
3348
         Set_Result_Definition (Specification (Body_To_Analyze),
3349
           New_Occurrence_Of (Etype (Subp), Sloc (N)));
3350
      end if;
3351
 
3352
      if No (Declarations (N)) then
3353
         Set_Declarations (N, New_List (Body_To_Analyze));
3354
      else
3355
         Append (Body_To_Analyze, Declarations (N));
3356
      end if;
3357
 
3358
      Expander_Mode_Save_And_Set (False);
3359
      Remove_Pragmas;
3360
 
3361
      Analyze (Body_To_Analyze);
3362
      Push_Scope (Defining_Entity (Body_To_Analyze));
3363
      Save_Global_References (Original_Body);
3364
      End_Scope;
3365
      Remove (Body_To_Analyze);
3366
 
3367
      Expander_Mode_Restore;
3368
 
3369
      --  Restore environment if previously saved
3370
 
3371
      if In_Instance and then Scope (Current_Scope) /= Standard_Standard then
3372
         Restore_Env;
3373
      end if;
3374
 
3375
      --  If secondary stk used there is no point in inlining. We have
3376
      --  already issued the warning in this case, so nothing to do.
3377
 
3378
      if Uses_Secondary_Stack (Body_To_Analyze) then
3379
         return;
3380
      end if;
3381
 
3382
      Set_Body_To_Inline (Decl, Original_Body);
3383
      Set_Ekind (Defining_Entity (Original_Body), Ekind (Subp));
3384
      Set_Is_Inlined (Subp);
3385
   end Build_Body_To_Inline;
3386
 
3387
   -------------------
3388
   -- Cannot_Inline --
3389
   -------------------
3390
 
3391
   procedure Cannot_Inline (Msg : String; N : Node_Id; Subp : Entity_Id) is
3392
   begin
3393
      --  Do not emit warning if this is a predefined unit which is not
3394
      --  the main unit. With validity checks enabled, some predefined
3395
      --  subprograms may contain nested subprograms and become ineligible
3396
      --  for inlining.
3397
 
3398
      if Is_Predefined_File_Name (Unit_File_Name (Get_Source_Unit (Subp)))
3399
        and then not In_Extended_Main_Source_Unit (Subp)
3400
      then
3401
         null;
3402
 
3403
      elsif Has_Pragma_Inline_Always (Subp) then
3404
 
3405
         --  Remove last character (question mark) to make this into an error,
3406
         --  because the Inline_Always pragma cannot be obeyed.
3407
 
3408
         Error_Msg_NE (Msg (Msg'First .. Msg'Last - 1), N, Subp);
3409
 
3410
      elsif Ineffective_Inline_Warnings then
3411
         Error_Msg_NE (Msg, N, Subp);
3412
      end if;
3413
   end Cannot_Inline;
3414
 
3415
   -----------------------
3416
   -- Check_Conformance --
3417
   -----------------------
3418
 
3419
   procedure Check_Conformance
3420
     (New_Id                   : Entity_Id;
3421
      Old_Id                   : Entity_Id;
3422
      Ctype                    : Conformance_Type;
3423
      Errmsg                   : Boolean;
3424
      Conforms                 : out Boolean;
3425
      Err_Loc                  : Node_Id := Empty;
3426
      Get_Inst                 : Boolean := False;
3427
      Skip_Controlling_Formals : Boolean := False)
3428
   is
3429
      procedure Conformance_Error (Msg : String; N : Node_Id := New_Id);
3430
      --  Sets Conforms to False. If Errmsg is False, then that's all it does.
3431
      --  If Errmsg is True, then processing continues to post an error message
3432
      --  for conformance error on given node. Two messages are output. The
3433
      --  first message points to the previous declaration with a general "no
3434
      --  conformance" message. The second is the detailed reason, supplied as
3435
      --  Msg. The parameter N provide information for a possible & insertion
3436
      --  in the message, and also provides the location for posting the
3437
      --  message in the absence of a specified Err_Loc location.
3438
 
3439
      -----------------------
3440
      -- Conformance_Error --
3441
      -----------------------
3442
 
3443
      procedure Conformance_Error (Msg : String; N : Node_Id := New_Id) is
3444
         Enode : Node_Id;
3445
 
3446
      begin
3447
         Conforms := False;
3448
 
3449
         if Errmsg then
3450
            if No (Err_Loc) then
3451
               Enode := N;
3452
            else
3453
               Enode := Err_Loc;
3454
            end if;
3455
 
3456
            Error_Msg_Sloc := Sloc (Old_Id);
3457
 
3458
            case Ctype is
3459
               when Type_Conformant =>
3460
                  Error_Msg_N -- CODEFIX
3461
                    ("not type conformant with declaration#!", Enode);
3462
 
3463
               when Mode_Conformant =>
3464
                  if Nkind (Parent (Old_Id)) = N_Full_Type_Declaration then
3465
                     Error_Msg_N -- CODEFIX???
3466
                       ("not mode conformant with operation inherited#!",
3467
                         Enode);
3468
                  else
3469
                     Error_Msg_N -- CODEFIX???
3470
                       ("not mode conformant with declaration#!", Enode);
3471
                  end if;
3472
 
3473
               when Subtype_Conformant =>
3474
                  if Nkind (Parent (Old_Id)) = N_Full_Type_Declaration then
3475
                     Error_Msg_N -- CODEFIX???
3476
                       ("not subtype conformant with operation inherited#!",
3477
                         Enode);
3478
                  else
3479
                     Error_Msg_N -- CODEFIX???
3480
                       ("not subtype conformant with declaration#!", Enode);
3481
                  end if;
3482
 
3483
               when Fully_Conformant =>
3484
                  if Nkind (Parent (Old_Id)) = N_Full_Type_Declaration then
3485
                     Error_Msg_N -- CODEFIX
3486
                       ("not fully conformant with operation inherited#!",
3487
                         Enode);
3488
                  else
3489
                     Error_Msg_N -- CODEFIX
3490
                       ("not fully conformant with declaration#!", Enode);
3491
                  end if;
3492
            end case;
3493
 
3494
            Error_Msg_NE (Msg, Enode, N);
3495
         end if;
3496
      end Conformance_Error;
3497
 
3498
      --  Local Variables
3499
 
3500
      Old_Type           : constant Entity_Id := Etype (Old_Id);
3501
      New_Type           : constant Entity_Id := Etype (New_Id);
3502
      Old_Formal         : Entity_Id;
3503
      New_Formal         : Entity_Id;
3504
      Access_Types_Match : Boolean;
3505
      Old_Formal_Base    : Entity_Id;
3506
      New_Formal_Base    : Entity_Id;
3507
 
3508
   --  Start of processing for Check_Conformance
3509
 
3510
   begin
3511
      Conforms := True;
3512
 
3513
      --  We need a special case for operators, since they don't appear
3514
      --  explicitly.
3515
 
3516
      if Ctype = Type_Conformant then
3517
         if Ekind (New_Id) = E_Operator
3518
           and then Operator_Matches_Spec (New_Id, Old_Id)
3519
         then
3520
            return;
3521
         end if;
3522
      end if;
3523
 
3524
      --  If both are functions/operators, check return types conform
3525
 
3526
      if Old_Type /= Standard_Void_Type
3527
        and then New_Type /= Standard_Void_Type
3528
      then
3529
 
3530
         --  If we are checking interface conformance we omit controlling
3531
         --  arguments and result, because we are only checking the conformance
3532
         --  of the remaining parameters.
3533
 
3534
         if Has_Controlling_Result (Old_Id)
3535
           and then Has_Controlling_Result (New_Id)
3536
           and then Skip_Controlling_Formals
3537
         then
3538
            null;
3539
 
3540
         elsif not Conforming_Types (Old_Type, New_Type, Ctype, Get_Inst) then
3541
            Conformance_Error ("\return type does not match!", New_Id);
3542
            return;
3543
         end if;
3544
 
3545
         --  Ada 2005 (AI-231): In case of anonymous access types check the
3546
         --  null-exclusion and access-to-constant attributes match.
3547
 
3548
         if Ada_Version >= Ada_05
3549
           and then Ekind (Etype (Old_Type)) = E_Anonymous_Access_Type
3550
           and then
3551
             (Can_Never_Be_Null (Old_Type)
3552
                /= Can_Never_Be_Null (New_Type)
3553
              or else Is_Access_Constant (Etype (Old_Type))
3554
                        /= Is_Access_Constant (Etype (New_Type)))
3555
         then
3556
            Conformance_Error ("\return type does not match!", New_Id);
3557
            return;
3558
         end if;
3559
 
3560
      --  If either is a function/operator and the other isn't, error
3561
 
3562
      elsif Old_Type /= Standard_Void_Type
3563
        or else New_Type /= Standard_Void_Type
3564
      then
3565
         Conformance_Error ("\functions can only match functions!", New_Id);
3566
         return;
3567
      end if;
3568
 
3569
      --  In subtype conformant case, conventions must match (RM 6.3.1(16)).
3570
      --  If this is a renaming as body, refine error message to indicate that
3571
      --  the conflict is with the original declaration. If the entity is not
3572
      --  frozen, the conventions don't have to match, the one of the renamed
3573
      --  entity is inherited.
3574
 
3575
      if Ctype >= Subtype_Conformant then
3576
         if Convention (Old_Id) /= Convention (New_Id) then
3577
 
3578
            if not Is_Frozen (New_Id) then
3579
               null;
3580
 
3581
            elsif Present (Err_Loc)
3582
              and then Nkind (Err_Loc) = N_Subprogram_Renaming_Declaration
3583
              and then Present (Corresponding_Spec (Err_Loc))
3584
            then
3585
               Error_Msg_Name_1 := Chars (New_Id);
3586
               Error_Msg_Name_2 :=
3587
                 Name_Ada + Convention_Id'Pos (Convention (New_Id));
3588
 
3589
               Conformance_Error ("\prior declaration for% has convention %!");
3590
 
3591
            else
3592
               Conformance_Error ("\calling conventions do not match!");
3593
            end if;
3594
 
3595
            return;
3596
 
3597
         elsif Is_Formal_Subprogram (Old_Id)
3598
           or else Is_Formal_Subprogram (New_Id)
3599
         then
3600
            Conformance_Error ("\formal subprograms not allowed!");
3601
            return;
3602
         end if;
3603
      end if;
3604
 
3605
      --  Deal with parameters
3606
 
3607
      --  Note: we use the entity information, rather than going directly
3608
      --  to the specification in the tree. This is not only simpler, but
3609
      --  absolutely necessary for some cases of conformance tests between
3610
      --  operators, where the declaration tree simply does not exist!
3611
 
3612
      Old_Formal := First_Formal (Old_Id);
3613
      New_Formal := First_Formal (New_Id);
3614
      while Present (Old_Formal) and then Present (New_Formal) loop
3615
         if Is_Controlling_Formal (Old_Formal)
3616
           and then Is_Controlling_Formal (New_Formal)
3617
           and then Skip_Controlling_Formals
3618
         then
3619
            --  The controlling formals will have different types when
3620
            --  comparing an interface operation with its match, but both
3621
            --  or neither must be access parameters.
3622
 
3623
            if Is_Access_Type (Etype (Old_Formal))
3624
                 =
3625
               Is_Access_Type (Etype (New_Formal))
3626
            then
3627
               goto Skip_Controlling_Formal;
3628
            else
3629
               Conformance_Error
3630
                 ("\access parameter does not match!", New_Formal);
3631
            end if;
3632
         end if;
3633
 
3634
         if Ctype = Fully_Conformant then
3635
 
3636
            --  Names must match. Error message is more accurate if we do
3637
            --  this before checking that the types of the formals match.
3638
 
3639
            if Chars (Old_Formal) /= Chars (New_Formal) then
3640
               Conformance_Error ("\name & does not match!", New_Formal);
3641
 
3642
               --  Set error posted flag on new formal as well to stop
3643
               --  junk cascaded messages in some cases.
3644
 
3645
               Set_Error_Posted (New_Formal);
3646
               return;
3647
            end if;
3648
         end if;
3649
 
3650
         --  Ada 2005 (AI-423): Possible access [sub]type and itype match. This
3651
         --  case occurs whenever a subprogram is being renamed and one of its
3652
         --  parameters imposes a null exclusion. For example:
3653
 
3654
         --     type T is null record;
3655
         --     type Acc_T is access T;
3656
         --     subtype Acc_T_Sub is Acc_T;
3657
 
3658
         --     procedure P     (Obj : not null Acc_T_Sub);  --  itype
3659
         --     procedure Ren_P (Obj :          Acc_T_Sub)   --  subtype
3660
         --       renames P;
3661
 
3662
         Old_Formal_Base := Etype (Old_Formal);
3663
         New_Formal_Base := Etype (New_Formal);
3664
 
3665
         if Get_Inst then
3666
            Old_Formal_Base := Get_Instance_Of (Old_Formal_Base);
3667
            New_Formal_Base := Get_Instance_Of (New_Formal_Base);
3668
         end if;
3669
 
3670
         Access_Types_Match := Ada_Version >= Ada_05
3671
 
3672
            --  Ensure that this rule is only applied when New_Id is a
3673
            --  renaming of Old_Id.
3674
 
3675
           and then Nkind (Parent (Parent (New_Id))) =
3676
                      N_Subprogram_Renaming_Declaration
3677
           and then Nkind (Name (Parent (Parent (New_Id)))) in N_Has_Entity
3678
           and then Present (Entity (Name (Parent (Parent (New_Id)))))
3679
           and then Entity (Name (Parent (Parent (New_Id)))) = Old_Id
3680
 
3681
            --  Now handle the allowed access-type case
3682
 
3683
           and then Is_Access_Type (Old_Formal_Base)
3684
           and then Is_Access_Type (New_Formal_Base)
3685
 
3686
            --  The type kinds must match. The only exception occurs with
3687
            --  multiple generics of the form:
3688
 
3689
            --   generic                    generic
3690
            --     type F is private;         type A is private;
3691
            --     type F_Ptr is access F;    type A_Ptr is access A;
3692
            --     with proc F_P (X : F_Ptr); with proc A_P (X : A_Ptr);
3693
            --   package F_Pack is ...      package A_Pack is
3694
            --                                package F_Inst is
3695
            --                                  new F_Pack (A, A_Ptr, A_P);
3696
 
3697
            --  When checking for conformance between the parameters of A_P
3698
            --  and F_P, the type kinds of F_Ptr and A_Ptr will not match
3699
            --  because the compiler has transformed A_Ptr into a subtype of
3700
            --  F_Ptr. We catch this case in the code below.
3701
 
3702
           and then (Ekind (Old_Formal_Base) = Ekind (New_Formal_Base)
3703
                  or else
3704
                    (Is_Generic_Type (Old_Formal_Base)
3705
                       and then Is_Generic_Type (New_Formal_Base)
3706
                       and then Is_Internal (New_Formal_Base)
3707
                       and then Etype (Etype (New_Formal_Base)) =
3708
                                  Old_Formal_Base))
3709
           and then Directly_Designated_Type (Old_Formal_Base) =
3710
                      Directly_Designated_Type (New_Formal_Base)
3711
           and then ((Is_Itype (Old_Formal_Base)
3712
                       and then Can_Never_Be_Null (Old_Formal_Base))
3713
                    or else
3714
                     (Is_Itype (New_Formal_Base)
3715
                       and then Can_Never_Be_Null (New_Formal_Base)));
3716
 
3717
         --  Types must always match. In the visible part of an instance,
3718
         --  usual overloading rules for dispatching operations apply, and
3719
         --  we check base types (not the actual subtypes).
3720
 
3721
         if In_Instance_Visible_Part
3722
           and then Is_Dispatching_Operation (New_Id)
3723
         then
3724
            if not Conforming_Types
3725
                     (T1       => Base_Type (Etype (Old_Formal)),
3726
                      T2       => Base_Type (Etype (New_Formal)),
3727
                      Ctype    => Ctype,
3728
                      Get_Inst => Get_Inst)
3729
               and then not Access_Types_Match
3730
            then
3731
               Conformance_Error ("\type of & does not match!", New_Formal);
3732
               return;
3733
            end if;
3734
 
3735
         elsif not Conforming_Types
3736
                     (T1       => Old_Formal_Base,
3737
                      T2       => New_Formal_Base,
3738
                      Ctype    => Ctype,
3739
                      Get_Inst => Get_Inst)
3740
           and then not Access_Types_Match
3741
         then
3742
            --  Don't give error message if old type is Any_Type. This test
3743
            --  avoids some cascaded errors, e.g. in case of a bad spec.
3744
 
3745
            if Errmsg and then Old_Formal_Base = Any_Type then
3746
               Conforms := False;
3747
            else
3748
               Conformance_Error ("\type of & does not match!", New_Formal);
3749
            end if;
3750
 
3751
            return;
3752
         end if;
3753
 
3754
         --  For mode conformance, mode must match
3755
 
3756
         if Ctype >= Mode_Conformant then
3757
            if Parameter_Mode (Old_Formal) /= Parameter_Mode (New_Formal) then
3758
               Conformance_Error ("\mode of & does not match!", New_Formal);
3759
               return;
3760
 
3761
            --  Part of mode conformance for access types is having the same
3762
            --  constant modifier.
3763
 
3764
            elsif Access_Types_Match
3765
              and then Is_Access_Constant (Old_Formal_Base) /=
3766
                       Is_Access_Constant (New_Formal_Base)
3767
            then
3768
               Conformance_Error
3769
                 ("\constant modifier does not match!", New_Formal);
3770
               return;
3771
            end if;
3772
         end if;
3773
 
3774
         if Ctype >= Subtype_Conformant then
3775
 
3776
            --  Ada 2005 (AI-231): In case of anonymous access types check
3777
            --  the null-exclusion and access-to-constant attributes must
3778
            --  match.
3779
 
3780
            if Ada_Version >= Ada_05
3781
              and then Ekind (Etype (Old_Formal)) = E_Anonymous_Access_Type
3782
              and then Ekind (Etype (New_Formal)) = E_Anonymous_Access_Type
3783
              and then
3784
                (Can_Never_Be_Null (Old_Formal) /=
3785
                 Can_Never_Be_Null (New_Formal)
3786
                   or else
3787
                 Is_Access_Constant (Etype (Old_Formal)) /=
3788
                 Is_Access_Constant (Etype (New_Formal)))
3789
            then
3790
               --  It is allowed to omit the null-exclusion in case of stream
3791
               --  attribute subprograms. We recognize stream subprograms
3792
               --  through their TSS-generated suffix.
3793
 
3794
               declare
3795
                  TSS_Name : constant TSS_Name_Type := Get_TSS_Name (New_Id);
3796
               begin
3797
                  if TSS_Name /= TSS_Stream_Read
3798
                    and then TSS_Name /= TSS_Stream_Write
3799
                    and then TSS_Name /= TSS_Stream_Input
3800
                    and then TSS_Name /= TSS_Stream_Output
3801
                  then
3802
                     Conformance_Error
3803
                       ("\type of & does not match!", New_Formal);
3804
                     return;
3805
                  end if;
3806
               end;
3807
            end if;
3808
         end if;
3809
 
3810
         --  Full conformance checks
3811
 
3812
         if Ctype = Fully_Conformant then
3813
 
3814
            --  We have checked already that names match
3815
 
3816
            if Parameter_Mode (Old_Formal) = E_In_Parameter then
3817
 
3818
               --  Check default expressions for in parameters
3819
 
3820
               declare
3821
                  NewD : constant Boolean :=
3822
                           Present (Default_Value (New_Formal));
3823
                  OldD : constant Boolean :=
3824
                           Present (Default_Value (Old_Formal));
3825
               begin
3826
                  if NewD or OldD then
3827
 
3828
                     --  The old default value has been analyzed because the
3829
                     --  current full declaration will have frozen everything
3830
                     --  before. The new default value has not been analyzed,
3831
                     --  so analyze it now before we check for conformance.
3832
 
3833
                     if NewD then
3834
                        Push_Scope (New_Id);
3835
                        Preanalyze_Spec_Expression
3836
                          (Default_Value (New_Formal), Etype (New_Formal));
3837
                        End_Scope;
3838
                     end if;
3839
 
3840
                     if not (NewD and OldD)
3841
                       or else not Fully_Conformant_Expressions
3842
                                    (Default_Value (Old_Formal),
3843
                                     Default_Value (New_Formal))
3844
                     then
3845
                        Conformance_Error
3846
                          ("\default expression for & does not match!",
3847
                           New_Formal);
3848
                        return;
3849
                     end if;
3850
                  end if;
3851
               end;
3852
            end if;
3853
         end if;
3854
 
3855
         --  A couple of special checks for Ada 83 mode. These checks are
3856
         --  skipped if either entity is an operator in package Standard,
3857
         --  or if either old or new instance is not from the source program.
3858
 
3859
         if Ada_Version = Ada_83
3860
           and then Sloc (Old_Id) > Standard_Location
3861
           and then Sloc (New_Id) > Standard_Location
3862
           and then Comes_From_Source (Old_Id)
3863
           and then Comes_From_Source (New_Id)
3864
         then
3865
            declare
3866
               Old_Param : constant Node_Id := Declaration_Node (Old_Formal);
3867
               New_Param : constant Node_Id := Declaration_Node (New_Formal);
3868
 
3869
            begin
3870
               --  Explicit IN must be present or absent in both cases. This
3871
               --  test is required only in the full conformance case.
3872
 
3873
               if In_Present (Old_Param) /= In_Present (New_Param)
3874
                 and then Ctype = Fully_Conformant
3875
               then
3876
                  Conformance_Error
3877
                    ("\(Ada 83) IN must appear in both declarations",
3878
                     New_Formal);
3879
                  return;
3880
               end if;
3881
 
3882
               --  Grouping (use of comma in param lists) must be the same
3883
               --  This is where we catch a misconformance like:
3884
 
3885
               --    A, B : Integer
3886
               --    A : Integer; B : Integer
3887
 
3888
               --  which are represented identically in the tree except
3889
               --  for the setting of the flags More_Ids and Prev_Ids.
3890
 
3891
               if More_Ids (Old_Param) /= More_Ids (New_Param)
3892
                 or else Prev_Ids (Old_Param) /= Prev_Ids (New_Param)
3893
               then
3894
                  Conformance_Error
3895
                    ("\grouping of & does not match!", New_Formal);
3896
                  return;
3897
               end if;
3898
            end;
3899
         end if;
3900
 
3901
         --  This label is required when skipping controlling formals
3902
 
3903
         <<Skip_Controlling_Formal>>
3904
 
3905
         Next_Formal (Old_Formal);
3906
         Next_Formal (New_Formal);
3907
      end loop;
3908
 
3909
      if Present (Old_Formal) then
3910
         Conformance_Error ("\too few parameters!");
3911
         return;
3912
 
3913
      elsif Present (New_Formal) then
3914
         Conformance_Error ("\too many parameters!", New_Formal);
3915
         return;
3916
      end if;
3917
   end Check_Conformance;
3918
 
3919
   -----------------------
3920
   -- Check_Conventions --
3921
   -----------------------
3922
 
3923
   procedure Check_Conventions (Typ : Entity_Id) is
3924
      Ifaces_List : Elist_Id;
3925
 
3926
      procedure Check_Convention (Op : Entity_Id);
3927
      --  Verify that the convention of inherited dispatching operation Op is
3928
      --  consistent among all subprograms it overrides. In order to minimize
3929
      --  the search, Search_From is utilized to designate a specific point in
3930
      --  the list rather than iterating over the whole list once more.
3931
 
3932
      ----------------------
3933
      -- Check_Convention --
3934
      ----------------------
3935
 
3936
      procedure Check_Convention (Op : Entity_Id) is
3937
         Iface_Elmt      : Elmt_Id;
3938
         Iface_Prim_Elmt : Elmt_Id;
3939
         Iface_Prim      : Entity_Id;
3940
 
3941
      begin
3942
         Iface_Elmt := First_Elmt (Ifaces_List);
3943
         while Present (Iface_Elmt) loop
3944
            Iface_Prim_Elmt :=
3945
               First_Elmt (Primitive_Operations (Node (Iface_Elmt)));
3946
            while Present (Iface_Prim_Elmt) loop
3947
               Iface_Prim := Node (Iface_Prim_Elmt);
3948
 
3949
               if Is_Interface_Conformant (Typ, Iface_Prim, Op)
3950
                 and then Convention (Iface_Prim) /= Convention (Op)
3951
               then
3952
                  Error_Msg_N
3953
                    ("inconsistent conventions in primitive operations", Typ);
3954
 
3955
                  Error_Msg_Name_1 := Chars (Op);
3956
                  Error_Msg_Name_2 := Get_Convention_Name (Convention (Op));
3957
                  Error_Msg_Sloc   := Sloc (Op);
3958
 
3959
                  if Comes_From_Source (Op) then
3960
                     if not Is_Overriding_Operation (Op) then
3961
                        Error_Msg_N ("\\primitive % defined #", Typ);
3962
                     else
3963
                        Error_Msg_N ("\\overriding operation % with " &
3964
                                     "convention % defined #", Typ);
3965
                     end if;
3966
 
3967
                  else pragma Assert (Present (Alias (Op)));
3968
                     Error_Msg_Sloc := Sloc (Alias (Op));
3969
                     Error_Msg_N ("\\inherited operation % with " &
3970
                                  "convention % defined #", Typ);
3971
                  end if;
3972
 
3973
                  Error_Msg_Name_1 := Chars (Op);
3974
                  Error_Msg_Name_2 :=
3975
                    Get_Convention_Name (Convention (Iface_Prim));
3976
                  Error_Msg_Sloc := Sloc (Iface_Prim);
3977
                  Error_Msg_N ("\\overridden operation % with " &
3978
                               "convention % defined #", Typ);
3979
 
3980
                  --  Avoid cascading errors
3981
 
3982
                  return;
3983
               end if;
3984
 
3985
               Next_Elmt (Iface_Prim_Elmt);
3986
            end loop;
3987
 
3988
            Next_Elmt (Iface_Elmt);
3989
         end loop;
3990
      end Check_Convention;
3991
 
3992
      --  Local variables
3993
 
3994
      Prim_Op      : Entity_Id;
3995
      Prim_Op_Elmt : Elmt_Id;
3996
 
3997
   --  Start of processing for Check_Conventions
3998
 
3999
   begin
4000
      if not Has_Interfaces (Typ) then
4001
         return;
4002
      end if;
4003
 
4004
      Collect_Interfaces (Typ, Ifaces_List);
4005
 
4006
      --  The algorithm checks every overriding dispatching operation against
4007
      --  all the corresponding overridden dispatching operations, detecting
4008
      --  differences in conventions.
4009
 
4010
      Prim_Op_Elmt := First_Elmt (Primitive_Operations (Typ));
4011
      while Present (Prim_Op_Elmt) loop
4012
         Prim_Op := Node (Prim_Op_Elmt);
4013
 
4014
         --  A small optimization: skip the predefined dispatching operations
4015
         --  since they always have the same convention.
4016
 
4017
         if not Is_Predefined_Dispatching_Operation (Prim_Op) then
4018
            Check_Convention (Prim_Op);
4019
         end if;
4020
 
4021
         Next_Elmt (Prim_Op_Elmt);
4022
      end loop;
4023
   end Check_Conventions;
4024
 
4025
   ------------------------------
4026
   -- Check_Delayed_Subprogram --
4027
   ------------------------------
4028
 
4029
   procedure Check_Delayed_Subprogram (Designator : Entity_Id) is
4030
      F : Entity_Id;
4031
 
4032
      procedure Possible_Freeze (T : Entity_Id);
4033
      --  T is the type of either a formal parameter or of the return type.
4034
      --  If T is not yet frozen and needs a delayed freeze, then the
4035
      --  subprogram itself must be delayed. If T is the limited view of an
4036
      --  incomplete type the subprogram must be frozen as well, because
4037
      --  T may depend on local types that have not been frozen yet.
4038
 
4039
      ---------------------
4040
      -- Possible_Freeze --
4041
      ---------------------
4042
 
4043
      procedure Possible_Freeze (T : Entity_Id) is
4044
      begin
4045
         if Has_Delayed_Freeze (T) and then not Is_Frozen (T) then
4046
            Set_Has_Delayed_Freeze (Designator);
4047
 
4048
         elsif Is_Access_Type (T)
4049
           and then Has_Delayed_Freeze (Designated_Type (T))
4050
           and then not Is_Frozen (Designated_Type (T))
4051
         then
4052
            Set_Has_Delayed_Freeze (Designator);
4053
 
4054
         elsif Ekind (T) = E_Incomplete_Type and then From_With_Type (T) then
4055
            Set_Has_Delayed_Freeze (Designator);
4056
         end if;
4057
 
4058
      end Possible_Freeze;
4059
 
4060
   --  Start of processing for Check_Delayed_Subprogram
4061
 
4062
   begin
4063
      --  Never need to freeze abstract subprogram
4064
 
4065
      if Ekind (Designator) /= E_Subprogram_Type
4066
        and then Is_Abstract_Subprogram (Designator)
4067
      then
4068
         null;
4069
      else
4070
         --  Need delayed freeze if return type itself needs a delayed
4071
         --  freeze and is not yet frozen.
4072
 
4073
         Possible_Freeze (Etype (Designator));
4074
         Possible_Freeze (Base_Type (Etype (Designator))); -- needed ???
4075
 
4076
         --  Need delayed freeze if any of the formal types themselves need
4077
         --  a delayed freeze and are not yet frozen.
4078
 
4079
         F := First_Formal (Designator);
4080
         while Present (F) loop
4081
            Possible_Freeze (Etype (F));
4082
            Possible_Freeze (Base_Type (Etype (F))); -- needed ???
4083
            Next_Formal (F);
4084
         end loop;
4085
      end if;
4086
 
4087
      --  Mark functions that return by reference. Note that it cannot be
4088
      --  done for delayed_freeze subprograms because the underlying
4089
      --  returned type may not be known yet (for private types)
4090
 
4091
      if not Has_Delayed_Freeze (Designator)
4092
        and then Expander_Active
4093
      then
4094
         declare
4095
            Typ  : constant Entity_Id := Etype (Designator);
4096
            Utyp : constant Entity_Id := Underlying_Type (Typ);
4097
 
4098
         begin
4099
            if Is_Inherently_Limited_Type (Typ) then
4100
               Set_Returns_By_Ref (Designator);
4101
 
4102
            elsif Present (Utyp) and then CW_Or_Has_Controlled_Part (Utyp) then
4103
               Set_Returns_By_Ref (Designator);
4104
            end if;
4105
         end;
4106
      end if;
4107
   end Check_Delayed_Subprogram;
4108
 
4109
   ------------------------------------
4110
   -- Check_Discriminant_Conformance --
4111
   ------------------------------------
4112
 
4113
   procedure Check_Discriminant_Conformance
4114
     (N        : Node_Id;
4115
      Prev     : Entity_Id;
4116
      Prev_Loc : Node_Id)
4117
   is
4118
      Old_Discr      : Entity_Id := First_Discriminant (Prev);
4119
      New_Discr      : Node_Id   := First (Discriminant_Specifications (N));
4120
      New_Discr_Id   : Entity_Id;
4121
      New_Discr_Type : Entity_Id;
4122
 
4123
      procedure Conformance_Error (Msg : String; N : Node_Id);
4124
      --  Post error message for conformance error on given node. Two messages
4125
      --  are output. The first points to the previous declaration with a
4126
      --  general "no conformance" message. The second is the detailed reason,
4127
      --  supplied as Msg. The parameter N provide information for a possible
4128
      --  & insertion in the message.
4129
 
4130
      -----------------------
4131
      -- Conformance_Error --
4132
      -----------------------
4133
 
4134
      procedure Conformance_Error (Msg : String; N : Node_Id) is
4135
      begin
4136
         Error_Msg_Sloc := Sloc (Prev_Loc);
4137
         Error_Msg_N -- CODEFIX
4138
           ("not fully conformant with declaration#!", N);
4139
         Error_Msg_NE (Msg, N, N);
4140
      end Conformance_Error;
4141
 
4142
   --  Start of processing for Check_Discriminant_Conformance
4143
 
4144
   begin
4145
      while Present (Old_Discr) and then Present (New_Discr) loop
4146
 
4147
         New_Discr_Id := Defining_Identifier (New_Discr);
4148
 
4149
         --  The subtype mark of the discriminant on the full type has not
4150
         --  been analyzed so we do it here. For an access discriminant a new
4151
         --  type is created.
4152
 
4153
         if Nkind (Discriminant_Type (New_Discr)) = N_Access_Definition then
4154
            New_Discr_Type :=
4155
              Access_Definition (N, Discriminant_Type (New_Discr));
4156
 
4157
         else
4158
            Analyze (Discriminant_Type (New_Discr));
4159
            New_Discr_Type := Etype (Discriminant_Type (New_Discr));
4160
 
4161
            --  Ada 2005: if the discriminant definition carries a null
4162
            --  exclusion, create an itype to check properly for consistency
4163
            --  with partial declaration.
4164
 
4165
            if Is_Access_Type (New_Discr_Type)
4166
                 and then Null_Exclusion_Present (New_Discr)
4167
            then
4168
               New_Discr_Type :=
4169
                 Create_Null_Excluding_Itype
4170
                   (T           => New_Discr_Type,
4171
                    Related_Nod => New_Discr,
4172
                    Scope_Id    => Current_Scope);
4173
            end if;
4174
         end if;
4175
 
4176
         if not Conforming_Types
4177
                  (Etype (Old_Discr), New_Discr_Type, Fully_Conformant)
4178
         then
4179
            Conformance_Error ("type of & does not match!", New_Discr_Id);
4180
            return;
4181
         else
4182
            --  Treat the new discriminant as an occurrence of the old one,
4183
            --  for navigation purposes, and fill in some semantic
4184
            --  information, for completeness.
4185
 
4186
            Generate_Reference (Old_Discr, New_Discr_Id, 'r');
4187
            Set_Etype (New_Discr_Id, Etype (Old_Discr));
4188
            Set_Scope (New_Discr_Id, Scope (Old_Discr));
4189
         end if;
4190
 
4191
         --  Names must match
4192
 
4193
         if Chars (Old_Discr) /= Chars (Defining_Identifier (New_Discr)) then
4194
            Conformance_Error ("name & does not match!", New_Discr_Id);
4195
            return;
4196
         end if;
4197
 
4198
         --  Default expressions must match
4199
 
4200
         declare
4201
            NewD : constant Boolean :=
4202
                     Present (Expression (New_Discr));
4203
            OldD : constant Boolean :=
4204
                     Present (Expression (Parent (Old_Discr)));
4205
 
4206
         begin
4207
            if NewD or OldD then
4208
 
4209
               --  The old default value has been analyzed and expanded,
4210
               --  because the current full declaration will have frozen
4211
               --  everything before. The new default values have not been
4212
               --  expanded, so expand now to check conformance.
4213
 
4214
               if NewD then
4215
                  Preanalyze_Spec_Expression
4216
                    (Expression (New_Discr), New_Discr_Type);
4217
               end if;
4218
 
4219
               if not (NewD and OldD)
4220
                 or else not Fully_Conformant_Expressions
4221
                              (Expression (Parent (Old_Discr)),
4222
                               Expression (New_Discr))
4223
 
4224
               then
4225
                  Conformance_Error
4226
                    ("default expression for & does not match!",
4227
                     New_Discr_Id);
4228
                  return;
4229
               end if;
4230
            end if;
4231
         end;
4232
 
4233
         --  In Ada 83 case, grouping must match: (A,B : X) /= (A : X; B : X)
4234
 
4235
         if Ada_Version = Ada_83 then
4236
            declare
4237
               Old_Disc : constant Node_Id := Declaration_Node (Old_Discr);
4238
 
4239
            begin
4240
               --  Grouping (use of comma in param lists) must be the same
4241
               --  This is where we catch a misconformance like:
4242
 
4243
               --    A,B : Integer
4244
               --    A : Integer; B : Integer
4245
 
4246
               --  which are represented identically in the tree except
4247
               --  for the setting of the flags More_Ids and Prev_Ids.
4248
 
4249
               if More_Ids (Old_Disc) /= More_Ids (New_Discr)
4250
                 or else Prev_Ids (Old_Disc) /= Prev_Ids (New_Discr)
4251
               then
4252
                  Conformance_Error
4253
                    ("grouping of & does not match!", New_Discr_Id);
4254
                  return;
4255
               end if;
4256
            end;
4257
         end if;
4258
 
4259
         Next_Discriminant (Old_Discr);
4260
         Next (New_Discr);
4261
      end loop;
4262
 
4263
      if Present (Old_Discr) then
4264
         Conformance_Error ("too few discriminants!", Defining_Identifier (N));
4265
         return;
4266
 
4267
      elsif Present (New_Discr) then
4268
         Conformance_Error
4269
           ("too many discriminants!", Defining_Identifier (New_Discr));
4270
         return;
4271
      end if;
4272
   end Check_Discriminant_Conformance;
4273
 
4274
   ----------------------------
4275
   -- Check_Fully_Conformant --
4276
   ----------------------------
4277
 
4278
   procedure Check_Fully_Conformant
4279
     (New_Id  : Entity_Id;
4280
      Old_Id  : Entity_Id;
4281
      Err_Loc : Node_Id := Empty)
4282
   is
4283
      Result : Boolean;
4284
      pragma Warnings (Off, Result);
4285
   begin
4286
      Check_Conformance
4287
        (New_Id, Old_Id, Fully_Conformant, True, Result, Err_Loc);
4288
   end Check_Fully_Conformant;
4289
 
4290
   ---------------------------
4291
   -- Check_Mode_Conformant --
4292
   ---------------------------
4293
 
4294
   procedure Check_Mode_Conformant
4295
     (New_Id   : Entity_Id;
4296
      Old_Id   : Entity_Id;
4297
      Err_Loc  : Node_Id := Empty;
4298
      Get_Inst : Boolean := False)
4299
   is
4300
      Result : Boolean;
4301
      pragma Warnings (Off, Result);
4302
   begin
4303
      Check_Conformance
4304
        (New_Id, Old_Id, Mode_Conformant, True, Result, Err_Loc, Get_Inst);
4305
   end Check_Mode_Conformant;
4306
 
4307
   --------------------------------
4308
   -- Check_Overriding_Indicator --
4309
   --------------------------------
4310
 
4311
   procedure Check_Overriding_Indicator
4312
     (Subp            : Entity_Id;
4313
      Overridden_Subp : Entity_Id;
4314
      Is_Primitive    : Boolean)
4315
   is
4316
      Decl : Node_Id;
4317
      Spec : Node_Id;
4318
 
4319
   begin
4320
      --  No overriding indicator for literals
4321
 
4322
      if Ekind (Subp) = E_Enumeration_Literal then
4323
         return;
4324
 
4325
      elsif Ekind (Subp) = E_Entry then
4326
         Decl := Parent (Subp);
4327
 
4328
         --  No point in analyzing a malformed operator
4329
 
4330
      elsif Nkind (Subp) = N_Defining_Operator_Symbol
4331
        and then Error_Posted (Subp)
4332
      then
4333
         return;
4334
 
4335
      else
4336
         Decl := Unit_Declaration_Node (Subp);
4337
      end if;
4338
 
4339
      if Nkind_In (Decl, N_Subprogram_Body,
4340
                         N_Subprogram_Body_Stub,
4341
                         N_Subprogram_Declaration,
4342
                         N_Abstract_Subprogram_Declaration,
4343
                         N_Subprogram_Renaming_Declaration)
4344
      then
4345
         Spec := Specification (Decl);
4346
 
4347
      elsif Nkind (Decl) = N_Entry_Declaration then
4348
         Spec := Decl;
4349
 
4350
      else
4351
         return;
4352
      end if;
4353
 
4354
      --  The overriding operation is type conformant with the overridden one,
4355
      --  but the names of the formals are not required to match. If the names
4356
      --  appear permuted in the overriding operation, this is a possible
4357
      --  source of confusion that is worth diagnosing. Controlling formals
4358
      --  often carry names that reflect the type, and it is not worthwhile
4359
      --  requiring that their names match.
4360
 
4361
      if Present (Overridden_Subp)
4362
        and then Nkind (Subp) /= N_Defining_Operator_Symbol
4363
      then
4364
         declare
4365
            Form1 : Entity_Id;
4366
            Form2 : Entity_Id;
4367
 
4368
         begin
4369
            Form1 := First_Formal (Subp);
4370
            Form2 := First_Formal (Overridden_Subp);
4371
 
4372
            --  If the overriding operation is a synchronized operation, skip
4373
            --  the first parameter of the overridden operation, which is
4374
            --  implicit in the new one. If the operation is declared in the
4375
            --  body it is not primitive and all formals must match.
4376
 
4377
            if Is_Concurrent_Type (Scope (Subp))
4378
              and then Is_Tagged_Type (Scope (Subp))
4379
              and then not Has_Completion (Scope (Subp))
4380
            then
4381
               Form2 := Next_Formal (Form2);
4382
            end if;
4383
 
4384
            if Present (Form1) then
4385
               Form1 := Next_Formal (Form1);
4386
               Form2 := Next_Formal (Form2);
4387
            end if;
4388
 
4389
            while Present (Form1) loop
4390
               if not Is_Controlling_Formal (Form1)
4391
                 and then Present (Next_Formal (Form2))
4392
                 and then Chars (Form1) = Chars (Next_Formal (Form2))
4393
               then
4394
                  Error_Msg_Node_2 := Alias (Overridden_Subp);
4395
                  Error_Msg_Sloc := Sloc (Error_Msg_Node_2);
4396
                  Error_Msg_NE ("& does not match corresponding formal of&#",
4397
                     Form1, Form1);
4398
                  exit;
4399
               end if;
4400
 
4401
               Next_Formal (Form1);
4402
               Next_Formal (Form2);
4403
            end loop;
4404
         end;
4405
      end if;
4406
 
4407
      if Present (Overridden_Subp)
4408
        and then not Is_Hidden (Overridden_Subp)
4409
      then
4410
         if Must_Not_Override (Spec) then
4411
            Error_Msg_Sloc := Sloc (Overridden_Subp);
4412
 
4413
            if Ekind (Subp) = E_Entry then
4414
               Error_Msg_NE
4415
                 ("entry & overrides inherited operation #", Spec, Subp);
4416
            else
4417
               Error_Msg_NE
4418
                 ("subprogram & overrides inherited operation #", Spec, Subp);
4419
            end if;
4420
 
4421
         elsif Is_Subprogram (Subp) then
4422
            Set_Is_Overriding_Operation (Subp);
4423
         end if;
4424
 
4425
         --  If primitive flag is set or this is a protected operation, then
4426
         --  the operation is overriding at the point of its declaration, so
4427
         --  warn if necessary. Otherwise it may have been declared before the
4428
         --  operation it overrides and no check is required.
4429
 
4430
         if Style_Check
4431
           and then not Must_Override (Spec)
4432
           and then (Is_Primitive
4433
                      or else Ekind (Scope (Subp)) = E_Protected_Type)
4434
         then
4435
            Style.Missing_Overriding (Decl, Subp);
4436
         end if;
4437
 
4438
      --  If Subp is an operator, it may override a predefined operation, if
4439
      --  it is defined in the same scope as the type to which it applies.
4440
      --  In that case overridden_subp is empty because of our implicit
4441
      --  representation for predefined operators. We have to check whether the
4442
      --  signature of Subp matches that of a predefined operator. Note that
4443
      --  first argument provides the name of the operator, and the second
4444
      --  argument the signature that may match that of a standard operation.
4445
      --  If the indicator is overriding, then the operator must match a
4446
      --  predefined signature, because we know already that there is no
4447
      --  explicit overridden operation.
4448
 
4449
      elsif Nkind (Subp) = N_Defining_Operator_Symbol then
4450
         declare
4451
            Typ : constant Entity_Id :=
4452
              Base_Type (Etype (First_Formal (Subp)));
4453
 
4454
            Can_Override : constant Boolean :=
4455
                             Operator_Matches_Spec (Subp, Subp)
4456
                               and then Scope (Subp) = Scope (Typ)
4457
                               and then not Is_Class_Wide_Type (Typ);
4458
 
4459
         begin
4460
            if Must_Not_Override (Spec) then
4461
 
4462
               --  If this is not a primitive or a protected subprogram, then
4463
               --  "not overriding" is illegal.
4464
 
4465
               if not Is_Primitive
4466
                 and then Ekind (Scope (Subp)) /= E_Protected_Type
4467
               then
4468
                  Error_Msg_N
4469
                    ("overriding indicator only allowed "
4470
                     & "if subprogram is primitive", Subp);
4471
 
4472
               elsif Can_Override then
4473
                  Error_Msg_NE
4474
                    ("subprogram & overrides predefined operator ",
4475
                       Spec, Subp);
4476
               end if;
4477
 
4478
            elsif Must_Override (Spec) then
4479
               if Is_Overriding_Operation (Subp) then
4480
                  Set_Is_Overriding_Operation (Subp);
4481
 
4482
               elsif not Can_Override then
4483
                  Error_Msg_NE ("subprogram & is not overriding", Spec, Subp);
4484
               end if;
4485
 
4486
            elsif not Error_Posted (Subp)
4487
              and then Style_Check
4488
              and then Can_Override
4489
              and then
4490
                not Is_Predefined_File_Name
4491
                      (Unit_File_Name (Get_Source_Unit (Subp)))
4492
            then
4493
               Set_Is_Overriding_Operation (Subp);
4494
 
4495
               --  If style checks are enabled, indicate that the indicator is
4496
               --  missing. However, at the point of declaration, the type of
4497
               --  which this is a primitive operation may be private, in which
4498
               --  case the indicator would be premature.
4499
 
4500
               if Has_Private_Declaration (Etype (Subp))
4501
                 or else Has_Private_Declaration (Etype (First_Formal (Subp)))
4502
               then
4503
                  null;
4504
               else
4505
                  Style.Missing_Overriding (Decl, Subp);
4506
               end if;
4507
            end if;
4508
         end;
4509
 
4510
      elsif Must_Override (Spec) then
4511
         if Ekind (Subp) = E_Entry then
4512
            Error_Msg_NE ("entry & is not overriding", Spec, Subp);
4513
         else
4514
            Error_Msg_NE ("subprogram & is not overriding", Spec, Subp);
4515
         end if;
4516
 
4517
      --  If the operation is marked "not overriding" and it's not primitive
4518
      --  then an error is issued, unless this is an operation of a task or
4519
      --  protected type (RM05-8.3.1(3/2-4/2)). Error cases where "overriding"
4520
      --  has been specified have already been checked above.
4521
 
4522
      elsif Must_Not_Override (Spec)
4523
        and then not Is_Primitive
4524
        and then Ekind (Subp) /= E_Entry
4525
        and then Ekind (Scope (Subp)) /= E_Protected_Type
4526
      then
4527
         Error_Msg_N
4528
           ("overriding indicator only allowed if subprogram is primitive",
4529
            Subp);
4530
         return;
4531
      end if;
4532
   end Check_Overriding_Indicator;
4533
 
4534
   -------------------
4535
   -- Check_Returns --
4536
   -------------------
4537
 
4538
   --  Note: this procedure needs to know far too much about how the expander
4539
   --  messes with exceptions. The use of the flag Exception_Junk and the
4540
   --  incorporation of knowledge of Exp_Ch11.Expand_Local_Exception_Handlers
4541
   --  works, but is not very clean. It would be better if the expansion
4542
   --  routines would leave Original_Node working nicely, and we could use
4543
   --  Original_Node here to ignore all the peculiar expander messing ???
4544
 
4545
   procedure Check_Returns
4546
     (HSS  : Node_Id;
4547
      Mode : Character;
4548
      Err  : out Boolean;
4549
      Proc : Entity_Id := Empty)
4550
   is
4551
      Handler : Node_Id;
4552
 
4553
      procedure Check_Statement_Sequence (L : List_Id);
4554
      --  Internal recursive procedure to check a list of statements for proper
4555
      --  termination by a return statement (or a transfer of control or a
4556
      --  compound statement that is itself internally properly terminated).
4557
 
4558
      ------------------------------
4559
      -- Check_Statement_Sequence --
4560
      ------------------------------
4561
 
4562
      procedure Check_Statement_Sequence (L : List_Id) is
4563
         Last_Stm : Node_Id;
4564
         Stm      : Node_Id;
4565
         Kind     : Node_Kind;
4566
 
4567
         Raise_Exception_Call : Boolean;
4568
         --  Set True if statement sequence terminated by Raise_Exception call
4569
         --  or a Reraise_Occurrence call.
4570
 
4571
      begin
4572
         Raise_Exception_Call := False;
4573
 
4574
         --  Get last real statement
4575
 
4576
         Last_Stm := Last (L);
4577
 
4578
         --  Deal with digging out exception handler statement sequences that
4579
         --  have been transformed by the local raise to goto optimization.
4580
         --  See Exp_Ch11.Expand_Local_Exception_Handlers for details. If this
4581
         --  optimization has occurred, we are looking at something like:
4582
 
4583
         --  begin
4584
         --     original stmts in block
4585
 
4586
         --  exception            \
4587
         --     when excep1 =>     |
4588
         --        goto L1;        | omitted if No_Exception_Propagation
4589
         --     when excep2 =>     |
4590
         --        goto L2;       /
4591
         --  end;
4592
 
4593
         --  goto L3;      -- skip handler when exception not raised
4594
 
4595
         --  <<L1>>        -- target label for local exception
4596
         --     begin
4597
         --        estmts1
4598
         --     end;
4599
 
4600
         --     goto L3;
4601
 
4602
         --  <<L2>>
4603
         --     begin
4604
         --        estmts2
4605
         --     end;
4606
 
4607
         --  <<L3>>
4608
 
4609
         --  and what we have to do is to dig out the estmts1 and estmts2
4610
         --  sequences (which were the original sequences of statements in
4611
         --  the exception handlers) and check them.
4612
 
4613
         if Nkind (Last_Stm) = N_Label
4614
           and then Exception_Junk (Last_Stm)
4615
         then
4616
            Stm := Last_Stm;
4617
            loop
4618
               Prev (Stm);
4619
               exit when No (Stm);
4620
               exit when Nkind (Stm) /= N_Block_Statement;
4621
               exit when not Exception_Junk (Stm);
4622
               Prev (Stm);
4623
               exit when No (Stm);
4624
               exit when Nkind (Stm) /= N_Label;
4625
               exit when not Exception_Junk (Stm);
4626
               Check_Statement_Sequence
4627
                 (Statements (Handled_Statement_Sequence (Next (Stm))));
4628
 
4629
               Prev (Stm);
4630
               Last_Stm := Stm;
4631
               exit when No (Stm);
4632
               exit when Nkind (Stm) /= N_Goto_Statement;
4633
               exit when not Exception_Junk (Stm);
4634
            end loop;
4635
         end if;
4636
 
4637
         --  Don't count pragmas
4638
 
4639
         while Nkind (Last_Stm) = N_Pragma
4640
 
4641
         --  Don't count call to SS_Release (can happen after Raise_Exception)
4642
 
4643
           or else
4644
             (Nkind (Last_Stm) = N_Procedure_Call_Statement
4645
                and then
4646
              Nkind (Name (Last_Stm)) = N_Identifier
4647
                and then
4648
              Is_RTE (Entity (Name (Last_Stm)), RE_SS_Release))
4649
 
4650
         --  Don't count exception junk
4651
 
4652
           or else
4653
             (Nkind_In (Last_Stm, N_Goto_Statement,
4654
                                   N_Label,
4655
                                   N_Object_Declaration)
4656
                and then Exception_Junk (Last_Stm))
4657
           or else Nkind (Last_Stm) in N_Push_xxx_Label
4658
           or else Nkind (Last_Stm) in N_Pop_xxx_Label
4659
         loop
4660
            Prev (Last_Stm);
4661
         end loop;
4662
 
4663
         --  Here we have the "real" last statement
4664
 
4665
         Kind := Nkind (Last_Stm);
4666
 
4667
         --  Transfer of control, OK. Note that in the No_Return procedure
4668
         --  case, we already diagnosed any explicit return statements, so
4669
         --  we can treat them as OK in this context.
4670
 
4671
         if Is_Transfer (Last_Stm) then
4672
            return;
4673
 
4674
         --  Check cases of explicit non-indirect procedure calls
4675
 
4676
         elsif Kind = N_Procedure_Call_Statement
4677
           and then Is_Entity_Name (Name (Last_Stm))
4678
         then
4679
            --  Check call to Raise_Exception procedure which is treated
4680
            --  specially, as is a call to Reraise_Occurrence.
4681
 
4682
            --  We suppress the warning in these cases since it is likely that
4683
            --  the programmer really does not expect to deal with the case
4684
            --  of Null_Occurrence, and thus would find a warning about a
4685
            --  missing return curious, and raising Program_Error does not
4686
            --  seem such a bad behavior if this does occur.
4687
 
4688
            --  Note that in the Ada 2005 case for Raise_Exception, the actual
4689
            --  behavior will be to raise Constraint_Error (see AI-329).
4690
 
4691
            if Is_RTE (Entity (Name (Last_Stm)), RE_Raise_Exception)
4692
                 or else
4693
               Is_RTE (Entity (Name (Last_Stm)), RE_Reraise_Occurrence)
4694
            then
4695
               Raise_Exception_Call := True;
4696
 
4697
               --  For Raise_Exception call, test first argument, if it is
4698
               --  an attribute reference for a 'Identity call, then we know
4699
               --  that the call cannot possibly return.
4700
 
4701
               declare
4702
                  Arg : constant Node_Id :=
4703
                          Original_Node (First_Actual (Last_Stm));
4704
               begin
4705
                  if Nkind (Arg) = N_Attribute_Reference
4706
                    and then Attribute_Name (Arg) = Name_Identity
4707
                  then
4708
                     return;
4709
                  end if;
4710
               end;
4711
            end if;
4712
 
4713
         --  If statement, need to look inside if there is an else and check
4714
         --  each constituent statement sequence for proper termination.
4715
 
4716
         elsif Kind = N_If_Statement
4717
           and then Present (Else_Statements (Last_Stm))
4718
         then
4719
            Check_Statement_Sequence (Then_Statements (Last_Stm));
4720
            Check_Statement_Sequence (Else_Statements (Last_Stm));
4721
 
4722
            if Present (Elsif_Parts (Last_Stm)) then
4723
               declare
4724
                  Elsif_Part : Node_Id := First (Elsif_Parts (Last_Stm));
4725
 
4726
               begin
4727
                  while Present (Elsif_Part) loop
4728
                     Check_Statement_Sequence (Then_Statements (Elsif_Part));
4729
                     Next (Elsif_Part);
4730
                  end loop;
4731
               end;
4732
            end if;
4733
 
4734
            return;
4735
 
4736
         --  Case statement, check each case for proper termination
4737
 
4738
         elsif Kind = N_Case_Statement then
4739
            declare
4740
               Case_Alt : Node_Id;
4741
            begin
4742
               Case_Alt := First_Non_Pragma (Alternatives (Last_Stm));
4743
               while Present (Case_Alt) loop
4744
                  Check_Statement_Sequence (Statements (Case_Alt));
4745
                  Next_Non_Pragma (Case_Alt);
4746
               end loop;
4747
            end;
4748
 
4749
            return;
4750
 
4751
         --  Block statement, check its handled sequence of statements
4752
 
4753
         elsif Kind = N_Block_Statement then
4754
            declare
4755
               Err1 : Boolean;
4756
 
4757
            begin
4758
               Check_Returns
4759
                 (Handled_Statement_Sequence (Last_Stm), Mode, Err1);
4760
 
4761
               if Err1 then
4762
                  Err := True;
4763
               end if;
4764
 
4765
               return;
4766
            end;
4767
 
4768
         --  Loop statement. If there is an iteration scheme, we can definitely
4769
         --  fall out of the loop. Similarly if there is an exit statement, we
4770
         --  can fall out. In either case we need a following return.
4771
 
4772
         elsif Kind = N_Loop_Statement then
4773
            if Present (Iteration_Scheme (Last_Stm))
4774
              or else Has_Exit (Entity (Identifier (Last_Stm)))
4775
            then
4776
               null;
4777
 
4778
            --  A loop with no exit statement or iteration scheme is either
4779
            --  an infinite loop, or it has some other exit (raise/return).
4780
            --  In either case, no warning is required.
4781
 
4782
            else
4783
               return;
4784
            end if;
4785
 
4786
         --  Timed entry call, check entry call and delay alternatives
4787
 
4788
         --  Note: in expanded code, the timed entry call has been converted
4789
         --  to a set of expanded statements on which the check will work
4790
         --  correctly in any case.
4791
 
4792
         elsif Kind = N_Timed_Entry_Call then
4793
            declare
4794
               ECA : constant Node_Id := Entry_Call_Alternative (Last_Stm);
4795
               DCA : constant Node_Id := Delay_Alternative      (Last_Stm);
4796
 
4797
            begin
4798
               --  If statement sequence of entry call alternative is missing,
4799
               --  then we can definitely fall through, and we post the error
4800
               --  message on the entry call alternative itself.
4801
 
4802
               if No (Statements (ECA)) then
4803
                  Last_Stm := ECA;
4804
 
4805
               --  If statement sequence of delay alternative is missing, then
4806
               --  we can definitely fall through, and we post the error
4807
               --  message on the delay alternative itself.
4808
 
4809
               --  Note: if both ECA and DCA are missing the return, then we
4810
               --  post only one message, should be enough to fix the bugs.
4811
               --  If not we will get a message next time on the DCA when the
4812
               --  ECA is fixed!
4813
 
4814
               elsif No (Statements (DCA)) then
4815
                  Last_Stm := DCA;
4816
 
4817
               --  Else check both statement sequences
4818
 
4819
               else
4820
                  Check_Statement_Sequence (Statements (ECA));
4821
                  Check_Statement_Sequence (Statements (DCA));
4822
                  return;
4823
               end if;
4824
            end;
4825
 
4826
         --  Conditional entry call, check entry call and else part
4827
 
4828
         --  Note: in expanded code, the conditional entry call has been
4829
         --  converted to a set of expanded statements on which the check
4830
         --  will work correctly in any case.
4831
 
4832
         elsif Kind = N_Conditional_Entry_Call then
4833
            declare
4834
               ECA : constant Node_Id := Entry_Call_Alternative (Last_Stm);
4835
 
4836
            begin
4837
               --  If statement sequence of entry call alternative is missing,
4838
               --  then we can definitely fall through, and we post the error
4839
               --  message on the entry call alternative itself.
4840
 
4841
               if No (Statements (ECA)) then
4842
                  Last_Stm := ECA;
4843
 
4844
               --  Else check statement sequence and else part
4845
 
4846
               else
4847
                  Check_Statement_Sequence (Statements (ECA));
4848
                  Check_Statement_Sequence (Else_Statements (Last_Stm));
4849
                  return;
4850
               end if;
4851
            end;
4852
         end if;
4853
 
4854
         --  If we fall through, issue appropriate message
4855
 
4856
         if Mode = 'F' then
4857
            if not Raise_Exception_Call then
4858
               Error_Msg_N
4859
                 ("?RETURN statement missing following this statement!",
4860
                  Last_Stm);
4861
               Error_Msg_N
4862
                 ("\?Program_Error may be raised at run time!",
4863
                  Last_Stm);
4864
            end if;
4865
 
4866
            --  Note: we set Err even though we have not issued a warning
4867
            --  because we still have a case of a missing return. This is
4868
            --  an extremely marginal case, probably will never be noticed
4869
            --  but we might as well get it right.
4870
 
4871
            Err := True;
4872
 
4873
         --  Otherwise we have the case of a procedure marked No_Return
4874
 
4875
         else
4876
            if not Raise_Exception_Call then
4877
               Error_Msg_N
4878
                 ("?implied return after this statement " &
4879
                  "will raise Program_Error",
4880
                  Last_Stm);
4881
               Error_Msg_NE
4882
                 ("\?procedure & is marked as No_Return!",
4883
                  Last_Stm, Proc);
4884
            end if;
4885
 
4886
            declare
4887
               RE : constant Node_Id :=
4888
                      Make_Raise_Program_Error (Sloc (Last_Stm),
4889
                        Reason => PE_Implicit_Return);
4890
            begin
4891
               Insert_After (Last_Stm, RE);
4892
               Analyze (RE);
4893
            end;
4894
         end if;
4895
      end Check_Statement_Sequence;
4896
 
4897
   --  Start of processing for Check_Returns
4898
 
4899
   begin
4900
      Err := False;
4901
      Check_Statement_Sequence (Statements (HSS));
4902
 
4903
      if Present (Exception_Handlers (HSS)) then
4904
         Handler := First_Non_Pragma (Exception_Handlers (HSS));
4905
         while Present (Handler) loop
4906
            Check_Statement_Sequence (Statements (Handler));
4907
            Next_Non_Pragma (Handler);
4908
         end loop;
4909
      end if;
4910
   end Check_Returns;
4911
 
4912
   ----------------------------
4913
   -- Check_Subprogram_Order --
4914
   ----------------------------
4915
 
4916
   procedure Check_Subprogram_Order (N : Node_Id) is
4917
 
4918
      function Subprogram_Name_Greater (S1, S2 : String) return Boolean;
4919
      --  This is used to check if S1 > S2 in the sense required by this
4920
      --  test, for example nameab < namec, but name2 < name10.
4921
 
4922
      -----------------------------
4923
      -- Subprogram_Name_Greater --
4924
      -----------------------------
4925
 
4926
      function Subprogram_Name_Greater (S1, S2 : String) return Boolean is
4927
         L1, L2 : Positive;
4928
         N1, N2 : Natural;
4929
 
4930
      begin
4931
         --  Remove trailing numeric parts
4932
 
4933
         L1 := S1'Last;
4934
         while S1 (L1) in '0' .. '9' loop
4935
            L1 := L1 - 1;
4936
         end loop;
4937
 
4938
         L2 := S2'Last;
4939
         while S2 (L2) in '0' .. '9' loop
4940
            L2 := L2 - 1;
4941
         end loop;
4942
 
4943
         --  If non-numeric parts non-equal, that's decisive
4944
 
4945
         if S1 (S1'First .. L1) < S2 (S2'First .. L2) then
4946
            return False;
4947
 
4948
         elsif S1 (S1'First .. L1) > S2 (S2'First .. L2) then
4949
            return True;
4950
 
4951
         --  If non-numeric parts equal, compare suffixed numeric parts. Note
4952
         --  that a missing suffix is treated as numeric zero in this test.
4953
 
4954
         else
4955
            N1 := 0;
4956
            while L1 < S1'Last loop
4957
               L1 := L1 + 1;
4958
               N1 := N1 * 10 + Character'Pos (S1 (L1)) - Character'Pos ('0');
4959
            end loop;
4960
 
4961
            N2 := 0;
4962
            while L2 < S2'Last loop
4963
               L2 := L2 + 1;
4964
               N2 := N2 * 10 + Character'Pos (S2 (L2)) - Character'Pos ('0');
4965
            end loop;
4966
 
4967
            return N1 > N2;
4968
         end if;
4969
      end Subprogram_Name_Greater;
4970
 
4971
   --  Start of processing for Check_Subprogram_Order
4972
 
4973
   begin
4974
      --  Check body in alpha order if this is option
4975
 
4976
      if Style_Check
4977
        and then Style_Check_Order_Subprograms
4978
        and then Nkind (N) = N_Subprogram_Body
4979
        and then Comes_From_Source (N)
4980
        and then In_Extended_Main_Source_Unit (N)
4981
      then
4982
         declare
4983
            LSN : String_Ptr
4984
                    renames Scope_Stack.Table
4985
                              (Scope_Stack.Last).Last_Subprogram_Name;
4986
 
4987
            Body_Id : constant Entity_Id :=
4988
                        Defining_Entity (Specification (N));
4989
 
4990
         begin
4991
            Get_Decoded_Name_String (Chars (Body_Id));
4992
 
4993
            if LSN /= null then
4994
               if Subprogram_Name_Greater
4995
                    (LSN.all, Name_Buffer (1 .. Name_Len))
4996
               then
4997
                  Style.Subprogram_Not_In_Alpha_Order (Body_Id);
4998
               end if;
4999
 
5000
               Free (LSN);
5001
            end if;
5002
 
5003
            LSN := new String'(Name_Buffer (1 .. Name_Len));
5004
         end;
5005
      end if;
5006
   end Check_Subprogram_Order;
5007
 
5008
   ------------------------------
5009
   -- Check_Subtype_Conformant --
5010
   ------------------------------
5011
 
5012
   procedure Check_Subtype_Conformant
5013
     (New_Id                   : Entity_Id;
5014
      Old_Id                   : Entity_Id;
5015
      Err_Loc                  : Node_Id := Empty;
5016
      Skip_Controlling_Formals : Boolean := False)
5017
   is
5018
      Result : Boolean;
5019
      pragma Warnings (Off, Result);
5020
   begin
5021
      Check_Conformance
5022
        (New_Id, Old_Id, Subtype_Conformant, True, Result, Err_Loc,
5023
         Skip_Controlling_Formals => Skip_Controlling_Formals);
5024
   end Check_Subtype_Conformant;
5025
 
5026
   ---------------------------
5027
   -- Check_Type_Conformant --
5028
   ---------------------------
5029
 
5030
   procedure Check_Type_Conformant
5031
     (New_Id  : Entity_Id;
5032
      Old_Id  : Entity_Id;
5033
      Err_Loc : Node_Id := Empty)
5034
   is
5035
      Result : Boolean;
5036
      pragma Warnings (Off, Result);
5037
   begin
5038
      Check_Conformance
5039
        (New_Id, Old_Id, Type_Conformant, True, Result, Err_Loc);
5040
   end Check_Type_Conformant;
5041
 
5042
   ----------------------
5043
   -- Conforming_Types --
5044
   ----------------------
5045
 
5046
   function Conforming_Types
5047
     (T1       : Entity_Id;
5048
      T2       : Entity_Id;
5049
      Ctype    : Conformance_Type;
5050
      Get_Inst : Boolean := False) return Boolean
5051
   is
5052
      Type_1 : Entity_Id := T1;
5053
      Type_2 : Entity_Id := T2;
5054
      Are_Anonymous_Access_To_Subprogram_Types : Boolean := False;
5055
 
5056
      function Base_Types_Match (T1, T2 : Entity_Id) return Boolean;
5057
      --  If neither T1 nor T2 are generic actual types, or if they are in
5058
      --  different scopes (e.g. parent and child instances), then verify that
5059
      --  the base types are equal. Otherwise T1 and T2 must be on the same
5060
      --  subtype chain. The whole purpose of this procedure is to prevent
5061
      --  spurious ambiguities in an instantiation that may arise if two
5062
      --  distinct generic types are instantiated with the same actual.
5063
 
5064
      function Find_Designated_Type (T : Entity_Id) return Entity_Id;
5065
      --  An access parameter can designate an incomplete type. If the
5066
      --  incomplete type is the limited view of a type from a limited_
5067
      --  with_clause, check whether the non-limited view is available. If
5068
      --  it is a (non-limited) incomplete type, get the full view.
5069
 
5070
      function Matches_Limited_With_View (T1, T2 : Entity_Id) return Boolean;
5071
      --  Returns True if and only if either T1 denotes a limited view of T2
5072
      --  or T2 denotes a limited view of T1. This can arise when the limited
5073
      --  with view of a type is used in a subprogram declaration and the
5074
      --  subprogram body is in the scope of a regular with clause for the
5075
      --  same unit. In such a case, the two type entities can be considered
5076
      --  identical for purposes of conformance checking.
5077
 
5078
      ----------------------
5079
      -- Base_Types_Match --
5080
      ----------------------
5081
 
5082
      function Base_Types_Match (T1, T2 : Entity_Id) return Boolean is
5083
      begin
5084
         if T1 = T2 then
5085
            return True;
5086
 
5087
         elsif Base_Type (T1) = Base_Type (T2) then
5088
 
5089
            --  The following is too permissive. A more precise test should
5090
            --  check that the generic actual is an ancestor subtype of the
5091
            --  other ???.
5092
 
5093
            return not Is_Generic_Actual_Type (T1)
5094
              or else not Is_Generic_Actual_Type (T2)
5095
              or else Scope (T1) /= Scope (T2);
5096
 
5097
         else
5098
            return False;
5099
         end if;
5100
      end Base_Types_Match;
5101
 
5102
      --------------------------
5103
      -- Find_Designated_Type --
5104
      --------------------------
5105
 
5106
      function Find_Designated_Type (T : Entity_Id) return Entity_Id is
5107
         Desig : Entity_Id;
5108
 
5109
      begin
5110
         Desig := Directly_Designated_Type (T);
5111
 
5112
         if Ekind (Desig) = E_Incomplete_Type then
5113
 
5114
            --  If regular incomplete type, get full view if available
5115
 
5116
            if Present (Full_View (Desig)) then
5117
               Desig := Full_View (Desig);
5118
 
5119
            --  If limited view of a type, get non-limited view if available,
5120
            --  and check again for a regular incomplete type.
5121
 
5122
            elsif Present (Non_Limited_View (Desig)) then
5123
               Desig := Get_Full_View (Non_Limited_View (Desig));
5124
            end if;
5125
         end if;
5126
 
5127
         return Desig;
5128
      end Find_Designated_Type;
5129
 
5130
      -------------------------------
5131
      -- Matches_Limited_With_View --
5132
      -------------------------------
5133
 
5134
      function Matches_Limited_With_View (T1, T2 : Entity_Id) return Boolean is
5135
      begin
5136
         --  In some cases a type imported through a limited_with clause, and
5137
         --  its nonlimited view are both visible, for example in an anonymous
5138
         --  access-to-class-wide type in a formal. Both entities designate the
5139
         --  same type.
5140
 
5141
         if From_With_Type (T1)
5142
           and then T2 = Available_View (T1)
5143
         then
5144
            return True;
5145
 
5146
         elsif From_With_Type (T2)
5147
           and then T1 = Available_View (T2)
5148
         then
5149
            return True;
5150
 
5151
         else
5152
            return False;
5153
         end if;
5154
      end Matches_Limited_With_View;
5155
 
5156
   --  Start of processing for Conforming_Types
5157
 
5158
   begin
5159
      --  The context is an instance association for a formal
5160
      --  access-to-subprogram type; the formal parameter types require
5161
      --  mapping because they may denote other formal parameters of the
5162
      --  generic unit.
5163
 
5164
      if Get_Inst then
5165
         Type_1 := Get_Instance_Of (T1);
5166
         Type_2 := Get_Instance_Of (T2);
5167
      end if;
5168
 
5169
      --  If one of the types is a view of the other introduced by a limited
5170
      --  with clause, treat these as conforming for all purposes.
5171
 
5172
      if Matches_Limited_With_View (T1, T2) then
5173
         return True;
5174
 
5175
      elsif Base_Types_Match (Type_1, Type_2) then
5176
         return Ctype <= Mode_Conformant
5177
           or else Subtypes_Statically_Match (Type_1, Type_2);
5178
 
5179
      elsif Is_Incomplete_Or_Private_Type (Type_1)
5180
        and then Present (Full_View (Type_1))
5181
        and then Base_Types_Match (Full_View (Type_1), Type_2)
5182
      then
5183
         return Ctype <= Mode_Conformant
5184
           or else Subtypes_Statically_Match (Full_View (Type_1), Type_2);
5185
 
5186
      elsif Ekind (Type_2) = E_Incomplete_Type
5187
        and then Present (Full_View (Type_2))
5188
        and then Base_Types_Match (Type_1, Full_View (Type_2))
5189
      then
5190
         return Ctype <= Mode_Conformant
5191
           or else Subtypes_Statically_Match (Type_1, Full_View (Type_2));
5192
 
5193
      elsif Is_Private_Type (Type_2)
5194
        and then In_Instance
5195
        and then Present (Full_View (Type_2))
5196
        and then Base_Types_Match (Type_1, Full_View (Type_2))
5197
      then
5198
         return Ctype <= Mode_Conformant
5199
           or else Subtypes_Statically_Match (Type_1, Full_View (Type_2));
5200
      end if;
5201
 
5202
      --  Ada 2005 (AI-254): Anonymous access-to-subprogram types must be
5203
      --  treated recursively because they carry a signature.
5204
 
5205
      Are_Anonymous_Access_To_Subprogram_Types :=
5206
        Ekind (Type_1) = Ekind (Type_2)
5207
          and then
5208
            (Ekind (Type_1) = E_Anonymous_Access_Subprogram_Type
5209
             or else
5210
               Ekind (Type_1) = E_Anonymous_Access_Protected_Subprogram_Type);
5211
 
5212
      --  Test anonymous access type case. For this case, static subtype
5213
      --  matching is required for mode conformance (RM 6.3.1(15)). We check
5214
      --  the base types because we may have built internal subtype entities
5215
      --  to handle null-excluding types (see Process_Formals).
5216
 
5217
      if (Ekind (Base_Type (Type_1)) = E_Anonymous_Access_Type
5218
            and then
5219
          Ekind (Base_Type (Type_2)) = E_Anonymous_Access_Type)
5220
        or else Are_Anonymous_Access_To_Subprogram_Types -- Ada 2005 (AI-254)
5221
      then
5222
         declare
5223
            Desig_1 : Entity_Id;
5224
            Desig_2 : Entity_Id;
5225
 
5226
         begin
5227
            --  In Ada2005, access constant indicators must match for
5228
            --  subtype conformance.
5229
 
5230
            if Ada_Version >= Ada_05
5231
              and then Ctype >= Subtype_Conformant
5232
              and then
5233
                Is_Access_Constant (Type_1) /= Is_Access_Constant (Type_2)
5234
            then
5235
               return False;
5236
            end if;
5237
 
5238
            Desig_1 := Find_Designated_Type (Type_1);
5239
 
5240
            Desig_2 := Find_Designated_Type (Type_2);
5241
 
5242
            --  If the context is an instance association for a formal
5243
            --  access-to-subprogram type; formal access parameter designated
5244
            --  types require mapping because they may denote other formal
5245
            --  parameters of the generic unit.
5246
 
5247
            if Get_Inst then
5248
               Desig_1 := Get_Instance_Of (Desig_1);
5249
               Desig_2 := Get_Instance_Of (Desig_2);
5250
            end if;
5251
 
5252
            --  It is possible for a Class_Wide_Type to be introduced for an
5253
            --  incomplete type, in which case there is a separate class_ wide
5254
            --  type for the full view. The types conform if their Etypes
5255
            --  conform, i.e. one may be the full view of the other. This can
5256
            --  only happen in the context of an access parameter, other uses
5257
            --  of an incomplete Class_Wide_Type are illegal.
5258
 
5259
            if Is_Class_Wide_Type (Desig_1)
5260
              and then Is_Class_Wide_Type (Desig_2)
5261
            then
5262
               return
5263
                 Conforming_Types
5264
                   (Etype (Base_Type (Desig_1)),
5265
                    Etype (Base_Type (Desig_2)), Ctype);
5266
 
5267
            elsif Are_Anonymous_Access_To_Subprogram_Types then
5268
               if Ada_Version < Ada_05 then
5269
                  return Ctype = Type_Conformant
5270
                    or else
5271
                      Subtypes_Statically_Match (Desig_1, Desig_2);
5272
 
5273
               --  We must check the conformance of the signatures themselves
5274
 
5275
               else
5276
                  declare
5277
                     Conformant : Boolean;
5278
                  begin
5279
                     Check_Conformance
5280
                       (Desig_1, Desig_2, Ctype, False, Conformant);
5281
                     return Conformant;
5282
                  end;
5283
               end if;
5284
 
5285
            else
5286
               return Base_Type (Desig_1) = Base_Type (Desig_2)
5287
                and then (Ctype = Type_Conformant
5288
                            or else
5289
                          Subtypes_Statically_Match (Desig_1, Desig_2));
5290
            end if;
5291
         end;
5292
 
5293
      --  Otherwise definitely no match
5294
 
5295
      else
5296
         if ((Ekind (Type_1) = E_Anonymous_Access_Type
5297
               and then Is_Access_Type (Type_2))
5298
            or else (Ekind (Type_2) = E_Anonymous_Access_Type
5299
                       and then Is_Access_Type (Type_1)))
5300
           and then
5301
             Conforming_Types
5302
               (Designated_Type (Type_1), Designated_Type (Type_2), Ctype)
5303
         then
5304
            May_Hide_Profile := True;
5305
         end if;
5306
 
5307
         return False;
5308
      end if;
5309
   end Conforming_Types;
5310
 
5311
   --------------------------
5312
   -- Create_Extra_Formals --
5313
   --------------------------
5314
 
5315
   procedure Create_Extra_Formals (E : Entity_Id) is
5316
      Formal      : Entity_Id;
5317
      First_Extra : Entity_Id := Empty;
5318
      Last_Extra  : Entity_Id;
5319
      Formal_Type : Entity_Id;
5320
      P_Formal    : Entity_Id := Empty;
5321
 
5322
      function Add_Extra_Formal
5323
        (Assoc_Entity : Entity_Id;
5324
         Typ          : Entity_Id;
5325
         Scope        : Entity_Id;
5326
         Suffix       : String) return Entity_Id;
5327
      --  Add an extra formal to the current list of formals and extra formals.
5328
      --  The extra formal is added to the end of the list of extra formals,
5329
      --  and also returned as the result. These formals are always of mode IN.
5330
      --  The new formal has the type Typ, is declared in Scope, and its name
5331
      --  is given by a concatenation of the name of Assoc_Entity and Suffix.
5332
 
5333
      ----------------------
5334
      -- Add_Extra_Formal --
5335
      ----------------------
5336
 
5337
      function Add_Extra_Formal
5338
        (Assoc_Entity : Entity_Id;
5339
         Typ          : Entity_Id;
5340
         Scope        : Entity_Id;
5341
         Suffix       : String) return Entity_Id
5342
      is
5343
         EF : constant Entity_Id :=
5344
                Make_Defining_Identifier (Sloc (Assoc_Entity),
5345
                  Chars  => New_External_Name (Chars (Assoc_Entity),
5346
                                               Suffix => Suffix));
5347
 
5348
      begin
5349
         --  A little optimization. Never generate an extra formal for the
5350
         --  _init operand of an initialization procedure, since it could
5351
         --  never be used.
5352
 
5353
         if Chars (Formal) = Name_uInit then
5354
            return Empty;
5355
         end if;
5356
 
5357
         Set_Ekind           (EF, E_In_Parameter);
5358
         Set_Actual_Subtype  (EF, Typ);
5359
         Set_Etype           (EF, Typ);
5360
         Set_Scope           (EF, Scope);
5361
         Set_Mechanism       (EF, Default_Mechanism);
5362
         Set_Formal_Validity (EF);
5363
 
5364
         if No (First_Extra) then
5365
            First_Extra := EF;
5366
            Set_Extra_Formals (Scope, First_Extra);
5367
         end if;
5368
 
5369
         if Present (Last_Extra) then
5370
            Set_Extra_Formal (Last_Extra, EF);
5371
         end if;
5372
 
5373
         Last_Extra := EF;
5374
 
5375
         return EF;
5376
      end Add_Extra_Formal;
5377
 
5378
   --  Start of processing for Create_Extra_Formals
5379
 
5380
   begin
5381
      --  We never generate extra formals if expansion is not active
5382
      --  because we don't need them unless we are generating code.
5383
 
5384
      if not Expander_Active then
5385
         return;
5386
      end if;
5387
 
5388
      --  If this is a derived subprogram then the subtypes of the parent
5389
      --  subprogram's formal parameters will be used to determine the need
5390
      --  for extra formals.
5391
 
5392
      if Is_Overloadable (E) and then Present (Alias (E)) then
5393
         P_Formal := First_Formal (Alias (E));
5394
      end if;
5395
 
5396
      Last_Extra := Empty;
5397
      Formal := First_Formal (E);
5398
      while Present (Formal) loop
5399
         Last_Extra := Formal;
5400
         Next_Formal (Formal);
5401
      end loop;
5402
 
5403
      --  If Extra_formals were already created, don't do it again. This
5404
      --  situation may arise for subprogram types created as part of
5405
      --  dispatching calls (see Expand_Dispatching_Call)
5406
 
5407
      if Present (Last_Extra) and then
5408
        Present (Extra_Formal (Last_Extra))
5409
      then
5410
         return;
5411
      end if;
5412
 
5413
      --  If the subprogram is a predefined dispatching subprogram then don't
5414
      --  generate any extra constrained or accessibility level formals. In
5415
      --  general we suppress these for internal subprograms (by not calling
5416
      --  Freeze_Subprogram and Create_Extra_Formals at all), but internally
5417
      --  generated stream attributes do get passed through because extra
5418
      --  build-in-place formals are needed in some cases (limited 'Input).
5419
 
5420
      if Is_Predefined_Internal_Operation (E) then
5421
         goto Test_For_BIP_Extras;
5422
      end if;
5423
 
5424
      Formal := First_Formal (E);
5425
      while Present (Formal) loop
5426
 
5427
         --  Create extra formal for supporting the attribute 'Constrained.
5428
         --  The case of a private type view without discriminants also
5429
         --  requires the extra formal if the underlying type has defaulted
5430
         --  discriminants.
5431
 
5432
         if Ekind (Formal) /= E_In_Parameter then
5433
            if Present (P_Formal) then
5434
               Formal_Type := Etype (P_Formal);
5435
            else
5436
               Formal_Type := Etype (Formal);
5437
            end if;
5438
 
5439
            --  Do not produce extra formals for Unchecked_Union parameters.
5440
            --  Jump directly to the end of the loop.
5441
 
5442
            if Is_Unchecked_Union (Base_Type (Formal_Type)) then
5443
               goto Skip_Extra_Formal_Generation;
5444
            end if;
5445
 
5446
            if not Has_Discriminants (Formal_Type)
5447
              and then Ekind (Formal_Type) in Private_Kind
5448
              and then Present (Underlying_Type (Formal_Type))
5449
            then
5450
               Formal_Type := Underlying_Type (Formal_Type);
5451
            end if;
5452
 
5453
            if Has_Discriminants (Formal_Type)
5454
              and then not Is_Constrained (Formal_Type)
5455
              and then not Is_Indefinite_Subtype (Formal_Type)
5456
            then
5457
               Set_Extra_Constrained
5458
                 (Formal, Add_Extra_Formal (Formal, Standard_Boolean, E, "F"));
5459
            end if;
5460
         end if;
5461
 
5462
         --  Create extra formal for supporting accessibility checking. This
5463
         --  is done for both anonymous access formals and formals of named
5464
         --  access types that are marked as controlling formals. The latter
5465
         --  case can occur when Expand_Dispatching_Call creates a subprogram
5466
         --  type and substitutes the types of access-to-class-wide actuals
5467
         --  for the anonymous access-to-specific-type of controlling formals.
5468
         --  Base_Type is applied because in cases where there is a null
5469
         --  exclusion the formal may have an access subtype.
5470
 
5471
         --  This is suppressed if we specifically suppress accessibility
5472
         --  checks at the package level for either the subprogram, or the
5473
         --  package in which it resides. However, we do not suppress it
5474
         --  simply if the scope has accessibility checks suppressed, since
5475
         --  this could cause trouble when clients are compiled with a
5476
         --  different suppression setting. The explicit checks at the
5477
         --  package level are safe from this point of view.
5478
 
5479
         if (Ekind (Base_Type (Etype (Formal))) = E_Anonymous_Access_Type
5480
              or else (Is_Controlling_Formal (Formal)
5481
                        and then Is_Access_Type (Base_Type (Etype (Formal)))))
5482
           and then not
5483
             (Explicit_Suppress (E, Accessibility_Check)
5484
               or else
5485
              Explicit_Suppress (Scope (E), Accessibility_Check))
5486
           and then
5487
             (No (P_Formal)
5488
               or else Present (Extra_Accessibility (P_Formal)))
5489
         then
5490
            Set_Extra_Accessibility
5491
              (Formal, Add_Extra_Formal (Formal, Standard_Natural, E, "F"));
5492
         end if;
5493
 
5494
         --  This label is required when skipping extra formal generation for
5495
         --  Unchecked_Union parameters.
5496
 
5497
         <<Skip_Extra_Formal_Generation>>
5498
 
5499
         if Present (P_Formal) then
5500
            Next_Formal (P_Formal);
5501
         end if;
5502
 
5503
         Next_Formal (Formal);
5504
      end loop;
5505
 
5506
      <<Test_For_BIP_Extras>>
5507
 
5508
      --  Ada 2005 (AI-318-02): In the case of build-in-place functions, add
5509
      --  appropriate extra formals. See type Exp_Ch6.BIP_Formal_Kind.
5510
 
5511
      if Ada_Version >= Ada_05 and then Is_Build_In_Place_Function (E) then
5512
         declare
5513
            Result_Subt : constant Entity_Id := Etype (E);
5514
 
5515
            Discard : Entity_Id;
5516
            pragma Warnings (Off, Discard);
5517
 
5518
         begin
5519
            --  In the case of functions with unconstrained result subtypes,
5520
            --  add a 3-state formal indicating whether the return object is
5521
            --  allocated by the caller (0), or should be allocated by the
5522
            --  callee on the secondary stack (1) or in the global heap (2).
5523
            --  For the moment we just use Natural for the type of this formal.
5524
            --  Note that this formal isn't usually needed in the case where
5525
            --  the result subtype is constrained, but it is needed when the
5526
            --  function has a tagged result, because generally such functions
5527
            --  can be called in a dispatching context and such calls must be
5528
            --  handled like calls to a class-wide function.
5529
 
5530
            if not Is_Constrained (Underlying_Type (Result_Subt))
5531
              or else Is_Tagged_Type (Underlying_Type (Result_Subt))
5532
            then
5533
               Discard :=
5534
                 Add_Extra_Formal
5535
                   (E, Standard_Natural,
5536
                    E, BIP_Formal_Suffix (BIP_Alloc_Form));
5537
            end if;
5538
 
5539
            --  In the case of functions whose result type has controlled
5540
            --  parts, we have an extra formal of type
5541
            --  System.Finalization_Implementation.Finalizable_Ptr_Ptr. That
5542
            --  is, we are passing a pointer to a finalization list (which is
5543
            --  itself a pointer). This extra formal is then passed along to
5544
            --  Move_Final_List in case of successful completion of a return
5545
            --  statement. We cannot pass an 'in out' parameter, because we
5546
            --  need to update the finalization list during an abort-deferred
5547
            --  region, rather than using copy-back after the function
5548
            --  returns. This is true even if we are able to get away with
5549
            --  having 'in out' parameters, which are normally illegal for
5550
            --  functions. This formal is also needed when the function has
5551
            --  a tagged result.
5552
 
5553
            if Needs_BIP_Final_List (E) then
5554
               Discard :=
5555
                 Add_Extra_Formal
5556
                   (E, RTE (RE_Finalizable_Ptr_Ptr),
5557
                    E, BIP_Formal_Suffix (BIP_Final_List));
5558
            end if;
5559
 
5560
            --  If the result type contains tasks, we have two extra formals:
5561
            --  the master of the tasks to be created, and the caller's
5562
            --  activation chain.
5563
 
5564
            if Has_Task (Result_Subt) then
5565
               Discard :=
5566
                 Add_Extra_Formal
5567
                   (E, RTE (RE_Master_Id),
5568
                    E, BIP_Formal_Suffix (BIP_Master));
5569
               Discard :=
5570
                 Add_Extra_Formal
5571
                   (E, RTE (RE_Activation_Chain_Access),
5572
                    E, BIP_Formal_Suffix (BIP_Activation_Chain));
5573
            end if;
5574
 
5575
            --  All build-in-place functions get an extra formal that will be
5576
            --  passed the address of the return object within the caller.
5577
 
5578
            declare
5579
               Formal_Type : constant Entity_Id :=
5580
                               Create_Itype
5581
                                 (E_Anonymous_Access_Type, E,
5582
                                  Scope_Id => Scope (E));
5583
            begin
5584
               Set_Directly_Designated_Type (Formal_Type, Result_Subt);
5585
               Set_Etype (Formal_Type, Formal_Type);
5586
               Set_Depends_On_Private
5587
                 (Formal_Type, Has_Private_Component (Formal_Type));
5588
               Set_Is_Public (Formal_Type, Is_Public (Scope (Formal_Type)));
5589
               Set_Is_Access_Constant (Formal_Type, False);
5590
 
5591
               --  Ada 2005 (AI-50217): Propagate the attribute that indicates
5592
               --  the designated type comes from the limited view (for
5593
               --  back-end purposes).
5594
 
5595
               Set_From_With_Type (Formal_Type, From_With_Type (Result_Subt));
5596
 
5597
               Layout_Type (Formal_Type);
5598
 
5599
               Discard :=
5600
                 Add_Extra_Formal
5601
                   (E, Formal_Type, E, BIP_Formal_Suffix (BIP_Object_Access));
5602
            end;
5603
         end;
5604
      end if;
5605
   end Create_Extra_Formals;
5606
 
5607
   -----------------------------
5608
   -- Enter_Overloaded_Entity --
5609
   -----------------------------
5610
 
5611
   procedure Enter_Overloaded_Entity (S : Entity_Id) is
5612
      E   : Entity_Id := Current_Entity_In_Scope (S);
5613
      C_E : Entity_Id := Current_Entity (S);
5614
 
5615
   begin
5616
      if Present (E) then
5617
         Set_Has_Homonym (E);
5618
         Set_Has_Homonym (S);
5619
      end if;
5620
 
5621
      Set_Is_Immediately_Visible (S);
5622
      Set_Scope (S, Current_Scope);
5623
 
5624
      --  Chain new entity if front of homonym in current scope, so that
5625
      --  homonyms are contiguous.
5626
 
5627
      if Present (E)
5628
        and then E /= C_E
5629
      then
5630
         while Homonym (C_E) /= E loop
5631
            C_E := Homonym (C_E);
5632
         end loop;
5633
 
5634
         Set_Homonym (C_E, S);
5635
 
5636
      else
5637
         E := C_E;
5638
         Set_Current_Entity (S);
5639
      end if;
5640
 
5641
      Set_Homonym (S, E);
5642
 
5643
      Append_Entity (S, Current_Scope);
5644
      Set_Public_Status (S);
5645
 
5646
      if Debug_Flag_E then
5647
         Write_Str ("New overloaded entity chain: ");
5648
         Write_Name (Chars (S));
5649
 
5650
         E := S;
5651
         while Present (E) loop
5652
            Write_Str (" "); Write_Int (Int (E));
5653
            E := Homonym (E);
5654
         end loop;
5655
 
5656
         Write_Eol;
5657
      end if;
5658
 
5659
      --  Generate warning for hiding
5660
 
5661
      if Warn_On_Hiding
5662
        and then Comes_From_Source (S)
5663
        and then In_Extended_Main_Source_Unit (S)
5664
      then
5665
         E := S;
5666
         loop
5667
            E := Homonym (E);
5668
            exit when No (E);
5669
 
5670
            --  Warn unless genuine overloading
5671
 
5672
            if (not Is_Overloadable (E) or else Subtype_Conformant (E, S))
5673
                  and then (Is_Immediately_Visible (E)
5674
                              or else
5675
                            Is_Potentially_Use_Visible (S))
5676
            then
5677
               Error_Msg_Sloc := Sloc (E);
5678
               Error_Msg_N ("declaration of & hides one#?", S);
5679
            end if;
5680
         end loop;
5681
      end if;
5682
   end Enter_Overloaded_Entity;
5683
 
5684
   -----------------------------
5685
   -- Find_Corresponding_Spec --
5686
   -----------------------------
5687
 
5688
   function Find_Corresponding_Spec
5689
     (N          : Node_Id;
5690
      Post_Error : Boolean := True) return Entity_Id
5691
   is
5692
      Spec       : constant Node_Id   := Specification (N);
5693
      Designator : constant Entity_Id := Defining_Entity (Spec);
5694
 
5695
      E : Entity_Id;
5696
 
5697
   begin
5698
      E := Current_Entity (Designator);
5699
      while Present (E) loop
5700
 
5701
         --  We are looking for a matching spec. It must have the same scope,
5702
         --  and the same name, and either be type conformant, or be the case
5703
         --  of a library procedure spec and its body (which belong to one
5704
         --  another regardless of whether they are type conformant or not).
5705
 
5706
         if Scope (E) = Current_Scope then
5707
            if Current_Scope = Standard_Standard
5708
              or else (Ekind (E) = Ekind (Designator)
5709
                         and then Type_Conformant (E, Designator))
5710
            then
5711
               --  Within an instantiation, we know that spec and body are
5712
               --  subtype conformant, because they were subtype conformant
5713
               --  in the generic. We choose the subtype-conformant entity
5714
               --  here as well, to resolve spurious ambiguities in the
5715
               --  instance that were not present in the generic (i.e. when
5716
               --  two different types are given the same actual). If we are
5717
               --  looking for a spec to match a body, full conformance is
5718
               --  expected.
5719
 
5720
               if In_Instance then
5721
                  Set_Convention (Designator, Convention (E));
5722
 
5723
                  if Nkind (N) = N_Subprogram_Body
5724
                    and then Present (Homonym (E))
5725
                    and then not Fully_Conformant (E, Designator)
5726
                  then
5727
                     goto Next_Entity;
5728
 
5729
                  elsif not Subtype_Conformant (E, Designator) then
5730
                     goto Next_Entity;
5731
                  end if;
5732
               end if;
5733
 
5734
               if not Has_Completion (E) then
5735
                  if Nkind (N) /= N_Subprogram_Body_Stub then
5736
                     Set_Corresponding_Spec (N, E);
5737
                  end if;
5738
 
5739
                  Set_Has_Completion (E);
5740
                  return E;
5741
 
5742
               elsif Nkind (Parent (N)) = N_Subunit then
5743
 
5744
                  --  If this is the proper body of a subunit, the completion
5745
                  --  flag is set when analyzing the stub.
5746
 
5747
                  return E;
5748
 
5749
               --  If E is an internal function with a controlling result
5750
               --  that was created for an operation inherited by a null
5751
               --  extension, it may be overridden by a body without a previous
5752
               --  spec (one more reason why these should be shunned). In that
5753
               --  case remove the generated body, because the current one is
5754
               --  the explicit overriding.
5755
 
5756
               elsif Ekind (E) = E_Function
5757
                 and then Ada_Version >= Ada_05
5758
                 and then not Comes_From_Source (E)
5759
                 and then Has_Controlling_Result (E)
5760
                 and then Is_Null_Extension (Etype (E))
5761
                 and then Comes_From_Source (Spec)
5762
               then
5763
                  Set_Has_Completion (E, False);
5764
 
5765
                  if Expander_Active then
5766
                     Remove
5767
                       (Unit_Declaration_Node
5768
                         (Corresponding_Body (Unit_Declaration_Node (E))));
5769
                     return E;
5770
 
5771
                  --  If expansion is disabled, the wrapper function has not
5772
                  --  been generated, and this is the standard case of a late
5773
                  --  body overriding an inherited operation.
5774
 
5775
                  else
5776
                     return Empty;
5777
                  end if;
5778
 
5779
               --  If the body already exists, then this is an error unless
5780
               --  the previous declaration is the implicit declaration of a
5781
               --  derived subprogram, or this is a spurious overloading in an
5782
               --  instance.
5783
 
5784
               elsif No (Alias (E))
5785
                 and then not Is_Intrinsic_Subprogram (E)
5786
                 and then not In_Instance
5787
                 and then Post_Error
5788
               then
5789
                  Error_Msg_Sloc := Sloc (E);
5790
 
5791
                  if Is_Imported (E) then
5792
                     Error_Msg_NE
5793
                      ("body not allowed for imported subprogram & declared#",
5794
                        N, E);
5795
                  else
5796
                     Error_Msg_NE ("duplicate body for & declared#", N, E);
5797
                  end if;
5798
               end if;
5799
 
5800
            --  Child units cannot be overloaded, so a conformance mismatch
5801
            --  between body and a previous spec is an error.
5802
 
5803
            elsif Is_Child_Unit (E)
5804
              and then
5805
                Nkind (Unit_Declaration_Node (Designator)) = N_Subprogram_Body
5806
              and then
5807
                Nkind (Parent (Unit_Declaration_Node (Designator))) =
5808
                  N_Compilation_Unit
5809
              and then Post_Error
5810
            then
5811
               Error_Msg_N
5812
                 ("body of child unit does not match previous declaration", N);
5813
            end if;
5814
         end if;
5815
 
5816
         <<Next_Entity>>
5817
            E := Homonym (E);
5818
      end loop;
5819
 
5820
      --  On exit, we know that no previous declaration of subprogram exists
5821
 
5822
      return Empty;
5823
   end Find_Corresponding_Spec;
5824
 
5825
   ----------------------
5826
   -- Fully_Conformant --
5827
   ----------------------
5828
 
5829
   function Fully_Conformant (New_Id, Old_Id : Entity_Id) return Boolean is
5830
      Result : Boolean;
5831
   begin
5832
      Check_Conformance (New_Id, Old_Id, Fully_Conformant, False, Result);
5833
      return Result;
5834
   end Fully_Conformant;
5835
 
5836
   ----------------------------------
5837
   -- Fully_Conformant_Expressions --
5838
   ----------------------------------
5839
 
5840
   function Fully_Conformant_Expressions
5841
     (Given_E1 : Node_Id;
5842
      Given_E2 : Node_Id) return Boolean
5843
   is
5844
      E1 : constant Node_Id := Original_Node (Given_E1);
5845
      E2 : constant Node_Id := Original_Node (Given_E2);
5846
      --  We always test conformance on original nodes, since it is possible
5847
      --  for analysis and/or expansion to make things look as though they
5848
      --  conform when they do not, e.g. by converting 1+2 into 3.
5849
 
5850
      function FCE (Given_E1, Given_E2 : Node_Id) return Boolean
5851
        renames Fully_Conformant_Expressions;
5852
 
5853
      function FCL (L1, L2 : List_Id) return Boolean;
5854
      --  Compare elements of two lists for conformance. Elements have to
5855
      --  be conformant, and actuals inserted as default parameters do not
5856
      --  match explicit actuals with the same value.
5857
 
5858
      function FCO (Op_Node, Call_Node : Node_Id) return Boolean;
5859
      --  Compare an operator node with a function call
5860
 
5861
      ---------
5862
      -- FCL --
5863
      ---------
5864
 
5865
      function FCL (L1, L2 : List_Id) return Boolean is
5866
         N1, N2 : Node_Id;
5867
 
5868
      begin
5869
         if L1 = No_List then
5870
            N1 := Empty;
5871
         else
5872
            N1 := First (L1);
5873
         end if;
5874
 
5875
         if L2 = No_List then
5876
            N2 := Empty;
5877
         else
5878
            N2 := First (L2);
5879
         end if;
5880
 
5881
         --  Compare two lists, skipping rewrite insertions (we want to
5882
         --  compare the original trees, not the expanded versions!)
5883
 
5884
         loop
5885
            if Is_Rewrite_Insertion (N1) then
5886
               Next (N1);
5887
            elsif Is_Rewrite_Insertion (N2) then
5888
               Next (N2);
5889
            elsif No (N1) then
5890
               return No (N2);
5891
            elsif No (N2) then
5892
               return False;
5893
            elsif not FCE (N1, N2) then
5894
               return False;
5895
            else
5896
               Next (N1);
5897
               Next (N2);
5898
            end if;
5899
         end loop;
5900
      end FCL;
5901
 
5902
      ---------
5903
      -- FCO --
5904
      ---------
5905
 
5906
      function FCO (Op_Node, Call_Node : Node_Id) return Boolean is
5907
         Actuals : constant List_Id := Parameter_Associations (Call_Node);
5908
         Act     : Node_Id;
5909
 
5910
      begin
5911
         if No (Actuals)
5912
            or else Entity (Op_Node) /= Entity (Name (Call_Node))
5913
         then
5914
            return False;
5915
 
5916
         else
5917
            Act := First (Actuals);
5918
 
5919
            if Nkind (Op_Node) in N_Binary_Op then
5920
               if not FCE (Left_Opnd (Op_Node), Act) then
5921
                  return False;
5922
               end if;
5923
 
5924
               Next (Act);
5925
            end if;
5926
 
5927
            return Present (Act)
5928
              and then FCE (Right_Opnd (Op_Node), Act)
5929
              and then No (Next (Act));
5930
         end if;
5931
      end FCO;
5932
 
5933
   --  Start of processing for Fully_Conformant_Expressions
5934
 
5935
   begin
5936
      --  Non-conformant if paren count does not match. Note: if some idiot
5937
      --  complains that we don't do this right for more than 3 levels of
5938
      --  parentheses, they will be treated with the respect they deserve!
5939
 
5940
      if Paren_Count (E1) /= Paren_Count (E2) then
5941
         return False;
5942
 
5943
      --  If same entities are referenced, then they are conformant even if
5944
      --  they have different forms (RM 8.3.1(19-20)).
5945
 
5946
      elsif Is_Entity_Name (E1) and then Is_Entity_Name (E2) then
5947
         if Present (Entity (E1)) then
5948
            return Entity (E1) = Entity (E2)
5949
              or else (Chars (Entity (E1)) = Chars (Entity (E2))
5950
                        and then Ekind (Entity (E1)) = E_Discriminant
5951
                        and then Ekind (Entity (E2)) = E_In_Parameter);
5952
 
5953
         elsif Nkind (E1) = N_Expanded_Name
5954
           and then Nkind (E2) = N_Expanded_Name
5955
           and then Nkind (Selector_Name (E1)) = N_Character_Literal
5956
           and then Nkind (Selector_Name (E2)) = N_Character_Literal
5957
         then
5958
            return Chars (Selector_Name (E1)) = Chars (Selector_Name (E2));
5959
 
5960
         else
5961
            --  Identifiers in component associations don't always have
5962
            --  entities, but their names must conform.
5963
 
5964
            return Nkind  (E1) = N_Identifier
5965
              and then Nkind (E2) = N_Identifier
5966
              and then Chars (E1) = Chars (E2);
5967
         end if;
5968
 
5969
      elsif Nkind (E1) = N_Character_Literal
5970
        and then Nkind (E2) = N_Expanded_Name
5971
      then
5972
         return Nkind (Selector_Name (E2)) = N_Character_Literal
5973
           and then Chars (E1) = Chars (Selector_Name (E2));
5974
 
5975
      elsif Nkind (E2) = N_Character_Literal
5976
        and then Nkind (E1) = N_Expanded_Name
5977
      then
5978
         return Nkind (Selector_Name (E1)) = N_Character_Literal
5979
           and then Chars (E2) = Chars (Selector_Name (E1));
5980
 
5981
      elsif Nkind (E1) in N_Op
5982
        and then Nkind (E2) = N_Function_Call
5983
      then
5984
         return FCO (E1, E2);
5985
 
5986
      elsif Nkind (E2) in N_Op
5987
        and then Nkind (E1) = N_Function_Call
5988
      then
5989
         return FCO (E2, E1);
5990
 
5991
      --  Otherwise we must have the same syntactic entity
5992
 
5993
      elsif Nkind (E1) /= Nkind (E2) then
5994
         return False;
5995
 
5996
      --  At this point, we specialize by node type
5997
 
5998
      else
5999
         case Nkind (E1) is
6000
 
6001
            when N_Aggregate =>
6002
               return
6003
                 FCL (Expressions (E1), Expressions (E2))
6004
                   and then FCL (Component_Associations (E1),
6005
                                 Component_Associations (E2));
6006
 
6007
            when N_Allocator =>
6008
               if Nkind (Expression (E1)) = N_Qualified_Expression
6009
                    or else
6010
                  Nkind (Expression (E2)) = N_Qualified_Expression
6011
               then
6012
                  return FCE (Expression (E1), Expression (E2));
6013
 
6014
               --  Check that the subtype marks and any constraints
6015
               --  are conformant
6016
 
6017
               else
6018
                  declare
6019
                     Indic1 : constant Node_Id := Expression (E1);
6020
                     Indic2 : constant Node_Id := Expression (E2);
6021
                     Elt1   : Node_Id;
6022
                     Elt2   : Node_Id;
6023
 
6024
                  begin
6025
                     if Nkind (Indic1) /= N_Subtype_Indication then
6026
                        return
6027
                          Nkind (Indic2) /= N_Subtype_Indication
6028
                            and then Entity (Indic1) = Entity (Indic2);
6029
 
6030
                     elsif Nkind (Indic2) /= N_Subtype_Indication then
6031
                        return
6032
                          Nkind (Indic1) /= N_Subtype_Indication
6033
                            and then Entity (Indic1) = Entity (Indic2);
6034
 
6035
                     else
6036
                        if Entity (Subtype_Mark (Indic1)) /=
6037
                          Entity (Subtype_Mark (Indic2))
6038
                        then
6039
                           return False;
6040
                        end if;
6041
 
6042
                        Elt1 := First (Constraints (Constraint (Indic1)));
6043
                        Elt2 := First (Constraints (Constraint (Indic2)));
6044
                        while Present (Elt1) and then Present (Elt2) loop
6045
                           if not FCE (Elt1, Elt2) then
6046
                              return False;
6047
                           end if;
6048
 
6049
                           Next (Elt1);
6050
                           Next (Elt2);
6051
                        end loop;
6052
 
6053
                        return True;
6054
                     end if;
6055
                  end;
6056
               end if;
6057
 
6058
            when N_Attribute_Reference =>
6059
               return
6060
                 Attribute_Name (E1) = Attribute_Name (E2)
6061
                   and then FCL (Expressions (E1), Expressions (E2));
6062
 
6063
            when N_Binary_Op =>
6064
               return
6065
                 Entity (E1) = Entity (E2)
6066
                   and then FCE (Left_Opnd  (E1), Left_Opnd  (E2))
6067
                   and then FCE (Right_Opnd (E1), Right_Opnd (E2));
6068
 
6069
            when N_Short_Circuit | N_Membership_Test =>
6070
               return
6071
                 FCE (Left_Opnd  (E1), Left_Opnd  (E2))
6072
                   and then
6073
                 FCE (Right_Opnd (E1), Right_Opnd (E2));
6074
 
6075
            when N_Character_Literal =>
6076
               return
6077
                 Char_Literal_Value (E1) = Char_Literal_Value (E2);
6078
 
6079
            when N_Component_Association =>
6080
               return
6081
                 FCL (Choices (E1), Choices (E2))
6082
                   and then FCE (Expression (E1), Expression (E2));
6083
 
6084
            when N_Conditional_Expression =>
6085
               return
6086
                 FCL (Expressions (E1), Expressions (E2));
6087
 
6088
            when N_Explicit_Dereference =>
6089
               return
6090
                 FCE (Prefix (E1), Prefix (E2));
6091
 
6092
            when N_Extension_Aggregate =>
6093
               return
6094
                 FCL (Expressions (E1), Expressions (E2))
6095
                   and then Null_Record_Present (E1) =
6096
                            Null_Record_Present (E2)
6097
                   and then FCL (Component_Associations (E1),
6098
                               Component_Associations (E2));
6099
 
6100
            when N_Function_Call =>
6101
               return
6102
                 FCE (Name (E1), Name (E2))
6103
                   and then FCL (Parameter_Associations (E1),
6104
                                 Parameter_Associations (E2));
6105
 
6106
            when N_Indexed_Component =>
6107
               return
6108
                 FCE (Prefix (E1), Prefix (E2))
6109
                   and then FCL (Expressions (E1), Expressions (E2));
6110
 
6111
            when N_Integer_Literal =>
6112
               return (Intval (E1) = Intval (E2));
6113
 
6114
            when N_Null =>
6115
               return True;
6116
 
6117
            when N_Operator_Symbol =>
6118
               return
6119
                 Chars (E1) = Chars (E2);
6120
 
6121
            when N_Others_Choice =>
6122
               return True;
6123
 
6124
            when N_Parameter_Association =>
6125
               return
6126
                 Chars (Selector_Name (E1))  = Chars (Selector_Name (E2))
6127
                   and then FCE (Explicit_Actual_Parameter (E1),
6128
                                 Explicit_Actual_Parameter (E2));
6129
 
6130
            when N_Qualified_Expression =>
6131
               return
6132
                 FCE (Subtype_Mark (E1), Subtype_Mark (E2))
6133
                   and then FCE (Expression (E1), Expression (E2));
6134
 
6135
            when N_Range =>
6136
               return
6137
                 FCE (Low_Bound (E1), Low_Bound (E2))
6138
                   and then FCE (High_Bound (E1), High_Bound (E2));
6139
 
6140
            when N_Real_Literal =>
6141
               return (Realval (E1) = Realval (E2));
6142
 
6143
            when N_Selected_Component =>
6144
               return
6145
                 FCE (Prefix (E1), Prefix (E2))
6146
                   and then FCE (Selector_Name (E1), Selector_Name (E2));
6147
 
6148
            when N_Slice =>
6149
               return
6150
                 FCE (Prefix (E1), Prefix (E2))
6151
                   and then FCE (Discrete_Range (E1), Discrete_Range (E2));
6152
 
6153
            when N_String_Literal =>
6154
               declare
6155
                  S1 : constant String_Id := Strval (E1);
6156
                  S2 : constant String_Id := Strval (E2);
6157
                  L1 : constant Nat       := String_Length (S1);
6158
                  L2 : constant Nat       := String_Length (S2);
6159
 
6160
               begin
6161
                  if L1 /= L2 then
6162
                     return False;
6163
 
6164
                  else
6165
                     for J in 1 .. L1 loop
6166
                        if Get_String_Char (S1, J) /=
6167
                           Get_String_Char (S2, J)
6168
                        then
6169
                           return False;
6170
                        end if;
6171
                     end loop;
6172
 
6173
                     return True;
6174
                  end if;
6175
               end;
6176
 
6177
            when N_Type_Conversion =>
6178
               return
6179
                 FCE (Subtype_Mark (E1), Subtype_Mark (E2))
6180
                   and then FCE (Expression (E1), Expression (E2));
6181
 
6182
            when N_Unary_Op =>
6183
               return
6184
                 Entity (E1) = Entity (E2)
6185
                   and then FCE (Right_Opnd (E1), Right_Opnd (E2));
6186
 
6187
            when N_Unchecked_Type_Conversion =>
6188
               return
6189
                 FCE (Subtype_Mark (E1), Subtype_Mark (E2))
6190
                   and then FCE (Expression (E1), Expression (E2));
6191
 
6192
            --  All other node types cannot appear in this context. Strictly
6193
            --  we should raise a fatal internal error. Instead we just ignore
6194
            --  the nodes. This means that if anyone makes a mistake in the
6195
            --  expander and mucks an expression tree irretrievably, the
6196
            --  result will be a failure to detect a (probably very obscure)
6197
            --  case of non-conformance, which is better than bombing on some
6198
            --  case where two expressions do in fact conform.
6199
 
6200
            when others =>
6201
               return True;
6202
 
6203
         end case;
6204
      end if;
6205
   end Fully_Conformant_Expressions;
6206
 
6207
   ----------------------------------------
6208
   -- Fully_Conformant_Discrete_Subtypes --
6209
   ----------------------------------------
6210
 
6211
   function Fully_Conformant_Discrete_Subtypes
6212
     (Given_S1 : Node_Id;
6213
      Given_S2 : Node_Id) return Boolean
6214
   is
6215
      S1 : constant Node_Id := Original_Node (Given_S1);
6216
      S2 : constant Node_Id := Original_Node (Given_S2);
6217
 
6218
      function Conforming_Bounds (B1, B2 : Node_Id) return Boolean;
6219
      --  Special-case for a bound given by a discriminant, which in the body
6220
      --  is replaced with the discriminal of the enclosing type.
6221
 
6222
      function Conforming_Ranges (R1, R2 : Node_Id) return Boolean;
6223
      --  Check both bounds
6224
 
6225
      -----------------------
6226
      -- Conforming_Bounds --
6227
      -----------------------
6228
 
6229
      function Conforming_Bounds (B1, B2 : Node_Id) return Boolean is
6230
      begin
6231
         if Is_Entity_Name (B1)
6232
           and then Is_Entity_Name (B2)
6233
           and then Ekind (Entity (B1)) = E_Discriminant
6234
         then
6235
            return Chars (B1) = Chars (B2);
6236
 
6237
         else
6238
            return Fully_Conformant_Expressions (B1, B2);
6239
         end if;
6240
      end Conforming_Bounds;
6241
 
6242
      -----------------------
6243
      -- Conforming_Ranges --
6244
      -----------------------
6245
 
6246
      function Conforming_Ranges (R1, R2 : Node_Id) return Boolean is
6247
      begin
6248
         return
6249
           Conforming_Bounds (Low_Bound (R1), Low_Bound (R2))
6250
             and then
6251
           Conforming_Bounds (High_Bound (R1), High_Bound (R2));
6252
      end Conforming_Ranges;
6253
 
6254
   --  Start of processing for Fully_Conformant_Discrete_Subtypes
6255
 
6256
   begin
6257
      if Nkind (S1) /= Nkind (S2) then
6258
         return False;
6259
 
6260
      elsif Is_Entity_Name (S1) then
6261
         return Entity (S1) = Entity (S2);
6262
 
6263
      elsif Nkind (S1) = N_Range then
6264
         return Conforming_Ranges (S1, S2);
6265
 
6266
      elsif Nkind (S1) = N_Subtype_Indication then
6267
         return
6268
            Entity (Subtype_Mark (S1)) = Entity (Subtype_Mark (S2))
6269
              and then
6270
            Conforming_Ranges
6271
              (Range_Expression (Constraint (S1)),
6272
               Range_Expression (Constraint (S2)));
6273
      else
6274
         return True;
6275
      end if;
6276
   end Fully_Conformant_Discrete_Subtypes;
6277
 
6278
   --------------------
6279
   -- Install_Entity --
6280
   --------------------
6281
 
6282
   procedure Install_Entity (E : Entity_Id) is
6283
      Prev : constant Entity_Id := Current_Entity (E);
6284
   begin
6285
      Set_Is_Immediately_Visible (E);
6286
      Set_Current_Entity (E);
6287
      Set_Homonym (E, Prev);
6288
   end Install_Entity;
6289
 
6290
   ---------------------
6291
   -- Install_Formals --
6292
   ---------------------
6293
 
6294
   procedure Install_Formals (Id : Entity_Id) is
6295
      F : Entity_Id;
6296
   begin
6297
      F := First_Formal (Id);
6298
      while Present (F) loop
6299
         Install_Entity (F);
6300
         Next_Formal (F);
6301
      end loop;
6302
   end Install_Formals;
6303
 
6304
   -----------------------------
6305
   -- Is_Interface_Conformant --
6306
   -----------------------------
6307
 
6308
   function Is_Interface_Conformant
6309
     (Tagged_Type : Entity_Id;
6310
      Iface_Prim  : Entity_Id;
6311
      Prim        : Entity_Id) return Boolean
6312
   is
6313
      Iface : constant Entity_Id := Find_Dispatching_Type (Iface_Prim);
6314
      Typ   : constant Entity_Id := Find_Dispatching_Type (Prim);
6315
 
6316
   begin
6317
      pragma Assert (Is_Subprogram (Iface_Prim)
6318
        and then Is_Subprogram (Prim)
6319
        and then Is_Dispatching_Operation (Iface_Prim)
6320
        and then Is_Dispatching_Operation (Prim));
6321
 
6322
      pragma Assert (Is_Interface (Iface)
6323
        or else (Present (Alias (Iface_Prim))
6324
                   and then
6325
                     Is_Interface
6326
                       (Find_Dispatching_Type (Ultimate_Alias (Iface_Prim)))));
6327
 
6328
      if Prim = Iface_Prim
6329
        or else not Is_Subprogram (Prim)
6330
        or else Ekind (Prim) /= Ekind (Iface_Prim)
6331
        or else not Is_Dispatching_Operation (Prim)
6332
        or else Scope (Prim) /= Scope (Tagged_Type)
6333
        or else No (Typ)
6334
        or else Base_Type (Typ) /= Tagged_Type
6335
        or else not Primitive_Names_Match (Iface_Prim, Prim)
6336
      then
6337
         return False;
6338
 
6339
      --  Case of a procedure, or a function that does not have a controlling
6340
      --  result (I or access I).
6341
 
6342
      elsif Ekind (Iface_Prim) = E_Procedure
6343
        or else Etype (Prim) = Etype (Iface_Prim)
6344
        or else not Has_Controlling_Result (Prim)
6345
      then
6346
         return Type_Conformant (Prim, Iface_Prim,
6347
                  Skip_Controlling_Formals => True);
6348
 
6349
      --  Case of a function returning an interface, or an access to one.
6350
      --  Check that the return types correspond.
6351
 
6352
      elsif Implements_Interface (Typ, Iface) then
6353
         if (Ekind (Etype (Prim)) = E_Anonymous_Access_Type)
6354
              /=
6355
            (Ekind (Etype (Iface_Prim)) = E_Anonymous_Access_Type)
6356
         then
6357
            return False;
6358
         else
6359
            return
6360
              Type_Conformant (Prim, Iface_Prim,
6361
                Skip_Controlling_Formals => True);
6362
         end if;
6363
 
6364
      else
6365
         return False;
6366
      end if;
6367
   end Is_Interface_Conformant;
6368
 
6369
   ---------------------------------
6370
   -- Is_Non_Overriding_Operation --
6371
   ---------------------------------
6372
 
6373
   function Is_Non_Overriding_Operation
6374
     (Prev_E : Entity_Id;
6375
      New_E  : Entity_Id) return Boolean
6376
   is
6377
      Formal : Entity_Id;
6378
      F_Typ  : Entity_Id;
6379
      G_Typ  : Entity_Id := Empty;
6380
 
6381
      function Get_Generic_Parent_Type (F_Typ : Entity_Id) return Entity_Id;
6382
      --  If F_Type is a derived type associated with a generic actual subtype,
6383
      --  then return its Generic_Parent_Type attribute, else return Empty.
6384
 
6385
      function Types_Correspond
6386
        (P_Type : Entity_Id;
6387
         N_Type : Entity_Id) return Boolean;
6388
      --  Returns true if and only if the types (or designated types in the
6389
      --  case of anonymous access types) are the same or N_Type is derived
6390
      --  directly or indirectly from P_Type.
6391
 
6392
      -----------------------------
6393
      -- Get_Generic_Parent_Type --
6394
      -----------------------------
6395
 
6396
      function Get_Generic_Parent_Type (F_Typ : Entity_Id) return Entity_Id is
6397
         G_Typ : Entity_Id;
6398
         Indic : Node_Id;
6399
 
6400
      begin
6401
         if Is_Derived_Type (F_Typ)
6402
           and then Nkind (Parent (F_Typ)) = N_Full_Type_Declaration
6403
         then
6404
            --  The tree must be traversed to determine the parent subtype in
6405
            --  the generic unit, which unfortunately isn't always available
6406
            --  via semantic attributes. ??? (Note: The use of Original_Node
6407
            --  is needed for cases where a full derived type has been
6408
            --  rewritten.)
6409
 
6410
            Indic := Subtype_Indication
6411
                       (Type_Definition (Original_Node (Parent (F_Typ))));
6412
 
6413
            if Nkind (Indic) = N_Subtype_Indication then
6414
               G_Typ := Entity (Subtype_Mark (Indic));
6415
            else
6416
               G_Typ := Entity (Indic);
6417
            end if;
6418
 
6419
            if Nkind (Parent (G_Typ)) = N_Subtype_Declaration
6420
              and then Present (Generic_Parent_Type (Parent (G_Typ)))
6421
            then
6422
               return Generic_Parent_Type (Parent (G_Typ));
6423
            end if;
6424
         end if;
6425
 
6426
         return Empty;
6427
      end Get_Generic_Parent_Type;
6428
 
6429
      ----------------------
6430
      -- Types_Correspond --
6431
      ----------------------
6432
 
6433
      function Types_Correspond
6434
        (P_Type : Entity_Id;
6435
         N_Type : Entity_Id) return Boolean
6436
      is
6437
         Prev_Type : Entity_Id := Base_Type (P_Type);
6438
         New_Type  : Entity_Id := Base_Type (N_Type);
6439
 
6440
      begin
6441
         if Ekind (Prev_Type) = E_Anonymous_Access_Type then
6442
            Prev_Type := Designated_Type (Prev_Type);
6443
         end if;
6444
 
6445
         if Ekind (New_Type) = E_Anonymous_Access_Type then
6446
            New_Type := Designated_Type (New_Type);
6447
         end if;
6448
 
6449
         if Prev_Type = New_Type then
6450
            return True;
6451
 
6452
         elsif not Is_Class_Wide_Type (New_Type) then
6453
            while Etype (New_Type) /= New_Type loop
6454
               New_Type := Etype (New_Type);
6455
               if New_Type = Prev_Type then
6456
                  return True;
6457
               end if;
6458
            end loop;
6459
         end if;
6460
         return False;
6461
      end Types_Correspond;
6462
 
6463
   --  Start of processing for Is_Non_Overriding_Operation
6464
 
6465
   begin
6466
      --  In the case where both operations are implicit derived subprograms
6467
      --  then neither overrides the other. This can only occur in certain
6468
      --  obscure cases (e.g., derivation from homographs created in a generic
6469
      --  instantiation).
6470
 
6471
      if Present (Alias (Prev_E)) and then Present (Alias (New_E)) then
6472
         return True;
6473
 
6474
      elsif Ekind (Current_Scope) = E_Package
6475
        and then Is_Generic_Instance (Current_Scope)
6476
        and then In_Private_Part (Current_Scope)
6477
        and then Comes_From_Source (New_E)
6478
      then
6479
         --  We examine the formals and result subtype of the inherited
6480
         --  operation, to determine whether their type is derived from (the
6481
         --  instance of) a generic type.
6482
 
6483
         Formal := First_Formal (Prev_E);
6484
 
6485
         while Present (Formal) loop
6486
            F_Typ := Base_Type (Etype (Formal));
6487
 
6488
            if Ekind (F_Typ) = E_Anonymous_Access_Type then
6489
               F_Typ := Designated_Type (F_Typ);
6490
            end if;
6491
 
6492
            G_Typ := Get_Generic_Parent_Type (F_Typ);
6493
 
6494
            Next_Formal (Formal);
6495
         end loop;
6496
 
6497
         if No (G_Typ) and then Ekind (Prev_E) = E_Function then
6498
            G_Typ := Get_Generic_Parent_Type (Base_Type (Etype (Prev_E)));
6499
         end if;
6500
 
6501
         if No (G_Typ) then
6502
            return False;
6503
         end if;
6504
 
6505
         --  If the generic type is a private type, then the original operation
6506
         --  was not overriding in the generic, because there was no primitive
6507
         --  operation to override.
6508
 
6509
         if Nkind (Parent (G_Typ)) = N_Formal_Type_Declaration
6510
           and then Nkind (Formal_Type_Definition (Parent (G_Typ))) =
6511
                      N_Formal_Private_Type_Definition
6512
         then
6513
            return True;
6514
 
6515
         --  The generic parent type is the ancestor of a formal derived
6516
         --  type declaration. We need to check whether it has a primitive
6517
         --  operation that should be overridden by New_E in the generic.
6518
 
6519
         else
6520
            declare
6521
               P_Formal : Entity_Id;
6522
               N_Formal : Entity_Id;
6523
               P_Typ    : Entity_Id;
6524
               N_Typ    : Entity_Id;
6525
               P_Prim   : Entity_Id;
6526
               Prim_Elt : Elmt_Id := First_Elmt (Primitive_Operations (G_Typ));
6527
 
6528
            begin
6529
               while Present (Prim_Elt) loop
6530
                  P_Prim := Node (Prim_Elt);
6531
 
6532
                  if Chars (P_Prim) = Chars (New_E)
6533
                    and then Ekind (P_Prim) = Ekind (New_E)
6534
                  then
6535
                     P_Formal := First_Formal (P_Prim);
6536
                     N_Formal := First_Formal (New_E);
6537
                     while Present (P_Formal) and then Present (N_Formal) loop
6538
                        P_Typ := Etype (P_Formal);
6539
                        N_Typ := Etype (N_Formal);
6540
 
6541
                        if not Types_Correspond (P_Typ, N_Typ) then
6542
                           exit;
6543
                        end if;
6544
 
6545
                        Next_Entity (P_Formal);
6546
                        Next_Entity (N_Formal);
6547
                     end loop;
6548
 
6549
                     --  Found a matching primitive operation belonging to the
6550
                     --  formal ancestor type, so the new subprogram is
6551
                     --  overriding.
6552
 
6553
                     if No (P_Formal)
6554
                       and then No (N_Formal)
6555
                       and then (Ekind (New_E) /= E_Function
6556
                                  or else
6557
                                 Types_Correspond
6558
                                   (Etype (P_Prim), Etype (New_E)))
6559
                     then
6560
                        return False;
6561
                     end if;
6562
                  end if;
6563
 
6564
                  Next_Elmt (Prim_Elt);
6565
               end loop;
6566
 
6567
               --  If no match found, then the new subprogram does not
6568
               --  override in the generic (nor in the instance).
6569
 
6570
               return True;
6571
            end;
6572
         end if;
6573
      else
6574
         return False;
6575
      end if;
6576
   end Is_Non_Overriding_Operation;
6577
 
6578
   ------------------------------
6579
   -- Make_Inequality_Operator --
6580
   ------------------------------
6581
 
6582
   --  S is the defining identifier of an equality operator. We build a
6583
   --  subprogram declaration with the right signature. This operation is
6584
   --  intrinsic, because it is always expanded as the negation of the
6585
   --  call to the equality function.
6586
 
6587
   procedure Make_Inequality_Operator (S : Entity_Id) is
6588
      Loc     : constant Source_Ptr := Sloc (S);
6589
      Decl    : Node_Id;
6590
      Formals : List_Id;
6591
      Op_Name : Entity_Id;
6592
 
6593
      FF : constant Entity_Id := First_Formal (S);
6594
      NF : constant Entity_Id := Next_Formal (FF);
6595
 
6596
   begin
6597
      --  Check that equality was properly defined, ignore call if not
6598
 
6599
      if No (NF) then
6600
         return;
6601
      end if;
6602
 
6603
      declare
6604
         A : constant Entity_Id :=
6605
               Make_Defining_Identifier (Sloc (FF),
6606
                 Chars => Chars (FF));
6607
 
6608
         B : constant Entity_Id :=
6609
               Make_Defining_Identifier (Sloc (NF),
6610
                 Chars => Chars (NF));
6611
 
6612
      begin
6613
         Op_Name := Make_Defining_Operator_Symbol (Loc, Name_Op_Ne);
6614
 
6615
         Formals := New_List (
6616
           Make_Parameter_Specification (Loc,
6617
             Defining_Identifier => A,
6618
             Parameter_Type      =>
6619
               New_Reference_To (Etype (First_Formal (S)),
6620
                 Sloc (Etype (First_Formal (S))))),
6621
 
6622
           Make_Parameter_Specification (Loc,
6623
             Defining_Identifier => B,
6624
             Parameter_Type      =>
6625
               New_Reference_To (Etype (Next_Formal (First_Formal (S))),
6626
                 Sloc (Etype (Next_Formal (First_Formal (S)))))));
6627
 
6628
         Decl :=
6629
           Make_Subprogram_Declaration (Loc,
6630
             Specification =>
6631
               Make_Function_Specification (Loc,
6632
                 Defining_Unit_Name       => Op_Name,
6633
                 Parameter_Specifications => Formals,
6634
                 Result_Definition        =>
6635
                   New_Reference_To (Standard_Boolean, Loc)));
6636
 
6637
         --  Insert inequality right after equality if it is explicit or after
6638
         --  the derived type when implicit. These entities are created only
6639
         --  for visibility purposes, and eventually replaced in the course of
6640
         --  expansion, so they do not need to be attached to the tree and seen
6641
         --  by the back-end. Keeping them internal also avoids spurious
6642
         --  freezing problems. The declaration is inserted in the tree for
6643
         --  analysis, and removed afterwards. If the equality operator comes
6644
         --  from an explicit declaration, attach the inequality immediately
6645
         --  after. Else the equality is inherited from a derived type
6646
         --  declaration, so insert inequality after that declaration.
6647
 
6648
         if No (Alias (S)) then
6649
            Insert_After (Unit_Declaration_Node (S), Decl);
6650
         elsif Is_List_Member (Parent (S)) then
6651
            Insert_After (Parent (S), Decl);
6652
         else
6653
            Insert_After (Parent (Etype (First_Formal (S))), Decl);
6654
         end if;
6655
 
6656
         Mark_Rewrite_Insertion (Decl);
6657
         Set_Is_Intrinsic_Subprogram (Op_Name);
6658
         Analyze (Decl);
6659
         Remove (Decl);
6660
         Set_Has_Completion (Op_Name);
6661
         Set_Corresponding_Equality (Op_Name, S);
6662
         Set_Is_Abstract_Subprogram (Op_Name, Is_Abstract_Subprogram (S));
6663
      end;
6664
   end Make_Inequality_Operator;
6665
 
6666
   ----------------------
6667
   -- May_Need_Actuals --
6668
   ----------------------
6669
 
6670
   procedure May_Need_Actuals (Fun : Entity_Id) is
6671
      F : Entity_Id;
6672
      B : Boolean;
6673
 
6674
   begin
6675
      F := First_Formal (Fun);
6676
      B := True;
6677
      while Present (F) loop
6678
         if No (Default_Value (F)) then
6679
            B := False;
6680
            exit;
6681
         end if;
6682
 
6683
         Next_Formal (F);
6684
      end loop;
6685
 
6686
      Set_Needs_No_Actuals (Fun, B);
6687
   end May_Need_Actuals;
6688
 
6689
   ---------------------
6690
   -- Mode_Conformant --
6691
   ---------------------
6692
 
6693
   function Mode_Conformant (New_Id, Old_Id : Entity_Id) return Boolean is
6694
      Result : Boolean;
6695
   begin
6696
      Check_Conformance (New_Id, Old_Id, Mode_Conformant, False, Result);
6697
      return Result;
6698
   end Mode_Conformant;
6699
 
6700
   ---------------------------
6701
   -- New_Overloaded_Entity --
6702
   ---------------------------
6703
 
6704
   procedure New_Overloaded_Entity
6705
     (S            : Entity_Id;
6706
      Derived_Type : Entity_Id := Empty)
6707
   is
6708
      Overridden_Subp : Entity_Id := Empty;
6709
      --  Set if the current scope has an operation that is type-conformant
6710
      --  with S, and becomes hidden by S.
6711
 
6712
      Is_Primitive_Subp : Boolean;
6713
      --  Set to True if the new subprogram is primitive
6714
 
6715
      E : Entity_Id;
6716
      --  Entity that S overrides
6717
 
6718
      Prev_Vis : Entity_Id := Empty;
6719
      --  Predecessor of E in Homonym chain
6720
 
6721
      procedure Check_For_Primitive_Subprogram
6722
        (Is_Primitive  : out Boolean;
6723
         Is_Overriding : Boolean := False);
6724
      --  If the subprogram being analyzed is a primitive operation of the type
6725
      --  of a formal or result, set the Has_Primitive_Operations flag on the
6726
      --  type, and set Is_Primitive to True (otherwise set to False). Set the
6727
      --  corresponding flag on the entity itself for later use.
6728
 
6729
      procedure Check_Synchronized_Overriding
6730
        (Def_Id          : Entity_Id;
6731
         Overridden_Subp : out Entity_Id);
6732
      --  First determine if Def_Id is an entry or a subprogram either defined
6733
      --  in the scope of a task or protected type, or is a primitive of such
6734
      --  a type. Check whether Def_Id overrides a subprogram of an interface
6735
      --  implemented by the synchronized type, return the overridden entity
6736
      --  or Empty.
6737
 
6738
      function Is_Private_Declaration (E : Entity_Id) return Boolean;
6739
      --  Check that E is declared in the private part of the current package,
6740
      --  or in the package body, where it may hide a previous declaration.
6741
      --  We can't use In_Private_Part by itself because this flag is also
6742
      --  set when freezing entities, so we must examine the place of the
6743
      --  declaration in the tree, and recognize wrapper packages as well.
6744
 
6745
      function Is_Overriding_Alias
6746
        (Old_E : Entity_Id;
6747
         New_E : Entity_Id) return Boolean;
6748
      --  Check whether new subprogram and old subprogram are both inherited
6749
      --  from subprograms that have distinct dispatch table entries. This can
6750
      --  occur with derivations from instances with accidental homonyms.
6751
      --  The function is conservative given that the converse is only true
6752
      --  within instances that contain accidental overloadings.
6753
 
6754
      ------------------------------------
6755
      -- Check_For_Primitive_Subprogram --
6756
      ------------------------------------
6757
 
6758
      procedure Check_For_Primitive_Subprogram
6759
        (Is_Primitive  : out Boolean;
6760
         Is_Overriding : Boolean := False)
6761
      is
6762
         Formal : Entity_Id;
6763
         F_Typ  : Entity_Id;
6764
         B_Typ  : Entity_Id;
6765
 
6766
         function Visible_Part_Type (T : Entity_Id) return Boolean;
6767
         --  Returns true if T is declared in the visible part of the current
6768
         --  package scope; otherwise returns false. Assumes that T is declared
6769
         --  in a package.
6770
 
6771
         procedure Check_Private_Overriding (T : Entity_Id);
6772
         --  Checks that if a primitive abstract subprogram of a visible
6773
         --  abstract type is declared in a private part, then it must override
6774
         --  an abstract subprogram declared in the visible part. Also checks
6775
         --  that if a primitive function with a controlling result is declared
6776
         --  in a private part, then it must override a function declared in
6777
         --  the visible part.
6778
 
6779
         ------------------------------
6780
         -- Check_Private_Overriding --
6781
         ------------------------------
6782
 
6783
         procedure Check_Private_Overriding (T : Entity_Id) is
6784
         begin
6785
            if Is_Package_Or_Generic_Package (Current_Scope)
6786
              and then In_Private_Part (Current_Scope)
6787
              and then Visible_Part_Type (T)
6788
              and then not In_Instance
6789
            then
6790
               if Is_Abstract_Type (T)
6791
                 and then Is_Abstract_Subprogram (S)
6792
                 and then (not Is_Overriding
6793
                            or else not Is_Abstract_Subprogram (E))
6794
               then
6795
                  Error_Msg_N ("abstract subprograms must be visible "
6796
                                   & "(RM 3.9.3(10))!", S);
6797
 
6798
               elsif Ekind (S) = E_Function
6799
                 and then Is_Tagged_Type (T)
6800
                 and then T = Base_Type (Etype (S))
6801
                 and then not Is_Overriding
6802
               then
6803
                  Error_Msg_N
6804
                    ("private function with tagged result must"
6805
                     & " override visible-part function", S);
6806
                  Error_Msg_N
6807
                    ("\move subprogram to the visible part"
6808
                     & " (RM 3.9.3(10))", S);
6809
               end if;
6810
            end if;
6811
         end Check_Private_Overriding;
6812
 
6813
         -----------------------
6814
         -- Visible_Part_Type --
6815
         -----------------------
6816
 
6817
         function Visible_Part_Type (T : Entity_Id) return Boolean is
6818
            P : constant Node_Id := Unit_Declaration_Node (Scope (T));
6819
            N : Node_Id;
6820
 
6821
         begin
6822
            --  If the entity is a private type, then it must be declared in a
6823
            --  visible part.
6824
 
6825
            if Ekind (T) in Private_Kind then
6826
               return True;
6827
            end if;
6828
 
6829
            --  Otherwise, we traverse the visible part looking for its
6830
            --  corresponding declaration. We cannot use the declaration
6831
            --  node directly because in the private part the entity of a
6832
            --  private type is the one in the full view, which does not
6833
            --  indicate that it is the completion of something visible.
6834
 
6835
            N := First (Visible_Declarations (Specification (P)));
6836
            while Present (N) loop
6837
               if Nkind (N) = N_Full_Type_Declaration
6838
                 and then Present (Defining_Identifier (N))
6839
                 and then T = Defining_Identifier (N)
6840
               then
6841
                  return True;
6842
 
6843
               elsif Nkind_In (N, N_Private_Type_Declaration,
6844
                                  N_Private_Extension_Declaration)
6845
                 and then Present (Defining_Identifier (N))
6846
                 and then T = Full_View (Defining_Identifier (N))
6847
               then
6848
                  return True;
6849
               end if;
6850
 
6851
               Next (N);
6852
            end loop;
6853
 
6854
            return False;
6855
         end Visible_Part_Type;
6856
 
6857
      --  Start of processing for Check_For_Primitive_Subprogram
6858
 
6859
      begin
6860
         Is_Primitive := False;
6861
 
6862
         if not Comes_From_Source (S) then
6863
            null;
6864
 
6865
         --  If subprogram is at library level, it is not primitive operation
6866
 
6867
         elsif Current_Scope = Standard_Standard then
6868
            null;
6869
 
6870
         elsif (Is_Package_Or_Generic_Package (Current_Scope)
6871
                 and then not In_Package_Body (Current_Scope))
6872
           or else Is_Overriding
6873
         then
6874
            --  For function, check return type
6875
 
6876
            if Ekind (S) = E_Function then
6877
               if Ekind (Etype (S)) = E_Anonymous_Access_Type then
6878
                  F_Typ := Designated_Type (Etype (S));
6879
               else
6880
                  F_Typ := Etype (S);
6881
               end if;
6882
 
6883
               B_Typ := Base_Type (F_Typ);
6884
 
6885
               if Scope (B_Typ) = Current_Scope
6886
                 and then not Is_Class_Wide_Type (B_Typ)
6887
                 and then not Is_Generic_Type (B_Typ)
6888
               then
6889
                  Is_Primitive := True;
6890
                  Set_Has_Primitive_Operations (B_Typ);
6891
                  Set_Is_Primitive (S);
6892
                  Check_Private_Overriding (B_Typ);
6893
               end if;
6894
            end if;
6895
 
6896
            --  For all subprograms, check formals
6897
 
6898
            Formal := First_Formal (S);
6899
            while Present (Formal) loop
6900
               if Ekind (Etype (Formal)) = E_Anonymous_Access_Type then
6901
                  F_Typ := Designated_Type (Etype (Formal));
6902
               else
6903
                  F_Typ := Etype (Formal);
6904
               end if;
6905
 
6906
               B_Typ := Base_Type (F_Typ);
6907
 
6908
               if Ekind (B_Typ) = E_Access_Subtype then
6909
                  B_Typ := Base_Type (B_Typ);
6910
               end if;
6911
 
6912
               if Scope (B_Typ) = Current_Scope
6913
                 and then not Is_Class_Wide_Type (B_Typ)
6914
                 and then not Is_Generic_Type (B_Typ)
6915
               then
6916
                  Is_Primitive := True;
6917
                  Set_Is_Primitive (S);
6918
                  Set_Has_Primitive_Operations (B_Typ);
6919
                  Check_Private_Overriding (B_Typ);
6920
               end if;
6921
 
6922
               Next_Formal (Formal);
6923
            end loop;
6924
         end if;
6925
      end Check_For_Primitive_Subprogram;
6926
 
6927
      -----------------------------------
6928
      -- Check_Synchronized_Overriding --
6929
      -----------------------------------
6930
 
6931
      procedure Check_Synchronized_Overriding
6932
        (Def_Id          : Entity_Id;
6933
         Overridden_Subp : out Entity_Id)
6934
      is
6935
         Ifaces_List : Elist_Id;
6936
         In_Scope    : Boolean;
6937
         Typ         : Entity_Id;
6938
 
6939
         function Matches_Prefixed_View_Profile
6940
           (Prim_Params  : List_Id;
6941
            Iface_Params : List_Id) return Boolean;
6942
         --  Determine whether a subprogram's parameter profile Prim_Params
6943
         --  matches that of a potentially overridden interface subprogram
6944
         --  Iface_Params. Also determine if the type of first parameter of
6945
         --  Iface_Params is an implemented interface.
6946
 
6947
         -----------------------------------
6948
         -- Matches_Prefixed_View_Profile --
6949
         -----------------------------------
6950
 
6951
         function Matches_Prefixed_View_Profile
6952
           (Prim_Params  : List_Id;
6953
            Iface_Params : List_Id) return Boolean
6954
         is
6955
            Iface_Id     : Entity_Id;
6956
            Iface_Param  : Node_Id;
6957
            Iface_Typ    : Entity_Id;
6958
            Prim_Id      : Entity_Id;
6959
            Prim_Param   : Node_Id;
6960
            Prim_Typ     : Entity_Id;
6961
 
6962
            function Is_Implemented
6963
              (Ifaces_List : Elist_Id;
6964
               Iface       : Entity_Id) return Boolean;
6965
            --  Determine if Iface is implemented by the current task or
6966
            --  protected type.
6967
 
6968
            --------------------
6969
            -- Is_Implemented --
6970
            --------------------
6971
 
6972
            function Is_Implemented
6973
              (Ifaces_List : Elist_Id;
6974
               Iface       : Entity_Id) return Boolean
6975
            is
6976
               Iface_Elmt : Elmt_Id;
6977
 
6978
            begin
6979
               Iface_Elmt := First_Elmt (Ifaces_List);
6980
               while Present (Iface_Elmt) loop
6981
                  if Node (Iface_Elmt) = Iface then
6982
                     return True;
6983
                  end if;
6984
 
6985
                  Next_Elmt (Iface_Elmt);
6986
               end loop;
6987
 
6988
               return False;
6989
            end Is_Implemented;
6990
 
6991
         --  Start of processing for Matches_Prefixed_View_Profile
6992
 
6993
         begin
6994
            Iface_Param := First (Iface_Params);
6995
            Iface_Typ   := Etype (Defining_Identifier (Iface_Param));
6996
 
6997
            if Is_Access_Type (Iface_Typ) then
6998
               Iface_Typ := Designated_Type (Iface_Typ);
6999
            end if;
7000
 
7001
            Prim_Param := First (Prim_Params);
7002
 
7003
            --  The first parameter of the potentially overridden subprogram
7004
            --  must be an interface implemented by Prim.
7005
 
7006
            if not Is_Interface (Iface_Typ)
7007
              or else not Is_Implemented (Ifaces_List, Iface_Typ)
7008
            then
7009
               return False;
7010
            end if;
7011
 
7012
            --  The checks on the object parameters are done, move onto the
7013
            --  rest of the parameters.
7014
 
7015
            if not In_Scope then
7016
               Prim_Param := Next (Prim_Param);
7017
            end if;
7018
 
7019
            Iface_Param := Next (Iface_Param);
7020
            while Present (Iface_Param) and then Present (Prim_Param) loop
7021
               Iface_Id  := Defining_Identifier (Iface_Param);
7022
               Iface_Typ := Find_Parameter_Type (Iface_Param);
7023
 
7024
               Prim_Id  := Defining_Identifier (Prim_Param);
7025
               Prim_Typ := Find_Parameter_Type (Prim_Param);
7026
 
7027
               if Ekind (Iface_Typ) = E_Anonymous_Access_Type
7028
                 and then Ekind (Prim_Typ) = E_Anonymous_Access_Type
7029
                 and then Is_Concurrent_Type (Designated_Type (Prim_Typ))
7030
               then
7031
                  Iface_Typ := Designated_Type (Iface_Typ);
7032
                  Prim_Typ := Designated_Type (Prim_Typ);
7033
               end if;
7034
 
7035
               --  Case of multiple interface types inside a parameter profile
7036
 
7037
               --     (Obj_Param : in out Iface; ...; Param : Iface)
7038
 
7039
               --  If the interface type is implemented, then the matching type
7040
               --  in the primitive should be the implementing record type.
7041
 
7042
               if Ekind (Iface_Typ) = E_Record_Type
7043
                 and then Is_Interface (Iface_Typ)
7044
                 and then Is_Implemented (Ifaces_List, Iface_Typ)
7045
               then
7046
                  if Prim_Typ /= Typ then
7047
                     return False;
7048
                  end if;
7049
 
7050
               --  The two parameters must be both mode and subtype conformant
7051
 
7052
               elsif Ekind (Iface_Id) /= Ekind (Prim_Id)
7053
                 or else not
7054
                   Conforming_Types (Iface_Typ, Prim_Typ, Subtype_Conformant)
7055
               then
7056
                  return False;
7057
               end if;
7058
 
7059
               Next (Iface_Param);
7060
               Next (Prim_Param);
7061
            end loop;
7062
 
7063
            --  One of the two lists contains more parameters than the other
7064
 
7065
            if Present (Iface_Param) or else Present (Prim_Param) then
7066
               return False;
7067
            end if;
7068
 
7069
            return True;
7070
         end Matches_Prefixed_View_Profile;
7071
 
7072
      --  Start of processing for Check_Synchronized_Overriding
7073
 
7074
      begin
7075
         Overridden_Subp := Empty;
7076
 
7077
         --  Def_Id must be an entry or a subprogram. We should skip predefined
7078
         --  primitives internally generated by the frontend; however at this
7079
         --  stage predefined primitives are still not fully decorated. As a
7080
         --  minor optimization we skip here internally generated subprograms.
7081
 
7082
         if (Ekind (Def_Id) /= E_Entry
7083
              and then Ekind (Def_Id) /= E_Function
7084
              and then Ekind (Def_Id) /= E_Procedure)
7085
           or else not Comes_From_Source (Def_Id)
7086
         then
7087
            return;
7088
         end if;
7089
 
7090
         --  Search for the concurrent declaration since it contains the list
7091
         --  of all implemented interfaces. In this case, the subprogram is
7092
         --  declared within the scope of a protected or a task type.
7093
 
7094
         if Present (Scope (Def_Id))
7095
           and then Is_Concurrent_Type (Scope (Def_Id))
7096
           and then not Is_Generic_Actual_Type (Scope (Def_Id))
7097
         then
7098
            Typ := Scope (Def_Id);
7099
            In_Scope := True;
7100
 
7101
         --  The enclosing scope is not a synchronized type and the subprogram
7102
         --  has no formals
7103
 
7104
         elsif No (First_Formal (Def_Id)) then
7105
            return;
7106
 
7107
         --  The subprogram has formals and hence it may be a primitive of a
7108
         --  concurrent type
7109
 
7110
         else
7111
            Typ := Etype (First_Formal (Def_Id));
7112
 
7113
            if Is_Access_Type (Typ) then
7114
               Typ := Directly_Designated_Type (Typ);
7115
            end if;
7116
 
7117
            if Is_Concurrent_Type (Typ)
7118
              and then not Is_Generic_Actual_Type (Typ)
7119
            then
7120
               In_Scope := False;
7121
 
7122
            --  This case occurs when the concurrent type is declared within
7123
            --  a generic unit. As a result the corresponding record has been
7124
            --  built and used as the type of the first formal, we just have
7125
            --  to retrieve the corresponding concurrent type.
7126
 
7127
            elsif Is_Concurrent_Record_Type (Typ)
7128
              and then Present (Corresponding_Concurrent_Type (Typ))
7129
            then
7130
               Typ := Corresponding_Concurrent_Type (Typ);
7131
               In_Scope := False;
7132
 
7133
            else
7134
               return;
7135
            end if;
7136
         end if;
7137
 
7138
         --  There is no overriding to check if is an inherited operation in a
7139
         --  type derivation on for a generic actual.
7140
 
7141
         Collect_Interfaces (Typ, Ifaces_List);
7142
 
7143
         if Is_Empty_Elmt_List (Ifaces_List) then
7144
            return;
7145
         end if;
7146
 
7147
         --  Determine whether entry or subprogram Def_Id overrides a primitive
7148
         --  operation that belongs to one of the interfaces in Ifaces_List.
7149
 
7150
         declare
7151
            Candidate : Entity_Id := Empty;
7152
            Hom       : Entity_Id := Empty;
7153
            Iface_Typ : Entity_Id;
7154
            Subp      : Entity_Id := Empty;
7155
 
7156
         begin
7157
            --  Traverse the homonym chain, looking at a potentially
7158
            --  overridden subprogram that belongs to an implemented
7159
            --  interface.
7160
 
7161
            Hom := Current_Entity_In_Scope (Def_Id);
7162
            while Present (Hom) loop
7163
               Subp := Hom;
7164
 
7165
               if Subp = Def_Id
7166
                 or else not Is_Overloadable (Subp)
7167
                 or else not Is_Primitive (Subp)
7168
                 or else not Is_Dispatching_Operation (Subp)
7169
                 or else not Present (Find_Dispatching_Type (Subp))
7170
                 or else not Is_Interface (Find_Dispatching_Type (Subp))
7171
               then
7172
                  null;
7173
 
7174
               --  Entries and procedures can override abstract or null
7175
               --  interface procedures
7176
 
7177
               elsif (Ekind (Def_Id) = E_Procedure
7178
                        or else Ekind (Def_Id) = E_Entry)
7179
                 and then Ekind (Subp) = E_Procedure
7180
                 and then Matches_Prefixed_View_Profile
7181
                            (Parameter_Specifications (Parent (Def_Id)),
7182
                             Parameter_Specifications (Parent (Subp)))
7183
               then
7184
                  Candidate := Subp;
7185
 
7186
                  --  For an overridden subprogram Subp, check whether the mode
7187
                  --  of its first parameter is correct depending on the kind
7188
                  --  of synchronized type.
7189
 
7190
                  declare
7191
                     Formal : constant Node_Id := First_Formal (Candidate);
7192
 
7193
                  begin
7194
                     --  In order for an entry or a protected procedure to
7195
                     --  override, the first parameter of the overridden
7196
                     --  routine must be of mode "out", "in out" or
7197
                     --  access-to-variable.
7198
 
7199
                     if (Ekind (Candidate) = E_Entry
7200
                         or else Ekind (Candidate) = E_Procedure)
7201
                       and then Is_Protected_Type (Typ)
7202
                       and then Ekind (Formal) /= E_In_Out_Parameter
7203
                       and then Ekind (Formal) /= E_Out_Parameter
7204
                       and then Nkind (Parameter_Type (Parent (Formal)))
7205
                                  /= N_Access_Definition
7206
                     then
7207
                        null;
7208
 
7209
                     --  All other cases are OK since a task entry or routine
7210
                     --  does not have a restriction on the mode of the first
7211
                     --  parameter of the overridden interface routine.
7212
 
7213
                     else
7214
                        Overridden_Subp := Candidate;
7215
                        return;
7216
                     end if;
7217
                  end;
7218
 
7219
               --  Functions can override abstract interface functions
7220
 
7221
               elsif Ekind (Def_Id) = E_Function
7222
                 and then Ekind (Subp) = E_Function
7223
                 and then Matches_Prefixed_View_Profile
7224
                            (Parameter_Specifications (Parent (Def_Id)),
7225
                             Parameter_Specifications (Parent (Subp)))
7226
                 and then Etype (Result_Definition (Parent (Def_Id))) =
7227
                          Etype (Result_Definition (Parent (Subp)))
7228
               then
7229
                  Overridden_Subp := Subp;
7230
                  return;
7231
               end if;
7232
 
7233
               Hom := Homonym (Hom);
7234
            end loop;
7235
 
7236
            --  After examining all candidates for overriding, we are
7237
            --  left with the best match which is a mode incompatible
7238
            --  interface routine. Do not emit an error if the Expander
7239
            --  is active since this error will be detected later on
7240
            --  after all concurrent types are expanded and all wrappers
7241
            --  are built. This check is meant for spec-only
7242
            --  compilations.
7243
 
7244
            if Present (Candidate)
7245
              and then not Expander_Active
7246
            then
7247
               Iface_Typ :=
7248
                 Find_Parameter_Type (Parent (First_Formal (Candidate)));
7249
 
7250
               --  Def_Id is primitive of a protected type, declared
7251
               --  inside the type, and the candidate is primitive of a
7252
               --  limited or synchronized interface.
7253
 
7254
               if In_Scope
7255
                 and then Is_Protected_Type (Typ)
7256
                 and then
7257
                   (Is_Limited_Interface (Iface_Typ)
7258
                      or else Is_Protected_Interface (Iface_Typ)
7259
                      or else Is_Synchronized_Interface (Iface_Typ)
7260
                      or else Is_Task_Interface (Iface_Typ))
7261
               then
7262
                  --  Must reword this message, comma before to in -gnatj
7263
                  --  mode ???
7264
 
7265
                  Error_Msg_NE
7266
                    ("first formal of & must be of mode `OUT`, `IN OUT`"
7267
                      & " or access-to-variable", Typ, Candidate);
7268
                  Error_Msg_N
7269
                    ("\to be overridden by protected procedure or entry "
7270
                      & "(RM 9.4(11.9/2))", Typ);
7271
               end if;
7272
            end if;
7273
 
7274
            Overridden_Subp := Candidate;
7275
            return;
7276
         end;
7277
      end Check_Synchronized_Overriding;
7278
 
7279
      ----------------------------
7280
      -- Is_Private_Declaration --
7281
      ----------------------------
7282
 
7283
      function Is_Private_Declaration (E : Entity_Id) return Boolean is
7284
         Priv_Decls : List_Id;
7285
         Decl       : constant Node_Id := Unit_Declaration_Node (E);
7286
 
7287
      begin
7288
         if Is_Package_Or_Generic_Package (Current_Scope)
7289
           and then In_Private_Part (Current_Scope)
7290
         then
7291
            Priv_Decls :=
7292
              Private_Declarations (
7293
                Specification (Unit_Declaration_Node (Current_Scope)));
7294
 
7295
            return In_Package_Body (Current_Scope)
7296
              or else
7297
                (Is_List_Member (Decl)
7298
                   and then List_Containing (Decl) = Priv_Decls)
7299
              or else (Nkind (Parent (Decl)) = N_Package_Specification
7300
                         and then not
7301
                           Is_Compilation_Unit
7302
                             (Defining_Entity (Parent (Decl)))
7303
                         and then List_Containing (Parent (Parent (Decl)))
7304
                                    = Priv_Decls);
7305
         else
7306
            return False;
7307
         end if;
7308
      end Is_Private_Declaration;
7309
 
7310
      --------------------------
7311
      -- Is_Overriding_Alias --
7312
      --------------------------
7313
 
7314
      function Is_Overriding_Alias
7315
        (Old_E : Entity_Id;
7316
         New_E : Entity_Id) return Boolean
7317
      is
7318
         AO : constant Entity_Id := Alias (Old_E);
7319
         AN : constant Entity_Id := Alias (New_E);
7320
 
7321
      begin
7322
         return Scope (AO) /= Scope (AN)
7323
           or else No (DTC_Entity (AO))
7324
           or else No (DTC_Entity (AN))
7325
           or else DT_Position (AO) = DT_Position (AN);
7326
      end Is_Overriding_Alias;
7327
 
7328
   --  Start of processing for New_Overloaded_Entity
7329
 
7330
   begin
7331
      --  We need to look for an entity that S may override. This must be a
7332
      --  homonym in the current scope, so we look for the first homonym of
7333
      --  S in the current scope as the starting point for the search.
7334
 
7335
      E := Current_Entity_In_Scope (S);
7336
 
7337
      --  If there is no homonym then this is definitely not overriding
7338
 
7339
      if No (E) then
7340
         Enter_Overloaded_Entity (S);
7341
         Check_Dispatching_Operation (S, Empty);
7342
         Check_For_Primitive_Subprogram (Is_Primitive_Subp);
7343
 
7344
         --  If subprogram has an explicit declaration, check whether it
7345
         --  has an overriding indicator.
7346
 
7347
         if Comes_From_Source (S) then
7348
            Check_Synchronized_Overriding (S, Overridden_Subp);
7349
            Check_Overriding_Indicator
7350
              (S, Overridden_Subp, Is_Primitive => Is_Primitive_Subp);
7351
         end if;
7352
 
7353
      --  If there is a homonym that is not overloadable, then we have an
7354
      --  error, except for the special cases checked explicitly below.
7355
 
7356
      elsif not Is_Overloadable (E) then
7357
 
7358
         --  Check for spurious conflict produced by a subprogram that has the
7359
         --  same name as that of the enclosing generic package. The conflict
7360
         --  occurs within an instance, between the subprogram and the renaming
7361
         --  declaration for the package. After the subprogram, the package
7362
         --  renaming declaration becomes hidden.
7363
 
7364
         if Ekind (E) = E_Package
7365
           and then Present (Renamed_Object (E))
7366
           and then Renamed_Object (E) = Current_Scope
7367
           and then Nkind (Parent (Renamed_Object (E))) =
7368
                                                     N_Package_Specification
7369
           and then Present (Generic_Parent (Parent (Renamed_Object (E))))
7370
         then
7371
            Set_Is_Hidden (E);
7372
            Set_Is_Immediately_Visible (E, False);
7373
            Enter_Overloaded_Entity (S);
7374
            Set_Homonym (S, Homonym (E));
7375
            Check_Dispatching_Operation (S, Empty);
7376
            Check_Overriding_Indicator (S, Empty, Is_Primitive => False);
7377
 
7378
         --  If the subprogram is implicit it is hidden by the previous
7379
         --  declaration. However if it is dispatching, it must appear in the
7380
         --  dispatch table anyway, because it can be dispatched to even if it
7381
         --  cannot be called directly.
7382
 
7383
         elsif Present (Alias (S))
7384
           and then not Comes_From_Source (S)
7385
         then
7386
            Set_Scope (S, Current_Scope);
7387
 
7388
            if Is_Dispatching_Operation (Alias (S)) then
7389
               Check_Dispatching_Operation (S, Empty);
7390
            end if;
7391
 
7392
            return;
7393
 
7394
         else
7395
            Error_Msg_Sloc := Sloc (E);
7396
 
7397
            --  Generate message, with useful additional warning if in generic
7398
 
7399
            if Is_Generic_Unit (E) then
7400
               Error_Msg_N ("previous generic unit cannot be overloaded", S);
7401
               Error_Msg_N ("\& conflicts with declaration#", S);
7402
            else
7403
               Error_Msg_N ("& conflicts with declaration#", S);
7404
            end if;
7405
 
7406
            return;
7407
         end if;
7408
 
7409
      --  E exists and is overloadable
7410
 
7411
      else
7412
         --  Ada 2005 (AI-251): Derivation of abstract interface primitives
7413
         --  need no check against the homonym chain. They are directly added
7414
         --  to the list of primitive operations of Derived_Type.
7415
 
7416
         if Ada_Version >= Ada_05
7417
           and then Present (Derived_Type)
7418
           and then Is_Dispatching_Operation (Alias (S))
7419
           and then Present (Find_Dispatching_Type (Alias (S)))
7420
           and then Is_Interface (Find_Dispatching_Type (Alias (S)))
7421
         then
7422
            goto Add_New_Entity;
7423
         end if;
7424
 
7425
         Check_Synchronized_Overriding (S, Overridden_Subp);
7426
 
7427
         --  Loop through E and its homonyms to determine if any of them is
7428
         --  the candidate for overriding by S.
7429
 
7430
         while Present (E) loop
7431
 
7432
            --  Definitely not interesting if not in the current scope
7433
 
7434
            if Scope (E) /= Current_Scope then
7435
               null;
7436
 
7437
            --  Check if we have type conformance
7438
 
7439
            elsif Type_Conformant (E, S) then
7440
 
7441
               --  If the old and new entities have the same profile and one
7442
               --  is not the body of the other, then this is an error, unless
7443
               --  one of them is implicitly declared.
7444
 
7445
               --  There are some cases when both can be implicit, for example
7446
               --  when both a literal and a function that overrides it are
7447
               --  inherited in a derivation, or when an inherited operation
7448
               --  of a tagged full type overrides the inherited operation of
7449
               --  a private extension. Ada 83 had a special rule for the
7450
               --  literal case. In Ada95, the later implicit operation hides
7451
               --  the former, and the literal is always the former. In the
7452
               --  odd case where both are derived operations declared at the
7453
               --  same point, both operations should be declared, and in that
7454
               --  case we bypass the following test and proceed to the next
7455
               --  part. This can only occur for certain obscure cases in
7456
               --  instances, when an operation on a type derived from a formal
7457
               --  private type does not override a homograph inherited from
7458
               --  the actual. In subsequent derivations of such a type, the
7459
               --  DT positions of these operations remain distinct, if they
7460
               --  have been set.
7461
 
7462
               if Present (Alias (S))
7463
                 and then (No (Alias (E))
7464
                            or else Comes_From_Source (E)
7465
                            or else Is_Abstract_Subprogram (S)
7466
                            or else
7467
                              (Is_Dispatching_Operation (E)
7468
                                 and then Is_Overriding_Alias (E, S)))
7469
                 and then Ekind (E) /= E_Enumeration_Literal
7470
               then
7471
                  --  When an derived operation is overloaded it may be due to
7472
                  --  the fact that the full view of a private extension
7473
                  --  re-inherits. It has to be dealt with.
7474
 
7475
                  if Is_Package_Or_Generic_Package (Current_Scope)
7476
                    and then In_Private_Part (Current_Scope)
7477
                  then
7478
                     Check_Operation_From_Private_View (S, E);
7479
                  end if;
7480
 
7481
                  --  In any case the implicit operation remains hidden by
7482
                  --  the existing declaration, which is overriding.
7483
 
7484
                  Set_Is_Overriding_Operation (E);
7485
 
7486
                  if Comes_From_Source (E) then
7487
                     Check_Overriding_Indicator (E, S, Is_Primitive => False);
7488
 
7489
                     --  Indicate that E overrides the operation from which
7490
                     --  S is inherited.
7491
 
7492
                     if Present (Alias (S)) then
7493
                        Set_Overridden_Operation (E, Alias (S));
7494
                     else
7495
                        Set_Overridden_Operation (E, S);
7496
                     end if;
7497
                  end if;
7498
 
7499
                  return;
7500
 
7501
               --  Within an instance, the renaming declarations for actual
7502
               --  subprograms may become ambiguous, but they do not hide each
7503
               --  other.
7504
 
7505
               elsif Ekind (E) /= E_Entry
7506
                 and then not Comes_From_Source (E)
7507
                 and then not Is_Generic_Instance (E)
7508
                 and then (Present (Alias (E))
7509
                            or else Is_Intrinsic_Subprogram (E))
7510
                 and then (not In_Instance
7511
                            or else No (Parent (E))
7512
                            or else Nkind (Unit_Declaration_Node (E)) /=
7513
                                      N_Subprogram_Renaming_Declaration)
7514
               then
7515
                  --  A subprogram child unit is not allowed to override an
7516
                  --  inherited subprogram (10.1.1(20)).
7517
 
7518
                  if Is_Child_Unit (S) then
7519
                     Error_Msg_N
7520
                       ("child unit overrides inherited subprogram in parent",
7521
                        S);
7522
                     return;
7523
                  end if;
7524
 
7525
                  if Is_Non_Overriding_Operation (E, S) then
7526
                     Enter_Overloaded_Entity (S);
7527
 
7528
                     if No (Derived_Type)
7529
                       or else Is_Tagged_Type (Derived_Type)
7530
                     then
7531
                        Check_Dispatching_Operation (S, Empty);
7532
                     end if;
7533
 
7534
                     return;
7535
                  end if;
7536
 
7537
                  --  E is a derived operation or an internal operator which
7538
                  --  is being overridden. Remove E from further visibility.
7539
                  --  Furthermore, if E is a dispatching operation, it must be
7540
                  --  replaced in the list of primitive operations of its type
7541
                  --  (see Override_Dispatching_Operation).
7542
 
7543
                  Overridden_Subp := E;
7544
 
7545
                  declare
7546
                     Prev : Entity_Id;
7547
 
7548
                  begin
7549
                     Prev := First_Entity (Current_Scope);
7550
                     while Present (Prev)
7551
                       and then Next_Entity (Prev) /= E
7552
                     loop
7553
                        Next_Entity (Prev);
7554
                     end loop;
7555
 
7556
                     --  It is possible for E to be in the current scope and
7557
                     --  yet not in the entity chain. This can only occur in a
7558
                     --  generic context where E is an implicit concatenation
7559
                     --  in the formal part, because in a generic body the
7560
                     --  entity chain starts with the formals.
7561
 
7562
                     pragma Assert
7563
                       (Present (Prev) or else Chars (E) = Name_Op_Concat);
7564
 
7565
                     --  E must be removed both from the entity_list of the
7566
                     --  current scope, and from the visibility chain
7567
 
7568
                     if Debug_Flag_E then
7569
                        Write_Str ("Override implicit operation ");
7570
                        Write_Int (Int (E));
7571
                        Write_Eol;
7572
                     end if;
7573
 
7574
                     --  If E is a predefined concatenation, it stands for four
7575
                     --  different operations. As a result, a single explicit
7576
                     --  declaration does not hide it. In a possible ambiguous
7577
                     --  situation, Disambiguate chooses the user-defined op,
7578
                     --  so it is correct to retain the previous internal one.
7579
 
7580
                     if Chars (E) /= Name_Op_Concat
7581
                       or else Ekind (E) /= E_Operator
7582
                     then
7583
                        --  For nondispatching derived operations that are
7584
                        --  overridden by a subprogram declared in the private
7585
                        --  part of a package, we retain the derived subprogram
7586
                        --  but mark it as not immediately visible. If the
7587
                        --  derived operation was declared in the visible part
7588
                        --  then this ensures that it will still be visible
7589
                        --  outside the package with the proper signature
7590
                        --  (calls from outside must also be directed to this
7591
                        --  version rather than the overriding one, unlike the
7592
                        --  dispatching case). Calls from inside the package
7593
                        --  will still resolve to the overriding subprogram
7594
                        --  since the derived one is marked as not visible
7595
                        --  within the package.
7596
 
7597
                        --  If the private operation is dispatching, we achieve
7598
                        --  the overriding by keeping the implicit operation
7599
                        --  but setting its alias to be the overriding one. In
7600
                        --  this fashion the proper body is executed in all
7601
                        --  cases, but the original signature is used outside
7602
                        --  of the package.
7603
 
7604
                        --  If the overriding is not in the private part, we
7605
                        --  remove the implicit operation altogether.
7606
 
7607
                        if Is_Private_Declaration (S) then
7608
                           if not Is_Dispatching_Operation (E) then
7609
                              Set_Is_Immediately_Visible (E, False);
7610
                           else
7611
                              --  Work done in Override_Dispatching_Operation,
7612
                              --  so nothing else need to be done here.
7613
 
7614
                              null;
7615
                           end if;
7616
 
7617
                        else
7618
                           --  Find predecessor of E in Homonym chain
7619
 
7620
                           if E = Current_Entity (E) then
7621
                              Prev_Vis := Empty;
7622
                           else
7623
                              Prev_Vis := Current_Entity (E);
7624
                              while Homonym (Prev_Vis) /= E loop
7625
                                 Prev_Vis := Homonym (Prev_Vis);
7626
                              end loop;
7627
                           end if;
7628
 
7629
                           if Prev_Vis /= Empty then
7630
 
7631
                              --  Skip E in the visibility chain
7632
 
7633
                              Set_Homonym (Prev_Vis, Homonym (E));
7634
 
7635
                           else
7636
                              Set_Name_Entity_Id (Chars (E), Homonym (E));
7637
                           end if;
7638
 
7639
                           Set_Next_Entity (Prev, Next_Entity (E));
7640
 
7641
                           if No (Next_Entity (Prev)) then
7642
                              Set_Last_Entity (Current_Scope, Prev);
7643
                           end if;
7644
 
7645
                        end if;
7646
                     end if;
7647
 
7648
                     Enter_Overloaded_Entity (S);
7649
                     Set_Is_Overriding_Operation (S);
7650
                     Check_Overriding_Indicator (S, E, Is_Primitive => True);
7651
 
7652
                     --  If S is a user-defined subprogram or a null procedure
7653
                     --  expanded to override an inherited null procedure, then
7654
                     --  indicate that E overrides the operation from which S
7655
                     --  is inherited. It seems odd that Overridden_Operation
7656
                     --  isn't set in all cases where Is_Overriding_Operation
7657
                     --  is true, but doing so causes infinite loops in the
7658
                     --  compiler for implicit overriding subprograms. ???
7659
 
7660
                     if Comes_From_Source (S)
7661
                       or else
7662
                         (Present (Parent (S))
7663
                           and then
7664
                             Nkind (Parent (S)) = N_Procedure_Specification
7665
                           and then
7666
                             Null_Present (Parent (S)))
7667
                     then
7668
                        if Present (Alias (E)) then
7669
                           Set_Overridden_Operation (S, Alias (E));
7670
                        else
7671
                           Set_Overridden_Operation (S, E);
7672
                        end if;
7673
                     end if;
7674
 
7675
                     if Is_Dispatching_Operation (E) then
7676
 
7677
                        --  An overriding dispatching subprogram inherits the
7678
                        --  convention of the overridden subprogram (by
7679
                        --  AI-117).
7680
 
7681
                        Set_Convention (S, Convention (E));
7682
                        Check_Dispatching_Operation (S, E);
7683
 
7684
                     else
7685
                        Check_Dispatching_Operation (S, Empty);
7686
                     end if;
7687
 
7688
                     Check_For_Primitive_Subprogram
7689
                       (Is_Primitive_Subp, Is_Overriding => True);
7690
                     goto Check_Inequality;
7691
                  end;
7692
 
7693
               --  Apparent redeclarations in instances can occur when two
7694
               --  formal types get the same actual type. The subprograms in
7695
               --  in the instance are legal,  even if not callable from the
7696
               --  outside. Calls from within are disambiguated elsewhere.
7697
               --  For dispatching operations in the visible part, the usual
7698
               --  rules apply, and operations with the same profile are not
7699
               --  legal (B830001).
7700
 
7701
               elsif (In_Instance_Visible_Part
7702
                       and then not Is_Dispatching_Operation (E))
7703
                 or else In_Instance_Not_Visible
7704
               then
7705
                  null;
7706
 
7707
               --  Here we have a real error (identical profile)
7708
 
7709
               else
7710
                  Error_Msg_Sloc := Sloc (E);
7711
 
7712
                  --  Avoid cascaded errors if the entity appears in
7713
                  --  subsequent calls.
7714
 
7715
                  Set_Scope (S, Current_Scope);
7716
 
7717
                  --  Generate error, with extra useful warning for the case
7718
                  --  of a generic instance with no completion.
7719
 
7720
                  if Is_Generic_Instance (S)
7721
                    and then not Has_Completion (E)
7722
                  then
7723
                     Error_Msg_N
7724
                       ("instantiation cannot provide body for&", S);
7725
                     Error_Msg_N ("\& conflicts with declaration#", S);
7726
                  else
7727
                     Error_Msg_N ("& conflicts with declaration#", S);
7728
                  end if;
7729
 
7730
                  return;
7731
               end if;
7732
 
7733
            else
7734
               --  If one subprogram has an access parameter and the other
7735
               --  a parameter of an access type, calls to either might be
7736
               --  ambiguous. Verify that parameters match except for the
7737
               --  access parameter.
7738
 
7739
               if May_Hide_Profile then
7740
                  declare
7741
                     F1 : Entity_Id;
7742
                     F2 : Entity_Id;
7743
 
7744
                  begin
7745
                     F1 := First_Formal (S);
7746
                     F2 := First_Formal (E);
7747
                     while Present (F1) and then Present (F2) loop
7748
                        if Is_Access_Type (Etype (F1)) then
7749
                           if not Is_Access_Type (Etype (F2))
7750
                              or else not Conforming_Types
7751
                                (Designated_Type (Etype (F1)),
7752
                                 Designated_Type (Etype (F2)),
7753
                                 Type_Conformant)
7754
                           then
7755
                              May_Hide_Profile := False;
7756
                           end if;
7757
 
7758
                        elsif
7759
                          not Conforming_Types
7760
                            (Etype (F1), Etype (F2), Type_Conformant)
7761
                        then
7762
                           May_Hide_Profile := False;
7763
                        end if;
7764
 
7765
                        Next_Formal (F1);
7766
                        Next_Formal (F2);
7767
                     end loop;
7768
 
7769
                     if May_Hide_Profile
7770
                       and then No (F1)
7771
                       and then No (F2)
7772
                     then
7773
                        Error_Msg_NE ("calls to& may be ambiguous?", S, S);
7774
                     end if;
7775
                  end;
7776
               end if;
7777
            end if;
7778
 
7779
            E := Homonym (E);
7780
         end loop;
7781
 
7782
         <<Add_New_Entity>>
7783
 
7784
         --  On exit, we know that S is a new entity
7785
 
7786
         Enter_Overloaded_Entity (S);
7787
         Check_For_Primitive_Subprogram (Is_Primitive_Subp);
7788
         Check_Overriding_Indicator
7789
           (S, Overridden_Subp, Is_Primitive => Is_Primitive_Subp);
7790
 
7791
         --  If S is a derived operation for an untagged type then by
7792
         --  definition it's not a dispatching operation (even if the parent
7793
         --  operation was dispatching), so we don't call
7794
         --  Check_Dispatching_Operation in that case.
7795
 
7796
         if No (Derived_Type)
7797
           or else Is_Tagged_Type (Derived_Type)
7798
         then
7799
            Check_Dispatching_Operation (S, Empty);
7800
         end if;
7801
      end if;
7802
 
7803
      --  If this is a user-defined equality operator that is not a derived
7804
      --  subprogram, create the corresponding inequality. If the operation is
7805
      --  dispatching, the expansion is done elsewhere, and we do not create
7806
      --  an explicit inequality operation.
7807
 
7808
      <<Check_Inequality>>
7809
         if Chars (S) = Name_Op_Eq
7810
           and then Etype (S) = Standard_Boolean
7811
           and then Present (Parent (S))
7812
           and then not Is_Dispatching_Operation (S)
7813
         then
7814
            Make_Inequality_Operator (S);
7815
         end if;
7816
   end New_Overloaded_Entity;
7817
 
7818
   ---------------------
7819
   -- Process_Formals --
7820
   ---------------------
7821
 
7822
   procedure Process_Formals
7823
     (T           : List_Id;
7824
      Related_Nod : Node_Id)
7825
   is
7826
      Param_Spec  : Node_Id;
7827
      Formal      : Entity_Id;
7828
      Formal_Type : Entity_Id;
7829
      Default     : Node_Id;
7830
      Ptype       : Entity_Id;
7831
 
7832
      Num_Out_Params  : Nat       := 0;
7833
      First_Out_Param : Entity_Id := Empty;
7834
      --  Used for setting Is_Only_Out_Parameter
7835
 
7836
      function Designates_From_With_Type (Typ : Entity_Id) return Boolean;
7837
      --  Determine whether an access type designates a type coming from a
7838
      --  limited view.
7839
 
7840
      function Is_Class_Wide_Default (D : Node_Id) return Boolean;
7841
      --  Check whether the default has a class-wide type. After analysis the
7842
      --  default has the type of the formal, so we must also check explicitly
7843
      --  for an access attribute.
7844
 
7845
      -------------------------------
7846
      -- Designates_From_With_Type --
7847
      -------------------------------
7848
 
7849
      function Designates_From_With_Type (Typ : Entity_Id) return Boolean is
7850
         Desig : Entity_Id := Typ;
7851
 
7852
      begin
7853
         if Is_Access_Type (Desig) then
7854
            Desig := Directly_Designated_Type (Desig);
7855
         end if;
7856
 
7857
         if Is_Class_Wide_Type (Desig) then
7858
            Desig := Root_Type (Desig);
7859
         end if;
7860
 
7861
         return
7862
           Ekind (Desig) = E_Incomplete_Type
7863
             and then From_With_Type (Desig);
7864
      end Designates_From_With_Type;
7865
 
7866
      ---------------------------
7867
      -- Is_Class_Wide_Default --
7868
      ---------------------------
7869
 
7870
      function Is_Class_Wide_Default (D : Node_Id) return Boolean is
7871
      begin
7872
         return Is_Class_Wide_Type (Designated_Type (Etype (D)))
7873
           or else (Nkind (D) =  N_Attribute_Reference
7874
                      and then Attribute_Name (D) = Name_Access
7875
                      and then Is_Class_Wide_Type (Etype (Prefix (D))));
7876
      end Is_Class_Wide_Default;
7877
 
7878
   --  Start of processing for Process_Formals
7879
 
7880
   begin
7881
      --  In order to prevent premature use of the formals in the same formal
7882
      --  part, the Ekind is left undefined until all default expressions are
7883
      --  analyzed. The Ekind is established in a separate loop at the end.
7884
 
7885
      Param_Spec := First (T);
7886
      while Present (Param_Spec) loop
7887
         Formal := Defining_Identifier (Param_Spec);
7888
         Set_Never_Set_In_Source (Formal, True);
7889
         Enter_Name (Formal);
7890
 
7891
         --  Case of ordinary parameters
7892
 
7893
         if Nkind (Parameter_Type (Param_Spec)) /= N_Access_Definition then
7894
            Find_Type (Parameter_Type (Param_Spec));
7895
            Ptype := Parameter_Type (Param_Spec);
7896
 
7897
            if Ptype = Error then
7898
               goto Continue;
7899
            end if;
7900
 
7901
            Formal_Type := Entity (Ptype);
7902
 
7903
            if Is_Incomplete_Type (Formal_Type)
7904
              or else
7905
               (Is_Class_Wide_Type (Formal_Type)
7906
                  and then Is_Incomplete_Type (Root_Type (Formal_Type)))
7907
            then
7908
               --  Ada 2005 (AI-326): Tagged incomplete types allowed in
7909
               --  primitive operations, as long as their completion is
7910
               --  in the same declarative part. If in the private part
7911
               --  this means that the type cannot be a Taft-amendment type.
7912
               --  Check is done on package exit. For access to subprograms,
7913
               --  the use is legal for Taft-amendment types.
7914
 
7915
               if Is_Tagged_Type (Formal_Type) then
7916
                  if Ekind (Scope (Current_Scope)) = E_Package
7917
                    and then In_Private_Part (Scope (Current_Scope))
7918
                    and then not From_With_Type (Formal_Type)
7919
                    and then not Is_Class_Wide_Type (Formal_Type)
7920
                  then
7921
                     if not Nkind_In
7922
                       (Parent (T), N_Access_Function_Definition,
7923
                                    N_Access_Procedure_Definition)
7924
                     then
7925
                        Append_Elmt
7926
                          (Current_Scope,
7927
                             Private_Dependents (Base_Type (Formal_Type)));
7928
                     end if;
7929
                  end if;
7930
 
7931
               --  Special handling of Value_Type for CIL case
7932
 
7933
               elsif Is_Value_Type (Formal_Type) then
7934
                  null;
7935
 
7936
               elsif not Nkind_In (Parent (T), N_Access_Function_Definition,
7937
                                               N_Access_Procedure_Definition)
7938
               then
7939
                  Error_Msg_NE
7940
                    ("invalid use of incomplete type&",
7941
                       Param_Spec, Formal_Type);
7942
 
7943
                  --  Further checks on the legality of incomplete types
7944
                  --  in formal parts must be delayed until the freeze point
7945
                  --  of the enclosing subprogram or access to subprogram.
7946
               end if;
7947
 
7948
            elsif Ekind (Formal_Type) = E_Void then
7949
               Error_Msg_NE ("premature use of&",
7950
                 Parameter_Type (Param_Spec), Formal_Type);
7951
            end if;
7952
 
7953
            --  Ada 2005 (AI-231): Create and decorate an internal subtype
7954
            --  declaration corresponding to the null-excluding type of the
7955
            --  formal in the enclosing scope. Finally, replace the parameter
7956
            --  type of the formal with the internal subtype.
7957
 
7958
            if Ada_Version >= Ada_05
7959
              and then Null_Exclusion_Present (Param_Spec)
7960
            then
7961
               if not Is_Access_Type (Formal_Type) then
7962
                  Error_Msg_N
7963
                    ("`NOT NULL` allowed only for an access type", Param_Spec);
7964
 
7965
               else
7966
                  if Can_Never_Be_Null (Formal_Type)
7967
                    and then Comes_From_Source (Related_Nod)
7968
                  then
7969
                     Error_Msg_NE
7970
                       ("`NOT NULL` not allowed (& already excludes null)",
7971
                        Param_Spec,
7972
                        Formal_Type);
7973
                  end if;
7974
 
7975
                  Formal_Type :=
7976
                    Create_Null_Excluding_Itype
7977
                      (T           => Formal_Type,
7978
                       Related_Nod => Related_Nod,
7979
                       Scope_Id    => Scope (Current_Scope));
7980
 
7981
                  --  If the designated type of the itype is an itype we
7982
                  --  decorate it with the Has_Delayed_Freeze attribute to
7983
                  --  avoid problems with the backend.
7984
 
7985
                  --  Example:
7986
                  --     type T is access procedure;
7987
                  --     procedure Op (O : not null T);
7988
 
7989
                  if Is_Itype (Directly_Designated_Type (Formal_Type)) then
7990
                     Set_Has_Delayed_Freeze (Formal_Type);
7991
                  end if;
7992
               end if;
7993
            end if;
7994
 
7995
         --  An access formal type
7996
 
7997
         else
7998
            Formal_Type :=
7999
              Access_Definition (Related_Nod, Parameter_Type (Param_Spec));
8000
 
8001
            --  No need to continue if we already notified errors
8002
 
8003
            if not Present (Formal_Type) then
8004
               return;
8005
            end if;
8006
 
8007
            --  Ada 2005 (AI-254)
8008
 
8009
            declare
8010
               AD : constant Node_Id :=
8011
                      Access_To_Subprogram_Definition
8012
                        (Parameter_Type (Param_Spec));
8013
            begin
8014
               if Present (AD) and then Protected_Present (AD) then
8015
                  Formal_Type :=
8016
                    Replace_Anonymous_Access_To_Protected_Subprogram
8017
                      (Param_Spec);
8018
               end if;
8019
            end;
8020
         end if;
8021
 
8022
         Set_Etype (Formal, Formal_Type);
8023
         Default := Expression (Param_Spec);
8024
 
8025
         if Present (Default) then
8026
            if Out_Present (Param_Spec) then
8027
               Error_Msg_N
8028
                 ("default initialization only allowed for IN parameters",
8029
                  Param_Spec);
8030
            end if;
8031
 
8032
            --  Do the special preanalysis of the expression (see section on
8033
            --  "Handling of Default Expressions" in the spec of package Sem).
8034
 
8035
            Preanalyze_Spec_Expression (Default, Formal_Type);
8036
 
8037
            --  An access to constant cannot be the default for
8038
            --  an access parameter that is an access to variable.
8039
 
8040
            if Ekind (Formal_Type) = E_Anonymous_Access_Type
8041
              and then not Is_Access_Constant (Formal_Type)
8042
              and then Is_Access_Type (Etype (Default))
8043
              and then Is_Access_Constant (Etype (Default))
8044
            then
8045
               Error_Msg_N
8046
                 ("formal that is access to variable cannot be initialized " &
8047
                    "with an access-to-constant expression", Default);
8048
            end if;
8049
 
8050
            --  Check that the designated type of an access parameter's default
8051
            --  is not a class-wide type unless the parameter's designated type
8052
            --  is also class-wide.
8053
 
8054
            if Ekind (Formal_Type) = E_Anonymous_Access_Type
8055
              and then not Designates_From_With_Type (Formal_Type)
8056
              and then Is_Class_Wide_Default (Default)
8057
              and then not Is_Class_Wide_Type (Designated_Type (Formal_Type))
8058
            then
8059
               Error_Msg_N
8060
                 ("access to class-wide expression not allowed here", Default);
8061
            end if;
8062
 
8063
            --  Check incorrect use of dynamically tagged expressions
8064
 
8065
            if Is_Tagged_Type (Formal_Type) then
8066
               Check_Dynamically_Tagged_Expression
8067
                 (Expr        => Default,
8068
                  Typ         => Formal_Type,
8069
                  Related_Nod => Default);
8070
            end if;
8071
         end if;
8072
 
8073
         --  Ada 2005 (AI-231): Static checks
8074
 
8075
         if Ada_Version >= Ada_05
8076
           and then Is_Access_Type (Etype (Formal))
8077
           and then Can_Never_Be_Null (Etype (Formal))
8078
         then
8079
            Null_Exclusion_Static_Checks (Param_Spec);
8080
         end if;
8081
 
8082
      <<Continue>>
8083
         Next (Param_Spec);
8084
      end loop;
8085
 
8086
      --  If this is the formal part of a function specification, analyze the
8087
      --  subtype mark in the context where the formals are visible but not
8088
      --  yet usable, and may hide outer homographs.
8089
 
8090
      if Nkind (Related_Nod) = N_Function_Specification then
8091
         Analyze_Return_Type (Related_Nod);
8092
      end if;
8093
 
8094
      --  Now set the kind (mode) of each formal
8095
 
8096
      Param_Spec := First (T);
8097
 
8098
      while Present (Param_Spec) loop
8099
         Formal := Defining_Identifier (Param_Spec);
8100
         Set_Formal_Mode (Formal);
8101
 
8102
         if Ekind (Formal) = E_In_Parameter then
8103
            Set_Default_Value (Formal, Expression (Param_Spec));
8104
 
8105
            if Present (Expression (Param_Spec)) then
8106
               Default :=  Expression (Param_Spec);
8107
 
8108
               if Is_Scalar_Type (Etype (Default)) then
8109
                  if Nkind
8110
                       (Parameter_Type (Param_Spec)) /= N_Access_Definition
8111
                  then
8112
                     Formal_Type := Entity (Parameter_Type (Param_Spec));
8113
 
8114
                  else
8115
                     Formal_Type := Access_Definition
8116
                       (Related_Nod, Parameter_Type (Param_Spec));
8117
                  end if;
8118
 
8119
                  Apply_Scalar_Range_Check (Default, Formal_Type);
8120
               end if;
8121
            end if;
8122
 
8123
         elsif Ekind (Formal) = E_Out_Parameter then
8124
            Num_Out_Params := Num_Out_Params + 1;
8125
 
8126
            if Num_Out_Params = 1 then
8127
               First_Out_Param := Formal;
8128
            end if;
8129
 
8130
         elsif Ekind (Formal) = E_In_Out_Parameter then
8131
            Num_Out_Params := Num_Out_Params + 1;
8132
         end if;
8133
 
8134
         Next (Param_Spec);
8135
      end loop;
8136
 
8137
      if Present (First_Out_Param) and then Num_Out_Params = 1 then
8138
         Set_Is_Only_Out_Parameter (First_Out_Param);
8139
      end if;
8140
   end Process_Formals;
8141
 
8142
   ------------------
8143
   -- Process_PPCs --
8144
   ------------------
8145
 
8146
   procedure Process_PPCs
8147
     (N       : Node_Id;
8148
      Spec_Id : Entity_Id;
8149
      Body_Id : Entity_Id)
8150
   is
8151
      Loc   : constant Source_Ptr := Sloc (N);
8152
      Prag  : Node_Id;
8153
      Plist : List_Id := No_List;
8154
      Subp  : Entity_Id;
8155
      Parms : List_Id;
8156
 
8157
      function Grab_PPC (Nam : Name_Id) return Node_Id;
8158
      --  Prag contains an analyzed precondition or postcondition pragma.
8159
      --  This function copies the pragma, changes it to the corresponding
8160
      --  Check pragma and returns the Check pragma as the result. The
8161
      --  argument Nam is either Name_Precondition or Name_Postcondition.
8162
 
8163
      --------------
8164
      -- Grab_PPC --
8165
      --------------
8166
 
8167
      function Grab_PPC (Nam : Name_Id) return Node_Id is
8168
         CP : constant Node_Id := New_Copy_Tree (Prag);
8169
 
8170
      begin
8171
         --  Set Analyzed to false, since we want to reanalyze the check
8172
         --  procedure. Note that it is only at the outer level that we
8173
         --  do this fiddling, for the spec cases, the already preanalyzed
8174
         --  parameters are not affected.
8175
 
8176
         --  For a postcondition pragma within a generic, preserve the pragma
8177
         --  for later expansion.
8178
 
8179
         Set_Analyzed (CP, False);
8180
 
8181
         if Nam = Name_Postcondition
8182
           and then not Expander_Active
8183
         then
8184
            return CP;
8185
         end if;
8186
 
8187
         --  Change pragma into corresponding pragma Check
8188
 
8189
         Prepend_To (Pragma_Argument_Associations (CP),
8190
           Make_Pragma_Argument_Association (Sloc (Prag),
8191
             Expression =>
8192
               Make_Identifier (Loc,
8193
                 Chars => Nam)));
8194
         Set_Pragma_Identifier (CP,
8195
           Make_Identifier (Sloc (Prag),
8196
             Chars => Name_Check));
8197
 
8198
         return CP;
8199
      end Grab_PPC;
8200
 
8201
   --  Start of processing for Process_PPCs
8202
 
8203
   begin
8204
      --  Nothing to do if we are not generating code
8205
 
8206
      if Operating_Mode /= Generate_Code then
8207
         return;
8208
      end if;
8209
 
8210
      --  Grab preconditions from spec
8211
 
8212
      if Present (Spec_Id) then
8213
 
8214
         --  Loop through PPC pragmas from spec. Note that preconditions from
8215
         --  the body will be analyzed and converted when we scan the body
8216
         --  declarations below.
8217
 
8218
         Prag := Spec_PPC_List (Spec_Id);
8219
         while Present (Prag) loop
8220
            if Pragma_Name (Prag) = Name_Precondition
8221
              and then Pragma_Enabled (Prag)
8222
            then
8223
               --  Add pragma Check at the start of the declarations of N.
8224
               --  Note that this processing reverses the order of the list,
8225
               --  which is what we want since new entries were chained to
8226
               --  the head of the list.
8227
 
8228
               Prepend (Grab_PPC (Name_Precondition), Declarations (N));
8229
            end if;
8230
 
8231
            Prag := Next_Pragma (Prag);
8232
         end loop;
8233
      end if;
8234
 
8235
      --  Build postconditions procedure if needed and prepend the following
8236
      --  declaration to the start of the declarations for the subprogram.
8237
 
8238
      --     procedure _postconditions [(_Result : resulttype)] is
8239
      --     begin
8240
      --        pragma Check (Postcondition, condition [,message]);
8241
      --        pragma Check (Postcondition, condition [,message]);
8242
      --        ...
8243
      --     end;
8244
 
8245
      --  First we deal with the postconditions in the body
8246
 
8247
      if Is_Non_Empty_List (Declarations (N)) then
8248
 
8249
         --  Loop through declarations
8250
 
8251
         Prag := First (Declarations (N));
8252
         while Present (Prag) loop
8253
            if Nkind (Prag) = N_Pragma then
8254
 
8255
               --  If pragma, capture if enabled postcondition, else ignore
8256
 
8257
               if Pragma_Name (Prag) = Name_Postcondition
8258
                 and then Check_Enabled (Name_Postcondition)
8259
               then
8260
                  if Plist = No_List then
8261
                     Plist := Empty_List;
8262
                  end if;
8263
 
8264
                  Analyze (Prag);
8265
 
8266
                  --  If expansion is disabled, as in a generic unit,
8267
                  --  save pragma for later expansion.
8268
 
8269
                  if not Expander_Active then
8270
                     Prepend (Grab_PPC (Name_Postcondition), Declarations (N));
8271
                  else
8272
                     Append (Grab_PPC (Name_Postcondition), Plist);
8273
                  end if;
8274
               end if;
8275
 
8276
               Next (Prag);
8277
 
8278
            --  Not a pragma, if comes from source, then end scan
8279
 
8280
            elsif Comes_From_Source (Prag) then
8281
               exit;
8282
 
8283
            --  Skip stuff not coming from source
8284
 
8285
            else
8286
               Next (Prag);
8287
            end if;
8288
         end loop;
8289
      end if;
8290
 
8291
      --  Now deal with any postconditions from the spec
8292
 
8293
      if Present (Spec_Id) then
8294
 
8295
         --  Loop through PPC pragmas from spec
8296
 
8297
         Prag := Spec_PPC_List (Spec_Id);
8298
         while Present (Prag) loop
8299
            if Pragma_Name (Prag) = Name_Postcondition
8300
              and then Pragma_Enabled (Prag)
8301
            then
8302
               if Plist = No_List then
8303
                  Plist := Empty_List;
8304
               end if;
8305
 
8306
               if not Expander_Active then
8307
                  Prepend (Grab_PPC (Name_Postcondition), Declarations (N));
8308
               else
8309
                  Append (Grab_PPC (Name_Postcondition), Plist);
8310
               end if;
8311
            end if;
8312
 
8313
            Prag := Next_Pragma (Prag);
8314
         end loop;
8315
      end if;
8316
 
8317
      --  If we had any postconditions and expansion is enabled, build
8318
      --  the _Postconditions procedure.
8319
 
8320
      if Present (Plist)
8321
        and then Expander_Active
8322
      then
8323
         Subp := Defining_Entity (N);
8324
 
8325
         if Etype (Subp) /= Standard_Void_Type then
8326
            Parms := New_List (
8327
              Make_Parameter_Specification (Loc,
8328
                Defining_Identifier =>
8329
                  Make_Defining_Identifier (Loc,
8330
                    Chars => Name_uResult),
8331
                Parameter_Type => New_Occurrence_Of (Etype (Subp), Loc)));
8332
         else
8333
            Parms := No_List;
8334
         end if;
8335
 
8336
         declare
8337
            Post_Proc : constant Entity_Id :=
8338
                   Make_Defining_Identifier (Loc,
8339
                     Chars => Name_uPostconditions);
8340
            --  The entity for the _Postconditions procedure
8341
         begin
8342
            Prepend_To (Declarations (N),
8343
              Make_Subprogram_Body (Loc,
8344
                Specification =>
8345
                  Make_Procedure_Specification (Loc,
8346
                    Defining_Unit_Name => Post_Proc,
8347
                    Parameter_Specifications => Parms),
8348
 
8349
                Declarations => Empty_List,
8350
 
8351
                Handled_Statement_Sequence =>
8352
                  Make_Handled_Sequence_Of_Statements (Loc,
8353
                    Statements => Plist)));
8354
 
8355
            --  If this is a procedure, set the Postcondition_Proc attribute on
8356
            --  the proper defining entity for the subprogram.
8357
 
8358
            if Etype (Subp) = Standard_Void_Type then
8359
               if Present (Spec_Id) then
8360
                  Set_Postcondition_Proc (Spec_Id, Post_Proc);
8361
               else
8362
                  Set_Postcondition_Proc (Body_Id, Post_Proc);
8363
               end if;
8364
            end if;
8365
         end;
8366
 
8367
         if Present (Spec_Id) then
8368
            Set_Has_Postconditions (Spec_Id);
8369
         else
8370
            Set_Has_Postconditions (Body_Id);
8371
         end if;
8372
      end if;
8373
   end Process_PPCs;
8374
 
8375
   ----------------------------
8376
   -- Reference_Body_Formals --
8377
   ----------------------------
8378
 
8379
   procedure Reference_Body_Formals (Spec : Entity_Id; Bod : Entity_Id) is
8380
      Fs : Entity_Id;
8381
      Fb : Entity_Id;
8382
 
8383
   begin
8384
      if Error_Posted (Spec) then
8385
         return;
8386
      end if;
8387
 
8388
      --  Iterate over both lists. They may be of different lengths if the two
8389
      --  specs are not conformant.
8390
 
8391
      Fs := First_Formal (Spec);
8392
      Fb := First_Formal (Bod);
8393
      while Present (Fs) and then Present (Fb) loop
8394
         Generate_Reference (Fs, Fb, 'b');
8395
 
8396
         if Style_Check then
8397
            Style.Check_Identifier (Fb, Fs);
8398
         end if;
8399
 
8400
         Set_Spec_Entity (Fb, Fs);
8401
         Set_Referenced (Fs, False);
8402
         Next_Formal (Fs);
8403
         Next_Formal (Fb);
8404
      end loop;
8405
   end Reference_Body_Formals;
8406
 
8407
   -------------------------
8408
   -- Set_Actual_Subtypes --
8409
   -------------------------
8410
 
8411
   procedure Set_Actual_Subtypes (N : Node_Id; Subp : Entity_Id) is
8412
      Loc            : constant Source_Ptr := Sloc (N);
8413
      Decl           : Node_Id;
8414
      Formal         : Entity_Id;
8415
      T              : Entity_Id;
8416
      First_Stmt     : Node_Id := Empty;
8417
      AS_Needed      : Boolean;
8418
 
8419
   begin
8420
      --  If this is an empty initialization procedure, no need to create
8421
      --  actual subtypes (small optimization).
8422
 
8423
      if Ekind (Subp) = E_Procedure
8424
        and then Is_Null_Init_Proc (Subp)
8425
      then
8426
         return;
8427
      end if;
8428
 
8429
      Formal := First_Formal (Subp);
8430
      while Present (Formal) loop
8431
         T := Etype (Formal);
8432
 
8433
         --  We never need an actual subtype for a constrained formal
8434
 
8435
         if Is_Constrained (T) then
8436
            AS_Needed := False;
8437
 
8438
         --  If we have unknown discriminants, then we do not need an actual
8439
         --  subtype, or more accurately we cannot figure it out! Note that
8440
         --  all class-wide types have unknown discriminants.
8441
 
8442
         elsif Has_Unknown_Discriminants (T) then
8443
            AS_Needed := False;
8444
 
8445
         --  At this stage we have an unconstrained type that may need an
8446
         --  actual subtype. For sure the actual subtype is needed if we have
8447
         --  an unconstrained array type.
8448
 
8449
         elsif Is_Array_Type (T) then
8450
            AS_Needed := True;
8451
 
8452
         --  The only other case needing an actual subtype is an unconstrained
8453
         --  record type which is an IN parameter (we cannot generate actual
8454
         --  subtypes for the OUT or IN OUT case, since an assignment can
8455
         --  change the discriminant values. However we exclude the case of
8456
         --  initialization procedures, since discriminants are handled very
8457
         --  specially in this context, see the section entitled "Handling of
8458
         --  Discriminants" in Einfo.
8459
 
8460
         --  We also exclude the case of Discrim_SO_Functions (functions used
8461
         --  in front end layout mode for size/offset values), since in such
8462
         --  functions only discriminants are referenced, and not only are such
8463
         --  subtypes not needed, but they cannot always be generated, because
8464
         --  of order of elaboration issues.
8465
 
8466
         elsif Is_Record_Type (T)
8467
           and then Ekind (Formal) = E_In_Parameter
8468
           and then Chars (Formal) /= Name_uInit
8469
           and then not Is_Unchecked_Union (T)
8470
           and then not Is_Discrim_SO_Function (Subp)
8471
         then
8472
            AS_Needed := True;
8473
 
8474
         --  All other cases do not need an actual subtype
8475
 
8476
         else
8477
            AS_Needed := False;
8478
         end if;
8479
 
8480
         --  Generate actual subtypes for unconstrained arrays and
8481
         --  unconstrained discriminated records.
8482
 
8483
         if AS_Needed then
8484
            if Nkind (N) = N_Accept_Statement then
8485
 
8486
               --  If expansion is active, The formal is replaced by a local
8487
               --  variable that renames the corresponding entry of the
8488
               --  parameter block, and it is this local variable that may
8489
               --  require an actual subtype.
8490
 
8491
               if Expander_Active then
8492
                  Decl := Build_Actual_Subtype (T, Renamed_Object (Formal));
8493
               else
8494
                  Decl := Build_Actual_Subtype (T, Formal);
8495
               end if;
8496
 
8497
               if Present (Handled_Statement_Sequence (N)) then
8498
                  First_Stmt :=
8499
                    First (Statements (Handled_Statement_Sequence (N)));
8500
                  Prepend (Decl, Statements (Handled_Statement_Sequence (N)));
8501
                  Mark_Rewrite_Insertion (Decl);
8502
               else
8503
                  --  If the accept statement has no body, there will be no
8504
                  --  reference to the actuals, so no need to compute actual
8505
                  --  subtypes.
8506
 
8507
                  return;
8508
               end if;
8509
 
8510
            else
8511
               Decl := Build_Actual_Subtype (T, Formal);
8512
               Prepend (Decl, Declarations (N));
8513
               Mark_Rewrite_Insertion (Decl);
8514
            end if;
8515
 
8516
            --  The declaration uses the bounds of an existing object, and
8517
            --  therefore needs no constraint checks.
8518
 
8519
            Analyze (Decl, Suppress => All_Checks);
8520
 
8521
            --  We need to freeze manually the generated type when it is
8522
            --  inserted anywhere else than in a declarative part.
8523
 
8524
            if Present (First_Stmt) then
8525
               Insert_List_Before_And_Analyze (First_Stmt,
8526
                 Freeze_Entity (Defining_Identifier (Decl), Loc));
8527
            end if;
8528
 
8529
            if Nkind (N) = N_Accept_Statement
8530
              and then Expander_Active
8531
            then
8532
               Set_Actual_Subtype (Renamed_Object (Formal),
8533
                 Defining_Identifier (Decl));
8534
            else
8535
               Set_Actual_Subtype (Formal, Defining_Identifier (Decl));
8536
            end if;
8537
         end if;
8538
 
8539
         Next_Formal (Formal);
8540
      end loop;
8541
   end Set_Actual_Subtypes;
8542
 
8543
   ---------------------
8544
   -- Set_Formal_Mode --
8545
   ---------------------
8546
 
8547
   procedure Set_Formal_Mode (Formal_Id : Entity_Id) is
8548
      Spec : constant Node_Id := Parent (Formal_Id);
8549
 
8550
   begin
8551
      --  Note: we set Is_Known_Valid for IN parameters and IN OUT parameters
8552
      --  since we ensure that corresponding actuals are always valid at the
8553
      --  point of the call.
8554
 
8555
      if Out_Present (Spec) then
8556
         if Ekind (Scope (Formal_Id)) = E_Function
8557
           or else Ekind (Scope (Formal_Id)) = E_Generic_Function
8558
         then
8559
            Error_Msg_N ("functions can only have IN parameters", Spec);
8560
            Set_Ekind (Formal_Id, E_In_Parameter);
8561
 
8562
         elsif In_Present (Spec) then
8563
            Set_Ekind (Formal_Id, E_In_Out_Parameter);
8564
 
8565
         else
8566
            Set_Ekind               (Formal_Id, E_Out_Parameter);
8567
            Set_Never_Set_In_Source (Formal_Id, True);
8568
            Set_Is_True_Constant    (Formal_Id, False);
8569
            Set_Current_Value       (Formal_Id, Empty);
8570
         end if;
8571
 
8572
      else
8573
         Set_Ekind (Formal_Id, E_In_Parameter);
8574
      end if;
8575
 
8576
      --  Set Is_Known_Non_Null for access parameters since the language
8577
      --  guarantees that access parameters are always non-null. We also set
8578
      --  Can_Never_Be_Null, since there is no way to change the value.
8579
 
8580
      if Nkind (Parameter_Type (Spec)) = N_Access_Definition then
8581
 
8582
         --  Ada 2005 (AI-231): In Ada95, access parameters are always non-
8583
         --  null; In Ada 2005, only if then null_exclusion is explicit.
8584
 
8585
         if Ada_Version < Ada_05
8586
           or else Can_Never_Be_Null (Etype (Formal_Id))
8587
         then
8588
            Set_Is_Known_Non_Null (Formal_Id);
8589
            Set_Can_Never_Be_Null (Formal_Id);
8590
         end if;
8591
 
8592
      --  Ada 2005 (AI-231): Null-exclusion access subtype
8593
 
8594
      elsif Is_Access_Type (Etype (Formal_Id))
8595
        and then Can_Never_Be_Null (Etype (Formal_Id))
8596
      then
8597
         Set_Is_Known_Non_Null (Formal_Id);
8598
      end if;
8599
 
8600
      Set_Mechanism (Formal_Id, Default_Mechanism);
8601
      Set_Formal_Validity (Formal_Id);
8602
   end Set_Formal_Mode;
8603
 
8604
   -------------------------
8605
   -- Set_Formal_Validity --
8606
   -------------------------
8607
 
8608
   procedure Set_Formal_Validity (Formal_Id : Entity_Id) is
8609
   begin
8610
      --  If no validity checking, then we cannot assume anything about the
8611
      --  validity of parameters, since we do not know there is any checking
8612
      --  of the validity on the call side.
8613
 
8614
      if not Validity_Checks_On then
8615
         return;
8616
 
8617
      --  If validity checking for parameters is enabled, this means we are
8618
      --  not supposed to make any assumptions about argument values.
8619
 
8620
      elsif Validity_Check_Parameters then
8621
         return;
8622
 
8623
      --  If we are checking in parameters, we will assume that the caller is
8624
      --  also checking parameters, so we can assume the parameter is valid.
8625
 
8626
      elsif Ekind (Formal_Id) = E_In_Parameter
8627
        and then Validity_Check_In_Params
8628
      then
8629
         Set_Is_Known_Valid (Formal_Id, True);
8630
 
8631
      --  Similar treatment for IN OUT parameters
8632
 
8633
      elsif Ekind (Formal_Id) = E_In_Out_Parameter
8634
        and then Validity_Check_In_Out_Params
8635
      then
8636
         Set_Is_Known_Valid (Formal_Id, True);
8637
      end if;
8638
   end Set_Formal_Validity;
8639
 
8640
   ------------------------
8641
   -- Subtype_Conformant --
8642
   ------------------------
8643
 
8644
   function Subtype_Conformant
8645
     (New_Id                   : Entity_Id;
8646
      Old_Id                   : Entity_Id;
8647
      Skip_Controlling_Formals : Boolean := False) return Boolean
8648
   is
8649
      Result : Boolean;
8650
   begin
8651
      Check_Conformance (New_Id, Old_Id, Subtype_Conformant, False, Result,
8652
        Skip_Controlling_Formals => Skip_Controlling_Formals);
8653
      return Result;
8654
   end Subtype_Conformant;
8655
 
8656
   ---------------------
8657
   -- Type_Conformant --
8658
   ---------------------
8659
 
8660
   function Type_Conformant
8661
     (New_Id                   : Entity_Id;
8662
      Old_Id                   : Entity_Id;
8663
      Skip_Controlling_Formals : Boolean := False) return Boolean
8664
   is
8665
      Result : Boolean;
8666
   begin
8667
      May_Hide_Profile := False;
8668
 
8669
      Check_Conformance
8670
        (New_Id, Old_Id, Type_Conformant, False, Result,
8671
         Skip_Controlling_Formals => Skip_Controlling_Formals);
8672
      return Result;
8673
   end Type_Conformant;
8674
 
8675
   -------------------------------
8676
   -- Valid_Operator_Definition --
8677
   -------------------------------
8678
 
8679
   procedure Valid_Operator_Definition (Designator : Entity_Id) is
8680
      N    : Integer := 0;
8681
      F    : Entity_Id;
8682
      Id   : constant Name_Id := Chars (Designator);
8683
      N_OK : Boolean;
8684
 
8685
   begin
8686
      F := First_Formal (Designator);
8687
      while Present (F) loop
8688
         N := N + 1;
8689
 
8690
         if Present (Default_Value (F)) then
8691
            Error_Msg_N
8692
              ("default values not allowed for operator parameters",
8693
               Parent (F));
8694
         end if;
8695
 
8696
         Next_Formal (F);
8697
      end loop;
8698
 
8699
      --  Verify that user-defined operators have proper number of arguments
8700
      --  First case of operators which can only be unary
8701
 
8702
      if Id = Name_Op_Not
8703
        or else Id = Name_Op_Abs
8704
      then
8705
         N_OK := (N = 1);
8706
 
8707
      --  Case of operators which can be unary or binary
8708
 
8709
      elsif Id = Name_Op_Add
8710
        or Id = Name_Op_Subtract
8711
      then
8712
         N_OK := (N in 1 .. 2);
8713
 
8714
      --  All other operators can only be binary
8715
 
8716
      else
8717
         N_OK := (N = 2);
8718
      end if;
8719
 
8720
      if not N_OK then
8721
         Error_Msg_N
8722
           ("incorrect number of arguments for operator", Designator);
8723
      end if;
8724
 
8725
      if Id = Name_Op_Ne
8726
        and then Base_Type (Etype (Designator)) = Standard_Boolean
8727
        and then not Is_Intrinsic_Subprogram (Designator)
8728
      then
8729
         Error_Msg_N
8730
            ("explicit definition of inequality not allowed", Designator);
8731
      end if;
8732
   end Valid_Operator_Definition;
8733
 
8734
end Sem_Ch6;

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.