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

Subversion Repositories openrisc

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

Details | Compare with Previous | View Log

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

powered by: WebSVN 2.1.0

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