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

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-stable/] [gcc-4.5.1/] [gcc/] [ada/] [par-ch9.adb] - Blame information for rev 281

Go to most recent revision | Details | Compare with Previous | View Log

Line No. Rev Author Line
1 281 jeremybenn
------------------------------------------------------------------------------
2
--                                                                          --
3
--                         GNAT COMPILER COMPONENTS                         --
4
--                                                                          --
5
--                              P A R . 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
pragma Style_Checks (All_Checks);
27
--  Turn off subprogram body ordering check. Subprograms are in order by RM
28
--  section rather than alphabetical.
29
 
30
separate (Par)
31
package body Ch9 is
32
 
33
   --  Local subprograms, used only in this chapter
34
 
35
   function P_Accept_Alternative                   return Node_Id;
36
   function P_Delay_Alternative                    return Node_Id;
37
   function P_Delay_Relative_Statement             return Node_Id;
38
   function P_Delay_Until_Statement                return Node_Id;
39
   function P_Entry_Barrier                        return Node_Id;
40
   function P_Entry_Body_Formal_Part               return Node_Id;
41
   function P_Entry_Declaration                    return Node_Id;
42
   function P_Entry_Index_Specification            return Node_Id;
43
   function P_Protected_Definition                 return Node_Id;
44
   function P_Protected_Operation_Declaration_Opt  return Node_Id;
45
   function P_Protected_Operation_Items            return List_Id;
46
   function P_Task_Definition                      return Node_Id;
47
   function P_Task_Items                           return List_Id;
48
 
49
   -----------------------------
50
   -- 9.1  Task (also 10.1.3) --
51
   -----------------------------
52
 
53
   --  TASK_TYPE_DECLARATION ::=
54
   --    task type DEFINING_IDENTIFIER [KNOWN_DISCRIMINANT_PART]
55
   --      [is [new INTERFACE_LIST with] TASK_DEFINITION];
56
 
57
   --  SINGLE_TASK_DECLARATION ::=
58
   --    task DEFINING_IDENTIFIER
59
   --      [is [new INTERFACE_LIST with] TASK_DEFINITION];
60
 
61
   --  TASK_BODY ::=
62
   --    task body DEFINING_IDENTIFIER is
63
   --      DECLARATIVE_PART
64
   --    begin
65
   --      HANDLED_SEQUENCE_OF_STATEMENTS
66
   --    end [task_IDENTIFIER]
67
 
68
   --  TASK_BODY_STUB ::=
69
   --    task body DEFINING_IDENTIFIER is separate;
70
 
71
   --  This routine scans out a task declaration, task body, or task stub
72
 
73
   --  The caller has checked that the initial token is TASK and scanned
74
   --  past it, so that Token is set to the token after TASK
75
 
76
   --  Error recovery: cannot raise Error_Resync
77
 
78
   function P_Task return Node_Id is
79
      Name_Node  : Node_Id;
80
      Task_Node  : Node_Id;
81
      Task_Sloc  : Source_Ptr;
82
 
83
   begin
84
      Push_Scope_Stack;
85
      Scope.Table (Scope.Last).Etyp := E_Name;
86
      Scope.Table (Scope.Last).Ecol := Start_Column;
87
      Scope.Table (Scope.Last).Sloc := Token_Ptr;
88
      Scope.Table (Scope.Last).Lreq := False;
89
      Task_Sloc := Prev_Token_Ptr;
90
 
91
      if Token = Tok_Body then
92
         Scan; -- past BODY
93
         Name_Node := P_Defining_Identifier (C_Is);
94
         Scope.Table (Scope.Last).Labl := Name_Node;
95
 
96
         if Token = Tok_Left_Paren then
97
            Error_Msg_SC ("discriminant part not allowed in task body");
98
            Discard_Junk_List (P_Known_Discriminant_Part_Opt);
99
         end if;
100
 
101
         TF_Is;
102
 
103
         --  Task stub
104
 
105
         if Token = Tok_Separate then
106
            Scan; -- past SEPARATE
107
            Task_Node := New_Node (N_Task_Body_Stub, Task_Sloc);
108
            Set_Defining_Identifier (Task_Node, Name_Node);
109
            TF_Semicolon;
110
            Pop_Scope_Stack; -- remove unused entry
111
 
112
         --  Task body
113
 
114
         else
115
            Task_Node := New_Node (N_Task_Body, Task_Sloc);
116
            Set_Defining_Identifier (Task_Node, Name_Node);
117
            Parse_Decls_Begin_End (Task_Node);
118
         end if;
119
 
120
         return Task_Node;
121
 
122
      --  Otherwise we must have a task declaration
123
 
124
      else
125
         if Token = Tok_Type then
126
            Scan; -- past TYPE
127
            Task_Node := New_Node (N_Task_Type_Declaration, Task_Sloc);
128
            Name_Node := P_Defining_Identifier;
129
            Set_Defining_Identifier (Task_Node, Name_Node);
130
            Scope.Table (Scope.Last).Labl := Name_Node;
131
            Set_Discriminant_Specifications
132
              (Task_Node, P_Known_Discriminant_Part_Opt);
133
 
134
         else
135
            Task_Node := New_Node (N_Single_Task_Declaration, Task_Sloc);
136
            Name_Node := P_Defining_Identifier (C_Is);
137
            Set_Defining_Identifier (Task_Node, Name_Node);
138
            Scope.Table (Scope.Last).Labl := Name_Node;
139
 
140
            if Token = Tok_Left_Paren then
141
               Error_Msg_SC ("discriminant part not allowed for single task");
142
               Discard_Junk_List (P_Known_Discriminant_Part_Opt);
143
            end if;
144
         end if;
145
 
146
         --  Parse optional task definition. Note that P_Task_Definition scans
147
         --  out the semicolon as well as the task definition itself.
148
 
149
         if Token = Tok_Semicolon then
150
 
151
            --  A little check, if the next token after semicolon is
152
            --  Entry, then surely the semicolon should really be IS
153
 
154
            Scan; -- past semicolon
155
 
156
            if Token = Tok_Entry then
157
               Error_Msg_SP ("|"";"" should be IS");
158
               Set_Task_Definition (Task_Node, P_Task_Definition);
159
            else
160
               Pop_Scope_Stack; -- Remove unused entry
161
            end if;
162
         else
163
            TF_Is; -- must have IS if no semicolon
164
 
165
            --  Ada 2005 (AI-345)
166
 
167
            if Token = Tok_New then
168
               Scan; --  past NEW
169
 
170
               if Ada_Version < Ada_05 then
171
                  Error_Msg_SP ("task interface is an Ada 2005 extension");
172
                  Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
173
               end if;
174
 
175
               Set_Interface_List (Task_Node, New_List);
176
 
177
               loop
178
                  Append (P_Qualified_Simple_Name, Interface_List (Task_Node));
179
                  exit when Token /= Tok_And;
180
                  Scan; --  past AND
181
               end loop;
182
 
183
               if Token /= Tok_With then
184
                  Error_Msg_SC ("WITH expected");
185
               end if;
186
 
187
               Scan; -- past WITH
188
 
189
               if Token = Tok_Private then
190
                  Error_Msg_SP
191
                    ("PRIVATE not allowed in task type declaration");
192
               end if;
193
            end if;
194
 
195
            Set_Task_Definition (Task_Node, P_Task_Definition);
196
         end if;
197
 
198
         return Task_Node;
199
      end if;
200
   end P_Task;
201
 
202
   --------------------------------
203
   -- 9.1  Task Type Declaration --
204
   --------------------------------
205
 
206
   --  Parsed by P_Task (9.1)
207
 
208
   ----------------------------------
209
   -- 9.1  Single Task Declaration --
210
   ----------------------------------
211
 
212
   --  Parsed by P_Task (9.1)
213
 
214
   --------------------------
215
   -- 9.1  Task Definition --
216
   --------------------------
217
 
218
   --  TASK_DEFINITION ::=
219
   --      {TASK_ITEM}
220
   --    [private
221
   --      {TASK_ITEM}]
222
   --    end [task_IDENTIFIER];
223
 
224
   --  The caller has already made the scope stack entry
225
 
226
   --  Note: there is a small deviation from official syntax here in that we
227
   --  regard the semicolon after end as part of the Task_Definition, and in
228
   --  the official syntax, it's part of the enclosing declaration. The reason
229
   --  for this deviation is that otherwise the end processing would have to
230
   --  be special cased, which would be a nuisance!
231
 
232
   --  Error recovery:  cannot raise Error_Resync
233
 
234
   function P_Task_Definition return Node_Id is
235
      Def_Node  : Node_Id;
236
 
237
   begin
238
      Def_Node := New_Node (N_Task_Definition, Token_Ptr);
239
      Set_Visible_Declarations (Def_Node, P_Task_Items);
240
 
241
      if Token = Tok_Private then
242
         Scan; -- past PRIVATE
243
         Set_Private_Declarations (Def_Node, P_Task_Items);
244
 
245
         --  Deal gracefully with multiple PRIVATE parts
246
 
247
         while Token = Tok_Private loop
248
            Error_Msg_SC ("only one private part allowed per task");
249
            Scan; -- past PRIVATE
250
            Append_List (P_Task_Items, Private_Declarations (Def_Node));
251
         end loop;
252
      end if;
253
 
254
      End_Statements (Def_Node);
255
      return Def_Node;
256
   end P_Task_Definition;
257
 
258
   --------------------
259
   -- 9.1  Task Item --
260
   --------------------
261
 
262
   --  TASK_ITEM ::= ENTRY_DECLARATION | REPRESENTATION_CLAUSE
263
 
264
   --  This subprogram scans a (possibly empty) list of task items and pragmas
265
 
266
   --  Error recovery:  cannot raise Error_Resync
267
 
268
   --  Note: a pragma can also be returned in this position
269
 
270
   function P_Task_Items return List_Id is
271
      Items      : List_Id;
272
      Item_Node  : Node_Id;
273
      Decl_Sloc  : Source_Ptr;
274
 
275
   begin
276
      --  Get rid of active SIS entry from outer scope. This means we will
277
      --  miss some nested cases, but it doesn't seem worth the effort. See
278
      --  discussion in Par for further details
279
 
280
      SIS_Entry_Active := False;
281
 
282
      --  Loop to scan out task items
283
 
284
      Items := New_List;
285
 
286
      Decl_Loop : loop
287
         Decl_Sloc := Token_Ptr;
288
 
289
         if Token = Tok_Pragma then
290
            Append (P_Pragma, Items);
291
 
292
         --  Ada 2005 (AI-397): Reserved words NOT and OVERRIDING
293
         --  may begin an entry declaration.
294
 
295
         elsif Token = Tok_Entry
296
           or else Token = Tok_Not
297
           or else Token = Tok_Overriding
298
         then
299
            Append (P_Entry_Declaration, Items);
300
 
301
         elsif Token = Tok_For then
302
            --  Representation clause in task declaration. The only rep
303
            --  clause which is legal in a protected is an address clause,
304
            --  so that is what we try to scan out.
305
 
306
            Item_Node := P_Representation_Clause;
307
 
308
            if Nkind (Item_Node) = N_At_Clause then
309
               Append (Item_Node, Items);
310
 
311
            elsif Nkind (Item_Node) = N_Attribute_Definition_Clause
312
              and then Chars (Item_Node) = Name_Address
313
            then
314
               Append (Item_Node, Items);
315
 
316
            else
317
               Error_Msg
318
                 ("the only representation clause " &
319
                  "allowed here is an address clause!", Decl_Sloc);
320
            end if;
321
 
322
         elsif Token = Tok_Identifier
323
           or else Token in Token_Class_Declk
324
         then
325
            Error_Msg_SC ("illegal declaration in task definition");
326
            Resync_Past_Semicolon;
327
 
328
         else
329
            exit Decl_Loop;
330
         end if;
331
      end loop Decl_Loop;
332
 
333
      return Items;
334
   end P_Task_Items;
335
 
336
   --------------------
337
   -- 9.1  Task Body --
338
   --------------------
339
 
340
   --  Parsed by P_Task (9.1)
341
 
342
   ----------------------------------
343
   -- 9.4  Protected (also 10.1.3) --
344
   ----------------------------------
345
 
346
   --  PROTECTED_TYPE_DECLARATION ::=
347
   --    protected type DEFINING_IDENTIFIER [KNOWN_DISCRIMINANT_PART]
348
   --      is [new INTERFACE_LIST with] PROTECTED_DEFINITION;
349
 
350
   --  SINGLE_PROTECTED_DECLARATION ::=
351
   --    protected DEFINING_IDENTIFIER
352
   --    is [new INTERFACE_LIST with] PROTECTED_DEFINITION;
353
 
354
   --  PROTECTED_BODY ::=
355
   --    protected body DEFINING_IDENTIFIER is
356
   --      {PROTECTED_OPERATION_ITEM}
357
   --    end [protected_IDENTIFIER];
358
 
359
   --  PROTECTED_BODY_STUB ::=
360
   --    protected body DEFINING_IDENTIFIER is separate;
361
 
362
   --  This routine scans out a protected declaration, protected body
363
   --  or a protected stub.
364
 
365
   --  The caller has checked that the initial token is PROTECTED and
366
   --  scanned past it, so Token is set to the following token.
367
 
368
   --  Error recovery: cannot raise Error_Resync
369
 
370
   function P_Protected return Node_Id is
371
      Name_Node      : Node_Id;
372
      Protected_Node : Node_Id;
373
      Protected_Sloc : Source_Ptr;
374
      Scan_State     : Saved_Scan_State;
375
 
376
   begin
377
      Push_Scope_Stack;
378
      Scope.Table (Scope.Last).Etyp := E_Name;
379
      Scope.Table (Scope.Last).Ecol := Start_Column;
380
      Scope.Table (Scope.Last).Lreq := False;
381
      Protected_Sloc := Prev_Token_Ptr;
382
 
383
      if Token = Tok_Body then
384
         Scan; -- past BODY
385
         Name_Node := P_Defining_Identifier (C_Is);
386
         Scope.Table (Scope.Last).Labl := Name_Node;
387
 
388
         if Token = Tok_Left_Paren then
389
            Error_Msg_SC ("discriminant part not allowed in protected body");
390
            Discard_Junk_List (P_Known_Discriminant_Part_Opt);
391
         end if;
392
 
393
         TF_Is;
394
 
395
         --  Protected stub
396
 
397
         if Token = Tok_Separate then
398
            Scan; -- past SEPARATE
399
            Protected_Node := New_Node (N_Protected_Body_Stub, Protected_Sloc);
400
            Set_Defining_Identifier (Protected_Node, Name_Node);
401
            TF_Semicolon;
402
            Pop_Scope_Stack; -- remove unused entry
403
 
404
         --  Protected body
405
 
406
         else
407
            Protected_Node := New_Node (N_Protected_Body, Protected_Sloc);
408
            Set_Defining_Identifier (Protected_Node, Name_Node);
409
            Set_Declarations (Protected_Node, P_Protected_Operation_Items);
410
            End_Statements (Protected_Node);
411
         end if;
412
 
413
         return Protected_Node;
414
 
415
      --  Otherwise we must have a protected declaration
416
 
417
      else
418
         if Token = Tok_Type then
419
            Scan; -- past TYPE
420
            Protected_Node :=
421
              New_Node (N_Protected_Type_Declaration, Protected_Sloc);
422
            Name_Node := P_Defining_Identifier (C_Is);
423
            Set_Defining_Identifier (Protected_Node, Name_Node);
424
            Scope.Table (Scope.Last).Labl := Name_Node;
425
            Set_Discriminant_Specifications
426
              (Protected_Node, P_Known_Discriminant_Part_Opt);
427
 
428
         else
429
            Protected_Node :=
430
              New_Node (N_Single_Protected_Declaration, Protected_Sloc);
431
            Name_Node := P_Defining_Identifier (C_Is);
432
            Set_Defining_Identifier (Protected_Node, Name_Node);
433
 
434
            if Token = Tok_Left_Paren then
435
               Error_Msg_SC
436
                 ("discriminant part not allowed for single protected");
437
               Discard_Junk_List (P_Known_Discriminant_Part_Opt);
438
            end if;
439
 
440
            Scope.Table (Scope.Last).Labl := Name_Node;
441
         end if;
442
 
443
         --  Check for semicolon not followed by IS, this is something like
444
 
445
         --    protected type r;
446
 
447
         --  where we want
448
 
449
         --    protected type r IS END;
450
 
451
         if Token = Tok_Semicolon then
452
            Save_Scan_State (Scan_State); -- at semicolon
453
            Scan; -- past semicolon
454
 
455
            if Token /= Tok_Is then
456
               Restore_Scan_State (Scan_State);
457
               Error_Msg_SC ("missing IS");
458
               Set_Protected_Definition (Protected_Node,
459
                 Make_Protected_Definition (Token_Ptr,
460
                   Visible_Declarations => Empty_List,
461
                   End_Label           => Empty));
462
 
463
               SIS_Entry_Active := False;
464
               End_Statements (Protected_Definition (Protected_Node));
465
               Scan; -- past semicolon
466
               return Protected_Node;
467
            end if;
468
 
469
            Error_Msg_SP ("|extra ""("" ignored");
470
         end if;
471
 
472
         T_Is;
473
 
474
         --  Ada 2005 (AI-345)
475
 
476
         if Token = Tok_New then
477
            Scan; --  past NEW
478
 
479
            if Ada_Version < Ada_05 then
480
               Error_Msg_SP ("protected interface is an Ada 2005 extension");
481
               Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
482
            end if;
483
 
484
            Set_Interface_List (Protected_Node, New_List);
485
 
486
            loop
487
               Append (P_Qualified_Simple_Name,
488
                 Interface_List (Protected_Node));
489
 
490
               exit when Token /= Tok_And;
491
               Scan; --  past AND
492
            end loop;
493
 
494
            if Token /= Tok_With then
495
               Error_Msg_SC ("WITH expected");
496
            end if;
497
 
498
            Scan; -- past WITH
499
         end if;
500
 
501
         Set_Protected_Definition (Protected_Node, P_Protected_Definition);
502
         return Protected_Node;
503
      end if;
504
   end P_Protected;
505
 
506
   -------------------------------------
507
   -- 9.4  Protected Type Declaration --
508
   -------------------------------------
509
 
510
   --  Parsed by P_Protected (9.4)
511
 
512
   ---------------------------------------
513
   -- 9.4  Single Protected Declaration --
514
   ---------------------------------------
515
 
516
   --  Parsed by P_Protected (9.4)
517
 
518
   -------------------------------
519
   -- 9.4  Protected Definition --
520
   -------------------------------
521
 
522
   --  PROTECTED_DEFINITION ::=
523
   --      {PROTECTED_OPERATION_DECLARATION}
524
   --    [private
525
   --      {PROTECTED_ELEMENT_DECLARATION}]
526
   --    end [protected_IDENTIFIER]
527
 
528
   --  PROTECTED_ELEMENT_DECLARATION ::=
529
   --    PROTECTED_OPERATION_DECLARATION
530
   --  | COMPONENT_DECLARATION
531
 
532
   --  The caller has already established the scope stack entry
533
 
534
   --  Error recovery: cannot raise Error_Resync
535
 
536
   function P_Protected_Definition return Node_Id is
537
      Def_Node  : Node_Id;
538
      Item_Node : Node_Id;
539
 
540
   begin
541
      Def_Node := New_Node (N_Protected_Definition, Token_Ptr);
542
 
543
      --  Get rid of active SIS entry from outer scope. This means we will
544
      --  miss some nested cases, but it doesn't seem worth the effort. See
545
      --  discussion in Par for further details
546
 
547
      SIS_Entry_Active := False;
548
 
549
      --  Loop to scan visible declarations (protected operation declarations)
550
 
551
      Set_Visible_Declarations (Def_Node, New_List);
552
 
553
      loop
554
         Item_Node := P_Protected_Operation_Declaration_Opt;
555
         exit when No (Item_Node);
556
         Append (Item_Node, Visible_Declarations (Def_Node));
557
      end loop;
558
 
559
      --  Deal with PRIVATE part (including graceful handling of multiple
560
      --  PRIVATE parts).
561
 
562
      Private_Loop : while Token = Tok_Private loop
563
         if No (Private_Declarations (Def_Node)) then
564
            Set_Private_Declarations (Def_Node, New_List);
565
         else
566
            Error_Msg_SC ("duplicate private part");
567
         end if;
568
 
569
         Scan; -- past PRIVATE
570
 
571
         Declaration_Loop : loop
572
            if Token = Tok_Identifier then
573
               P_Component_Items (Private_Declarations (Def_Node));
574
            else
575
               Item_Node := P_Protected_Operation_Declaration_Opt;
576
               exit Declaration_Loop when No (Item_Node);
577
               Append (Item_Node, Private_Declarations (Def_Node));
578
            end if;
579
         end loop Declaration_Loop;
580
      end loop Private_Loop;
581
 
582
      End_Statements (Def_Node);
583
      return Def_Node;
584
   end P_Protected_Definition;
585
 
586
   ------------------------------------------
587
   -- 9.4  Protected Operation Declaration --
588
   ------------------------------------------
589
 
590
   --  PROTECTED_OPERATION_DECLARATION ::=
591
   --    SUBPROGRAM_DECLARATION
592
   --  | ENTRY_DECLARATION
593
   --  | REPRESENTATION_CLAUSE
594
 
595
   --  Error recovery: cannot raise Error_Resync
596
 
597
   --  Note: a pragma can also be returned in this position
598
 
599
   --  We are not currently permitting representation clauses to appear as
600
   --  protected operation declarations, do we have to rethink this???
601
 
602
   function P_Protected_Operation_Declaration_Opt return Node_Id is
603
      L : List_Id;
604
      P : Source_Ptr;
605
 
606
      function P_Entry_Or_Subprogram_With_Indicator return Node_Id;
607
      --  Ada 2005 (AI-397): Parse an entry or a subprogram with an overriding
608
      --  indicator. The caller has checked that the initial token is NOT or
609
      --  OVERRIDING.
610
 
611
      ------------------------------------------
612
      -- P_Entry_Or_Subprogram_With_Indicator --
613
      ------------------------------------------
614
 
615
      function P_Entry_Or_Subprogram_With_Indicator return Node_Id is
616
         Decl           : Node_Id := Error;
617
         Is_Overriding  : Boolean := False;
618
         Not_Overriding : Boolean := False;
619
 
620
      begin
621
         if Token = Tok_Not then
622
            Scan;  -- past NOT
623
 
624
            if Token = Tok_Overriding then
625
               Scan;  -- past OVERRIDING
626
               Not_Overriding := True;
627
            else
628
               Error_Msg_SC ("OVERRIDING expected!");
629
            end if;
630
 
631
         else
632
            Scan;  -- past OVERRIDING
633
            Is_Overriding := True;
634
         end if;
635
 
636
         if (Is_Overriding or else Not_Overriding) then
637
            if Ada_Version < Ada_05 then
638
               Error_Msg_SP ("overriding indicator is an Ada 2005 extension");
639
               Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
640
 
641
            elsif Token = Tok_Entry then
642
               Decl := P_Entry_Declaration;
643
 
644
               Set_Must_Override     (Decl, Is_Overriding);
645
               Set_Must_Not_Override (Decl, Not_Overriding);
646
 
647
            elsif Token = Tok_Function or else Token = Tok_Procedure then
648
               Decl := P_Subprogram (Pf_Decl);
649
 
650
               Set_Must_Override     (Specification (Decl), Is_Overriding);
651
               Set_Must_Not_Override (Specification (Decl), Not_Overriding);
652
 
653
            else
654
               Error_Msg_SC -- CODEFIX
655
                 ("ENTRY, FUNCTION or PROCEDURE expected!");
656
            end if;
657
         end if;
658
 
659
         return Decl;
660
      end P_Entry_Or_Subprogram_With_Indicator;
661
 
662
   --  Start of processing for P_Protected_Operation_Declaration_Opt
663
 
664
   begin
665
      --  This loop runs more than once only when a junk declaration
666
      --  is skipped.
667
 
668
      loop
669
         if Token = Tok_Pragma then
670
            return P_Pragma;
671
 
672
         elsif Token = Tok_Not or else Token = Tok_Overriding then
673
            return P_Entry_Or_Subprogram_With_Indicator;
674
 
675
         elsif Token = Tok_Entry then
676
            return P_Entry_Declaration;
677
 
678
         elsif Token = Tok_Function or else Token = Tok_Procedure then
679
            return P_Subprogram (Pf_Decl);
680
 
681
         elsif Token = Tok_Identifier then
682
            L := New_List;
683
            P := Token_Ptr;
684
            Skip_Declaration (L);
685
 
686
            if Nkind (First (L)) = N_Object_Declaration then
687
               Error_Msg
688
                 ("component must be declared in private part of " &
689
                  "protected type", P);
690
            else
691
               Error_Msg
692
                 ("illegal declaration in protected definition", P);
693
            end if;
694
 
695
         elsif Token in Token_Class_Declk then
696
            Error_Msg_SC ("illegal declaration in protected definition");
697
            Resync_Past_Semicolon;
698
 
699
            --  Return now to avoid cascaded messages if next declaration
700
            --  is a valid component declaration.
701
 
702
            return Error;
703
 
704
         elsif Token = Tok_For then
705
            Error_Msg_SC
706
              ("representation clause not allowed in protected definition");
707
            Resync_Past_Semicolon;
708
 
709
         else
710
            return Empty;
711
         end if;
712
      end loop;
713
   end P_Protected_Operation_Declaration_Opt;
714
 
715
   -----------------------------------
716
   -- 9.4  Protected Operation Item --
717
   -----------------------------------
718
 
719
   --  PROTECTED_OPERATION_ITEM ::=
720
   --    SUBPROGRAM_DECLARATION
721
   --  | SUBPROGRAM_BODY
722
   --  | ENTRY_BODY
723
   --  | REPRESENTATION_CLAUSE
724
 
725
   --  This procedure parses and returns a list of protected operation items
726
 
727
   --  We are not currently permitting representation clauses to appear
728
   --  as protected operation items, do we have to rethink this???
729
 
730
   function P_Protected_Operation_Items return List_Id is
731
      Item_List : List_Id;
732
 
733
   begin
734
      Item_List := New_List;
735
 
736
      loop
737
         if Token = Tok_Entry or else Bad_Spelling_Of (Tok_Entry) then
738
            Append (P_Entry_Body, Item_List);
739
 
740
         --  If the operation starts with procedure, function, or an overriding
741
         --  indicator ("overriding" or "not overriding"), parse a subprogram.
742
 
743
         elsif Token = Tok_Function or else Bad_Spelling_Of (Tok_Function)
744
                 or else
745
               Token = Tok_Procedure or else Bad_Spelling_Of (Tok_Procedure)
746
                 or else
747
               Token = Tok_Overriding or else Bad_Spelling_Of (Tok_Overriding)
748
                 or else
749
               Token = Tok_Not or else Bad_Spelling_Of (Tok_Not)
750
         then
751
            Append (P_Subprogram (Pf_Decl_Pbod), Item_List);
752
 
753
         elsif Token = Tok_Pragma or else Bad_Spelling_Of (Tok_Pragma) then
754
            P_Pragmas_Opt (Item_List);
755
 
756
         elsif Token = Tok_Private or else Bad_Spelling_Of (Tok_Private) then
757
            Error_Msg_SC ("PRIVATE not allowed in protected body");
758
            Scan; -- past PRIVATE
759
 
760
         elsif Token = Tok_Identifier then
761
            Error_Msg_SC
762
              ("all components must be declared in spec!");
763
            Resync_Past_Semicolon;
764
 
765
         elsif Token in Token_Class_Declk then
766
            Error_Msg_SC ("this declaration not allowed in protected body");
767
            Resync_Past_Semicolon;
768
 
769
         else
770
            exit;
771
         end if;
772
      end loop;
773
 
774
      return Item_List;
775
   end P_Protected_Operation_Items;
776
 
777
   ------------------------------
778
   -- 9.5.2  Entry Declaration --
779
   ------------------------------
780
 
781
   --  ENTRY_DECLARATION ::=
782
   --    [OVERRIDING_INDICATOR]
783
   --    entry DEFINING_IDENTIFIER [(DISCRETE_SUBTYPE_DEFINITION)]
784
   --      PARAMETER_PROFILE;
785
 
786
   --  The caller has checked that the initial token is ENTRY, NOT or
787
   --  OVERRIDING.
788
 
789
   --  Error recovery: cannot raise Error_Resync
790
 
791
   function P_Entry_Declaration return Node_Id is
792
      Decl_Node  : Node_Id;
793
      Scan_State : Saved_Scan_State;
794
 
795
      --  Flags for optional overriding indication. Two flags are needed,
796
      --  to distinguish positive and negative overriding indicators from
797
      --  the absence of any indicator.
798
 
799
      Is_Overriding  : Boolean := False;
800
      Not_Overriding : Boolean := False;
801
 
802
   begin
803
      --  Ada 2005 (AI-397): Scan leading overriding indicator
804
 
805
      if Token = Tok_Not then
806
         Scan;  -- past NOT
807
 
808
         if Token = Tok_Overriding then
809
            Scan;  -- part OVERRIDING
810
            Not_Overriding := True;
811
         else
812
            Error_Msg_SC ("OVERRIDING expected!");
813
         end if;
814
 
815
      elsif Token = Tok_Overriding then
816
         Scan;  -- part OVERRIDING
817
         Is_Overriding := True;
818
      end if;
819
 
820
      if (Is_Overriding or else Not_Overriding) then
821
         if Ada_Version < Ada_05 then
822
            Error_Msg_SP ("overriding indicator is an Ada 2005 extension");
823
            Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
824
 
825
         elsif Token /= Tok_Entry then
826
            Error_Msg_SC ("ENTRY expected!");
827
         end if;
828
      end if;
829
 
830
      Decl_Node := New_Node (N_Entry_Declaration, Token_Ptr);
831
      Scan; -- past ENTRY
832
 
833
      Set_Defining_Identifier
834
        (Decl_Node, P_Defining_Identifier (C_Left_Paren_Semicolon));
835
 
836
      --  If left paren, could be (Discrete_Subtype_Definition) or Formal_Part
837
 
838
      if Token = Tok_Left_Paren then
839
         Scan; -- past (
840
 
841
         --  If identifier after left paren, could still be either
842
 
843
         if Token = Tok_Identifier then
844
            Save_Scan_State (Scan_State); -- at Id
845
            Scan; -- past Id
846
 
847
            --  If comma or colon after Id, must be Formal_Part
848
 
849
            if Token = Tok_Comma or else Token = Tok_Colon then
850
               Restore_Scan_State (Scan_State); -- to Id
851
               Set_Parameter_Specifications (Decl_Node, P_Formal_Part);
852
 
853
            --  Else if Id without comma or colon, must be discrete subtype
854
            --  defn
855
 
856
            else
857
               Restore_Scan_State (Scan_State); -- to Id
858
               Set_Discrete_Subtype_Definition
859
                 (Decl_Node, P_Discrete_Subtype_Definition);
860
               T_Right_Paren;
861
               Set_Parameter_Specifications (Decl_Node, P_Parameter_Profile);
862
            end if;
863
 
864
         --  If no Id, must be discrete subtype definition
865
 
866
         else
867
            Set_Discrete_Subtype_Definition
868
              (Decl_Node, P_Discrete_Subtype_Definition);
869
            T_Right_Paren;
870
            Set_Parameter_Specifications (Decl_Node, P_Parameter_Profile);
871
         end if;
872
      end if;
873
 
874
      if Is_Overriding then
875
         Set_Must_Override (Decl_Node);
876
      elsif Not_Overriding then
877
         Set_Must_Not_Override (Decl_Node);
878
      end if;
879
 
880
      --  Error recovery check for illegal return
881
 
882
      if Token = Tok_Return then
883
         Error_Msg_SC ("entry cannot have return value!");
884
         Scan;
885
         Discard_Junk_Node (P_Subtype_Indication);
886
      end if;
887
 
888
      --  Error recovery check for improper use of entry barrier in spec
889
 
890
      if Token = Tok_When then
891
         Error_Msg_SC ("barrier not allowed here (belongs in body)");
892
         Scan; -- past WHEN;
893
         Discard_Junk_Node (P_Expression_No_Right_Paren);
894
      end if;
895
 
896
      TF_Semicolon;
897
      return Decl_Node;
898
 
899
   exception
900
      when Error_Resync =>
901
         Resync_Past_Semicolon;
902
         return Error;
903
   end P_Entry_Declaration;
904
 
905
   -----------------------------
906
   -- 9.5.2  Accept Statement --
907
   -----------------------------
908
 
909
   --  ACCEPT_STATEMENT ::=
910
   --    accept entry_DIRECT_NAME
911
   --      [(ENTRY_INDEX)] PARAMETER_PROFILE [do
912
   --        HANDLED_SEQUENCE_OF_STATEMENTS
913
   --    end [entry_IDENTIFIER]];
914
 
915
   --  The caller has checked that the initial token is ACCEPT
916
 
917
   --  Error recovery: cannot raise Error_Resync. If an error occurs, the
918
   --  scan is resynchronized past the next semicolon and control returns.
919
 
920
   function P_Accept_Statement return Node_Id is
921
      Scan_State  : Saved_Scan_State;
922
      Accept_Node : Node_Id;
923
      Hand_Seq    : Node_Id;
924
 
925
   begin
926
      Push_Scope_Stack;
927
      Scope.Table (Scope.Last).Sloc := Token_Ptr;
928
      Scope.Table (Scope.Last).Ecol := Start_Column;
929
 
930
      Accept_Node := New_Node (N_Accept_Statement, Token_Ptr);
931
      Scan; -- past ACCEPT
932
      Scope.Table (Scope.Last).Labl := Token_Node;
933
 
934
      Set_Entry_Direct_Name (Accept_Node, P_Identifier (C_Do));
935
 
936
      --  Left paren could be (Entry_Index) or Formal_Part, determine which
937
 
938
      if Token = Tok_Left_Paren then
939
         Save_Scan_State (Scan_State); -- at left paren
940
         Scan; -- past left paren
941
 
942
         --  If first token after left paren not identifier, then Entry_Index
943
 
944
         if Token /= Tok_Identifier then
945
            Set_Entry_Index (Accept_Node, P_Expression);
946
            T_Right_Paren;
947
            Set_Parameter_Specifications (Accept_Node, P_Parameter_Profile);
948
 
949
         --  First token after left paren is identifier, could be either case
950
 
951
         else -- Token = Tok_Identifier
952
            Scan; -- past identifier
953
 
954
            --  If identifier followed by comma or colon, must be Formal_Part
955
 
956
            if Token = Tok_Comma or else Token = Tok_Colon then
957
               Restore_Scan_State (Scan_State); -- to left paren
958
               Set_Parameter_Specifications (Accept_Node, P_Parameter_Profile);
959
 
960
            --  If identifier not followed by comma/colon, must be entry index
961
 
962
            else
963
               Restore_Scan_State (Scan_State); -- to left paren
964
               Scan; -- past left paren (again!)
965
               Set_Entry_Index (Accept_Node, P_Expression);
966
               T_Right_Paren;
967
               Set_Parameter_Specifications (Accept_Node, P_Parameter_Profile);
968
            end if;
969
         end if;
970
      end if;
971
 
972
      --  Scan out DO if present
973
 
974
      if Token = Tok_Do then
975
         Scope.Table (Scope.Last).Etyp := E_Name;
976
         Scope.Table (Scope.Last).Lreq := False;
977
         Scan; -- past DO
978
         Hand_Seq := P_Handled_Sequence_Of_Statements;
979
         Set_Handled_Statement_Sequence (Accept_Node, Hand_Seq);
980
         End_Statements (Handled_Statement_Sequence (Accept_Node));
981
 
982
         --  Exception handlers not allowed in Ada 95 node
983
 
984
         if Present (Exception_Handlers (Hand_Seq)) then
985
            if Ada_Version = Ada_83 then
986
               Error_Msg_N
987
                 ("(Ada 83) exception handlers in accept not allowed",
988
                  First_Non_Pragma (Exception_Handlers (Hand_Seq)));
989
            end if;
990
         end if;
991
 
992
      else
993
         Pop_Scope_Stack; -- discard unused entry
994
         TF_Semicolon;
995
      end if;
996
 
997
      return Accept_Node;
998
 
999
   --  If error, resynchronize past semicolon
1000
 
1001
   exception
1002
      when Error_Resync =>
1003
         Resync_Past_Semicolon;
1004
         Pop_Scope_Stack; -- discard unused entry
1005
         return Error;
1006
 
1007
   end P_Accept_Statement;
1008
 
1009
   ------------------------
1010
   -- 9.5.2  Entry Index --
1011
   ------------------------
1012
 
1013
   --  Parsed by P_Expression (4.4)
1014
 
1015
   -----------------------
1016
   -- 9.5.2  Entry Body --
1017
   -----------------------
1018
 
1019
   --  ENTRY_BODY ::=
1020
   --    entry DEFINING_IDENTIFIER ENTRY_BODY_FORMAL_PART ENTRY_BARRIER is
1021
   --      DECLARATIVE_PART
1022
   --    begin
1023
   --      HANDLED_SEQUENCE_OF_STATEMENTS
1024
   --    end [entry_IDENTIFIER];
1025
 
1026
   --  The caller has checked that the initial token is ENTRY
1027
 
1028
   --  Error_Recovery: cannot raise Error_Resync
1029
 
1030
   function P_Entry_Body return Node_Id is
1031
      Entry_Node       : Node_Id;
1032
      Formal_Part_Node : Node_Id;
1033
      Name_Node        : Node_Id;
1034
 
1035
   begin
1036
      Push_Scope_Stack;
1037
      Entry_Node := New_Node (N_Entry_Body, Token_Ptr);
1038
      Scan; -- past ENTRY
1039
 
1040
      Scope.Table (Scope.Last).Ecol := Start_Column;
1041
      Scope.Table (Scope.Last).Lreq := False;
1042
      Scope.Table (Scope.Last).Etyp := E_Name;
1043
 
1044
      Name_Node := P_Defining_Identifier;
1045
      Set_Defining_Identifier (Entry_Node, Name_Node);
1046
      Scope.Table (Scope.Last).Labl := Name_Node;
1047
 
1048
      Formal_Part_Node := P_Entry_Body_Formal_Part;
1049
      Set_Entry_Body_Formal_Part (Entry_Node, Formal_Part_Node);
1050
 
1051
      Set_Condition (Formal_Part_Node, P_Entry_Barrier);
1052
      Parse_Decls_Begin_End (Entry_Node);
1053
      return Entry_Node;
1054
   end P_Entry_Body;
1055
 
1056
   -----------------------------------
1057
   -- 9.5.2  Entry Body Formal Part --
1058
   -----------------------------------
1059
 
1060
   --  ENTRY_BODY_FORMAL_PART ::=
1061
   --    [(ENTRY_INDEX_SPECIFICATION)] [PARAMETER_PART]
1062
 
1063
   --  Error_Recovery: cannot raise Error_Resync
1064
 
1065
   function P_Entry_Body_Formal_Part return Node_Id is
1066
      Fpart_Node : Node_Id;
1067
      Scan_State : Saved_Scan_State;
1068
 
1069
   begin
1070
      Fpart_Node := New_Node (N_Entry_Body_Formal_Part, Token_Ptr);
1071
 
1072
      --  See if entry index specification present, and if so parse it
1073
 
1074
      if Token = Tok_Left_Paren then
1075
         Save_Scan_State (Scan_State); -- at left paren
1076
         Scan; -- past left paren
1077
 
1078
         if Token = Tok_For then
1079
            Set_Entry_Index_Specification
1080
              (Fpart_Node, P_Entry_Index_Specification);
1081
            T_Right_Paren;
1082
         else
1083
            Restore_Scan_State (Scan_State); -- to left paren
1084
         end if;
1085
 
1086
      --  Check for (common?) case of left paren omitted before FOR. This
1087
      --  is a tricky case, because the corresponding missing left paren
1088
      --  can cause real havoc if a formal part is present which gets
1089
      --  treated as part of the discrete subtype definition of the
1090
      --  entry index specification, so just give error and resynchronize
1091
 
1092
      elsif Token = Tok_For then
1093
         T_Left_Paren; -- to give error message
1094
         Resync_To_When;
1095
      end if;
1096
 
1097
      Set_Parameter_Specifications (Fpart_Node, P_Parameter_Profile);
1098
      return Fpart_Node;
1099
   end P_Entry_Body_Formal_Part;
1100
 
1101
   --------------------------
1102
   -- 9.5.2  Entry Barrier --
1103
   --------------------------
1104
 
1105
   --  ENTRY_BARRIER ::= when CONDITION
1106
 
1107
   --  Error_Recovery: cannot raise Error_Resync
1108
 
1109
   function P_Entry_Barrier return Node_Id is
1110
      Bnode : Node_Id;
1111
 
1112
   begin
1113
      if Token = Tok_When then
1114
         Scan; -- past WHEN;
1115
         Bnode := P_Expression_No_Right_Paren;
1116
 
1117
         if Token = Tok_Colon_Equal then
1118
            Error_Msg_SC ("|"":="" should be ""=""");
1119
            Scan;
1120
            Bnode := P_Expression_No_Right_Paren;
1121
         end if;
1122
 
1123
      else
1124
         T_When; -- to give error message
1125
         Bnode := Error;
1126
      end if;
1127
 
1128
      TF_Is;
1129
      return Bnode;
1130
   end P_Entry_Barrier;
1131
 
1132
   --------------------------------------
1133
   -- 9.5.2  Entry Index Specification --
1134
   --------------------------------------
1135
 
1136
   --  ENTRY_INDEX_SPECIFICATION ::=
1137
   --    for DEFINING_IDENTIFIER in DISCRETE_SUBTYPE_DEFINITION
1138
 
1139
   --  Error recovery: can raise Error_Resync
1140
 
1141
   function P_Entry_Index_Specification return Node_Id is
1142
      Iterator_Node : Node_Id;
1143
 
1144
   begin
1145
      Iterator_Node := New_Node (N_Entry_Index_Specification, Token_Ptr);
1146
      T_For; -- past FOR
1147
      Set_Defining_Identifier (Iterator_Node, P_Defining_Identifier (C_In));
1148
      T_In;
1149
      Set_Discrete_Subtype_Definition
1150
        (Iterator_Node, P_Discrete_Subtype_Definition);
1151
      return Iterator_Node;
1152
   end P_Entry_Index_Specification;
1153
 
1154
   ---------------------------------
1155
   -- 9.5.3  Entry Call Statement --
1156
   ---------------------------------
1157
 
1158
   --  Parsed by P_Name (4.1). Within a select, an entry call is parsed
1159
   --  by P_Select_Statement (9.7)
1160
 
1161
   ------------------------------
1162
   -- 9.5.4  Requeue Statement --
1163
   ------------------------------
1164
 
1165
   --  REQUEUE_STATEMENT ::= requeue entry_NAME [with abort];
1166
 
1167
   --  The caller has checked that the initial token is requeue
1168
 
1169
   --  Error recovery: can raise Error_Resync
1170
 
1171
   function P_Requeue_Statement return Node_Id is
1172
      Requeue_Node : Node_Id;
1173
 
1174
   begin
1175
      Requeue_Node := New_Node (N_Requeue_Statement, Token_Ptr);
1176
      Scan; -- past REQUEUE
1177
      Set_Name (Requeue_Node, P_Name);
1178
 
1179
      if Token = Tok_With then
1180
         Scan; -- past WITH
1181
         T_Abort;
1182
         Set_Abort_Present (Requeue_Node, True);
1183
      end if;
1184
 
1185
      TF_Semicolon;
1186
      return Requeue_Node;
1187
   end P_Requeue_Statement;
1188
 
1189
   --------------------------
1190
   -- 9.6  Delay Statement --
1191
   --------------------------
1192
 
1193
   --  DELAY_STATEMENT ::=
1194
   --    DELAY_UNTIL_STATEMENT
1195
   --  | DELAY_RELATIVE_STATEMENT
1196
 
1197
   --  The caller has checked that the initial token is DELAY
1198
 
1199
   --  Error recovery: cannot raise Error_Resync
1200
 
1201
   function P_Delay_Statement return Node_Id is
1202
   begin
1203
      Scan; -- past DELAY
1204
 
1205
      --  The following check for delay until misused in Ada 83 doesn't catch
1206
      --  all cases, but it's good enough to catch most of them!
1207
 
1208
      if Token_Name = Name_Until then
1209
         Check_95_Keyword (Tok_Until, Tok_Left_Paren);
1210
         Check_95_Keyword (Tok_Until, Tok_Identifier);
1211
      end if;
1212
 
1213
      if Token = Tok_Until then
1214
         return P_Delay_Until_Statement;
1215
      else
1216
         return P_Delay_Relative_Statement;
1217
      end if;
1218
   end P_Delay_Statement;
1219
 
1220
   --------------------------------
1221
   -- 9.6  Delay Until Statement --
1222
   --------------------------------
1223
 
1224
   --  DELAY_UNTIL_STATEMENT ::= delay until delay_EXPRESSION;
1225
 
1226
   --  The caller has checked that the initial token is DELAY, scanned it
1227
   --  out and checked that the current token is UNTIL
1228
 
1229
   --  Error recovery: cannot raise Error_Resync
1230
 
1231
   function P_Delay_Until_Statement return Node_Id is
1232
      Delay_Node : Node_Id;
1233
 
1234
   begin
1235
      Delay_Node := New_Node (N_Delay_Until_Statement, Prev_Token_Ptr);
1236
      Scan; -- past UNTIL
1237
      Set_Expression (Delay_Node, P_Expression_No_Right_Paren);
1238
      TF_Semicolon;
1239
      return Delay_Node;
1240
   end P_Delay_Until_Statement;
1241
 
1242
   -----------------------------------
1243
   -- 9.6  Delay Relative Statement --
1244
   -----------------------------------
1245
 
1246
   --  DELAY_RELATIVE_STATEMENT ::= delay delay_EXPRESSION;
1247
 
1248
   --  The caller has checked that the initial token is DELAY, scanned it
1249
   --  out and determined that the current token is not UNTIL
1250
 
1251
   --  Error recovery: cannot raise Error_Resync
1252
 
1253
   function P_Delay_Relative_Statement return Node_Id is
1254
      Delay_Node : Node_Id;
1255
 
1256
   begin
1257
      Delay_Node := New_Node (N_Delay_Relative_Statement, Prev_Token_Ptr);
1258
      Set_Expression (Delay_Node, P_Expression_No_Right_Paren);
1259
      Check_Simple_Expression_In_Ada_83 (Expression (Delay_Node));
1260
      TF_Semicolon;
1261
      return Delay_Node;
1262
   end P_Delay_Relative_Statement;
1263
 
1264
   ---------------------------
1265
   -- 9.7  Select Statement --
1266
   ---------------------------
1267
 
1268
   --  SELECT_STATEMENT ::=
1269
   --    SELECTIVE_ACCEPT
1270
   --  | TIMED_ENTRY_CALL
1271
   --  | CONDITIONAL_ENTRY_CALL
1272
   --  | ASYNCHRONOUS_SELECT
1273
 
1274
   --  SELECTIVE_ACCEPT ::=
1275
   --    select
1276
   --      [GUARD]
1277
   --        SELECT_ALTERNATIVE
1278
   --    {or
1279
   --      [GUARD]
1280
   --        SELECT_ALTERNATIVE
1281
   --    [else
1282
   --      SEQUENCE_OF_STATEMENTS]
1283
   --    end select;
1284
 
1285
   --  GUARD ::= when CONDITION =>
1286
 
1287
   --  Note: the guard preceding a select alternative is included as part
1288
   --  of the node generated for a selective accept alternative.
1289
 
1290
   --  SELECT_ALTERNATIVE ::=
1291
   --    ACCEPT_ALTERNATIVE
1292
   --  | DELAY_ALTERNATIVE
1293
   --  | TERMINATE_ALTERNATIVE
1294
 
1295
   --  TIMED_ENTRY_CALL ::=
1296
   --    select
1297
   --      ENTRY_CALL_ALTERNATIVE
1298
   --    or
1299
   --      DELAY_ALTERNATIVE
1300
   --    end select;
1301
 
1302
   --  CONDITIONAL_ENTRY_CALL ::=
1303
   --    select
1304
   --      ENTRY_CALL_ALTERNATIVE
1305
   --    else
1306
   --      SEQUENCE_OF_STATEMENTS
1307
   --    end select;
1308
 
1309
   --  ENTRY_CALL_ALTERNATIVE ::=
1310
   --    ENTRY_CALL_STATEMENT [SEQUENCE_OF_STATEMENTS]
1311
 
1312
   --  ASYNCHRONOUS_SELECT ::=
1313
   --    select
1314
   --      TRIGGERING_ALTERNATIVE
1315
   --    then abort
1316
   --      ABORTABLE_PART
1317
   --    end select;
1318
 
1319
   --  TRIGGERING_ALTERNATIVE ::=
1320
   --    TRIGGERING_STATEMENT [SEQUENCE_OF_STATEMENTS]
1321
 
1322
   --  TRIGGERING_STATEMENT ::= ENTRY_CALL_STATEMENT | DELAY_STATEMENT
1323
 
1324
   --  The caller has checked that the initial token is SELECT
1325
 
1326
   --  Error recovery: can raise Error_Resync
1327
 
1328
   function P_Select_Statement return Node_Id is
1329
      Select_Node    : Node_Id;
1330
      Select_Sloc    : Source_Ptr;
1331
      Stmnt_Sloc     : Source_Ptr;
1332
      Ecall_Node     : Node_Id;
1333
      Alternative    : Node_Id;
1334
      Select_Pragmas : List_Id;
1335
      Alt_Pragmas    : List_Id;
1336
      Statement_List : List_Id;
1337
      Alt_List       : List_Id;
1338
      Cond_Expr      : Node_Id;
1339
      Delay_Stmnt    : Node_Id;
1340
 
1341
   begin
1342
      Push_Scope_Stack;
1343
      Scope.Table (Scope.Last).Etyp := E_Select;
1344
      Scope.Table (Scope.Last).Ecol := Start_Column;
1345
      Scope.Table (Scope.Last).Sloc := Token_Ptr;
1346
      Scope.Table (Scope.Last).Labl := Error;
1347
 
1348
      Select_Sloc := Token_Ptr;
1349
      Scan; -- past SELECT
1350
      Stmnt_Sloc := Token_Ptr;
1351
      Select_Pragmas := P_Pragmas_Opt;
1352
 
1353
      --  If first token after select is designator, then we have an entry
1354
      --  call, which must be the start of a conditional entry call, timed
1355
      --  entry call or asynchronous select
1356
 
1357
      if Token in Token_Class_Desig then
1358
 
1359
         --  Scan entry call statement
1360
 
1361
         begin
1362
            Ecall_Node := P_Name;
1363
 
1364
            --  ??  The following two clauses exactly parallel code in ch5
1365
            --      and should be combined sometime
1366
 
1367
            if Nkind (Ecall_Node) = N_Indexed_Component then
1368
               declare
1369
                  Prefix_Node : constant Node_Id := Prefix (Ecall_Node);
1370
                  Exprs_Node  : constant List_Id := Expressions (Ecall_Node);
1371
 
1372
               begin
1373
                  Change_Node (Ecall_Node, N_Procedure_Call_Statement);
1374
                  Set_Name (Ecall_Node, Prefix_Node);
1375
                  Set_Parameter_Associations (Ecall_Node, Exprs_Node);
1376
               end;
1377
 
1378
            elsif Nkind (Ecall_Node) = N_Function_Call then
1379
               declare
1380
                  Fname_Node  : constant Node_Id := Name (Ecall_Node);
1381
                  Params_List : constant List_Id :=
1382
                                  Parameter_Associations (Ecall_Node);
1383
 
1384
               begin
1385
                  Change_Node (Ecall_Node, N_Procedure_Call_Statement);
1386
                  Set_Name (Ecall_Node, Fname_Node);
1387
                  Set_Parameter_Associations (Ecall_Node, Params_List);
1388
               end;
1389
 
1390
            elsif Nkind (Ecall_Node) = N_Identifier
1391
              or else Nkind (Ecall_Node) = N_Selected_Component
1392
            then
1393
               --  Case of a call to a parameterless entry
1394
 
1395
               declare
1396
                  C_Node : constant Node_Id :=
1397
                         New_Node (N_Procedure_Call_Statement, Stmnt_Sloc);
1398
               begin
1399
                  Set_Name (C_Node, Ecall_Node);
1400
                  Set_Parameter_Associations (C_Node, No_List);
1401
                  Ecall_Node := C_Node;
1402
               end;
1403
            end if;
1404
 
1405
            TF_Semicolon;
1406
 
1407
         exception
1408
            when Error_Resync =>
1409
               Resync_Past_Semicolon;
1410
               return Error;
1411
         end;
1412
 
1413
         Statement_List := P_Sequence_Of_Statements (SS_Eltm_Ortm_Tatm);
1414
 
1415
         --  OR follows, we have a timed entry call
1416
 
1417
         if Token = Tok_Or then
1418
            Scan; -- past OR
1419
            Alt_Pragmas := P_Pragmas_Opt;
1420
 
1421
            Select_Node := New_Node (N_Timed_Entry_Call, Select_Sloc);
1422
            Set_Entry_Call_Alternative (Select_Node,
1423
              Make_Entry_Call_Alternative (Stmnt_Sloc,
1424
                Entry_Call_Statement => Ecall_Node,
1425
                Pragmas_Before       => Select_Pragmas,
1426
                Statements           => Statement_List));
1427
 
1428
            --  Only possibility is delay alternative. If we have anything
1429
            --  else, give message, and treat as conditional entry call.
1430
 
1431
            if Token /= Tok_Delay then
1432
               Error_Msg_SC
1433
                 ("only allowed alternative in timed entry call is delay!");
1434
               Discard_Junk_List (P_Sequence_Of_Statements (SS_Sreq));
1435
               Set_Delay_Alternative (Select_Node, Error);
1436
 
1437
            else
1438
               Set_Delay_Alternative (Select_Node, P_Delay_Alternative);
1439
               Set_Pragmas_Before
1440
                 (Delay_Alternative (Select_Node), Alt_Pragmas);
1441
            end if;
1442
 
1443
         --  ELSE follows, we have a conditional entry call
1444
 
1445
         elsif Token = Tok_Else then
1446
            Scan; -- past ELSE
1447
            Select_Node := New_Node (N_Conditional_Entry_Call, Select_Sloc);
1448
 
1449
            Set_Entry_Call_Alternative (Select_Node,
1450
              Make_Entry_Call_Alternative (Stmnt_Sloc,
1451
                Entry_Call_Statement => Ecall_Node,
1452
                Pragmas_Before       => Select_Pragmas,
1453
                Statements           => Statement_List));
1454
 
1455
            Set_Else_Statements
1456
              (Select_Node, P_Sequence_Of_Statements (SS_Sreq));
1457
 
1458
         --  Only remaining case is THEN ABORT (asynchronous select)
1459
 
1460
         elsif Token = Tok_Abort then
1461
            Select_Node :=
1462
              Make_Asynchronous_Select (Select_Sloc,
1463
                Triggering_Alternative =>
1464
                  Make_Triggering_Alternative (Stmnt_Sloc,
1465
                    Triggering_Statement => Ecall_Node,
1466
                    Pragmas_Before       => Select_Pragmas,
1467
                    Statements           => Statement_List),
1468
                Abortable_Part => P_Abortable_Part);
1469
 
1470
         --  Else error
1471
 
1472
         else
1473
            if Ada_Version = Ada_83 then
1474
               Error_Msg_BC ("OR or ELSE expected");
1475
            else
1476
               Error_Msg_BC ("OR or ELSE or THEN ABORT expected");
1477
            end if;
1478
 
1479
            Select_Node := Error;
1480
         end if;
1481
 
1482
         End_Statements;
1483
 
1484
      --  Here we have a selective accept or an asynchronous select (first
1485
      --  token after SELECT is other than a designator token).
1486
 
1487
      else
1488
         --  If we have delay with no guard, could be asynchronous select
1489
 
1490
         if Token = Tok_Delay then
1491
            Delay_Stmnt := P_Delay_Statement;
1492
            Statement_List := P_Sequence_Of_Statements (SS_Eltm_Ortm_Tatm);
1493
 
1494
            --  Asynchronous select
1495
 
1496
            if Token = Tok_Abort then
1497
               Select_Node :=
1498
                 Make_Asynchronous_Select (Select_Sloc,
1499
                   Triggering_Alternative =>
1500
                     Make_Triggering_Alternative (Stmnt_Sloc,
1501
                       Triggering_Statement => Delay_Stmnt,
1502
                       Pragmas_Before       => Select_Pragmas,
1503
                       Statements           => Statement_List),
1504
                     Abortable_Part => P_Abortable_Part);
1505
 
1506
               End_Statements;
1507
               return Select_Node;
1508
 
1509
            --  Delay which was not an asynchronous select. Must be a selective
1510
            --  accept, and since at least one accept statement is required,
1511
            --  we must have at least one OR phrase present.
1512
 
1513
            else
1514
               Alt_List := New_List (
1515
                 Make_Delay_Alternative (Stmnt_Sloc,
1516
                   Delay_Statement => Delay_Stmnt,
1517
                   Pragmas_Before  => Select_Pragmas,
1518
                   Statements      => Statement_List));
1519
               T_Or;
1520
               Alt_Pragmas := P_Pragmas_Opt;
1521
            end if;
1522
 
1523
         --  If not a delay statement, then must be another possibility for
1524
         --  a selective accept alternative, or perhaps a guard is present
1525
 
1526
         else
1527
            Alt_List := New_List;
1528
            Alt_Pragmas := Select_Pragmas;
1529
         end if;
1530
 
1531
         Select_Node := New_Node (N_Selective_Accept, Select_Sloc);
1532
         Set_Select_Alternatives (Select_Node, Alt_List);
1533
 
1534
         --  Scan out selective accept alternatives. On entry to this loop,
1535
         --  we are just past a SELECT or OR token, and any pragmas that
1536
         --  immediately follow the SELECT or OR are in Alt_Pragmas.
1537
 
1538
         loop
1539
            if Token = Tok_When then
1540
 
1541
               if Present (Alt_Pragmas) then
1542
                  Error_Msg_SC ("pragmas may not precede guard");
1543
               end if;
1544
 
1545
               Scan; --  past WHEN
1546
               Cond_Expr := P_Expression_No_Right_Paren;
1547
               T_Arrow;
1548
               Alt_Pragmas := P_Pragmas_Opt;
1549
 
1550
            else
1551
               Cond_Expr := Empty;
1552
            end if;
1553
 
1554
            if Token = Tok_Accept then
1555
               Alternative := P_Accept_Alternative;
1556
 
1557
               --  Check for junk attempt at asynchronous select using
1558
               --  an Accept alternative as the triggering statement
1559
 
1560
               if Token = Tok_Abort
1561
                 and then Is_Empty_List (Alt_List)
1562
                 and then No (Cond_Expr)
1563
               then
1564
                  Error_Msg
1565
                    ("triggering statement must be entry call or delay",
1566
                     Sloc (Alternative));
1567
                  Scan; -- past junk ABORT
1568
                  Discard_Junk_List (P_Sequence_Of_Statements (SS_Sreq));
1569
                  End_Statements;
1570
                  return Error;
1571
               end if;
1572
 
1573
            elsif Token = Tok_Delay then
1574
               Alternative := P_Delay_Alternative;
1575
 
1576
            elsif Token = Tok_Terminate then
1577
               Alternative := P_Terminate_Alternative;
1578
 
1579
            else
1580
               Error_Msg_SC
1581
                 ("select alternative (ACCEPT, ABORT, DELAY) expected");
1582
               Alternative := Error;
1583
 
1584
               if Token = Tok_Semicolon then
1585
                  Scan; -- past junk semicolon
1586
               end if;
1587
            end if;
1588
 
1589
            --  THEN ABORT at this stage is just junk
1590
 
1591
            if Token = Tok_Abort then
1592
               Error_Msg_SP ("misplaced `THEN ABORT`");
1593
               Scan; -- past junk ABORT
1594
               Discard_Junk_List (P_Sequence_Of_Statements (SS_Sreq));
1595
               End_Statements;
1596
               return Error;
1597
 
1598
            else
1599
               if Alternative /= Error then
1600
                  Set_Condition (Alternative, Cond_Expr);
1601
                  Set_Pragmas_Before (Alternative, Alt_Pragmas);
1602
                  Append (Alternative, Alt_List);
1603
               end if;
1604
 
1605
               exit when Token /= Tok_Or;
1606
            end if;
1607
 
1608
            T_Or;
1609
            Alt_Pragmas := P_Pragmas_Opt;
1610
         end loop;
1611
 
1612
         if Token = Tok_Else then
1613
            Scan; -- past ELSE
1614
            Set_Else_Statements
1615
              (Select_Node, P_Sequence_Of_Statements (SS_Ortm_Sreq));
1616
 
1617
            if Token = Tok_Or then
1618
               Error_Msg_SC ("select alternative cannot follow else part!");
1619
            end if;
1620
         end if;
1621
 
1622
         End_Statements;
1623
      end if;
1624
 
1625
      return Select_Node;
1626
   end P_Select_Statement;
1627
 
1628
   -----------------------------
1629
   -- 9.7.1  Selective Accept --
1630
   -----------------------------
1631
 
1632
   --  Parsed by P_Select_Statement (9.7)
1633
 
1634
   ------------------
1635
   -- 9.7.1  Guard --
1636
   ------------------
1637
 
1638
   --  Parsed by P_Select_Statement (9.7)
1639
 
1640
   -------------------------------
1641
   -- 9.7.1  Select Alternative --
1642
   -------------------------------
1643
 
1644
   --  SELECT_ALTERNATIVE ::=
1645
   --    ACCEPT_ALTERNATIVE
1646
   --  | DELAY_ALTERNATIVE
1647
   --  | TERMINATE_ALTERNATIVE
1648
 
1649
   --  Note: the guard preceding a select alternative is included as part
1650
   --  of the node generated for a selective accept alternative.
1651
 
1652
   --  Error recovery: cannot raise Error_Resync
1653
 
1654
   -------------------------------
1655
   -- 9.7.1  Accept Alternative --
1656
   -------------------------------
1657
 
1658
   --  ACCEPT_ALTERNATIVE ::=
1659
   --    ACCEPT_STATEMENT [SEQUENCE_OF_STATEMENTS]
1660
 
1661
   --  Error_Recovery: Cannot raise Error_Resync
1662
 
1663
   --  Note: the caller is responsible for setting the Pragmas_Before
1664
   --  field of the returned N_Terminate_Alternative node.
1665
 
1666
   function P_Accept_Alternative return Node_Id is
1667
      Accept_Alt_Node : Node_Id;
1668
 
1669
   begin
1670
      Accept_Alt_Node := New_Node (N_Accept_Alternative, Token_Ptr);
1671
      Set_Accept_Statement (Accept_Alt_Node, P_Accept_Statement);
1672
 
1673
      --  Note: the reason that we accept THEN ABORT as a terminator for
1674
      --  the sequence of statements is for error recovery which allows
1675
      --  for misuse of an accept statement as a triggering statement.
1676
 
1677
      Set_Statements
1678
        (Accept_Alt_Node, P_Sequence_Of_Statements (SS_Eltm_Ortm_Tatm));
1679
      return Accept_Alt_Node;
1680
   end P_Accept_Alternative;
1681
 
1682
   ------------------------------
1683
   -- 9.7.1  Delay Alternative --
1684
   ------------------------------
1685
 
1686
   --  DELAY_ALTERNATIVE ::=
1687
   --    DELAY_STATEMENT [SEQUENCE_OF_STATEMENTS]
1688
 
1689
   --  Error_Recovery: Cannot raise Error_Resync
1690
 
1691
   --  Note: the caller is responsible for setting the Pragmas_Before
1692
   --  field of the returned N_Terminate_Alternative node.
1693
 
1694
   function P_Delay_Alternative return Node_Id is
1695
      Delay_Alt_Node : Node_Id;
1696
 
1697
   begin
1698
      Delay_Alt_Node := New_Node (N_Delay_Alternative, Token_Ptr);
1699
      Set_Delay_Statement (Delay_Alt_Node, P_Delay_Statement);
1700
 
1701
      --  Note: the reason that we accept THEN ABORT as a terminator for
1702
      --  the sequence of statements is for error recovery which allows
1703
      --  for misuse of an accept statement as a triggering statement.
1704
 
1705
      Set_Statements
1706
        (Delay_Alt_Node, P_Sequence_Of_Statements (SS_Eltm_Ortm_Tatm));
1707
      return Delay_Alt_Node;
1708
   end P_Delay_Alternative;
1709
 
1710
   ----------------------------------
1711
   -- 9.7.1  Terminate Alternative --
1712
   ----------------------------------
1713
 
1714
   --  TERMINATE_ALTERNATIVE ::= terminate;
1715
 
1716
   --  Error_Recovery: Cannot raise Error_Resync
1717
 
1718
   --  Note: the caller is responsible for setting the Pragmas_Before
1719
   --  field of the returned N_Terminate_Alternative node.
1720
 
1721
   function P_Terminate_Alternative return Node_Id is
1722
      Terminate_Alt_Node : Node_Id;
1723
 
1724
   begin
1725
      Terminate_Alt_Node := New_Node (N_Terminate_Alternative, Token_Ptr);
1726
      Scan; -- past TERMINATE
1727
      TF_Semicolon;
1728
 
1729
      --  For all other select alternatives, the sequence of statements
1730
      --  after the alternative statement will swallow up any pragmas
1731
      --  coming in this position. But the terminate alternative has no
1732
      --  sequence of statements, so the pragmas here must be treated
1733
      --  specially.
1734
 
1735
      Set_Pragmas_After (Terminate_Alt_Node, P_Pragmas_Opt);
1736
      return Terminate_Alt_Node;
1737
   end P_Terminate_Alternative;
1738
 
1739
   -----------------------------
1740
   -- 9.7.2  Timed Entry Call --
1741
   -----------------------------
1742
 
1743
   --  Parsed by P_Select_Statement (9.7)
1744
 
1745
   -----------------------------------
1746
   -- 9.7.2  Entry Call Alternative --
1747
   -----------------------------------
1748
 
1749
   --  Parsed by P_Select_Statement (9.7)
1750
 
1751
   -----------------------------------
1752
   -- 9.7.3  Conditional Entry Call --
1753
   -----------------------------------
1754
 
1755
   --  Parsed by P_Select_Statement (9.7)
1756
 
1757
   --------------------------------
1758
   -- 9.7.4  Asynchronous Select --
1759
   --------------------------------
1760
 
1761
   --  Parsed by P_Select_Statement (9.7)
1762
 
1763
   -----------------------------------
1764
   -- 9.7.4  Triggering Alternative --
1765
   -----------------------------------
1766
 
1767
   --  Parsed by P_Select_Statement (9.7)
1768
 
1769
   ---------------------------------
1770
   -- 9.7.4  Triggering Statement --
1771
   ---------------------------------
1772
 
1773
   --  Parsed by P_Select_Statement (9.7)
1774
 
1775
   ---------------------------
1776
   -- 9.7.4  Abortable Part --
1777
   ---------------------------
1778
 
1779
   --  ABORTABLE_PART ::= SEQUENCE_OF_STATEMENTS
1780
 
1781
   --  The caller has verified that THEN ABORT is present, and Token is
1782
   --  pointing to the ABORT on entry (or if not, then we have an error)
1783
 
1784
   --  Error recovery: cannot raise Error_Resync
1785
 
1786
   function P_Abortable_Part return Node_Id is
1787
      Abortable_Part_Node : Node_Id;
1788
 
1789
   begin
1790
      Abortable_Part_Node := New_Node (N_Abortable_Part, Token_Ptr);
1791
      T_Abort; -- scan past ABORT
1792
 
1793
      if Ada_Version = Ada_83 then
1794
         Error_Msg_SP ("(Ada 83) asynchronous select not allowed!");
1795
      end if;
1796
 
1797
      Set_Statements (Abortable_Part_Node, P_Sequence_Of_Statements (SS_Sreq));
1798
      return Abortable_Part_Node;
1799
   end P_Abortable_Part;
1800
 
1801
   --------------------------
1802
   -- 9.8  Abort Statement --
1803
   --------------------------
1804
 
1805
   --  ABORT_STATEMENT ::= abort task_NAME {, task_NAME};
1806
 
1807
   --  The caller has checked that the initial token is ABORT
1808
 
1809
   --  Error recovery: cannot raise Error_Resync
1810
 
1811
   function P_Abort_Statement return Node_Id is
1812
      Abort_Node : Node_Id;
1813
 
1814
   begin
1815
      Abort_Node := New_Node (N_Abort_Statement, Token_Ptr);
1816
      Scan; -- past ABORT
1817
      Set_Names (Abort_Node, New_List);
1818
 
1819
      loop
1820
         Append (P_Name, Names (Abort_Node));
1821
         exit when Token /= Tok_Comma;
1822
         Scan; -- past comma
1823
      end loop;
1824
 
1825
      TF_Semicolon;
1826
      return Abort_Node;
1827
   end P_Abort_Statement;
1828
 
1829
end Ch9;

powered by: WebSVN 2.1.0

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