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

Subversion Repositories openrisc

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

Details | Compare with Previous | View Log

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

powered by: WebSVN 2.1.0

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