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

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [sem_ch9.adb] - Blame information for rev 706

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 706 jeremybenn
------------------------------------------------------------------------------
2
--                                                                          --
3
--                         GNAT COMPILER COMPONENTS                         --
4
--                                                                          --
5
--                              S E M _ C H 9                               --
6
--                                                                          --
7
--                                 B o d y                                  --
8
--                                                                          --
9
--          Copyright (C) 1992-2012, 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 Einfo;    use Einfo;
29
with Errout;   use Errout;
30
with Exp_Ch9;  use Exp_Ch9;
31
with Elists;   use Elists;
32
with Freeze;   use Freeze;
33
with Lib.Xref; use Lib.Xref;
34
with Namet;    use Namet;
35
with Nlists;   use Nlists;
36
with Nmake;    use Nmake;
37
with Opt;      use Opt;
38
with Restrict; use Restrict;
39
with Rident;   use Rident;
40
with Rtsfind;  use Rtsfind;
41
with Sem;      use Sem;
42
with Sem_Aux;  use Sem_Aux;
43
with Sem_Ch3;  use Sem_Ch3;
44
with Sem_Ch5;  use Sem_Ch5;
45
with Sem_Ch6;  use Sem_Ch6;
46
with Sem_Ch8;  use Sem_Ch8;
47
with Sem_Ch13; use Sem_Ch13;
48
with Sem_Eval; use Sem_Eval;
49
with Sem_Res;  use Sem_Res;
50
with Sem_Type; use Sem_Type;
51
with Sem_Util; use Sem_Util;
52
with Sem_Warn; use Sem_Warn;
53
with Snames;   use Snames;
54
with Stand;    use Stand;
55
with Sinfo;    use Sinfo;
56
with Style;
57
with Targparm; use Targparm;
58
with Tbuild;   use Tbuild;
59
with Uintp;    use Uintp;
60
 
61
package body Sem_Ch9 is
62
 
63
   -----------------------
64
   -- Local Subprograms --
65
   -----------------------
66
 
67
   procedure Check_Max_Entries (D : Node_Id; R : All_Parameter_Restrictions);
68
   --  Given either a protected definition or a task definition in D, check
69
   --  the corresponding restriction parameter identifier R, and if it is set,
70
   --  count the entries (checking the static requirement), and compare with
71
   --  the given maximum.
72
 
73
   procedure Check_Interfaces (N : Node_Id; T : Entity_Id);
74
   --  N is an N_Protected_Type_Declaration or N_Task_Type_Declaration node.
75
   --  Complete decoration of T and check legality of the covered interfaces.
76
 
77
   procedure Check_Triggering_Statement
78
     (Trigger        : Node_Id;
79
      Error_Node     : Node_Id;
80
      Is_Dispatching : out Boolean);
81
   --  Examine the triggering statement of a select statement, conditional or
82
   --  timed entry call. If Trigger is a dispatching call, return its status
83
   --  in Is_Dispatching and check whether the primitive belongs to a limited
84
   --  interface. If it does not, emit an error at Error_Node.
85
 
86
   function Find_Concurrent_Spec (Body_Id : Entity_Id) return Entity_Id;
87
   --  Find entity in corresponding task or protected declaration. Use full
88
   --  view if first declaration was for an incomplete type.
89
 
90
   procedure Install_Declarations (Spec : Entity_Id);
91
   --  Utility to make visible in corresponding body the entities defined in
92
   --  task, protected type declaration, or entry declaration.
93
 
94
   -----------------------------
95
   -- Analyze_Abort_Statement --
96
   -----------------------------
97
 
98
   procedure Analyze_Abort_Statement (N : Node_Id) is
99
      T_Name : Node_Id;
100
 
101
   begin
102
      Tasking_Used := True;
103
      Check_SPARK_Restriction ("abort statement is not allowed", N);
104
 
105
      T_Name := First (Names (N));
106
      while Present (T_Name) loop
107
         Analyze (T_Name);
108
 
109
         if Is_Task_Type (Etype (T_Name))
110
           or else (Ada_Version >= Ada_2005
111
                      and then Ekind (Etype (T_Name)) = E_Class_Wide_Type
112
                      and then Is_Interface (Etype (T_Name))
113
                      and then Is_Task_Interface (Etype (T_Name)))
114
         then
115
            Resolve (T_Name);
116
         else
117
            if Ada_Version >= Ada_2005 then
118
               Error_Msg_N ("expect task name or task interface class-wide "
119
                          & "object for ABORT", T_Name);
120
            else
121
               Error_Msg_N ("expect task name for ABORT", T_Name);
122
            end if;
123
 
124
            return;
125
         end if;
126
 
127
         Next (T_Name);
128
      end loop;
129
 
130
      Check_Restriction (No_Abort_Statements, N);
131
      Check_Potentially_Blocking_Operation (N);
132
   end Analyze_Abort_Statement;
133
 
134
   --------------------------------
135
   -- Analyze_Accept_Alternative --
136
   --------------------------------
137
 
138
   procedure Analyze_Accept_Alternative (N : Node_Id) is
139
   begin
140
      Tasking_Used := True;
141
 
142
      if Present (Pragmas_Before (N)) then
143
         Analyze_List (Pragmas_Before (N));
144
      end if;
145
 
146
      if Present (Condition (N)) then
147
         Analyze_And_Resolve (Condition (N), Any_Boolean);
148
      end if;
149
 
150
      Analyze (Accept_Statement (N));
151
 
152
      if Is_Non_Empty_List (Statements (N)) then
153
         Analyze_Statements (Statements (N));
154
      end if;
155
   end Analyze_Accept_Alternative;
156
 
157
   ------------------------------
158
   -- Analyze_Accept_Statement --
159
   ------------------------------
160
 
161
   procedure Analyze_Accept_Statement (N : Node_Id) is
162
      Nam       : constant Entity_Id := Entry_Direct_Name (N);
163
      Formals   : constant List_Id   := Parameter_Specifications (N);
164
      Index     : constant Node_Id   := Entry_Index (N);
165
      Stats     : constant Node_Id   := Handled_Statement_Sequence (N);
166
      Accept_Id : Entity_Id;
167
      Entry_Nam : Entity_Id;
168
      E         : Entity_Id;
169
      Kind      : Entity_Kind;
170
      Task_Nam  : Entity_Id;
171
 
172
   begin
173
      Tasking_Used := True;
174
      Check_SPARK_Restriction ("accept statement is not allowed", N);
175
 
176
      --  Entry name is initialized to Any_Id. It should get reset to the
177
      --  matching entry entity. An error is signalled if it is not reset.
178
 
179
      Entry_Nam := Any_Id;
180
 
181
      for J in reverse 0 .. Scope_Stack.Last loop
182
         Task_Nam := Scope_Stack.Table (J).Entity;
183
         exit when Ekind (Etype (Task_Nam)) = E_Task_Type;
184
         Kind :=  Ekind (Task_Nam);
185
 
186
         if Kind /= E_Block and then Kind /= E_Loop
187
           and then not Is_Entry (Task_Nam)
188
         then
189
            Error_Msg_N ("enclosing body of accept must be a task", N);
190
            return;
191
         end if;
192
      end loop;
193
 
194
      if Ekind (Etype (Task_Nam)) /= E_Task_Type then
195
         Error_Msg_N ("invalid context for accept statement",  N);
196
         return;
197
      end if;
198
 
199
      --  In order to process the parameters, we create a defining identifier
200
      --  that can be used as the name of the scope. The name of the accept
201
      --  statement itself is not a defining identifier, and we cannot use
202
      --  its name directly because the task may have any number of accept
203
      --  statements for the same entry.
204
 
205
      if Present (Index) then
206
         Accept_Id := New_Internal_Entity
207
           (E_Entry_Family, Current_Scope, Sloc (N), 'E');
208
      else
209
         Accept_Id := New_Internal_Entity
210
           (E_Entry, Current_Scope, Sloc (N), 'E');
211
      end if;
212
 
213
      Set_Etype          (Accept_Id, Standard_Void_Type);
214
      Set_Accept_Address (Accept_Id, New_Elmt_List);
215
 
216
      if Present (Formals) then
217
         Push_Scope (Accept_Id);
218
         Process_Formals (Formals, N);
219
         Create_Extra_Formals (Accept_Id);
220
         End_Scope;
221
      end if;
222
 
223
      --  We set the default expressions processed flag because we don't need
224
      --  default expression functions. This is really more like body entity
225
      --  than a spec entity anyway.
226
 
227
      Set_Default_Expressions_Processed (Accept_Id);
228
 
229
      E := First_Entity (Etype (Task_Nam));
230
      while Present (E) loop
231
         if Chars (E) = Chars (Nam)
232
           and then (Ekind (E) = Ekind (Accept_Id))
233
           and then Type_Conformant (Accept_Id, E)
234
         then
235
            Entry_Nam := E;
236
            exit;
237
         end if;
238
 
239
         Next_Entity (E);
240
      end loop;
241
 
242
      if Entry_Nam = Any_Id then
243
         Error_Msg_N ("no entry declaration matches accept statement",  N);
244
         return;
245
      else
246
         Set_Entity (Nam, Entry_Nam);
247
         Generate_Reference (Entry_Nam, Nam, 'b', Set_Ref => False);
248
         Style.Check_Identifier (Nam, Entry_Nam);
249
      end if;
250
 
251
      --  Verify that the entry is not hidden by a procedure declared in the
252
      --  current block (pathological but possible).
253
 
254
      if Current_Scope /= Task_Nam then
255
         declare
256
            E1 : Entity_Id;
257
 
258
         begin
259
            E1 := First_Entity (Current_Scope);
260
            while Present (E1) loop
261
               if Ekind (E1) = E_Procedure
262
                 and then Chars (E1) = Chars (Entry_Nam)
263
                 and then Type_Conformant (E1, Entry_Nam)
264
               then
265
                  Error_Msg_N ("entry name is not visible", N);
266
               end if;
267
 
268
               Next_Entity (E1);
269
            end loop;
270
         end;
271
      end if;
272
 
273
      Set_Convention (Accept_Id, Convention (Entry_Nam));
274
      Check_Fully_Conformant (Accept_Id, Entry_Nam, N);
275
 
276
      for J in reverse 0 .. Scope_Stack.Last loop
277
         exit when Task_Nam = Scope_Stack.Table (J).Entity;
278
 
279
         if Entry_Nam = Scope_Stack.Table (J).Entity then
280
            Error_Msg_N ("duplicate accept statement for same entry", N);
281
         end if;
282
      end loop;
283
 
284
      declare
285
         P : Node_Id := N;
286
      begin
287
         loop
288
            P := Parent (P);
289
            case Nkind (P) is
290
               when N_Task_Body | N_Compilation_Unit =>
291
                  exit;
292
               when N_Asynchronous_Select =>
293
                  Error_Msg_N ("accept statements are not allowed within" &
294
                               " an asynchronous select inner" &
295
                               " to the enclosing task body", N);
296
                  exit;
297
               when others =>
298
                  null;
299
            end case;
300
         end loop;
301
      end;
302
 
303
      if Ekind (E) = E_Entry_Family then
304
         if No (Index) then
305
            Error_Msg_N ("missing entry index in accept for entry family", N);
306
         else
307
            Analyze_And_Resolve (Index, Entry_Index_Type (E));
308
            Apply_Range_Check (Index, Entry_Index_Type (E));
309
         end if;
310
 
311
      elsif Present (Index) then
312
         Error_Msg_N ("invalid entry index in accept for simple entry", N);
313
      end if;
314
 
315
      --  If label declarations present, analyze them. They are declared in the
316
      --  enclosing task, but their enclosing scope is the entry itself, so
317
      --  that goto's to the label are recognized as local to the accept.
318
 
319
      if Present (Declarations (N)) then
320
         declare
321
            Decl : Node_Id;
322
            Id   : Entity_Id;
323
 
324
         begin
325
            Decl := First (Declarations (N));
326
            while Present (Decl) loop
327
               Analyze (Decl);
328
 
329
               pragma Assert
330
                 (Nkind (Decl) = N_Implicit_Label_Declaration);
331
 
332
               Id := Defining_Identifier (Decl);
333
               Set_Enclosing_Scope (Id, Entry_Nam);
334
               Next (Decl);
335
            end loop;
336
         end;
337
      end if;
338
 
339
      --  If statements are present, they must be analyzed in the context of
340
      --  the entry, so that references to formals are correctly resolved. We
341
      --  also have to add the declarations that are required by the expansion
342
      --  of the accept statement in this case if expansion active.
343
 
344
      --  In the case of a select alternative of a selective accept, the
345
      --  expander references the address declaration even if there is no
346
      --  statement list.
347
 
348
      --  We also need to create the renaming declarations for the local
349
      --  variables that will replace references to the formals within the
350
      --  accept statement.
351
 
352
      Exp_Ch9.Expand_Accept_Declarations (N, Entry_Nam);
353
 
354
      --  Set Never_Set_In_Source and clear Is_True_Constant/Current_Value
355
      --  fields on all entry formals (this loop ignores all other entities).
356
      --  Reset Referenced, Referenced_As_xxx and Has_Pragma_Unreferenced as
357
      --  well, so that we can post accurate warnings on each accept statement
358
      --  for the same entry.
359
 
360
      E := First_Entity (Entry_Nam);
361
      while Present (E) loop
362
         if Is_Formal (E) then
363
            Set_Never_Set_In_Source         (E, True);
364
            Set_Is_True_Constant            (E, False);
365
            Set_Current_Value               (E, Empty);
366
            Set_Referenced                  (E, False);
367
            Set_Referenced_As_LHS           (E, False);
368
            Set_Referenced_As_Out_Parameter (E, False);
369
            Set_Has_Pragma_Unreferenced     (E, False);
370
         end if;
371
 
372
         Next_Entity (E);
373
      end loop;
374
 
375
      --  Analyze statements if present
376
 
377
      if Present (Stats) then
378
         Push_Scope (Entry_Nam);
379
         Install_Declarations (Entry_Nam);
380
 
381
         Set_Actual_Subtypes (N, Current_Scope);
382
 
383
         Analyze (Stats);
384
         Process_End_Label (Handled_Statement_Sequence (N), 't', Entry_Nam);
385
         End_Scope;
386
      end if;
387
 
388
      --  Some warning checks
389
 
390
      Check_Potentially_Blocking_Operation (N);
391
      Check_References (Entry_Nam, N);
392
      Set_Entry_Accepted (Entry_Nam);
393
   end Analyze_Accept_Statement;
394
 
395
   ---------------------------------
396
   -- Analyze_Asynchronous_Select --
397
   ---------------------------------
398
 
399
   procedure Analyze_Asynchronous_Select (N : Node_Id) is
400
      Is_Disp_Select : Boolean := False;
401
      Trigger        : Node_Id;
402
 
403
   begin
404
      Tasking_Used := True;
405
      Check_SPARK_Restriction ("select statement is not allowed", N);
406
      Check_Restriction (Max_Asynchronous_Select_Nesting, N);
407
      Check_Restriction (No_Select_Statements, N);
408
 
409
      if Ada_Version >= Ada_2005 then
410
         Trigger := Triggering_Statement (Triggering_Alternative (N));
411
 
412
         Analyze (Trigger);
413
 
414
         --  Ada 2005 (AI-345): Check for a potential dispatching select
415
 
416
         Check_Triggering_Statement (Trigger, N, Is_Disp_Select);
417
      end if;
418
 
419
      --  Ada 2005 (AI-345): The expansion of the dispatching asynchronous
420
      --  select will have to duplicate the triggering statements. Postpone
421
      --  the analysis of the statements till expansion. Analyze only if the
422
      --  expander is disabled in order to catch any semantic errors.
423
 
424
      if Is_Disp_Select then
425
         if not Expander_Active then
426
            Analyze_Statements (Statements (Abortable_Part (N)));
427
            Analyze (Triggering_Alternative (N));
428
         end if;
429
 
430
      --  Analyze the statements. We analyze statements in the abortable part,
431
      --  because this is the section that is executed first, and that way our
432
      --  remembering of saved values and checks is accurate.
433
 
434
      else
435
         Analyze_Statements (Statements (Abortable_Part (N)));
436
         Analyze (Triggering_Alternative (N));
437
      end if;
438
   end Analyze_Asynchronous_Select;
439
 
440
   ------------------------------------
441
   -- Analyze_Conditional_Entry_Call --
442
   ------------------------------------
443
 
444
   procedure Analyze_Conditional_Entry_Call (N : Node_Id) is
445
      Trigger        : constant Node_Id :=
446
                         Entry_Call_Statement (Entry_Call_Alternative (N));
447
      Is_Disp_Select : Boolean := False;
448
 
449
   begin
450
      Tasking_Used := True;
451
      Check_SPARK_Restriction ("select statement is not allowed", N);
452
      Check_Restriction (No_Select_Statements, N);
453
 
454
      --  Ada 2005 (AI-345): The trigger may be a dispatching call
455
 
456
      if Ada_Version >= Ada_2005 then
457
         Analyze (Trigger);
458
         Check_Triggering_Statement (Trigger, N, Is_Disp_Select);
459
      end if;
460
 
461
      if List_Length (Else_Statements (N)) = 1
462
        and then Nkind (First (Else_Statements (N))) in N_Delay_Statement
463
      then
464
         Error_Msg_N
465
           ("suspicious form of conditional entry call?!", N);
466
         Error_Msg_N
467
           ("\`SELECT OR` may be intended rather than `SELECT ELSE`!", N);
468
      end if;
469
 
470
      --  Postpone the analysis of the statements till expansion. Analyze only
471
      --  if the expander is disabled in order to catch any semantic errors.
472
 
473
      if Is_Disp_Select then
474
         if not Expander_Active then
475
            Analyze (Entry_Call_Alternative (N));
476
            Analyze_Statements (Else_Statements (N));
477
         end if;
478
 
479
      --  Regular select analysis
480
 
481
      else
482
         Analyze (Entry_Call_Alternative (N));
483
         Analyze_Statements (Else_Statements (N));
484
      end if;
485
   end Analyze_Conditional_Entry_Call;
486
 
487
   --------------------------------
488
   -- Analyze_Delay_Alternative  --
489
   --------------------------------
490
 
491
   procedure Analyze_Delay_Alternative (N : Node_Id) is
492
      Expr : Node_Id;
493
      Typ  : Entity_Id;
494
 
495
   begin
496
      Tasking_Used := True;
497
      Check_Restriction (No_Delay, N);
498
 
499
      if Present (Pragmas_Before (N)) then
500
         Analyze_List (Pragmas_Before (N));
501
      end if;
502
 
503
      if Nkind_In (Parent (N), N_Selective_Accept, N_Timed_Entry_Call) then
504
         Expr := Expression (Delay_Statement (N));
505
 
506
         --  Defer full analysis until the statement is expanded, to insure
507
         --  that generated code does not move past the guard. The delay
508
         --  expression is only evaluated if the guard is open.
509
 
510
         if Nkind (Delay_Statement (N)) = N_Delay_Relative_Statement then
511
            Preanalyze_And_Resolve (Expr, Standard_Duration);
512
         else
513
            Preanalyze_And_Resolve (Expr);
514
         end if;
515
 
516
         Typ := First_Subtype (Etype (Expr));
517
 
518
         if Nkind (Delay_Statement (N)) = N_Delay_Until_Statement
519
           and then not Is_RTE (Typ, RO_CA_Time)
520
           and then not Is_RTE (Typ, RO_RT_Time)
521
         then
522
            Error_Msg_N ("expect Time types for `DELAY UNTIL`", Expr);
523
         end if;
524
 
525
         Check_Restriction (No_Fixed_Point, Expr);
526
 
527
      else
528
         Analyze (Delay_Statement (N));
529
      end if;
530
 
531
      if Present (Condition (N)) then
532
         Analyze_And_Resolve (Condition (N), Any_Boolean);
533
      end if;
534
 
535
      if Is_Non_Empty_List (Statements (N)) then
536
         Analyze_Statements (Statements (N));
537
      end if;
538
   end Analyze_Delay_Alternative;
539
 
540
   ----------------------------
541
   -- Analyze_Delay_Relative --
542
   ----------------------------
543
 
544
   procedure Analyze_Delay_Relative (N : Node_Id) is
545
      E : constant Node_Id := Expression (N);
546
   begin
547
      Tasking_Used := True;
548
      Check_SPARK_Restriction ("delay statement is not allowed", N);
549
      Check_Restriction (No_Relative_Delay, N);
550
      Check_Restriction (No_Delay, N);
551
      Check_Potentially_Blocking_Operation (N);
552
      Analyze_And_Resolve (E, Standard_Duration);
553
      Check_Restriction (No_Fixed_Point, E);
554
   end Analyze_Delay_Relative;
555
 
556
   -------------------------
557
   -- Analyze_Delay_Until --
558
   -------------------------
559
 
560
   procedure Analyze_Delay_Until (N : Node_Id) is
561
      E   : constant Node_Id := Expression (N);
562
      Typ : Entity_Id;
563
 
564
   begin
565
      Tasking_Used := True;
566
      Check_SPARK_Restriction ("delay statement is not allowed", N);
567
      Check_Restriction (No_Delay, N);
568
      Check_Potentially_Blocking_Operation (N);
569
      Analyze (E);
570
      Typ := First_Subtype (Etype (E));
571
 
572
      if not Is_RTE (Typ, RO_CA_Time) and then
573
         not Is_RTE (Typ, RO_RT_Time)
574
      then
575
         Error_Msg_N ("expect Time types for `DELAY UNTIL`", E);
576
      end if;
577
   end Analyze_Delay_Until;
578
 
579
   ------------------------
580
   -- Analyze_Entry_Body --
581
   ------------------------
582
 
583
   procedure Analyze_Entry_Body (N : Node_Id) is
584
      Id         : constant Entity_Id := Defining_Identifier (N);
585
      Decls      : constant List_Id   := Declarations (N);
586
      Stats      : constant Node_Id   := Handled_Statement_Sequence (N);
587
      Formals    : constant Node_Id   := Entry_Body_Formal_Part (N);
588
      P_Type     : constant Entity_Id := Current_Scope;
589
      E          : Entity_Id;
590
      Entry_Name : Entity_Id;
591
 
592
   begin
593
      Tasking_Used := True;
594
 
595
      --  Entry_Name is initialized to Any_Id. It should get reset to the
596
      --  matching entry entity. An error is signalled if it is not reset
597
 
598
      Entry_Name := Any_Id;
599
 
600
      Analyze (Formals);
601
 
602
      if Present (Entry_Index_Specification (Formals)) then
603
         Set_Ekind (Id, E_Entry_Family);
604
      else
605
         Set_Ekind (Id, E_Entry);
606
      end if;
607
 
608
      Set_Scope          (Id, Current_Scope);
609
      Set_Etype          (Id, Standard_Void_Type);
610
      Set_Accept_Address (Id, New_Elmt_List);
611
 
612
      E := First_Entity (P_Type);
613
      while Present (E) loop
614
         if Chars (E) = Chars (Id)
615
           and then (Ekind (E) = Ekind (Id))
616
           and then Type_Conformant (Id, E)
617
         then
618
            Entry_Name := E;
619
            Set_Convention (Id, Convention (E));
620
            Set_Corresponding_Body (Parent (Entry_Name), Id);
621
            Check_Fully_Conformant (Id, E, N);
622
 
623
            if Ekind (Id) = E_Entry_Family then
624
               if not Fully_Conformant_Discrete_Subtypes (
625
                  Discrete_Subtype_Definition (Parent (E)),
626
                  Discrete_Subtype_Definition
627
                    (Entry_Index_Specification (Formals)))
628
               then
629
                  Error_Msg_N
630
                    ("index not fully conformant with previous declaration",
631
                      Discrete_Subtype_Definition
632
                       (Entry_Index_Specification (Formals)));
633
 
634
               else
635
                  --  The elaboration of the entry body does not recompute the
636
                  --  bounds of the index, which may have side effects. Inherit
637
                  --  the bounds from the entry declaration. This is critical
638
                  --  if the entry has a per-object constraint. If a bound is
639
                  --  given by a discriminant, it must be reanalyzed in order
640
                  --  to capture the discriminal of the current entry, rather
641
                  --  than that of the protected type.
642
 
643
                  declare
644
                     Index_Spec : constant Node_Id :=
645
                                    Entry_Index_Specification (Formals);
646
 
647
                     Def : constant Node_Id :=
648
                             New_Copy_Tree
649
                               (Discrete_Subtype_Definition (Parent (E)));
650
 
651
                  begin
652
                     if Nkind
653
                       (Original_Node
654
                         (Discrete_Subtype_Definition (Index_Spec))) = N_Range
655
                     then
656
                        Set_Etype (Def, Empty);
657
                        Set_Analyzed (Def, False);
658
 
659
                        --  Keep the original subtree to ensure a properly
660
                        --  formed tree (e.g. for ASIS use).
661
 
662
                        Rewrite
663
                          (Discrete_Subtype_Definition (Index_Spec), Def);
664
 
665
                        Set_Analyzed (Low_Bound (Def), False);
666
                        Set_Analyzed (High_Bound (Def), False);
667
 
668
                        if Denotes_Discriminant (Low_Bound (Def)) then
669
                           Set_Entity (Low_Bound (Def), Empty);
670
                        end if;
671
 
672
                        if Denotes_Discriminant (High_Bound (Def)) then
673
                           Set_Entity (High_Bound (Def), Empty);
674
                        end if;
675
 
676
                        Analyze (Def);
677
                        Make_Index (Def, Index_Spec);
678
                        Set_Etype
679
                          (Defining_Identifier (Index_Spec), Etype (Def));
680
                     end if;
681
                  end;
682
               end if;
683
            end if;
684
 
685
            exit;
686
         end if;
687
 
688
         Next_Entity (E);
689
      end loop;
690
 
691
      if Entry_Name = Any_Id then
692
         Error_Msg_N ("no entry declaration matches entry body",  N);
693
         return;
694
 
695
      elsif Has_Completion (Entry_Name) then
696
         Error_Msg_N ("duplicate entry body", N);
697
         return;
698
 
699
      else
700
         Set_Has_Completion (Entry_Name);
701
         Generate_Reference (Entry_Name, Id, 'b', Set_Ref => False);
702
         Style.Check_Identifier (Id, Entry_Name);
703
      end if;
704
 
705
      Exp_Ch9.Expand_Entry_Barrier (N, Entry_Name);
706
      Push_Scope (Entry_Name);
707
 
708
      Install_Declarations (Entry_Name);
709
      Set_Actual_Subtypes (N, Current_Scope);
710
 
711
      --  The entity for the protected subprogram corresponding to the entry
712
      --  has been created. We retain the name of this entity in the entry
713
      --  body, for use when the corresponding subprogram body is created.
714
      --  Note that entry bodies have no corresponding_spec, and there is no
715
      --  easy link back in the tree between the entry body and the entity for
716
      --  the entry itself, which is why we must propagate some attributes
717
      --  explicitly from spec to body.
718
 
719
      Set_Protected_Body_Subprogram
720
        (Id, Protected_Body_Subprogram (Entry_Name));
721
 
722
      Set_Entry_Parameters_Type
723
        (Id, Entry_Parameters_Type (Entry_Name));
724
 
725
      --  Add a declaration for the Protection object, renaming declarations
726
      --  for the discriminals and privals and finally a declaration for the
727
      --  entry family index (if applicable).
728
 
729
      if Full_Expander_Active
730
        and then Is_Protected_Type (P_Type)
731
      then
732
         Install_Private_Data_Declarations
733
           (Sloc (N), Entry_Name, P_Type, N, Decls);
734
      end if;
735
 
736
      if Present (Decls) then
737
         Analyze_Declarations (Decls);
738
         Inspect_Deferred_Constant_Completion (Decls);
739
      end if;
740
 
741
      if Present (Stats) then
742
         Analyze (Stats);
743
      end if;
744
 
745
      --  Check for unreferenced variables etc. Before the Check_References
746
      --  call, we transfer Never_Set_In_Source and Referenced flags from
747
      --  parameters in the spec to the corresponding entities in the body,
748
      --  since we want the warnings on the body entities. Note that we do
749
      --  not have to transfer Referenced_As_LHS, since that flag can only
750
      --  be set for simple variables.
751
 
752
      --  At the same time, we set the flags on the spec entities to suppress
753
      --  any warnings on the spec formals, since we also scan the spec.
754
      --  Finally, we propagate the Entry_Component attribute to the body
755
      --  formals, for use in the renaming declarations created later for the
756
      --  formals (see exp_ch9.Add_Formal_Renamings).
757
 
758
      declare
759
         E1 : Entity_Id;
760
         E2 : Entity_Id;
761
 
762
      begin
763
         E1 := First_Entity (Entry_Name);
764
         while Present (E1) loop
765
            E2 := First_Entity (Id);
766
            while Present (E2) loop
767
               exit when Chars (E1) = Chars (E2);
768
               Next_Entity (E2);
769
            end loop;
770
 
771
            --  If no matching body entity, then we already had a detected
772
            --  error of some kind, so just don't worry about these warnings.
773
 
774
            if No (E2) then
775
               goto Continue;
776
            end if;
777
 
778
            if Ekind (E1) = E_Out_Parameter then
779
               Set_Never_Set_In_Source (E2, Never_Set_In_Source (E1));
780
               Set_Never_Set_In_Source (E1, False);
781
            end if;
782
 
783
            Set_Referenced (E2, Referenced (E1));
784
            Set_Referenced (E1);
785
            Set_Entry_Component (E2, Entry_Component (E1));
786
 
787
         <<Continue>>
788
            Next_Entity (E1);
789
         end loop;
790
 
791
         Check_References (Id);
792
      end;
793
 
794
      --  We still need to check references for the spec, since objects
795
      --  declared in the body are chained (in the First_Entity sense) to
796
      --  the spec rather than the body in the case of entries.
797
 
798
      Check_References (Entry_Name);
799
 
800
      --  Process the end label, and terminate the scope
801
 
802
      Process_End_Label (Handled_Statement_Sequence (N), 't', Entry_Name);
803
      End_Scope;
804
 
805
      --  If this is an entry family, remove the loop created to provide
806
      --  a scope for the entry index.
807
 
808
      if Ekind (Id) = E_Entry_Family
809
        and then Present (Entry_Index_Specification (Formals))
810
      then
811
         End_Scope;
812
      end if;
813
   end Analyze_Entry_Body;
814
 
815
   ------------------------------------
816
   -- Analyze_Entry_Body_Formal_Part --
817
   ------------------------------------
818
 
819
   procedure Analyze_Entry_Body_Formal_Part (N : Node_Id) is
820
      Id      : constant Entity_Id := Defining_Identifier (Parent (N));
821
      Index   : constant Node_Id   := Entry_Index_Specification (N);
822
      Formals : constant List_Id   := Parameter_Specifications (N);
823
 
824
   begin
825
      Tasking_Used := True;
826
 
827
      if Present (Index) then
828
         Analyze (Index);
829
 
830
         --  The entry index functions like a loop variable, thus it is known
831
         --  to have a valid value.
832
 
833
         Set_Is_Known_Valid (Defining_Identifier (Index));
834
      end if;
835
 
836
      if Present (Formals) then
837
         Set_Scope (Id, Current_Scope);
838
         Push_Scope (Id);
839
         Process_Formals (Formals, Parent (N));
840
         End_Scope;
841
      end if;
842
   end Analyze_Entry_Body_Formal_Part;
843
 
844
   ------------------------------------
845
   -- Analyze_Entry_Call_Alternative --
846
   ------------------------------------
847
 
848
   procedure Analyze_Entry_Call_Alternative (N : Node_Id) is
849
      Call : constant Node_Id := Entry_Call_Statement (N);
850
 
851
   begin
852
      Tasking_Used := True;
853
      Check_SPARK_Restriction ("entry call is not allowed", N);
854
 
855
      if Present (Pragmas_Before (N)) then
856
         Analyze_List (Pragmas_Before (N));
857
      end if;
858
 
859
      if Nkind (Call) = N_Attribute_Reference then
860
 
861
         --  Possibly a stream attribute, but definitely illegal. Other
862
         --  illegalities, such as procedure calls, are diagnosed after
863
         --  resolution.
864
 
865
         Error_Msg_N ("entry call alternative requires an entry call", Call);
866
         return;
867
      end if;
868
 
869
      Analyze (Call);
870
 
871
      if Is_Non_Empty_List (Statements (N)) then
872
         Analyze_Statements (Statements (N));
873
      end if;
874
   end Analyze_Entry_Call_Alternative;
875
 
876
   -------------------------------
877
   -- Analyze_Entry_Declaration --
878
   -------------------------------
879
 
880
   procedure Analyze_Entry_Declaration (N : Node_Id) is
881
      D_Sdef  : constant Node_Id   := Discrete_Subtype_Definition (N);
882
      Def_Id  : constant Entity_Id := Defining_Identifier (N);
883
      Formals : constant List_Id   := Parameter_Specifications (N);
884
 
885
   begin
886
      Generate_Definition (Def_Id);
887
      Set_Contract (Def_Id, Make_Contract (Sloc (Def_Id)));
888
      Tasking_Used := True;
889
 
890
      --  Case of no discrete subtype definition
891
 
892
      if No (D_Sdef) then
893
         Set_Ekind (Def_Id, E_Entry);
894
 
895
      --  Processing for discrete subtype definition present
896
 
897
      else
898
         Enter_Name (Def_Id);
899
         Set_Ekind (Def_Id, E_Entry_Family);
900
         Analyze (D_Sdef);
901
         Make_Index (D_Sdef, N, Def_Id);
902
 
903
         --  Check subtype with predicate in entry family
904
 
905
         Bad_Predicated_Subtype_Use
906
           ("subtype& has predicate, not allowed in entry family",
907
            D_Sdef, Etype (D_Sdef));
908
 
909
         --  Check entry family static bounds outside allowed limits
910
 
911
         --  Note: originally this check was not performed here, but in that
912
         --  case the check happens deep in the expander, and the message is
913
         --  posted at the wrong location, and omitted in -gnatc mode.
914
         --  If the type of the entry index is a generic formal, no check
915
         --  is possible. In an instance, the check is not static and a run-
916
         --  time exception will be raised if the bounds are unreasonable.
917
 
918
         declare
919
            PEI : constant Entity_Id := RTE (RE_Protected_Entry_Index);
920
            LB  : constant Uint      := Expr_Value (Type_Low_Bound (PEI));
921
            UB  : constant Uint      := Expr_Value (Type_High_Bound (PEI));
922
 
923
            LBR : Node_Id;
924
            UBR : Node_Id;
925
 
926
         begin
927
 
928
            --  No bounds checking if the type is generic or if previous error.
929
            --  In an instance the check is dynamic.
930
 
931
            if Is_Generic_Type (Etype (D_Sdef))
932
              or else In_Instance
933
              or else Error_Posted (D_Sdef)
934
            then
935
               goto Skip_LB;
936
 
937
            elsif Nkind (D_Sdef) = N_Range then
938
               LBR := Low_Bound (D_Sdef);
939
 
940
            elsif Is_Entity_Name (D_Sdef)
941
              and then Is_Type (Entity (D_Sdef))
942
            then
943
               LBR := Type_Low_Bound (Entity (D_Sdef));
944
 
945
            else
946
               goto Skip_LB;
947
            end if;
948
 
949
            if Is_Static_Expression (LBR)
950
              and then Expr_Value (LBR) < LB
951
            then
952
               Error_Msg_Uint_1 := LB;
953
               Error_Msg_N ("entry family low bound must be '>'= ^!", D_Sdef);
954
            end if;
955
 
956
         <<Skip_LB>>
957
            if Is_Generic_Type (Etype (D_Sdef))
958
              or else In_Instance
959
              or else Error_Posted (D_Sdef)
960
            then
961
               goto Skip_UB;
962
 
963
            elsif Nkind (D_Sdef) = N_Range then
964
               UBR := High_Bound (D_Sdef);
965
 
966
            elsif Is_Entity_Name (D_Sdef)
967
              and then Is_Type (Entity (D_Sdef))
968
            then
969
               UBR := Type_High_Bound (Entity (D_Sdef));
970
 
971
            else
972
               goto Skip_UB;
973
            end if;
974
 
975
            if Is_Static_Expression (UBR)
976
              and then Expr_Value (UBR) > UB
977
            then
978
               Error_Msg_Uint_1 := UB;
979
               Error_Msg_N ("entry family high bound must be '<'= ^!", D_Sdef);
980
            end if;
981
 
982
         <<Skip_UB>>
983
            null;
984
         end;
985
      end if;
986
 
987
      --  Decorate Def_Id
988
 
989
      Set_Etype          (Def_Id, Standard_Void_Type);
990
      Set_Convention     (Def_Id, Convention_Entry);
991
      Set_Accept_Address (Def_Id, New_Elmt_List);
992
 
993
      --  Process formals
994
 
995
      if Present (Formals) then
996
         Set_Scope (Def_Id, Current_Scope);
997
         Push_Scope (Def_Id);
998
         Process_Formals (Formals, N);
999
         Create_Extra_Formals (Def_Id);
1000
         End_Scope;
1001
      end if;
1002
 
1003
      if Ekind (Def_Id) = E_Entry then
1004
         New_Overloaded_Entity (Def_Id);
1005
      end if;
1006
 
1007
      Generate_Reference_To_Formals (Def_Id);
1008
 
1009
      if Has_Aspects (N) then
1010
         Analyze_Aspect_Specifications (N, Def_Id);
1011
      end if;
1012
   end Analyze_Entry_Declaration;
1013
 
1014
   ---------------------------------------
1015
   -- Analyze_Entry_Index_Specification --
1016
   ---------------------------------------
1017
 
1018
   --  The Defining_Identifier of the entry index specification is local to the
1019
   --  entry body, but it must be available in the entry barrier which is
1020
   --  evaluated outside of the entry body. The index is eventually renamed as
1021
   --  a run-time object, so is visibility is strictly a front-end concern. In
1022
   --  order to make it available to the barrier, we create an additional
1023
   --  scope, as for a loop, whose only declaration is the index name. This
1024
   --  loop is not attached to the tree and does not appear as an entity local
1025
   --  to the protected type, so its existence need only be known to routines
1026
   --  that process entry families.
1027
 
1028
   procedure Analyze_Entry_Index_Specification (N : Node_Id) is
1029
      Iden    : constant Node_Id   := Defining_Identifier (N);
1030
      Def     : constant Node_Id   := Discrete_Subtype_Definition (N);
1031
      Loop_Id : constant Entity_Id := Make_Temporary (Sloc (N), 'L');
1032
 
1033
   begin
1034
      Tasking_Used := True;
1035
      Analyze (Def);
1036
 
1037
      --  There is no elaboration of the entry index specification. Therefore,
1038
      --  if the index is a range, it is not resolved and expanded, but the
1039
      --  bounds are inherited from the entry declaration, and reanalyzed.
1040
      --  See Analyze_Entry_Body.
1041
 
1042
      if Nkind (Def) /= N_Range then
1043
         Make_Index (Def, N);
1044
      end if;
1045
 
1046
      Set_Ekind (Loop_Id, E_Loop);
1047
      Set_Scope (Loop_Id, Current_Scope);
1048
      Push_Scope (Loop_Id);
1049
      Enter_Name (Iden);
1050
      Set_Ekind (Iden, E_Entry_Index_Parameter);
1051
      Set_Etype (Iden, Etype (Def));
1052
   end Analyze_Entry_Index_Specification;
1053
 
1054
   ----------------------------
1055
   -- Analyze_Protected_Body --
1056
   ----------------------------
1057
 
1058
   procedure Analyze_Protected_Body (N : Node_Id) is
1059
      Body_Id : constant Entity_Id := Defining_Identifier (N);
1060
      Last_E  : Entity_Id;
1061
 
1062
      Spec_Id : Entity_Id;
1063
      --  This is initially the entity of the protected object or protected
1064
      --  type involved, but is replaced by the protected type always in the
1065
      --  case of a single protected declaration, since this is the proper
1066
      --  scope to be used.
1067
 
1068
      Ref_Id : Entity_Id;
1069
      --  This is the entity of the protected object or protected type
1070
      --  involved, and is the entity used for cross-reference purposes (it
1071
      --  differs from Spec_Id in the case of a single protected object, since
1072
      --  Spec_Id is set to the protected type in this case).
1073
 
1074
   begin
1075
      Tasking_Used := True;
1076
      Set_Ekind (Body_Id, E_Protected_Body);
1077
      Spec_Id := Find_Concurrent_Spec (Body_Id);
1078
 
1079
      if Present (Spec_Id)
1080
        and then Ekind (Spec_Id) = E_Protected_Type
1081
      then
1082
         null;
1083
 
1084
      elsif Present (Spec_Id)
1085
        and then Ekind (Etype (Spec_Id)) = E_Protected_Type
1086
        and then not Comes_From_Source (Etype (Spec_Id))
1087
      then
1088
         null;
1089
 
1090
      else
1091
         Error_Msg_N ("missing specification for protected body", Body_Id);
1092
         return;
1093
      end if;
1094
 
1095
      Ref_Id := Spec_Id;
1096
      Generate_Reference (Ref_Id, Body_Id, 'b', Set_Ref => False);
1097
      Style.Check_Identifier (Body_Id, Spec_Id);
1098
 
1099
      --  The declarations are always attached to the type
1100
 
1101
      if Ekind (Spec_Id) /= E_Protected_Type then
1102
         Spec_Id := Etype (Spec_Id);
1103
      end if;
1104
 
1105
      Push_Scope (Spec_Id);
1106
      Set_Corresponding_Spec (N, Spec_Id);
1107
      Set_Corresponding_Body (Parent (Spec_Id), Body_Id);
1108
      Set_Has_Completion (Spec_Id);
1109
      Install_Declarations (Spec_Id);
1110
 
1111
      Expand_Protected_Body_Declarations (N, Spec_Id);
1112
 
1113
      Last_E := Last_Entity (Spec_Id);
1114
 
1115
      Analyze_Declarations (Declarations (N));
1116
 
1117
      --  For visibility purposes, all entities in the body are private. Set
1118
      --  First_Private_Entity accordingly, if there was no private part in the
1119
      --  protected declaration.
1120
 
1121
      if No (First_Private_Entity (Spec_Id)) then
1122
         if Present (Last_E) then
1123
            Set_First_Private_Entity (Spec_Id, Next_Entity (Last_E));
1124
         else
1125
            Set_First_Private_Entity (Spec_Id, First_Entity (Spec_Id));
1126
         end if;
1127
      end if;
1128
 
1129
      Check_Completion (Body_Id);
1130
      Check_References (Spec_Id);
1131
      Process_End_Label (N, 't', Ref_Id);
1132
      End_Scope;
1133
   end Analyze_Protected_Body;
1134
 
1135
   ----------------------------------
1136
   -- Analyze_Protected_Definition --
1137
   ----------------------------------
1138
 
1139
   procedure Analyze_Protected_Definition (N : Node_Id) is
1140
      E : Entity_Id;
1141
      L : Entity_Id;
1142
 
1143
      procedure Undelay_Itypes (T : Entity_Id);
1144
      --  Itypes created for the private components of a protected type
1145
      --  do not receive freeze nodes, because there is no scope in which
1146
      --  they can be elaborated, and they can depend on discriminants of
1147
      --  the enclosed protected type. Given that the components can be
1148
      --  composite types with inner components, we traverse recursively
1149
      --  the private components of the protected type, and indicate that
1150
      --  all itypes within are frozen. This ensures that no freeze nodes
1151
      --  will be generated for them.
1152
      --
1153
      --  On the other hand, components of the corresponding record are
1154
      --  frozen (or receive itype references) as for other records.
1155
 
1156
      --------------------
1157
      -- Undelay_Itypes --
1158
      --------------------
1159
 
1160
      procedure Undelay_Itypes (T : Entity_Id) is
1161
         Comp : Entity_Id;
1162
 
1163
      begin
1164
         if Is_Protected_Type (T) then
1165
            Comp := First_Private_Entity (T);
1166
         elsif Is_Record_Type (T) then
1167
            Comp := First_Entity (T);
1168
         else
1169
            return;
1170
         end if;
1171
 
1172
         while Present (Comp) loop
1173
            if Is_Type (Comp)
1174
              and then Is_Itype (Comp)
1175
            then
1176
               Set_Has_Delayed_Freeze (Comp, False);
1177
               Set_Is_Frozen (Comp);
1178
 
1179
               if Is_Record_Type (Comp)
1180
                 or else Is_Protected_Type (Comp)
1181
               then
1182
                  Undelay_Itypes (Comp);
1183
               end if;
1184
            end if;
1185
 
1186
            Next_Entity (Comp);
1187
         end loop;
1188
      end Undelay_Itypes;
1189
 
1190
   --  Start of processing for Analyze_Protected_Definition
1191
 
1192
   begin
1193
      Tasking_Used := True;
1194
      Check_SPARK_Restriction ("protected definition is not allowed", N);
1195
      Analyze_Declarations (Visible_Declarations (N));
1196
 
1197
      if Present (Private_Declarations (N))
1198
        and then not Is_Empty_List (Private_Declarations (N))
1199
      then
1200
         L := Last_Entity (Current_Scope);
1201
         Analyze_Declarations (Private_Declarations (N));
1202
 
1203
         if Present (L) then
1204
            Set_First_Private_Entity (Current_Scope, Next_Entity (L));
1205
         else
1206
            Set_First_Private_Entity (Current_Scope,
1207
              First_Entity (Current_Scope));
1208
         end if;
1209
      end if;
1210
 
1211
      E := First_Entity (Current_Scope);
1212
      while Present (E) loop
1213
         if Ekind_In (E, E_Function, E_Procedure) then
1214
            Set_Convention (E, Convention_Protected);
1215
 
1216
         elsif Is_Task_Type (Etype (E))
1217
           or else Has_Task (Etype (E))
1218
         then
1219
            Set_Has_Task (Current_Scope);
1220
         end if;
1221
 
1222
         Next_Entity (E);
1223
      end loop;
1224
 
1225
      Undelay_Itypes (Current_Scope);
1226
 
1227
      Check_Max_Entries (N, Max_Protected_Entries);
1228
      Process_End_Label (N, 'e', Current_Scope);
1229
   end Analyze_Protected_Definition;
1230
 
1231
   ----------------------------------------
1232
   -- Analyze_Protected_Type_Declaration --
1233
   ----------------------------------------
1234
 
1235
   procedure Analyze_Protected_Type_Declaration (N : Node_Id) is
1236
      Def_Id : constant Entity_Id := Defining_Identifier (N);
1237
      E      : Entity_Id;
1238
      T      : Entity_Id;
1239
 
1240
   begin
1241
      if No_Run_Time_Mode then
1242
         Error_Msg_CRT ("protected type", N);
1243
 
1244
         if Has_Aspects (N) then
1245
            Analyze_Aspect_Specifications (N, Def_Id);
1246
         end if;
1247
 
1248
         return;
1249
      end if;
1250
 
1251
      Tasking_Used := True;
1252
      Check_Restriction (No_Protected_Types, N);
1253
 
1254
      T := Find_Type_Name (N);
1255
 
1256
      --  In the case of an incomplete type, use the full view, unless it's not
1257
      --  present (as can occur for an incomplete view from a limited with).
1258
 
1259
      if Ekind (T) = E_Incomplete_Type and then Present (Full_View (T)) then
1260
         T := Full_View (T);
1261
         Set_Completion_Referenced (T);
1262
      end if;
1263
 
1264
      Set_Ekind              (T, E_Protected_Type);
1265
      Set_Is_First_Subtype   (T, True);
1266
      Init_Size_Align        (T);
1267
      Set_Etype              (T, T);
1268
      Set_Has_Delayed_Freeze (T, True);
1269
      Set_Stored_Constraint  (T, No_Elist);
1270
      Push_Scope (T);
1271
 
1272
      if Ada_Version >= Ada_2005 then
1273
         Check_Interfaces (N, T);
1274
      end if;
1275
 
1276
      if Present (Discriminant_Specifications (N)) then
1277
         if Has_Discriminants (T) then
1278
 
1279
            --  Install discriminants. Also, verify conformance of
1280
            --  discriminants of previous and current view. ???
1281
 
1282
            Install_Declarations (T);
1283
         else
1284
            Process_Discriminants (N);
1285
         end if;
1286
      end if;
1287
 
1288
      Set_Is_Constrained (T, not Has_Discriminants (T));
1289
 
1290
      --  If aspects are present, analyze them now. They can make references
1291
      --  to the discriminants of the type, but not to any components.
1292
 
1293
      if Has_Aspects (N) then
1294
         Analyze_Aspect_Specifications (N, Def_Id);
1295
      end if;
1296
 
1297
      Analyze (Protected_Definition (N));
1298
 
1299
      --  In the case where the protected type is declared at a nested level
1300
      --  and the No_Local_Protected_Objects restriction applies, issue a
1301
      --  warning that objects of the type will violate the restriction.
1302
 
1303
      if Restriction_Check_Required (No_Local_Protected_Objects)
1304
        and then not Is_Library_Level_Entity (T)
1305
        and then Comes_From_Source (T)
1306
      then
1307
         Error_Msg_Sloc := Restrictions_Loc (No_Local_Protected_Objects);
1308
 
1309
         if Error_Msg_Sloc = No_Location then
1310
            Error_Msg_N
1311
              ("objects of this type will violate " &
1312
               "`No_Local_Protected_Objects`?", N);
1313
         else
1314
            Error_Msg_N
1315
              ("objects of this type will violate " &
1316
               "`No_Local_Protected_Objects`?#", N);
1317
         end if;
1318
      end if;
1319
 
1320
      --  Protected types with entries are controlled (because of the
1321
      --  Protection component if nothing else), same for any protected type
1322
      --  with interrupt handlers. Note that we need to analyze the protected
1323
      --  definition to set Has_Entries and such.
1324
 
1325
      if (Abort_Allowed or else Restriction_Active (No_Entry_Queue) = False
1326
           or else Number_Entries (T) > 1)
1327
        and then
1328
          (Has_Entries (T)
1329
            or else Has_Interrupt_Handler (T)
1330
            or else Has_Attach_Handler (T))
1331
      then
1332
         Set_Has_Controlled_Component (T, True);
1333
      end if;
1334
 
1335
      --  The Ekind of components is E_Void during analysis to detect illegal
1336
      --  uses. Now it can be set correctly.
1337
 
1338
      E := First_Entity (Current_Scope);
1339
      while Present (E) loop
1340
         if Ekind (E) = E_Void then
1341
            Set_Ekind (E, E_Component);
1342
            Init_Component_Location (E);
1343
         end if;
1344
 
1345
         Next_Entity (E);
1346
      end loop;
1347
 
1348
      End_Scope;
1349
 
1350
      --  Case of a completion of a private declaration
1351
 
1352
      if T /= Def_Id
1353
        and then Is_Private_Type (Def_Id)
1354
      then
1355
         --  Deal with preelaborable initialization. Note that this processing
1356
         --  is done by Process_Full_View, but as can be seen below, in this
1357
         --  case the call to Process_Full_View is skipped if any serious
1358
         --  errors have occurred, and we don't want to lose this check.
1359
 
1360
         if Known_To_Have_Preelab_Init (Def_Id) then
1361
            Set_Must_Have_Preelab_Init (T);
1362
         end if;
1363
 
1364
         --  Create corresponding record now, because some private dependents
1365
         --  may be subtypes of the partial view.
1366
 
1367
         --  Skip if errors are present, to prevent cascaded messages
1368
 
1369
         if Serious_Errors_Detected = 0
1370
 
1371
           --  Also skip if expander is not active
1372
 
1373
           and then Full_Expander_Active
1374
         then
1375
            Expand_N_Protected_Type_Declaration (N);
1376
            Process_Full_View (N, T, Def_Id);
1377
         end if;
1378
      end if;
1379
   end Analyze_Protected_Type_Declaration;
1380
 
1381
   ---------------------
1382
   -- Analyze_Requeue --
1383
   ---------------------
1384
 
1385
   procedure Analyze_Requeue (N : Node_Id) is
1386
      Count       : Natural := 0;
1387
      Entry_Name  : Node_Id := Name (N);
1388
      Entry_Id    : Entity_Id;
1389
      I           : Interp_Index;
1390
      Is_Disp_Req : Boolean;
1391
      It          : Interp;
1392
      Enclosing   : Entity_Id;
1393
      Target_Obj  : Node_Id := Empty;
1394
      Req_Scope   : Entity_Id;
1395
      Outer_Ent   : Entity_Id;
1396
      Synch_Type  : Entity_Id;
1397
 
1398
   begin
1399
      Tasking_Used := True;
1400
      Check_SPARK_Restriction ("requeue statement is not allowed", N);
1401
      Check_Restriction (No_Requeue_Statements, N);
1402
      Check_Unreachable_Code (N);
1403
 
1404
      Enclosing := Empty;
1405
      for J in reverse 0 .. Scope_Stack.Last loop
1406
         Enclosing := Scope_Stack.Table (J).Entity;
1407
         exit when Is_Entry (Enclosing);
1408
 
1409
         if not Ekind_In (Enclosing, E_Block, E_Loop) then
1410
            Error_Msg_N ("requeue must appear within accept or entry body", N);
1411
            return;
1412
         end if;
1413
      end loop;
1414
 
1415
      Analyze (Entry_Name);
1416
 
1417
      if Etype (Entry_Name) = Any_Type then
1418
         return;
1419
      end if;
1420
 
1421
      if Nkind (Entry_Name) = N_Selected_Component then
1422
         Target_Obj := Prefix (Entry_Name);
1423
         Entry_Name := Selector_Name (Entry_Name);
1424
      end if;
1425
 
1426
      --  If an explicit target object is given then we have to check the
1427
      --  restrictions of 9.5.4(6).
1428
 
1429
      if Present (Target_Obj) then
1430
 
1431
         --  Locate containing concurrent unit and determine enclosing entry
1432
         --  body or outermost enclosing accept statement within the unit.
1433
 
1434
         Outer_Ent := Empty;
1435
         for S in reverse 0 .. Scope_Stack.Last loop
1436
            Req_Scope := Scope_Stack.Table (S).Entity;
1437
 
1438
            exit when Ekind (Req_Scope) in Task_Kind
1439
              or else Ekind (Req_Scope) in Protected_Kind;
1440
 
1441
            if Is_Entry (Req_Scope) then
1442
               Outer_Ent := Req_Scope;
1443
            end if;
1444
         end loop;
1445
 
1446
         pragma Assert (Present (Outer_Ent));
1447
 
1448
         --  Check that the accessibility level of the target object is not
1449
         --  greater or equal to the outermost enclosing accept statement (or
1450
         --  entry body) unless it is a parameter of the innermost enclosing
1451
         --  accept statement (or entry body).
1452
 
1453
         if Object_Access_Level (Target_Obj) >= Scope_Depth (Outer_Ent)
1454
           and then
1455
             (not Is_Entity_Name (Target_Obj)
1456
               or else Ekind (Entity (Target_Obj)) not in Formal_Kind
1457
               or else Enclosing /= Scope (Entity (Target_Obj)))
1458
         then
1459
            Error_Msg_N
1460
              ("target object has invalid level for requeue", Target_Obj);
1461
         end if;
1462
      end if;
1463
 
1464
      --  Overloaded case, find right interpretation
1465
 
1466
      if Is_Overloaded (Entry_Name) then
1467
         Entry_Id := Empty;
1468
 
1469
         --  Loop over candidate interpretations and filter out any that are
1470
         --  not parameterless, are not type conformant, are not entries, or
1471
         --  do not come from source.
1472
 
1473
         Get_First_Interp (Entry_Name, I, It);
1474
         while Present (It.Nam) loop
1475
 
1476
            --  Note: we test type conformance here, not subtype conformance.
1477
            --  Subtype conformance will be tested later on, but it is better
1478
            --  for error output in some cases not to do that here.
1479
 
1480
            if (No (First_Formal (It.Nam))
1481
                 or else (Type_Conformant (Enclosing, It.Nam)))
1482
              and then Ekind (It.Nam) = E_Entry
1483
            then
1484
               --  Ada 2005 (AI-345): Since protected and task types have
1485
               --  primitive entry wrappers, we only consider source entries.
1486
 
1487
               if Comes_From_Source (It.Nam) then
1488
                  Count := Count + 1;
1489
                  Entry_Id := It.Nam;
1490
               else
1491
                  Remove_Interp (I);
1492
               end if;
1493
            end if;
1494
 
1495
            Get_Next_Interp (I, It);
1496
         end loop;
1497
 
1498
         if Count = 0 then
1499
            Error_Msg_N ("no entry matches context", N);
1500
            return;
1501
 
1502
         elsif Count > 1 then
1503
            Error_Msg_N ("ambiguous entry name in requeue", N);
1504
            return;
1505
 
1506
         else
1507
            Set_Is_Overloaded (Entry_Name, False);
1508
            Set_Entity (Entry_Name, Entry_Id);
1509
         end if;
1510
 
1511
      --  Non-overloaded cases
1512
 
1513
      --  For the case of a reference to an element of an entry family, the
1514
      --  Entry_Name is an indexed component.
1515
 
1516
      elsif Nkind (Entry_Name) = N_Indexed_Component then
1517
 
1518
         --  Requeue to an entry out of the body
1519
 
1520
         if Nkind (Prefix (Entry_Name)) = N_Selected_Component then
1521
            Entry_Id := Entity (Selector_Name (Prefix (Entry_Name)));
1522
 
1523
         --  Requeue from within the body itself
1524
 
1525
         elsif Nkind (Prefix (Entry_Name)) = N_Identifier then
1526
            Entry_Id := Entity (Prefix (Entry_Name));
1527
 
1528
         else
1529
            Error_Msg_N ("invalid entry_name specified",  N);
1530
            return;
1531
         end if;
1532
 
1533
      --  If we had a requeue of the form REQUEUE A (B), then the parser
1534
      --  accepted it (because it could have been a requeue on an entry index.
1535
      --  If A turns out not to be an entry family, then the analysis of A (B)
1536
      --  turned it into a function call.
1537
 
1538
      elsif Nkind (Entry_Name) = N_Function_Call then
1539
         Error_Msg_N
1540
           ("arguments not allowed in requeue statement",
1541
            First (Parameter_Associations (Entry_Name)));
1542
         return;
1543
 
1544
      --  Normal case of no entry family, no argument
1545
 
1546
      else
1547
         Entry_Id := Entity (Entry_Name);
1548
      end if;
1549
 
1550
      --  Ada 2012 (AI05-0030): Potential dispatching requeue statement. The
1551
      --  target type must be a concurrent interface class-wide type and the
1552
      --  target must be a procedure, flagged by pragma Implemented. The
1553
      --  target may be an access to class-wide type, in which case it must
1554
      --  be dereferenced.
1555
 
1556
      if Present (Target_Obj) then
1557
         Synch_Type := Etype (Target_Obj);
1558
 
1559
         if Is_Access_Type (Synch_Type) then
1560
            Synch_Type := Designated_Type (Synch_Type);
1561
         end if;
1562
      end if;
1563
 
1564
      Is_Disp_Req :=
1565
        Ada_Version >= Ada_2012
1566
          and then Present (Target_Obj)
1567
          and then Is_Class_Wide_Type (Synch_Type)
1568
          and then Is_Concurrent_Interface (Synch_Type)
1569
          and then Ekind (Entry_Id) = E_Procedure
1570
          and then Has_Rep_Pragma (Entry_Id, Name_Implemented);
1571
 
1572
      --  Resolve entry, and check that it is subtype conformant with the
1573
      --  enclosing construct if this construct has formals (RM 9.5.4(5)).
1574
      --  Ada 2005 (AI05-0030): Do not emit an error for this specific case.
1575
 
1576
      if not Is_Entry (Entry_Id)
1577
        and then not Is_Disp_Req
1578
      then
1579
         Error_Msg_N ("expect entry name in requeue statement", Name (N));
1580
 
1581
      elsif Ekind (Entry_Id) = E_Entry_Family
1582
        and then Nkind (Entry_Name) /= N_Indexed_Component
1583
      then
1584
         Error_Msg_N ("missing index for entry family component", Name (N));
1585
 
1586
      else
1587
         Resolve_Entry (Name (N));
1588
         Generate_Reference (Entry_Id, Entry_Name);
1589
 
1590
         if Present (First_Formal (Entry_Id)) then
1591
            if VM_Target = JVM_Target then
1592
               Error_Msg_N
1593
                 ("arguments unsupported in requeue statement",
1594
                  First_Formal (Entry_Id));
1595
               return;
1596
            end if;
1597
 
1598
            --  Ada 2012 (AI05-0030): Perform type conformance after skipping
1599
            --  the first parameter of Entry_Id since it is the interface
1600
            --  controlling formal.
1601
 
1602
            if Ada_Version >= Ada_2012
1603
              and then Is_Disp_Req
1604
            then
1605
               declare
1606
                  Enclosing_Formal : Entity_Id;
1607
                  Target_Formal    : Entity_Id;
1608
 
1609
               begin
1610
                  Enclosing_Formal := First_Formal (Enclosing);
1611
                  Target_Formal := Next_Formal (First_Formal (Entry_Id));
1612
                  while Present (Enclosing_Formal)
1613
                    and then Present (Target_Formal)
1614
                  loop
1615
                     if not Conforming_Types
1616
                              (T1    => Etype (Enclosing_Formal),
1617
                               T2    => Etype (Target_Formal),
1618
                               Ctype => Subtype_Conformant)
1619
                     then
1620
                        Error_Msg_Node_2 := Target_Formal;
1621
                        Error_Msg_NE
1622
                          ("formal & is not subtype conformant with &" &
1623
                           "in dispatching requeue", N, Enclosing_Formal);
1624
                     end if;
1625
 
1626
                     Next_Formal (Enclosing_Formal);
1627
                     Next_Formal (Target_Formal);
1628
                  end loop;
1629
               end;
1630
            else
1631
               Check_Subtype_Conformant (Enclosing, Entry_Id, Name (N));
1632
            end if;
1633
 
1634
            --  Processing for parameters accessed by the requeue
1635
 
1636
            declare
1637
               Ent : Entity_Id;
1638
 
1639
            begin
1640
               Ent := First_Formal (Enclosing);
1641
               while Present (Ent) loop
1642
 
1643
                  --  For OUT or IN OUT parameter, the effect of the requeue is
1644
                  --  to assign the parameter a value on exit from the requeued
1645
                  --  body, so we can set it as source assigned. We also clear
1646
                  --  the Is_True_Constant indication. We do not need to clear
1647
                  --  Current_Value, since the effect of the requeue is to
1648
                  --  perform an unconditional goto so that any further
1649
                  --  references will not occur anyway.
1650
 
1651
                  if Ekind_In (Ent, E_Out_Parameter, E_In_Out_Parameter) then
1652
                     Set_Never_Set_In_Source (Ent, False);
1653
                     Set_Is_True_Constant    (Ent, False);
1654
                  end if;
1655
 
1656
                  --  For all parameters, the requeue acts as a reference,
1657
                  --  since the value of the parameter is passed to the new
1658
                  --  entry, so we want to suppress unreferenced warnings.
1659
 
1660
                  Set_Referenced (Ent);
1661
                  Next_Formal (Ent);
1662
               end loop;
1663
            end;
1664
         end if;
1665
      end if;
1666
   end Analyze_Requeue;
1667
 
1668
   ------------------------------
1669
   -- Analyze_Selective_Accept --
1670
   ------------------------------
1671
 
1672
   procedure Analyze_Selective_Accept (N : Node_Id) is
1673
      Alts : constant List_Id := Select_Alternatives (N);
1674
      Alt  : Node_Id;
1675
 
1676
      Accept_Present    : Boolean := False;
1677
      Terminate_Present : Boolean := False;
1678
      Delay_Present     : Boolean := False;
1679
      Relative_Present  : Boolean := False;
1680
      Alt_Count         : Uint    := Uint_0;
1681
 
1682
   begin
1683
      Tasking_Used := True;
1684
      Check_SPARK_Restriction ("select statement is not allowed", N);
1685
      Check_Restriction (No_Select_Statements, N);
1686
 
1687
      --  Loop to analyze alternatives
1688
 
1689
      Alt := First (Alts);
1690
      while Present (Alt) loop
1691
         Alt_Count := Alt_Count + 1;
1692
         Analyze (Alt);
1693
 
1694
         if Nkind (Alt) = N_Delay_Alternative then
1695
            if Delay_Present then
1696
 
1697
               if Relative_Present /=
1698
                   (Nkind (Delay_Statement (Alt)) = N_Delay_Relative_Statement)
1699
               then
1700
                  Error_Msg_N
1701
                    ("delay_until and delay_relative alternatives ", Alt);
1702
                  Error_Msg_N
1703
                    ("\cannot appear in the same selective_wait", Alt);
1704
               end if;
1705
 
1706
            else
1707
               Delay_Present := True;
1708
               Relative_Present :=
1709
                 Nkind (Delay_Statement (Alt)) = N_Delay_Relative_Statement;
1710
            end if;
1711
 
1712
         elsif Nkind (Alt) = N_Terminate_Alternative then
1713
            if Terminate_Present then
1714
               Error_Msg_N ("only one terminate alternative allowed", N);
1715
            else
1716
               Terminate_Present := True;
1717
               Check_Restriction (No_Terminate_Alternatives, N);
1718
            end if;
1719
 
1720
         elsif Nkind (Alt) = N_Accept_Alternative then
1721
            Accept_Present := True;
1722
 
1723
            --  Check for duplicate accept
1724
 
1725
            declare
1726
               Alt1 : Node_Id;
1727
               Stm  : constant Node_Id := Accept_Statement (Alt);
1728
               EDN  : constant Node_Id := Entry_Direct_Name (Stm);
1729
               Ent  : Entity_Id;
1730
 
1731
            begin
1732
               if Nkind (EDN) = N_Identifier
1733
                 and then No (Condition (Alt))
1734
                 and then Present (Entity (EDN)) -- defend against junk
1735
                 and then Ekind (Entity (EDN)) = E_Entry
1736
               then
1737
                  Ent := Entity (EDN);
1738
 
1739
                  Alt1 := First (Alts);
1740
                  while Alt1 /= Alt loop
1741
                     if Nkind (Alt1) = N_Accept_Alternative
1742
                       and then No (Condition (Alt1))
1743
                     then
1744
                        declare
1745
                           Stm1 : constant Node_Id := Accept_Statement (Alt1);
1746
                           EDN1 : constant Node_Id := Entry_Direct_Name (Stm1);
1747
 
1748
                        begin
1749
                           if Nkind (EDN1) = N_Identifier then
1750
                              if Entity (EDN1) = Ent then
1751
                                 Error_Msg_Sloc := Sloc (Stm1);
1752
                                 Error_Msg_N
1753
                                   ("?accept duplicates one on line#", Stm);
1754
                                 exit;
1755
                              end if;
1756
                           end if;
1757
                        end;
1758
                     end if;
1759
 
1760
                     Next (Alt1);
1761
                  end loop;
1762
               end if;
1763
            end;
1764
         end if;
1765
 
1766
         Next (Alt);
1767
      end loop;
1768
 
1769
      Check_Restriction (Max_Select_Alternatives, N, Alt_Count);
1770
      Check_Potentially_Blocking_Operation (N);
1771
 
1772
      if Terminate_Present and Delay_Present then
1773
         Error_Msg_N ("at most one of terminate or delay alternative", N);
1774
 
1775
      elsif not Accept_Present then
1776
         Error_Msg_N
1777
           ("select must contain at least one accept alternative", N);
1778
      end if;
1779
 
1780
      if Present (Else_Statements (N)) then
1781
         if Terminate_Present or Delay_Present then
1782
            Error_Msg_N ("else part not allowed with other alternatives", N);
1783
         end if;
1784
 
1785
         Analyze_Statements (Else_Statements (N));
1786
      end if;
1787
   end Analyze_Selective_Accept;
1788
 
1789
   ------------------------------------------
1790
   -- Analyze_Single_Protected_Declaration --
1791
   ------------------------------------------
1792
 
1793
   procedure Analyze_Single_Protected_Declaration (N : Node_Id) is
1794
      Loc    : constant Source_Ptr := Sloc (N);
1795
      Id     : constant Node_Id    := Defining_Identifier (N);
1796
      T      : Entity_Id;
1797
      T_Decl : Node_Id;
1798
      O_Decl : Node_Id;
1799
      O_Name : constant Entity_Id := Id;
1800
 
1801
   begin
1802
      Generate_Definition (Id);
1803
      Tasking_Used := True;
1804
 
1805
      --  The node is rewritten as a protected type declaration, in exact
1806
      --  analogy with what is done with single tasks.
1807
 
1808
      T :=
1809
        Make_Defining_Identifier (Sloc (Id),
1810
          New_External_Name (Chars (Id), 'T'));
1811
 
1812
      T_Decl :=
1813
        Make_Protected_Type_Declaration (Loc,
1814
         Defining_Identifier => T,
1815
         Protected_Definition => Relocate_Node (Protected_Definition (N)),
1816
         Interface_List       => Interface_List (N));
1817
 
1818
      O_Decl :=
1819
        Make_Object_Declaration (Loc,
1820
          Defining_Identifier => O_Name,
1821
          Object_Definition   => Make_Identifier (Loc,  Chars (T)));
1822
 
1823
      Rewrite (N, T_Decl);
1824
      Insert_After (N, O_Decl);
1825
      Mark_Rewrite_Insertion (O_Decl);
1826
 
1827
      --  Enter names of type and object before analysis, because the name of
1828
      --  the object may be used in its own body.
1829
 
1830
      Enter_Name (T);
1831
      Set_Ekind (T, E_Protected_Type);
1832
      Set_Etype (T, T);
1833
 
1834
      Enter_Name (O_Name);
1835
      Set_Ekind (O_Name, E_Variable);
1836
      Set_Etype (O_Name, T);
1837
 
1838
      --  Instead of calling Analyze on the new node, call the proper analysis
1839
      --  procedure directly. Otherwise the node would be expanded twice, with
1840
      --  disastrous result.
1841
 
1842
      Analyze_Protected_Type_Declaration (N);
1843
 
1844
      if Has_Aspects (N) then
1845
         Analyze_Aspect_Specifications (N, Id);
1846
      end if;
1847
   end Analyze_Single_Protected_Declaration;
1848
 
1849
   -------------------------------------
1850
   -- Analyze_Single_Task_Declaration --
1851
   -------------------------------------
1852
 
1853
   procedure Analyze_Single_Task_Declaration (N : Node_Id) is
1854
      Loc    : constant Source_Ptr := Sloc (N);
1855
      Id     : constant Node_Id    := Defining_Identifier (N);
1856
      T      : Entity_Id;
1857
      T_Decl : Node_Id;
1858
      O_Decl : Node_Id;
1859
      O_Name : constant Entity_Id := Id;
1860
 
1861
   begin
1862
      Generate_Definition (Id);
1863
      Tasking_Used := True;
1864
 
1865
      --  The node is rewritten as a task type declaration, followed by an
1866
      --  object declaration of that anonymous task type.
1867
 
1868
      T :=
1869
        Make_Defining_Identifier (Sloc (Id),
1870
          New_External_Name (Chars (Id), Suffix => "TK"));
1871
 
1872
      T_Decl :=
1873
        Make_Task_Type_Declaration (Loc,
1874
          Defining_Identifier => T,
1875
          Task_Definition     => Relocate_Node (Task_Definition (N)),
1876
          Interface_List      => Interface_List (N));
1877
 
1878
      --  We use the original defining identifier of the single task in the
1879
      --  generated object declaration, so that debugging information can
1880
      --  be attached to it when compiling with -gnatD. The parent of the
1881
      --  entity is the new object declaration. The single_task_declaration
1882
      --  is not used further in semantics or code generation, but is scanned
1883
      --  when generating debug information, and therefore needs the updated
1884
      --  Sloc information for the entity (see Sprint). Aspect specifications
1885
      --  are moved from the single task node to the object declaration node.
1886
 
1887
      O_Decl :=
1888
        Make_Object_Declaration (Loc,
1889
          Defining_Identifier => O_Name,
1890
          Object_Definition   => Make_Identifier (Loc, Chars (T)));
1891
 
1892
      Rewrite (N, T_Decl);
1893
      Insert_After (N, O_Decl);
1894
      Mark_Rewrite_Insertion (O_Decl);
1895
 
1896
      --  Enter names of type and object before analysis, because the name of
1897
      --  the object may be used in its own body.
1898
 
1899
      Enter_Name (T);
1900
      Set_Ekind (T, E_Task_Type);
1901
      Set_Etype (T, T);
1902
 
1903
      Enter_Name (O_Name);
1904
      Set_Ekind (O_Name, E_Variable);
1905
      Set_Etype (O_Name, T);
1906
 
1907
      --  Instead of calling Analyze on the new node, call the proper analysis
1908
      --  procedure directly. Otherwise the node would be expanded twice, with
1909
      --  disastrous result.
1910
 
1911
      Analyze_Task_Type_Declaration (N);
1912
 
1913
      if Has_Aspects (N) then
1914
         Analyze_Aspect_Specifications (N, Id);
1915
      end if;
1916
   end Analyze_Single_Task_Declaration;
1917
 
1918
   -----------------------
1919
   -- Analyze_Task_Body --
1920
   -----------------------
1921
 
1922
   procedure Analyze_Task_Body (N : Node_Id) is
1923
      Body_Id : constant Entity_Id := Defining_Identifier (N);
1924
      Decls   : constant List_Id   := Declarations (N);
1925
      HSS     : constant Node_Id   := Handled_Statement_Sequence (N);
1926
      Last_E  : Entity_Id;
1927
 
1928
      Spec_Id : Entity_Id;
1929
      --  This is initially the entity of the task or task type involved, but
1930
      --  is replaced by the task type always in the case of a single task
1931
      --  declaration, since this is the proper scope to be used.
1932
 
1933
      Ref_Id : Entity_Id;
1934
      --  This is the entity of the task or task type, and is the entity used
1935
      --  for cross-reference purposes (it differs from Spec_Id in the case of
1936
      --  a single task, since Spec_Id is set to the task type)
1937
 
1938
   begin
1939
      Tasking_Used := True;
1940
      Set_Ekind (Body_Id, E_Task_Body);
1941
      Set_Scope (Body_Id, Current_Scope);
1942
      Spec_Id := Find_Concurrent_Spec (Body_Id);
1943
 
1944
      --  The spec is either a task type declaration, or a single task
1945
      --  declaration for which we have created an anonymous type.
1946
 
1947
      if Present (Spec_Id)
1948
        and then Ekind (Spec_Id) = E_Task_Type
1949
      then
1950
         null;
1951
 
1952
      elsif Present (Spec_Id)
1953
        and then Ekind (Etype (Spec_Id)) = E_Task_Type
1954
        and then not Comes_From_Source (Etype (Spec_Id))
1955
      then
1956
         null;
1957
 
1958
      else
1959
         Error_Msg_N ("missing specification for task body", Body_Id);
1960
         return;
1961
      end if;
1962
 
1963
      if Has_Completion (Spec_Id)
1964
        and then Present (Corresponding_Body (Parent (Spec_Id)))
1965
      then
1966
         if Nkind (Parent (Spec_Id)) = N_Task_Type_Declaration then
1967
            Error_Msg_NE ("duplicate body for task type&", N, Spec_Id);
1968
 
1969
         else
1970
            Error_Msg_NE ("duplicate body for task&", N, Spec_Id);
1971
         end if;
1972
      end if;
1973
 
1974
      Ref_Id := Spec_Id;
1975
      Generate_Reference (Ref_Id, Body_Id, 'b', Set_Ref => False);
1976
      Style.Check_Identifier (Body_Id, Spec_Id);
1977
 
1978
      --  Deal with case of body of single task (anonymous type was created)
1979
 
1980
      if Ekind (Spec_Id) = E_Variable then
1981
         Spec_Id := Etype (Spec_Id);
1982
      end if;
1983
 
1984
      Push_Scope (Spec_Id);
1985
      Set_Corresponding_Spec (N, Spec_Id);
1986
      Set_Corresponding_Body (Parent (Spec_Id), Body_Id);
1987
      Set_Has_Completion (Spec_Id);
1988
      Install_Declarations (Spec_Id);
1989
      Last_E := Last_Entity (Spec_Id);
1990
 
1991
      Analyze_Declarations (Decls);
1992
      Inspect_Deferred_Constant_Completion (Decls);
1993
 
1994
      --  For visibility purposes, all entities in the body are private. Set
1995
      --  First_Private_Entity accordingly, if there was no private part in the
1996
      --  protected declaration.
1997
 
1998
      if No (First_Private_Entity (Spec_Id)) then
1999
         if Present (Last_E) then
2000
            Set_First_Private_Entity (Spec_Id, Next_Entity (Last_E));
2001
         else
2002
            Set_First_Private_Entity (Spec_Id, First_Entity (Spec_Id));
2003
         end if;
2004
      end if;
2005
 
2006
      --  Mark all handlers as not suitable for local raise optimization,
2007
      --  since this optimization causes difficulties in a task context.
2008
 
2009
      if Present (Exception_Handlers (HSS)) then
2010
         declare
2011
            Handlr : Node_Id;
2012
         begin
2013
            Handlr := First (Exception_Handlers (HSS));
2014
            while Present (Handlr) loop
2015
               Set_Local_Raise_Not_OK (Handlr);
2016
               Next (Handlr);
2017
            end loop;
2018
         end;
2019
      end if;
2020
 
2021
      --  Now go ahead and complete analysis of the task body
2022
 
2023
      Analyze (HSS);
2024
      Check_Completion (Body_Id);
2025
      Check_References (Body_Id);
2026
      Check_References (Spec_Id);
2027
 
2028
      --  Check for entries with no corresponding accept
2029
 
2030
      declare
2031
         Ent : Entity_Id;
2032
 
2033
      begin
2034
         Ent := First_Entity (Spec_Id);
2035
         while Present (Ent) loop
2036
            if Is_Entry (Ent)
2037
              and then not Entry_Accepted (Ent)
2038
              and then Comes_From_Source (Ent)
2039
            then
2040
               Error_Msg_NE ("no accept for entry &?", N, Ent);
2041
            end if;
2042
 
2043
            Next_Entity (Ent);
2044
         end loop;
2045
      end;
2046
 
2047
      Process_End_Label (HSS, 't', Ref_Id);
2048
      End_Scope;
2049
   end Analyze_Task_Body;
2050
 
2051
   -----------------------------
2052
   -- Analyze_Task_Definition --
2053
   -----------------------------
2054
 
2055
   procedure Analyze_Task_Definition (N : Node_Id) is
2056
      L : Entity_Id;
2057
 
2058
   begin
2059
      Tasking_Used := True;
2060
      Check_SPARK_Restriction ("task definition is not allowed", N);
2061
 
2062
      if Present (Visible_Declarations (N)) then
2063
         Analyze_Declarations (Visible_Declarations (N));
2064
      end if;
2065
 
2066
      if Present (Private_Declarations (N)) then
2067
         L := Last_Entity (Current_Scope);
2068
         Analyze_Declarations (Private_Declarations (N));
2069
 
2070
         if Present (L) then
2071
            Set_First_Private_Entity
2072
              (Current_Scope, Next_Entity (L));
2073
         else
2074
            Set_First_Private_Entity
2075
              (Current_Scope, First_Entity (Current_Scope));
2076
         end if;
2077
      end if;
2078
 
2079
      Check_Max_Entries (N, Max_Task_Entries);
2080
      Process_End_Label (N, 'e', Current_Scope);
2081
   end Analyze_Task_Definition;
2082
 
2083
   -----------------------------------
2084
   -- Analyze_Task_Type_Declaration --
2085
   -----------------------------------
2086
 
2087
   procedure Analyze_Task_Type_Declaration (N : Node_Id) is
2088
      Def_Id : constant Entity_Id := Defining_Identifier (N);
2089
      T      : Entity_Id;
2090
 
2091
   begin
2092
      Check_Restriction (No_Tasking, N);
2093
      Tasking_Used := True;
2094
      T := Find_Type_Name (N);
2095
      Generate_Definition (T);
2096
 
2097
      --  In the case of an incomplete type, use the full view, unless it's not
2098
      --  present (as can occur for an incomplete view from a limited with).
2099
      --  Initialize the Corresponding_Record_Type (which overlays the Private
2100
      --  Dependents field of the incomplete view).
2101
 
2102
      if Ekind (T) = E_Incomplete_Type then
2103
         if Present (Full_View (T)) then
2104
            T := Full_View (T);
2105
            Set_Completion_Referenced (T);
2106
 
2107
         else
2108
            Set_Ekind (T, E_Task_Type);
2109
            Set_Corresponding_Record_Type (T, Empty);
2110
         end if;
2111
      end if;
2112
 
2113
      Set_Ekind              (T, E_Task_Type);
2114
      Set_Is_First_Subtype   (T, True);
2115
      Set_Has_Task           (T, True);
2116
      Init_Size_Align        (T);
2117
      Set_Etype              (T, T);
2118
      Set_Has_Delayed_Freeze (T, True);
2119
      Set_Stored_Constraint  (T, No_Elist);
2120
      Push_Scope (T);
2121
 
2122
      if Ada_Version >= Ada_2005 then
2123
         Check_Interfaces (N, T);
2124
      end if;
2125
 
2126
      if Present (Discriminant_Specifications (N)) then
2127
         if Ada_Version = Ada_83 and then Comes_From_Source (N) then
2128
            Error_Msg_N ("(Ada 83) task discriminant not allowed!", N);
2129
         end if;
2130
 
2131
         if Has_Discriminants (T) then
2132
 
2133
            --  Install discriminants. Also, verify conformance of
2134
            --  discriminants of previous and current view. ???
2135
 
2136
            Install_Declarations (T);
2137
         else
2138
            Process_Discriminants (N);
2139
         end if;
2140
      end if;
2141
 
2142
      Set_Is_Constrained (T, not Has_Discriminants (T));
2143
 
2144
      if Has_Aspects (N) then
2145
         Analyze_Aspect_Specifications (N, Def_Id);
2146
      end if;
2147
 
2148
      if Present (Task_Definition (N)) then
2149
         Analyze_Task_Definition (Task_Definition (N));
2150
      end if;
2151
 
2152
      --  In the case where the task type is declared at a nested level and the
2153
      --  No_Task_Hierarchy restriction applies, issue a warning that objects
2154
      --  of the type will violate the restriction.
2155
 
2156
      if Restriction_Check_Required (No_Task_Hierarchy)
2157
        and then not Is_Library_Level_Entity (T)
2158
        and then Comes_From_Source (T)
2159
      then
2160
         Error_Msg_Sloc := Restrictions_Loc (No_Task_Hierarchy);
2161
 
2162
         if Error_Msg_Sloc = No_Location then
2163
            Error_Msg_N
2164
              ("objects of this type will violate `No_Task_Hierarchy`?", N);
2165
         else
2166
            Error_Msg_N
2167
              ("objects of this type will violate `No_Task_Hierarchy`?#", N);
2168
         end if;
2169
      end if;
2170
 
2171
      End_Scope;
2172
 
2173
      --  Case of a completion of a private declaration
2174
 
2175
      if T /= Def_Id
2176
        and then Is_Private_Type (Def_Id)
2177
      then
2178
         --  Deal with preelaborable initialization. Note that this processing
2179
         --  is done by Process_Full_View, but as can be seen below, in this
2180
         --  case the call to Process_Full_View is skipped if any serious
2181
         --  errors have occurred, and we don't want to lose this check.
2182
 
2183
         if Known_To_Have_Preelab_Init (Def_Id) then
2184
            Set_Must_Have_Preelab_Init (T);
2185
         end if;
2186
 
2187
         --  Create corresponding record now, because some private dependents
2188
         --  may be subtypes of the partial view.
2189
 
2190
         --  Skip if errors are present, to prevent cascaded messages
2191
 
2192
         if Serious_Errors_Detected = 0
2193
 
2194
           --  Also skip if expander is not active
2195
 
2196
           and then Full_Expander_Active
2197
         then
2198
            Expand_N_Task_Type_Declaration (N);
2199
            Process_Full_View (N, T, Def_Id);
2200
         end if;
2201
      end if;
2202
   end Analyze_Task_Type_Declaration;
2203
 
2204
   -----------------------------------
2205
   -- Analyze_Terminate_Alternative --
2206
   -----------------------------------
2207
 
2208
   procedure Analyze_Terminate_Alternative (N : Node_Id) is
2209
   begin
2210
      Tasking_Used := True;
2211
 
2212
      if Present (Pragmas_Before (N)) then
2213
         Analyze_List (Pragmas_Before (N));
2214
      end if;
2215
 
2216
      if Present (Condition (N)) then
2217
         Analyze_And_Resolve (Condition (N), Any_Boolean);
2218
      end if;
2219
   end Analyze_Terminate_Alternative;
2220
 
2221
   ------------------------------
2222
   -- Analyze_Timed_Entry_Call --
2223
   ------------------------------
2224
 
2225
   procedure Analyze_Timed_Entry_Call (N : Node_Id) is
2226
      Trigger        : constant Node_Id :=
2227
                         Entry_Call_Statement (Entry_Call_Alternative (N));
2228
      Is_Disp_Select : Boolean := False;
2229
 
2230
   begin
2231
      Tasking_Used := True;
2232
      Check_SPARK_Restriction ("select statement is not allowed", N);
2233
      Check_Restriction (No_Select_Statements, N);
2234
 
2235
      --  Ada 2005 (AI-345): The trigger may be a dispatching call
2236
 
2237
      if Ada_Version >= Ada_2005 then
2238
         Analyze (Trigger);
2239
         Check_Triggering_Statement (Trigger, N, Is_Disp_Select);
2240
      end if;
2241
 
2242
      --  Postpone the analysis of the statements till expansion. Analyze only
2243
      --  if the expander is disabled in order to catch any semantic errors.
2244
 
2245
      if Is_Disp_Select then
2246
         if not Expander_Active then
2247
            Analyze (Entry_Call_Alternative (N));
2248
            Analyze (Delay_Alternative (N));
2249
         end if;
2250
 
2251
      --  Regular select analysis
2252
 
2253
      else
2254
         Analyze (Entry_Call_Alternative (N));
2255
         Analyze (Delay_Alternative (N));
2256
      end if;
2257
   end Analyze_Timed_Entry_Call;
2258
 
2259
   ------------------------------------
2260
   -- Analyze_Triggering_Alternative --
2261
   ------------------------------------
2262
 
2263
   procedure Analyze_Triggering_Alternative (N : Node_Id) is
2264
      Trigger : constant Node_Id := Triggering_Statement (N);
2265
 
2266
   begin
2267
      Tasking_Used := True;
2268
 
2269
      if Present (Pragmas_Before (N)) then
2270
         Analyze_List (Pragmas_Before (N));
2271
      end if;
2272
 
2273
      Analyze (Trigger);
2274
 
2275
      if Comes_From_Source (Trigger)
2276
        and then Nkind (Trigger) not in N_Delay_Statement
2277
        and then Nkind (Trigger) /= N_Entry_Call_Statement
2278
      then
2279
         if Ada_Version < Ada_2005 then
2280
            Error_Msg_N
2281
             ("triggering statement must be delay or entry call", Trigger);
2282
 
2283
         --  Ada 2005 (AI-345): If a procedure_call_statement is used for a
2284
         --  procedure_or_entry_call, the procedure_name or procedure_prefix
2285
         --  of the procedure_call_statement shall denote an entry renamed by a
2286
         --  procedure, or (a view of) a primitive subprogram of a limited
2287
         --  interface whose first parameter is a controlling parameter.
2288
 
2289
         elsif Nkind (Trigger) = N_Procedure_Call_Statement
2290
           and then not Is_Renamed_Entry (Entity (Name (Trigger)))
2291
           and then not Is_Controlling_Limited_Procedure
2292
                          (Entity (Name (Trigger)))
2293
         then
2294
            Error_Msg_N ("triggering statement must be delay, procedure " &
2295
                         "or entry call", Trigger);
2296
         end if;
2297
      end if;
2298
 
2299
      if Is_Non_Empty_List (Statements (N)) then
2300
         Analyze_Statements (Statements (N));
2301
      end if;
2302
   end Analyze_Triggering_Alternative;
2303
 
2304
   -----------------------
2305
   -- Check_Max_Entries --
2306
   -----------------------
2307
 
2308
   procedure Check_Max_Entries (D : Node_Id; R : All_Parameter_Restrictions) is
2309
      Ecount : Uint;
2310
 
2311
      procedure Count (L : List_Id);
2312
      --  Count entries in given declaration list
2313
 
2314
      -----------
2315
      -- Count --
2316
      -----------
2317
 
2318
      procedure Count (L : List_Id) is
2319
         D : Node_Id;
2320
 
2321
      begin
2322
         if No (L) then
2323
            return;
2324
         end if;
2325
 
2326
         D := First (L);
2327
         while Present (D) loop
2328
            if Nkind (D) = N_Entry_Declaration then
2329
               declare
2330
                  DSD : constant Node_Id :=
2331
                          Discrete_Subtype_Definition (D);
2332
 
2333
               begin
2334
                  --  If not an entry family, then just one entry
2335
 
2336
                  if No (DSD) then
2337
                     Ecount := Ecount + 1;
2338
 
2339
                  --  If entry family with static bounds, count entries
2340
 
2341
                  elsif Is_OK_Static_Subtype (Etype (DSD)) then
2342
                     declare
2343
                        Lo : constant Uint :=
2344
                               Expr_Value
2345
                                 (Type_Low_Bound (Etype (DSD)));
2346
                        Hi : constant Uint :=
2347
                               Expr_Value
2348
                                 (Type_High_Bound (Etype (DSD)));
2349
 
2350
                     begin
2351
                        if Hi >= Lo then
2352
                           Ecount := Ecount + Hi - Lo + 1;
2353
                        end if;
2354
                     end;
2355
 
2356
                  --  Entry family with non-static bounds
2357
 
2358
                  else
2359
                     --  Record an unknown count restriction, and if the
2360
                     --  restriction is active, post a message or warning.
2361
 
2362
                     Check_Restriction (R, D);
2363
                  end if;
2364
               end;
2365
            end if;
2366
 
2367
            Next (D);
2368
         end loop;
2369
      end Count;
2370
 
2371
   --  Start of processing for Check_Max_Entries
2372
 
2373
   begin
2374
      Ecount := Uint_0;
2375
      Count (Visible_Declarations (D));
2376
      Count (Private_Declarations (D));
2377
 
2378
      if Ecount > 0 then
2379
         Check_Restriction (R, D, Ecount);
2380
      end if;
2381
   end Check_Max_Entries;
2382
 
2383
   ----------------------
2384
   -- Check_Interfaces --
2385
   ----------------------
2386
 
2387
   procedure Check_Interfaces (N : Node_Id; T : Entity_Id) is
2388
      Iface     : Node_Id;
2389
      Iface_Typ : Entity_Id;
2390
 
2391
   begin
2392
      pragma Assert
2393
        (Nkind_In (N, N_Protected_Type_Declaration, N_Task_Type_Declaration));
2394
 
2395
      if Present (Interface_List (N)) then
2396
         Set_Is_Tagged_Type (T);
2397
 
2398
         Iface := First (Interface_List (N));
2399
         while Present (Iface) loop
2400
            Iface_Typ := Find_Type_Of_Subtype_Indic (Iface);
2401
 
2402
            if not Is_Interface (Iface_Typ) then
2403
               Error_Msg_NE
2404
                 ("(Ada 2005) & must be an interface", Iface, Iface_Typ);
2405
 
2406
            else
2407
               --  Ada 2005 (AI-251): "The declaration of a specific descendant
2408
               --  of an interface type freezes the interface type" RM 13.14.
2409
 
2410
               Freeze_Before (N, Etype (Iface));
2411
 
2412
               if Nkind (N) = N_Protected_Type_Declaration then
2413
 
2414
                  --  Ada 2005 (AI-345): Protected types can only implement
2415
                  --  limited, synchronized, or protected interfaces (note that
2416
                  --  the predicate Is_Limited_Interface includes synchronized
2417
                  --  and protected interfaces).
2418
 
2419
                  if Is_Task_Interface (Iface_Typ) then
2420
                     Error_Msg_N ("(Ada 2005) protected type cannot implement "
2421
                       & "a task interface", Iface);
2422
 
2423
                  elsif not Is_Limited_Interface (Iface_Typ) then
2424
                     Error_Msg_N ("(Ada 2005) protected type cannot implement "
2425
                       & "a non-limited interface", Iface);
2426
                  end if;
2427
 
2428
               else pragma Assert (Nkind (N) = N_Task_Type_Declaration);
2429
 
2430
                  --  Ada 2005 (AI-345): Task types can only implement limited,
2431
                  --  synchronized, or task interfaces (note that the predicate
2432
                  --  Is_Limited_Interface includes synchronized and task
2433
                  --  interfaces).
2434
 
2435
                  if Is_Protected_Interface (Iface_Typ) then
2436
                     Error_Msg_N ("(Ada 2005) task type cannot implement a " &
2437
                       "protected interface", Iface);
2438
 
2439
                  elsif not Is_Limited_Interface (Iface_Typ) then
2440
                     Error_Msg_N ("(Ada 2005) task type cannot implement a " &
2441
                       "non-limited interface", Iface);
2442
                  end if;
2443
               end if;
2444
            end if;
2445
 
2446
            Next (Iface);
2447
         end loop;
2448
      end if;
2449
 
2450
      if not Has_Private_Declaration (T) then
2451
         return;
2452
      end if;
2453
 
2454
      --  Additional checks on full-types associated with private type
2455
      --  declarations. Search for the private type declaration.
2456
 
2457
      declare
2458
         Full_T_Ifaces : Elist_Id;
2459
         Iface         : Node_Id;
2460
         Priv_T        : Entity_Id;
2461
         Priv_T_Ifaces : Elist_Id;
2462
 
2463
      begin
2464
         Priv_T := First_Entity (Scope (T));
2465
         loop
2466
            pragma Assert (Present (Priv_T));
2467
 
2468
            if Is_Type (Priv_T) and then Present (Full_View (Priv_T)) then
2469
               exit when Full_View (Priv_T) = T;
2470
            end if;
2471
 
2472
            Next_Entity (Priv_T);
2473
         end loop;
2474
 
2475
         --  In case of synchronized types covering interfaces the private type
2476
         --  declaration must be limited.
2477
 
2478
         if Present (Interface_List (N))
2479
           and then not Is_Limited_Type (Priv_T)
2480
         then
2481
            Error_Msg_Sloc := Sloc (Priv_T);
2482
            Error_Msg_N ("(Ada 2005) limited type declaration expected for " &
2483
                         "private type#", T);
2484
         end if;
2485
 
2486
         --  RM 7.3 (7.1/2): If the full view has a partial view that is
2487
         --  tagged then check RM 7.3 subsidiary rules.
2488
 
2489
         if Is_Tagged_Type (Priv_T)
2490
           and then not Error_Posted (N)
2491
         then
2492
            --  RM 7.3 (7.2/2): The partial view shall be a synchronized tagged
2493
            --  type if and only if the full type is a synchronized tagged type
2494
 
2495
            if Is_Synchronized_Tagged_Type (Priv_T)
2496
              and then not Is_Synchronized_Tagged_Type (T)
2497
            then
2498
               Error_Msg_N
2499
                 ("(Ada 2005) full view must be a synchronized tagged " &
2500
                  "type (RM 7.3 (7.2/2))", Priv_T);
2501
 
2502
            elsif Is_Synchronized_Tagged_Type (T)
2503
              and then not Is_Synchronized_Tagged_Type (Priv_T)
2504
            then
2505
               Error_Msg_N
2506
                 ("(Ada 2005) partial view must be a synchronized tagged " &
2507
                  "type (RM 7.3 (7.2/2))", T);
2508
            end if;
2509
 
2510
            --  RM 7.3 (7.3/2): The partial view shall be a descendant of an
2511
            --  interface type if and only if the full type is descendant of
2512
            --  the interface type.
2513
 
2514
            if Present (Interface_List (N))
2515
              or else (Is_Tagged_Type (Priv_T)
2516
                         and then Has_Interfaces
2517
                                   (Priv_T, Use_Full_View => False))
2518
            then
2519
               if Is_Tagged_Type (Priv_T) then
2520
                  Collect_Interfaces
2521
                    (Priv_T, Priv_T_Ifaces, Use_Full_View => False);
2522
               end if;
2523
 
2524
               if Is_Tagged_Type (T) then
2525
                  Collect_Interfaces (T, Full_T_Ifaces);
2526
               end if;
2527
 
2528
               Iface := Find_Hidden_Interface (Priv_T_Ifaces, Full_T_Ifaces);
2529
 
2530
               if Present (Iface) then
2531
                  Error_Msg_NE
2532
                    ("interface & not implemented by full type " &
2533
                     "(RM-2005 7.3 (7.3/2))", Priv_T, Iface);
2534
               end if;
2535
 
2536
               Iface := Find_Hidden_Interface (Full_T_Ifaces, Priv_T_Ifaces);
2537
 
2538
               if Present (Iface) then
2539
                  Error_Msg_NE
2540
                    ("interface & not implemented by partial " &
2541
                     "view (RM-2005 7.3 (7.3/2))", T, Iface);
2542
               end if;
2543
            end if;
2544
         end if;
2545
      end;
2546
   end Check_Interfaces;
2547
 
2548
   --------------------------------
2549
   -- Check_Triggering_Statement --
2550
   --------------------------------
2551
 
2552
   procedure Check_Triggering_Statement
2553
     (Trigger        : Node_Id;
2554
      Error_Node     : Node_Id;
2555
      Is_Dispatching : out Boolean)
2556
   is
2557
      Param : Node_Id;
2558
 
2559
   begin
2560
      Is_Dispatching := False;
2561
 
2562
      --  It is not possible to have a dispatching trigger if we are not in
2563
      --  Ada 2005 mode.
2564
 
2565
      if Ada_Version >= Ada_2005
2566
        and then Nkind (Trigger) = N_Procedure_Call_Statement
2567
        and then Present (Parameter_Associations (Trigger))
2568
      then
2569
         Param := First (Parameter_Associations (Trigger));
2570
 
2571
         if Is_Controlling_Actual (Param)
2572
           and then Is_Interface (Etype (Param))
2573
         then
2574
            if Is_Limited_Record (Etype (Param)) then
2575
               Is_Dispatching := True;
2576
            else
2577
               Error_Msg_N
2578
                 ("dispatching operation of limited or synchronized " &
2579
                  "interface required (RM 9.7.2(3))!", Error_Node);
2580
            end if;
2581
         end if;
2582
      end if;
2583
   end Check_Triggering_Statement;
2584
 
2585
   --------------------------
2586
   -- Find_Concurrent_Spec --
2587
   --------------------------
2588
 
2589
   function Find_Concurrent_Spec (Body_Id : Entity_Id) return Entity_Id is
2590
      Spec_Id : Entity_Id := Current_Entity_In_Scope (Body_Id);
2591
 
2592
   begin
2593
      --  The type may have been given by an incomplete type declaration.
2594
      --  Find full view now.
2595
 
2596
      if Present (Spec_Id) and then Ekind (Spec_Id) = E_Incomplete_Type then
2597
         Spec_Id := Full_View (Spec_Id);
2598
      end if;
2599
 
2600
      return Spec_Id;
2601
   end Find_Concurrent_Spec;
2602
 
2603
   --------------------------
2604
   -- Install_Declarations --
2605
   --------------------------
2606
 
2607
   procedure Install_Declarations (Spec : Entity_Id) is
2608
      E    : Entity_Id;
2609
      Prev : Entity_Id;
2610
   begin
2611
      E := First_Entity (Spec);
2612
      while Present (E) loop
2613
         Prev := Current_Entity (E);
2614
         Set_Current_Entity (E);
2615
         Set_Is_Immediately_Visible (E);
2616
         Set_Homonym (E, Prev);
2617
         Next_Entity (E);
2618
      end loop;
2619
   end Install_Declarations;
2620
 
2621
end Sem_Ch9;

powered by: WebSVN 2.1.0

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