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

Subversion Repositories openrisc_me

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

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 6                               --
6
--                                                                          --
7
--                                 B o d y                                  --
8
--                                                                          --
9
--          Copyright (C) 1992-2009, Free Software Foundation, Inc.         --
10
--                                                                          --
11
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
12
-- terms of the  GNU General Public License as published  by the Free Soft- --
13
-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
14
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
15
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
16
-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
17
-- for  more details.  You should have  received  a copy of the GNU General --
18
-- Public License  distributed with GNAT; see file COPYING3.  If not, go to --
19
-- http://www.gnu.org/licenses for a complete copy of the license.          --
20
--                                                                          --
21
-- GNAT was originally developed  by the GNAT team at  New York University. --
22
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
23
--                                                                          --
24
------------------------------------------------------------------------------
25
 
26
pragma Style_Checks (All_Checks);
27
--  Turn off subprogram body ordering check. Subprograms are in order
28
--  by RM section rather than alphabetical
29
 
30
with Sinfo.CN; use Sinfo.CN;
31
 
32
separate (Par)
33
package body Ch6 is
34
 
35
   --  Local subprograms, used only in this chapter
36
 
37
   function P_Defining_Designator        return Node_Id;
38
   function P_Defining_Operator_Symbol   return Node_Id;
39
   function P_Return_Object_Declaration  return Node_Id;
40
 
41
   procedure P_Return_Subtype_Indication (Decl_Node : Node_Id);
42
   --  Decl_Node is a N_Object_Declaration.
43
   --  Set the Null_Exclusion_Present and Object_Definition fields of
44
   --  Decl_Node.
45
 
46
   procedure Check_Junk_Semicolon_Before_Return;
47
 
48
   --  Check for common error of junk semicolon before RETURN keyword of
49
   --  function specification. If present, skip over it with appropriate
50
   --  error message, leaving Scan_Ptr pointing to the RETURN after. This
51
   --  routine also deals with a possibly misspelled version of Return.
52
 
53
   ----------------------------------------
54
   -- Check_Junk_Semicolon_Before_Return --
55
   ----------------------------------------
56
 
57
   procedure Check_Junk_Semicolon_Before_Return is
58
      Scan_State : Saved_Scan_State;
59
 
60
   begin
61
      if Token = Tok_Semicolon then
62
         Save_Scan_State (Scan_State);
63
         Scan; -- past the semicolon
64
 
65
         if Token = Tok_Return then
66
            Restore_Scan_State (Scan_State);
67
            Error_Msg_SC ("|extra "";"" ignored");
68
            Scan; -- rescan past junk semicolon
69
         else
70
            Restore_Scan_State (Scan_State);
71
         end if;
72
 
73
      elsif Bad_Spelling_Of (Tok_Return) then
74
         null;
75
      end if;
76
   end Check_Junk_Semicolon_Before_Return;
77
 
78
   -----------------------------------------------------
79
   -- 6.1  Subprogram (Also 6.3, 8.5.4, 10.1.3, 12.3) --
80
   -----------------------------------------------------
81
 
82
   --  This routine scans out a subprogram declaration, subprogram body,
83
   --  subprogram renaming declaration or subprogram generic instantiation.
84
 
85
   --  SUBPROGRAM_DECLARATION ::= SUBPROGRAM_SPECIFICATION;
86
 
87
   --  ABSTRACT_SUBPROGRAM_DECLARATION ::=
88
   --    SUBPROGRAM_SPECIFICATION is abstract;
89
 
90
   --  SUBPROGRAM_SPECIFICATION ::=
91
   --      procedure DEFINING_PROGRAM_UNIT_NAME PARAMETER_PROFILE
92
   --    | function DEFINING_DESIGNATOR PARAMETER_AND_RESULT_PROFILE
93
 
94
   --  PARAMETER_PROFILE ::= [FORMAL_PART]
95
 
96
   --  PARAMETER_AND_RESULT_PROFILE ::= [FORMAL_PART] return SUBTYPE_MARK
97
 
98
   --  SUBPROGRAM_BODY ::=
99
   --    SUBPROGRAM_SPECIFICATION is
100
   --      DECLARATIVE_PART
101
   --    begin
102
   --      HANDLED_SEQUENCE_OF_STATEMENTS
103
   --    end [DESIGNATOR];
104
 
105
   --  SUBPROGRAM_RENAMING_DECLARATION ::=
106
   --    SUBPROGRAM_SPECIFICATION renames callable_entity_NAME;
107
 
108
   --  SUBPROGRAM_BODY_STUB ::=
109
   --    SUBPROGRAM_SPECIFICATION is separate;
110
 
111
   --  GENERIC_INSTANTIATION ::=
112
   --    procedure DEFINING_PROGRAM_UNIT_NAME is
113
   --      new generic_procedure_NAME [GENERIC_ACTUAL_PART];
114
   --  | function DEFINING_DESIGNATOR is
115
   --      new generic_function_NAME [GENERIC_ACTUAL_PART];
116
 
117
   --  NULL_PROCEDURE_DECLARATION ::=
118
   --    SUBPROGRAM_SPECIFICATION is null;
119
 
120
   --  Null procedures are an Ada 2005 feature. A null procedure declaration
121
   --  is classified as a basic declarative item, but it is parsed here, with
122
   --  other subprogram constructs.
123
 
124
   --  The value in Pf_Flags indicates which of these possible declarations
125
   --  is acceptable to the caller:
126
 
127
   --    Pf_Flags.Decl                 Set if declaration OK
128
   --    Pf_Flags.Gins                 Set if generic instantiation OK
129
   --    Pf_Flags.Pbod                 Set if proper body OK
130
   --    Pf_Flags.Rnam                 Set if renaming declaration OK
131
   --    Pf_Flags.Stub                 Set if body stub OK
132
 
133
   --  If an inappropriate form is encountered, it is scanned out but an
134
   --  error message indicating that it is appearing in an inappropriate
135
   --  context is issued. The only possible values for Pf_Flags are those
136
   --  defined as constants in the Par package.
137
 
138
   --  The caller has checked that the initial token is FUNCTION, PROCEDURE,
139
   --  NOT or OVERRIDING.
140
 
141
   --  Error recovery: cannot raise Error_Resync
142
 
143
   function P_Subprogram (Pf_Flags : Pf_Rec) return Node_Id is
144
      Specification_Node : Node_Id;
145
      Name_Node          : Node_Id;
146
      Fpart_List         : List_Id;
147
      Fpart_Sloc         : Source_Ptr;
148
      Result_Not_Null    : Boolean := False;
149
      Result_Node        : Node_Id;
150
      Inst_Node          : Node_Id;
151
      Body_Node          : Node_Id;
152
      Decl_Node          : Node_Id;
153
      Rename_Node        : Node_Id;
154
      Absdec_Node        : Node_Id;
155
      Stub_Node          : Node_Id;
156
      Fproc_Sloc         : Source_Ptr;
157
      Func               : Boolean;
158
      Scan_State         : Saved_Scan_State;
159
 
160
      --  Flags for optional overriding indication. Two flags are needed,
161
      --  to distinguish positive and negative overriding indicators from
162
      --  the absence of any indicator.
163
 
164
      Is_Overriding  : Boolean := False;
165
      Not_Overriding : Boolean := False;
166
 
167
   begin
168
      --  Set up scope stack entry. Note that the Labl field will be set later
169
 
170
      SIS_Entry_Active := False;
171
      SIS_Missing_Semicolon_Message := No_Error_Msg;
172
      Push_Scope_Stack;
173
      Scope.Table (Scope.Last).Sloc := Token_Ptr;
174
      Scope.Table (Scope.Last).Etyp := E_Name;
175
      Scope.Table (Scope.Last).Ecol := Start_Column;
176
      Scope.Table (Scope.Last).Lreq := False;
177
 
178
      --  Ada2005: scan leading NOT OVERRIDING indicator
179
 
180
      if Token = Tok_Not then
181
         Scan;  -- past NOT
182
 
183
         if Token = Tok_Overriding then
184
            Scan;  --  past OVERRIDING
185
            Not_Overriding := True;
186
 
187
         --  Overriding keyword used in non Ada 2005 mode
188
 
189
         elsif Token = Tok_Identifier
190
           and then Token_Name = Name_Overriding
191
         then
192
            Error_Msg_SC ("overriding indicator is an Ada 2005 extension");
193
            Error_Msg_SC ("\unit must be compiled with -gnat05 switch");
194
            Scan;  --  past Overriding
195
            Not_Overriding := True;
196
 
197
         else
198
            Error_Msg_SC ("OVERRIDING expected!");
199
         end if;
200
 
201
      --  Ada 2005: scan leading OVERRIDING indicator
202
 
203
      --  Note: in the case of OVERRIDING keyword used in Ada 95 mode, the
204
      --  declaration circuit already gave an error message and changed the
205
      --  token to Tok_Overriding.
206
 
207
      elsif Token = Tok_Overriding then
208
         Scan;  --  past OVERRIDING
209
         Is_Overriding := True;
210
      end if;
211
 
212
      if (Is_Overriding or else Not_Overriding) then
213
 
214
         --  Note that if we are not in Ada_05 mode, error messages have
215
         --  already been given, so no need to give another message here.
216
 
217
         --  An overriding indicator is allowed for subprogram declarations,
218
         --  bodies, renamings, stubs, and instantiations. The test against
219
         --  Pf_Decl_Pbod is added to account for the case of subprograms
220
         --  declared in a protected type, where only subprogram declarations
221
         --  and bodies can occur.
222
 
223
         if Pf_Flags /= Pf_Decl_Gins_Pbod_Rnam_Stub
224
              and then
225
            Pf_Flags /= Pf_Decl_Pbod
226
         then
227
            Error_Msg_SC ("overriding indicator not allowed here!");
228
 
229
         elsif Token /= Tok_Function and then Token /= Tok_Procedure then
230
            Error_Msg_SC -- CODEFIX
231
              ("FUNCTION or PROCEDURE expected!");
232
         end if;
233
      end if;
234
 
235
      Func := (Token = Tok_Function);
236
      Fproc_Sloc := Token_Ptr;
237
      Scan; -- past FUNCTION or PROCEDURE
238
      Ignore (Tok_Type);
239
      Ignore (Tok_Body);
240
 
241
      if Func then
242
         Name_Node := P_Defining_Designator;
243
 
244
         if Nkind (Name_Node) = N_Defining_Operator_Symbol
245
           and then Scope.Last = 1
246
         then
247
            Error_Msg_SP ("operator symbol not allowed at library level");
248
            Name_Node := New_Entity (N_Defining_Identifier, Sloc (Name_Node));
249
 
250
            --  Set name from file name, we need some junk name, and that's
251
            --  as good as anything. This is only approximate, since we do
252
            --  not do anything with non-standard name translations.
253
 
254
            Get_Name_String (File_Name (Current_Source_File));
255
 
256
            for J in 1 .. Name_Len loop
257
               if Name_Buffer (J) = '.' then
258
                  Name_Len := J - 1;
259
                  exit;
260
               end if;
261
            end loop;
262
 
263
            Set_Chars (Name_Node, Name_Find);
264
            Set_Error_Posted (Name_Node);
265
         end if;
266
 
267
      else
268
         Name_Node := P_Defining_Program_Unit_Name;
269
      end if;
270
 
271
      Scope.Table (Scope.Last).Labl := Name_Node;
272
      Ignore (Tok_Colon);
273
 
274
      --  Deal with generic instantiation, the one case in which we do not
275
      --  have a subprogram specification as part of whatever we are parsing
276
 
277
      if Token = Tok_Is then
278
         Save_Scan_State (Scan_State); -- at the IS
279
         T_Is; -- checks for redundant IS
280
 
281
         if Token = Tok_New then
282
            if not Pf_Flags.Gins then
283
               Error_Msg_SC ("generic instantiation not allowed here!");
284
            end if;
285
 
286
            Scan; -- past NEW
287
 
288
            if Func then
289
               Inst_Node := New_Node (N_Function_Instantiation, Fproc_Sloc);
290
               Set_Name (Inst_Node, P_Function_Name);
291
            else
292
               Inst_Node := New_Node (N_Procedure_Instantiation, Fproc_Sloc);
293
               Set_Name (Inst_Node, P_Qualified_Simple_Name);
294
            end if;
295
 
296
            Set_Defining_Unit_Name (Inst_Node, Name_Node);
297
            Set_Generic_Associations (Inst_Node, P_Generic_Actual_Part_Opt);
298
            TF_Semicolon;
299
            Pop_Scope_Stack; -- Don't need scope stack entry in this case
300
 
301
            if Is_Overriding then
302
               Set_Must_Override (Inst_Node);
303
 
304
            elsif Not_Overriding then
305
               Set_Must_Not_Override (Inst_Node);
306
            end if;
307
 
308
            return Inst_Node;
309
 
310
         else
311
            Restore_Scan_State (Scan_State); -- to the IS
312
         end if;
313
      end if;
314
 
315
      --  If not a generic instantiation, then we definitely have a subprogram
316
      --  specification (all possibilities at this stage include one here)
317
 
318
      Fpart_Sloc := Token_Ptr;
319
 
320
      Check_Misspelling_Of (Tok_Return);
321
 
322
      --  Scan formal part. First a special error check. If we have an
323
      --  identifier here, then we have a definite error. If this identifier
324
      --  is on the same line as the designator, then we assume it is the
325
      --  first formal after a missing left parenthesis
326
 
327
      if Token = Tok_Identifier
328
        and then not Token_Is_At_Start_Of_Line
329
      then
330
            T_Left_Paren; -- to generate message
331
            Fpart_List := P_Formal_Part;
332
 
333
      --  Otherwise scan out an optional formal part in the usual manner
334
 
335
      else
336
         Fpart_List := P_Parameter_Profile;
337
      end if;
338
 
339
      --  We treat what we have as a function specification if FUNCTION was
340
      --  used, or if a RETURN is present. This gives better error recovery
341
      --  since later RETURN statements will be valid in either case.
342
 
343
      Check_Junk_Semicolon_Before_Return;
344
      Result_Node := Error;
345
 
346
      if Token = Tok_Return then
347
         if not Func then
348
            Error_Msg ("PROCEDURE should be FUNCTION", Fproc_Sloc);
349
            Func := True;
350
         end if;
351
 
352
         Scan; -- past RETURN
353
 
354
         Result_Not_Null := P_Null_Exclusion;     --  Ada 2005 (AI-231)
355
 
356
         --  Ada 2005 (AI-318-02)
357
 
358
         if Token = Tok_Access then
359
            if Ada_Version < Ada_05 then
360
               Error_Msg_SC
361
                 ("anonymous access result type is an Ada 2005 extension");
362
               Error_Msg_SC ("\unit must be compiled with -gnat05 switch");
363
            end if;
364
 
365
            Result_Node := P_Access_Definition (Result_Not_Null);
366
 
367
         else
368
            Result_Node := P_Subtype_Mark;
369
            No_Constraint;
370
         end if;
371
 
372
      else
373
         if Func then
374
            Ignore (Tok_Right_Paren);
375
            TF_Return;
376
         end if;
377
      end if;
378
 
379
      if Func then
380
         Specification_Node :=
381
           New_Node (N_Function_Specification, Fproc_Sloc);
382
 
383
         Set_Null_Exclusion_Present (Specification_Node, Result_Not_Null);
384
         Set_Result_Definition (Specification_Node, Result_Node);
385
 
386
      else
387
         Specification_Node :=
388
           New_Node (N_Procedure_Specification, Fproc_Sloc);
389
      end if;
390
 
391
      Set_Defining_Unit_Name (Specification_Node, Name_Node);
392
      Set_Parameter_Specifications (Specification_Node, Fpart_List);
393
 
394
      if Is_Overriding then
395
         Set_Must_Override (Specification_Node);
396
 
397
      elsif Not_Overriding then
398
         Set_Must_Not_Override (Specification_Node);
399
      end if;
400
 
401
      --  Error check: barriers not allowed on protected functions/procedures
402
 
403
      if Token = Tok_When then
404
         if Func then
405
            Error_Msg_SC ("barrier not allowed on function, only on entry");
406
         else
407
            Error_Msg_SC ("barrier not allowed on procedure, only on entry");
408
         end if;
409
 
410
         Scan; -- past WHEN
411
         Discard_Junk_Node (P_Expression);
412
      end if;
413
 
414
      --  Deal with semicolon followed by IS. We want to treat this as IS
415
 
416
      if Token = Tok_Semicolon then
417
         Save_Scan_State (Scan_State);
418
         Scan; -- past semicolon
419
 
420
         if Token = Tok_Is then
421
            Error_Msg_SP ("extra "";"" ignored");
422
         else
423
            Restore_Scan_State (Scan_State);
424
         end if;
425
      end if;
426
 
427
      --  Deal with case of semicolon ending a subprogram declaration
428
 
429
      if Token = Tok_Semicolon then
430
         if not Pf_Flags.Decl then
431
            T_Is;
432
         end if;
433
 
434
         Scan; -- past semicolon
435
 
436
         --  If semicolon is immediately followed by IS, then ignore the
437
         --  semicolon, and go process the body.
438
 
439
         if Token = Tok_Is then
440
            Error_Msg_SP ("|extra "";"" ignored");
441
            T_Is; -- scan past IS
442
            goto Subprogram_Body;
443
 
444
         --  If BEGIN follows in an appropriate column, we immediately
445
         --  commence the error action of assuming that the previous
446
         --  subprogram declaration should have been a subprogram body,
447
         --  i.e. that the terminating semicolon should have been IS.
448
 
449
         elsif Token = Tok_Begin
450
            and then Start_Column >= Scope.Table (Scope.Last).Ecol
451
         then
452
            Error_Msg_SP ("|"";"" should be IS!");
453
            goto Subprogram_Body;
454
 
455
         else
456
            goto Subprogram_Declaration;
457
         end if;
458
 
459
      --  Case of not followed by semicolon
460
 
461
      else
462
         --  Subprogram renaming declaration case
463
 
464
         Check_Misspelling_Of (Tok_Renames);
465
 
466
         if Token = Tok_Renames then
467
            if not Pf_Flags.Rnam then
468
               Error_Msg_SC ("renaming declaration not allowed here!");
469
            end if;
470
 
471
            Rename_Node :=
472
              New_Node (N_Subprogram_Renaming_Declaration, Token_Ptr);
473
            Scan; -- past RENAMES
474
            Set_Name (Rename_Node, P_Name);
475
            Set_Specification (Rename_Node, Specification_Node);
476
            TF_Semicolon;
477
            Pop_Scope_Stack;
478
            return Rename_Node;
479
 
480
         --  Case of IS following subprogram specification
481
 
482
         elsif Token = Tok_Is then
483
            T_Is; -- ignore redundant Is's
484
 
485
            if Token_Name = Name_Abstract then
486
               Check_95_Keyword (Tok_Abstract, Tok_Semicolon);
487
            end if;
488
 
489
            --  Deal nicely with (now obsolete) use of <> in place of abstract
490
 
491
            if Token = Tok_Box then
492
               Error_Msg_SC ("ABSTRACT expected");
493
               Token := Tok_Abstract;
494
            end if;
495
 
496
            --  Abstract subprogram declaration case
497
 
498
            if Token = Tok_Abstract then
499
               Absdec_Node :=
500
                 New_Node (N_Abstract_Subprogram_Declaration, Token_Ptr);
501
               Set_Specification (Absdec_Node, Specification_Node);
502
               Pop_Scope_Stack; -- discard unneeded entry
503
               Scan; -- past ABSTRACT
504
               TF_Semicolon;
505
               return Absdec_Node;
506
 
507
            --  Ada 2005 (AI-248): Parse a null procedure declaration
508
 
509
            elsif Token = Tok_Null then
510
               if Ada_Version < Ada_05 then
511
                  Error_Msg_SP ("null procedures are an Ada 2005 extension");
512
                  Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
513
               end if;
514
 
515
               Scan; -- past NULL
516
 
517
               if Func then
518
                  Error_Msg_SP ("only procedures can be null");
519
               else
520
                  Set_Null_Present (Specification_Node);
521
               end if;
522
 
523
               TF_Semicolon;
524
               goto Subprogram_Declaration;
525
 
526
            --  Check for IS NEW with Formal_Part present and handle nicely
527
 
528
            elsif Token = Tok_New then
529
               Error_Msg
530
                 ("formal part not allowed in instantiation", Fpart_Sloc);
531
               Scan; -- past NEW
532
 
533
               if Func then
534
                  Inst_Node := New_Node (N_Function_Instantiation, Fproc_Sloc);
535
               else
536
                  Inst_Node :=
537
                    New_Node (N_Procedure_Instantiation, Fproc_Sloc);
538
               end if;
539
 
540
               Set_Defining_Unit_Name (Inst_Node, Name_Node);
541
               Set_Name (Inst_Node, P_Name);
542
               Set_Generic_Associations (Inst_Node, P_Generic_Actual_Part_Opt);
543
               TF_Semicolon;
544
               Pop_Scope_Stack; -- Don't need scope stack entry in this case
545
               return Inst_Node;
546
 
547
            else
548
               goto Subprogram_Body;
549
            end if;
550
 
551
         --  Here we have a missing IS or missing semicolon, we always guess
552
         --  a missing semicolon, since we are pretty good at fixing up a
553
         --  semicolon which should really be an IS
554
 
555
         else
556
            Error_Msg_AP ("|missing "";""");
557
            SIS_Missing_Semicolon_Message := Get_Msg_Id;
558
            goto Subprogram_Declaration;
559
         end if;
560
      end if;
561
 
562
      --  Processing for subprogram body
563
 
564
      <<Subprogram_Body>>
565
         if not Pf_Flags.Pbod then
566
            Error_Msg_SP ("subprogram body not allowed here!");
567
         end if;
568
 
569
         --  Subprogram body stub case
570
 
571
         if Separate_Present then
572
            if not Pf_Flags.Stub then
573
               Error_Msg_SC ("body stub not allowed here!");
574
            end if;
575
 
576
            if Nkind (Name_Node) = N_Defining_Operator_Symbol then
577
               Error_Msg
578
                 ("operator symbol cannot be used as subunit name",
579
                  Sloc (Name_Node));
580
            end if;
581
 
582
            Stub_Node :=
583
              New_Node (N_Subprogram_Body_Stub, Sloc (Specification_Node));
584
            Set_Specification (Stub_Node, Specification_Node);
585
            Scan; -- past SEPARATE
586
            Pop_Scope_Stack;
587
            TF_Semicolon;
588
            return Stub_Node;
589
 
590
         --  Subprogram body case
591
 
592
         else
593
            --  Here is the test for a suspicious IS (i.e. one that looks
594
            --  like it might more properly be a semicolon). See separate
595
            --  section discussing use of IS instead of semicolon in
596
            --  package Parse.
597
 
598
            if (Token in Token_Class_Declk
599
                  or else
600
                Token = Tok_Identifier)
601
              and then Start_Column <= Scope.Table (Scope.Last).Ecol
602
              and then Scope.Last /= 1
603
            then
604
               Scope.Table (Scope.Last).Etyp := E_Suspicious_Is;
605
               Scope.Table (Scope.Last).S_Is := Prev_Token_Ptr;
606
            end if;
607
 
608
            Body_Node :=
609
              New_Node (N_Subprogram_Body, Sloc (Specification_Node));
610
            Set_Specification (Body_Node, Specification_Node);
611
            Parse_Decls_Begin_End (Body_Node);
612
            return Body_Node;
613
         end if;
614
 
615
      --  Processing for subprogram declaration
616
 
617
      <<Subprogram_Declaration>>
618
         Decl_Node :=
619
           New_Node (N_Subprogram_Declaration, Sloc (Specification_Node));
620
         Set_Specification (Decl_Node, Specification_Node);
621
 
622
         --  If this is a context in which a subprogram body is permitted,
623
         --  set active SIS entry in case (see section titled "Handling
624
         --  Semicolon Used in Place of IS" in body of Parser package)
625
         --  Note that SIS_Missing_Semicolon_Message is already set properly.
626
 
627
         if Pf_Flags.Pbod then
628
            SIS_Labl := Scope.Table (Scope.Last).Labl;
629
            SIS_Sloc := Scope.Table (Scope.Last).Sloc;
630
            SIS_Ecol := Scope.Table (Scope.Last).Ecol;
631
            SIS_Declaration_Node := Decl_Node;
632
            SIS_Semicolon_Sloc := Prev_Token_Ptr;
633
            SIS_Entry_Active := True;
634
         end if;
635
 
636
         Pop_Scope_Stack;
637
         return Decl_Node;
638
 
639
   end P_Subprogram;
640
 
641
   ---------------------------------
642
   -- 6.1  Subprogram Declaration --
643
   ---------------------------------
644
 
645
   --  Parsed by P_Subprogram (6.1)
646
 
647
   ------------------------------------------
648
   -- 6.1  Abstract Subprogram Declaration --
649
   ------------------------------------------
650
 
651
   --  Parsed by P_Subprogram (6.1)
652
 
653
   -----------------------------------
654
   -- 6.1  Subprogram Specification --
655
   -----------------------------------
656
 
657
   --  SUBPROGRAM_SPECIFICATION ::=
658
   --      procedure DEFINING_PROGRAM_UNIT_NAME PARAMETER_PROFILE
659
   --    | function DEFINING_DESIGNATOR PARAMETER_AND_RESULT_PROFILE
660
 
661
   --  PARAMETER_PROFILE ::= [FORMAL_PART]
662
 
663
   --  PARAMETER_AND_RESULT_PROFILE ::= [FORMAL_PART] return SUBTYPE_MARK
664
 
665
   --  Subprogram specifications that appear in subprogram declarations
666
   --  are parsed by P_Subprogram (6.1). This routine is used in other
667
   --  contexts where subprogram specifications occur.
668
 
669
   --  Note: this routine does not affect the scope stack in any way
670
 
671
   --  Error recovery: can raise Error_Resync
672
 
673
   function P_Subprogram_Specification return Node_Id is
674
      Specification_Node : Node_Id;
675
      Result_Not_Null    : Boolean;
676
      Result_Node        : Node_Id;
677
 
678
   begin
679
      if Token = Tok_Function then
680
         Specification_Node := New_Node (N_Function_Specification, Token_Ptr);
681
         Scan; -- past FUNCTION
682
         Ignore (Tok_Body);
683
         Set_Defining_Unit_Name (Specification_Node, P_Defining_Designator);
684
         Set_Parameter_Specifications
685
           (Specification_Node, P_Parameter_Profile);
686
         Check_Junk_Semicolon_Before_Return;
687
         TF_Return;
688
 
689
         Result_Not_Null := P_Null_Exclusion;     --  Ada 2005 (AI-231)
690
 
691
         --  Ada 2005 (AI-318-02)
692
 
693
         if Token = Tok_Access then
694
            if Ada_Version < Ada_05 then
695
               Error_Msg_SC
696
                 ("anonymous access result type is an Ada 2005 extension");
697
               Error_Msg_SC ("\unit must be compiled with -gnat05 switch");
698
            end if;
699
 
700
            Result_Node := P_Access_Definition (Result_Not_Null);
701
 
702
         else
703
            Result_Node := P_Subtype_Mark;
704
            No_Constraint;
705
         end if;
706
 
707
         Set_Null_Exclusion_Present (Specification_Node, Result_Not_Null);
708
         Set_Result_Definition (Specification_Node, Result_Node);
709
         return Specification_Node;
710
 
711
      elsif Token = Tok_Procedure then
712
         Specification_Node := New_Node (N_Procedure_Specification, Token_Ptr);
713
         Scan; -- past PROCEDURE
714
         Ignore (Tok_Body);
715
         Set_Defining_Unit_Name
716
           (Specification_Node, P_Defining_Program_Unit_Name);
717
         Set_Parameter_Specifications
718
           (Specification_Node, P_Parameter_Profile);
719
         return Specification_Node;
720
 
721
      else
722
         Error_Msg_SC ("subprogram specification expected");
723
         raise Error_Resync;
724
      end if;
725
   end P_Subprogram_Specification;
726
 
727
   ---------------------
728
   -- 6.1  Designator --
729
   ---------------------
730
 
731
   --  DESIGNATOR ::=
732
   --    [PARENT_UNIT_NAME .] IDENTIFIER | OPERATOR_SYMBOL
733
 
734
   --  The caller has checked that the initial token is an identifier,
735
   --  operator symbol, or string literal. Note that we don't bother to
736
   --  do much error diagnosis in this routine, since it is only used for
737
   --  the label on END lines, and the routines in package Par.Endh will
738
   --  check that the label is appropriate.
739
 
740
   --  Error recovery: cannot raise Error_Resync
741
 
742
   function P_Designator return Node_Id is
743
      Ident_Node  : Node_Id;
744
      Name_Node   : Node_Id;
745
      Prefix_Node : Node_Id;
746
 
747
      function Real_Dot return Boolean;
748
      --  Tests if a current token is an interesting period, i.e. is followed
749
      --  by an identifier or operator symbol or string literal. If not, it is
750
      --  probably just incorrect punctuation to be caught by our caller. Note
751
      --  that the case of an operator symbol or string literal is also an
752
      --  error, but that is an error that we catch here. If the result is
753
      --  True, a real dot has been scanned and we are positioned past it,
754
      --  if the result is False, the scan position is unchanged.
755
 
756
      --------------
757
      -- Real_Dot --
758
      --------------
759
 
760
      function Real_Dot return Boolean is
761
         Scan_State  : Saved_Scan_State;
762
 
763
      begin
764
         if Token /= Tok_Dot then
765
            return False;
766
 
767
         else
768
            Save_Scan_State (Scan_State);
769
            Scan; -- past dot
770
 
771
            if Token = Tok_Identifier
772
              or else Token = Tok_Operator_Symbol
773
              or else Token = Tok_String_Literal
774
            then
775
               return True;
776
 
777
            else
778
               Restore_Scan_State (Scan_State);
779
               return False;
780
            end if;
781
         end if;
782
      end Real_Dot;
783
 
784
   --  Start of processing for P_Designator
785
 
786
   begin
787
      Ident_Node := Token_Node;
788
      Scan; -- past initial token
789
 
790
      if Prev_Token = Tok_Operator_Symbol
791
        or else Prev_Token = Tok_String_Literal
792
        or else not Real_Dot
793
      then
794
         return Ident_Node;
795
 
796
      --  Child name case
797
 
798
      else
799
         Prefix_Node := Ident_Node;
800
 
801
         --  Loop through child names, on entry to this loop, Prefix contains
802
         --  the name scanned so far, and Ident_Node is the last identifier.
803
 
804
         loop
805
            Name_Node := New_Node (N_Selected_Component, Prev_Token_Ptr);
806
            Set_Prefix (Name_Node, Prefix_Node);
807
            Ident_Node := P_Identifier;
808
            Set_Selector_Name (Name_Node, Ident_Node);
809
            Prefix_Node := Name_Node;
810
            exit when not Real_Dot;
811
         end loop;
812
 
813
         --  On exit from the loop, Ident_Node is the last identifier scanned,
814
         --  i.e. the defining identifier, and Prefix_Node is a node for the
815
         --  entire name, structured (incorrectly!) as a selected component.
816
 
817
         Name_Node := Prefix (Prefix_Node);
818
         Change_Node (Prefix_Node, N_Designator);
819
         Set_Name (Prefix_Node, Name_Node);
820
         Set_Identifier (Prefix_Node, Ident_Node);
821
         return Prefix_Node;
822
      end if;
823
 
824
   exception
825
      when Error_Resync =>
826
         while Token = Tok_Dot or else Token = Tok_Identifier loop
827
            Scan;
828
         end loop;
829
 
830
         return Error;
831
   end P_Designator;
832
 
833
   ------------------------------
834
   -- 6.1  Defining Designator --
835
   ------------------------------
836
 
837
   --  DEFINING_DESIGNATOR ::=
838
   --    DEFINING_PROGRAM_UNIT_NAME | DEFINING_OPERATOR_SYMBOL
839
 
840
   --  Error recovery: cannot raise Error_Resync
841
 
842
   function P_Defining_Designator return Node_Id is
843
   begin
844
      if Token = Tok_Operator_Symbol then
845
         return P_Defining_Operator_Symbol;
846
 
847
      elsif Token = Tok_String_Literal then
848
         Error_Msg_SC ("invalid operator name");
849
         Scan; -- past junk string
850
         return Error;
851
 
852
      else
853
         return P_Defining_Program_Unit_Name;
854
      end if;
855
   end P_Defining_Designator;
856
 
857
   -------------------------------------
858
   -- 6.1  Defining Program Unit Name --
859
   -------------------------------------
860
 
861
   --  DEFINING_PROGRAM_UNIT_NAME ::=
862
   --    [PARENT_UNIT_NAME .] DEFINING_IDENTIFIER
863
 
864
   --  Note: PARENT_UNIT_NAME may be present only in 95 mode at the outer level
865
 
866
   --  Error recovery: cannot raise Error_Resync
867
 
868
   function P_Defining_Program_Unit_Name return Node_Id is
869
      Ident_Node  : Node_Id;
870
      Name_Node   : Node_Id;
871
      Prefix_Node : Node_Id;
872
 
873
   begin
874
      --  Set identifier casing if not already set and scan initial identifier
875
 
876
      if Token = Tok_Identifier
877
        and then Identifier_Casing (Current_Source_File) = Unknown
878
      then
879
         Set_Identifier_Casing (Current_Source_File, Determine_Token_Casing);
880
      end if;
881
 
882
      Ident_Node := P_Identifier (C_Dot);
883
      Merge_Identifier (Ident_Node, Tok_Return);
884
 
885
      --  Normal case (not child library unit name)
886
 
887
      if Token /= Tok_Dot then
888
         Change_Identifier_To_Defining_Identifier (Ident_Node);
889
         return Ident_Node;
890
 
891
      --  Child library unit name case
892
 
893
      else
894
         if Scope.Last > 1 then
895
            Error_Msg_SP ("child unit allowed only at library level");
896
            raise Error_Resync;
897
 
898
         elsif Ada_Version = Ada_83 then
899
            Error_Msg_SP ("(Ada 83) child unit not allowed!");
900
 
901
         end if;
902
 
903
         Prefix_Node := Ident_Node;
904
 
905
         --  Loop through child names, on entry to this loop, Prefix contains
906
         --  the name scanned so far, and Ident_Node is the last identifier.
907
 
908
         loop
909
            exit when Token /= Tok_Dot;
910
            Name_Node := New_Node (N_Selected_Component, Token_Ptr);
911
            Scan; -- past period
912
            Set_Prefix (Name_Node, Prefix_Node);
913
            Ident_Node := P_Identifier (C_Dot);
914
            Set_Selector_Name (Name_Node, Ident_Node);
915
            Prefix_Node := Name_Node;
916
         end loop;
917
 
918
         --  On exit from the loop, Ident_Node is the last identifier scanned,
919
         --  i.e. the defining identifier, and Prefix_Node is a node for the
920
         --  entire name, structured (incorrectly!) as a selected component.
921
 
922
         Name_Node := Prefix (Prefix_Node);
923
         Change_Node (Prefix_Node, N_Defining_Program_Unit_Name);
924
         Set_Name (Prefix_Node, Name_Node);
925
         Change_Identifier_To_Defining_Identifier (Ident_Node);
926
         Set_Defining_Identifier (Prefix_Node, Ident_Node);
927
 
928
         --  All set with unit name parsed
929
 
930
         return Prefix_Node;
931
      end if;
932
 
933
   exception
934
      when Error_Resync =>
935
         while Token = Tok_Dot or else Token = Tok_Identifier loop
936
            Scan;
937
         end loop;
938
 
939
         return Error;
940
   end P_Defining_Program_Unit_Name;
941
 
942
   --------------------------
943
   -- 6.1  Operator Symbol --
944
   --------------------------
945
 
946
   --  OPERATOR_SYMBOL ::= STRING_LITERAL
947
 
948
   --  Operator symbol is returned by the scanner as Tok_Operator_Symbol
949
 
950
   -----------------------------------
951
   -- 6.1  Defining Operator Symbol --
952
   -----------------------------------
953
 
954
   --  DEFINING_OPERATOR_SYMBOL ::= OPERATOR_SYMBOL
955
 
956
   --  The caller has checked that the initial symbol is an operator symbol
957
 
958
   function P_Defining_Operator_Symbol return Node_Id is
959
      Op_Node : Node_Id;
960
 
961
   begin
962
      Op_Node := Token_Node;
963
      Change_Operator_Symbol_To_Defining_Operator_Symbol (Op_Node);
964
      Scan; -- past operator symbol
965
      return Op_Node;
966
   end P_Defining_Operator_Symbol;
967
 
968
   ----------------------------
969
   -- 6.1  Parameter_Profile --
970
   ----------------------------
971
 
972
   --  PARAMETER_PROFILE ::= [FORMAL_PART]
973
 
974
   --  Empty is returned if no formal part is present
975
 
976
   --  Error recovery: cannot raise Error_Resync
977
 
978
   function P_Parameter_Profile return List_Id is
979
   begin
980
      if Token = Tok_Left_Paren then
981
         Scan; -- part left paren
982
         return P_Formal_Part;
983
      else
984
         return No_List;
985
      end if;
986
   end P_Parameter_Profile;
987
 
988
   ---------------------------------------
989
   -- 6.1  Parameter And Result Profile --
990
   ---------------------------------------
991
 
992
   --  Parsed by its parent construct, which uses P_Parameter_Profile to
993
   --  parse the parameters, and P_Subtype_Mark to parse the return type.
994
 
995
   ----------------------
996
   -- 6.1  Formal part --
997
   ----------------------
998
 
999
   --  FORMAL_PART ::= (PARAMETER_SPECIFICATION {; PARAMETER_SPECIFICATION})
1000
 
1001
   --  PARAMETER_SPECIFICATION ::=
1002
   --    DEFINING_IDENTIFIER_LIST : MODE [NULL_EXCLUSION] SUBTYPE_MARK
1003
   --      [:= DEFAULT_EXPRESSION]
1004
   --  | DEFINING_IDENTIFIER_LIST : ACCESS_DEFINITION
1005
   --      [:= DEFAULT_EXPRESSION]
1006
 
1007
   --  This scans the construct Formal_Part. The caller has already checked
1008
   --  that the initial token is a left parenthesis, and skipped past it, so
1009
   --  that on entry Token is the first token following the left parenthesis.
1010
 
1011
   --  Error recovery: cannot raise Error_Resync
1012
 
1013
   function P_Formal_Part return List_Id is
1014
      Specification_List : List_Id;
1015
      Specification_Node : Node_Id;
1016
      Scan_State         : Saved_Scan_State;
1017
      Num_Idents         : Nat;
1018
      Ident              : Nat;
1019
      Ident_Sloc         : Source_Ptr;
1020
      Not_Null_Present   : Boolean := False;
1021
      Not_Null_Sloc      : Source_Ptr;
1022
 
1023
      Idents : array (Int range 1 .. 4096) of Entity_Id;
1024
      --  This array holds the list of defining identifiers. The upper bound
1025
      --  of 4096 is intended to be essentially infinite, and we do not even
1026
      --  bother to check for it being exceeded.
1027
 
1028
   begin
1029
      Specification_List := New_List;
1030
      Specification_Loop : loop
1031
         begin
1032
            if Token = Tok_Pragma then
1033
               Error_Msg_SC ("pragma not allowed in formal part");
1034
               Discard_Junk_Node (P_Pragma (Skipping => True));
1035
            end if;
1036
 
1037
            Ignore (Tok_Left_Paren);
1038
            Ident_Sloc := Token_Ptr;
1039
            Idents (1) := P_Defining_Identifier (C_Comma_Colon);
1040
            Num_Idents := 1;
1041
 
1042
            Ident_Loop : loop
1043
               exit Ident_Loop when Token = Tok_Colon;
1044
 
1045
               --  The only valid tokens are colon and comma, so if we have
1046
               --  neither do a bit of investigation to see which is the
1047
               --  better choice for insertion.
1048
 
1049
               if Token /= Tok_Comma then
1050
 
1051
                  --  Assume colon if IN or OUT keyword found
1052
 
1053
                  exit Ident_Loop when Token = Tok_In or else Token = Tok_Out;
1054
 
1055
                  --  Otherwise scan ahead
1056
 
1057
                  Save_Scan_State (Scan_State);
1058
                  Look_Ahead : loop
1059
 
1060
                     --  If we run into a semicolon, then assume that a
1061
                     --  colon was missing, e.g.  Parms (X Y; ...). Also
1062
                     --  assume missing colon on EOF (a real disaster!)
1063
                     --  and on a right paren, e.g. Parms (X Y), and also
1064
                     --  on an assignment symbol, e.g. Parms (X Y := ..)
1065
 
1066
                     if Token = Tok_Semicolon
1067
                       or else Token = Tok_Right_Paren
1068
                       or else Token = Tok_EOF
1069
                       or else Token = Tok_Colon_Equal
1070
                     then
1071
                        Restore_Scan_State (Scan_State);
1072
                        exit Ident_Loop;
1073
 
1074
                     --  If we run into a colon, assume that we had a missing
1075
                     --  comma, e.g. Parms (A B : ...). Also assume a missing
1076
                     --  comma if we hit another comma, e.g. Parms (A B, C ..)
1077
 
1078
                     elsif Token = Tok_Colon
1079
                       or else Token = Tok_Comma
1080
                     then
1081
                        Restore_Scan_State (Scan_State);
1082
                        exit Look_Ahead;
1083
                     end if;
1084
 
1085
                     Scan;
1086
                  end loop Look_Ahead;
1087
               end if;
1088
 
1089
               --  Here if a comma is present, or to be assumed
1090
 
1091
               T_Comma;
1092
               Num_Idents := Num_Idents + 1;
1093
               Idents (Num_Idents) := P_Defining_Identifier (C_Comma_Colon);
1094
            end loop Ident_Loop;
1095
 
1096
            --  Fall through the loop on encountering a colon, or deciding
1097
            --  that there is a missing colon.
1098
 
1099
            T_Colon;
1100
 
1101
            --  If there are multiple identifiers, we repeatedly scan the
1102
            --  type and initialization expression information by resetting
1103
            --  the scan pointer (so that we get completely separate trees
1104
            --  for each occurrence).
1105
 
1106
            if Num_Idents > 1 then
1107
               Save_Scan_State (Scan_State);
1108
            end if;
1109
 
1110
            --  Loop through defining identifiers in list
1111
 
1112
            Ident := 1;
1113
 
1114
            Ident_List_Loop : loop
1115
               Specification_Node :=
1116
                 New_Node (N_Parameter_Specification, Ident_Sloc);
1117
               Set_Defining_Identifier (Specification_Node, Idents (Ident));
1118
 
1119
               --  Scan possible NOT NULL for Ada 2005 (AI-231, AI-447)
1120
 
1121
               Not_Null_Sloc := Token_Ptr;
1122
               Not_Null_Present :=
1123
                 P_Null_Exclusion (Allow_Anonymous_In_95 => True);
1124
 
1125
               --  Case of ACCESS keyword present
1126
 
1127
               if Token = Tok_Access then
1128
                  Set_Null_Exclusion_Present
1129
                    (Specification_Node, Not_Null_Present);
1130
 
1131
                  if Ada_Version = Ada_83 then
1132
                     Error_Msg_SC ("(Ada 83) access parameters not allowed");
1133
                  end if;
1134
 
1135
                  Set_Parameter_Type
1136
                    (Specification_Node,
1137
                     P_Access_Definition (Not_Null_Present));
1138
 
1139
               --  Case of IN or OUT present
1140
 
1141
               else
1142
                  if Token = Tok_In or else Token = Tok_Out then
1143
                     if Not_Null_Present then
1144
                        Error_Msg
1145
                          ("`NOT NULL` can only be used with `ACCESS`",
1146
                           Not_Null_Sloc);
1147
 
1148
                        if Token = Tok_In then
1149
                           Error_Msg
1150
                             ("\`IN` not allowed together with `ACCESS`",
1151
                              Not_Null_Sloc);
1152
                        else
1153
                           Error_Msg
1154
                             ("\`OUT` not allowed together with `ACCESS`",
1155
                              Not_Null_Sloc);
1156
                        end if;
1157
                     end if;
1158
 
1159
                     P_Mode (Specification_Node);
1160
                     Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231)
1161
                  end if;
1162
 
1163
                  Set_Null_Exclusion_Present
1164
                    (Specification_Node, Not_Null_Present);
1165
 
1166
                  if Token = Tok_Procedure
1167
                       or else
1168
                     Token = Tok_Function
1169
                  then
1170
                     Error_Msg_SC ("formal subprogram parameter not allowed");
1171
                     Scan;
1172
 
1173
                     if Token = Tok_Left_Paren then
1174
                        Discard_Junk_List (P_Formal_Part);
1175
                     end if;
1176
 
1177
                     if Token = Tok_Return then
1178
                        Scan;
1179
                        Discard_Junk_Node (P_Subtype_Mark);
1180
                     end if;
1181
 
1182
                     Set_Parameter_Type (Specification_Node, Error);
1183
 
1184
                  else
1185
                     Set_Parameter_Type (Specification_Node, P_Subtype_Mark);
1186
                     No_Constraint;
1187
                  end if;
1188
               end if;
1189
 
1190
               Set_Expression (Specification_Node, Init_Expr_Opt (True));
1191
 
1192
               if Ident > 1 then
1193
                  Set_Prev_Ids (Specification_Node, True);
1194
               end if;
1195
 
1196
               if Ident < Num_Idents then
1197
                  Set_More_Ids (Specification_Node, True);
1198
               end if;
1199
 
1200
               Append (Specification_Node, Specification_List);
1201
               exit Ident_List_Loop when Ident = Num_Idents;
1202
               Ident := Ident + 1;
1203
               Restore_Scan_State (Scan_State);
1204
            end loop Ident_List_Loop;
1205
 
1206
         exception
1207
            when Error_Resync =>
1208
               Resync_Semicolon_List;
1209
         end;
1210
 
1211
         if Token = Tok_Semicolon then
1212
            Save_Scan_State (Scan_State);
1213
            Scan; -- past semicolon
1214
 
1215
            --  If we have RETURN or IS after the semicolon, then assume
1216
            --  that semicolon should have been a right parenthesis and exit
1217
 
1218
            if Token = Tok_Is or else Token = Tok_Return then
1219
               Error_Msg_SP ("|"";"" should be "")""");
1220
               exit Specification_Loop;
1221
            end if;
1222
 
1223
            --  If we have a declaration keyword after the semicolon, then
1224
            --  assume we had a missing right parenthesis and terminate list
1225
 
1226
            if Token in Token_Class_Declk then
1227
               Error_Msg_AP ("missing "")""");
1228
               Restore_Scan_State (Scan_State);
1229
               exit Specification_Loop;
1230
            end if;
1231
 
1232
         elsif Token = Tok_Right_Paren then
1233
            Scan; -- past right paren
1234
            exit Specification_Loop;
1235
 
1236
         --  Special check for common error of using comma instead of semicolon
1237
 
1238
         elsif Token = Tok_Comma then
1239
            T_Semicolon;
1240
            Scan; -- past comma
1241
 
1242
         --  Special check for omitted separator
1243
 
1244
         elsif Token = Tok_Identifier then
1245
            T_Semicolon;
1246
 
1247
         --  If nothing sensible, skip to next semicolon or right paren
1248
 
1249
         else
1250
            T_Semicolon;
1251
            Resync_Semicolon_List;
1252
 
1253
            if Token = Tok_Semicolon then
1254
               Scan; -- past semicolon
1255
            else
1256
               T_Right_Paren;
1257
               exit Specification_Loop;
1258
            end if;
1259
         end if;
1260
      end loop Specification_Loop;
1261
 
1262
      return Specification_List;
1263
   end P_Formal_Part;
1264
 
1265
   ----------------------------------
1266
   -- 6.1  Parameter Specification --
1267
   ----------------------------------
1268
 
1269
   --  Parsed by P_Formal_Part (6.1)
1270
 
1271
   ---------------
1272
   -- 6.1  Mode --
1273
   ---------------
1274
 
1275
   --  MODE ::= [in] | in out | out
1276
 
1277
   --  There is no explicit node in the tree for the Mode. Instead the
1278
   --  In_Present and Out_Present flags are set in the parent node to
1279
   --  record the presence of keywords specifying the mode.
1280
 
1281
   --  Error_Recovery: cannot raise Error_Resync
1282
 
1283
   procedure P_Mode (Node : Node_Id) is
1284
   begin
1285
      if Token = Tok_In then
1286
         Scan; -- past IN
1287
         Set_In_Present (Node, True);
1288
 
1289
         if Style.Mode_In_Check and then Token /= Tok_Out then
1290
            Error_Msg_SP ("(style) IN should be omitted");
1291
         end if;
1292
 
1293
         if Token = Tok_Access then
1294
            Error_Msg_SP ("IN not allowed together with ACCESS");
1295
            Scan; -- past ACCESS
1296
         end if;
1297
      end if;
1298
 
1299
      if Token = Tok_Out then
1300
         Scan; -- past OUT
1301
         Set_Out_Present (Node, True);
1302
      end if;
1303
 
1304
      if Token = Tok_In then
1305
         Error_Msg_SC -- CODEFIX ???
1306
           ("IN must precede OUT in parameter mode");
1307
         Scan; -- past IN
1308
         Set_In_Present (Node, True);
1309
      end if;
1310
   end P_Mode;
1311
 
1312
   --------------------------
1313
   -- 6.3  Subprogram Body --
1314
   --------------------------
1315
 
1316
   --  Parsed by P_Subprogram (6.1)
1317
 
1318
   -----------------------------------
1319
   -- 6.4  Procedure Call Statement --
1320
   -----------------------------------
1321
 
1322
   --  Parsed by P_Sequence_Of_Statements (5.1)
1323
 
1324
   ------------------------
1325
   -- 6.4  Function Call --
1326
   ------------------------
1327
 
1328
   --  Parsed by P_Call_Or_Name (4.1)
1329
 
1330
   --------------------------------
1331
   -- 6.4  Actual Parameter Part --
1332
   --------------------------------
1333
 
1334
   --  Parsed by P_Call_Or_Name (4.1)
1335
 
1336
   --------------------------------
1337
   -- 6.4  Parameter Association --
1338
   --------------------------------
1339
 
1340
   --  Parsed by P_Call_Or_Name (4.1)
1341
 
1342
   ------------------------------------
1343
   -- 6.4  Explicit Actual Parameter --
1344
   ------------------------------------
1345
 
1346
   --  Parsed by P_Call_Or_Name (4.1)
1347
 
1348
   ---------------------------
1349
   -- 6.5  Return Statement --
1350
   ---------------------------
1351
 
1352
   --  SIMPLE_RETURN_STATEMENT ::= return [EXPRESSION];
1353
   --
1354
   --  EXTENDED_RETURN_STATEMENT ::=
1355
   --    return DEFINING_IDENTIFIER : [aliased] RETURN_SUBTYPE_INDICATION
1356
   --                                           [:= EXPRESSION] [do
1357
   --      HANDLED_SEQUENCE_OF_STATEMENTS
1358
   --    end return];
1359
   --
1360
   --  RETURN_SUBTYPE_INDICATION ::= SUBTYPE_INDICATION | ACCESS_DEFINITION
1361
 
1362
   --  RETURN_STATEMENT ::= return [EXPRESSION];
1363
 
1364
   --  Error recovery: can raise Error_Resync
1365
 
1366
   procedure P_Return_Subtype_Indication (Decl_Node : Node_Id) is
1367
 
1368
      --  Note: We don't need to check Ada_Version here, because this is
1369
      --  only called in >= Ada 2005 cases anyway.
1370
 
1371
      Not_Null_Present : constant Boolean := P_Null_Exclusion;
1372
 
1373
   begin
1374
      Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present);
1375
 
1376
      if Token = Tok_Access then
1377
         Set_Object_Definition
1378
           (Decl_Node, P_Access_Definition (Not_Null_Present));
1379
      else
1380
         Set_Object_Definition
1381
           (Decl_Node, P_Subtype_Indication (Not_Null_Present));
1382
      end if;
1383
   end P_Return_Subtype_Indication;
1384
 
1385
   --  Error recovery: can raise Error_Resync
1386
 
1387
   function P_Return_Object_Declaration return Node_Id is
1388
      Return_Obj : Node_Id;
1389
      Decl_Node  : Node_Id;
1390
 
1391
   begin
1392
      Return_Obj := Token_Node;
1393
      Change_Identifier_To_Defining_Identifier (Return_Obj);
1394
      Decl_Node := New_Node (N_Object_Declaration, Token_Ptr);
1395
      Set_Defining_Identifier (Decl_Node, Return_Obj);
1396
 
1397
      Scan; -- past identifier
1398
      Scan; -- past :
1399
 
1400
      --  First an error check, if we have two identifiers in a row, a likely
1401
      --  possibility is that the first of the identifiers is an incorrectly
1402
      --  spelled keyword. See similar check in P_Identifier_Declarations.
1403
 
1404
      if Token = Tok_Identifier then
1405
         declare
1406
            SS : Saved_Scan_State;
1407
            I2 : Boolean;
1408
 
1409
         begin
1410
            Save_Scan_State (SS);
1411
            Scan; -- past initial identifier
1412
            I2 := (Token = Tok_Identifier);
1413
            Restore_Scan_State (SS);
1414
 
1415
            if I2
1416
              and then
1417
                (Bad_Spelling_Of (Tok_Access)   or else
1418
                 Bad_Spelling_Of (Tok_Aliased)  or else
1419
                 Bad_Spelling_Of (Tok_Constant))
1420
            then
1421
               null;
1422
            end if;
1423
         end;
1424
      end if;
1425
 
1426
      --  We allow "constant" here (as in "return Result : constant
1427
      --  T..."). This is not in the latest RM, but the ARG is considering an
1428
      --  AI on the subject (see AI05-0015-1), which we expect to be approved.
1429
 
1430
      if Token = Tok_Constant then
1431
         Scan; -- past CONSTANT
1432
         Set_Constant_Present (Decl_Node);
1433
 
1434
         if Token = Tok_Aliased then
1435
            Error_Msg_SC -- CODEFIX
1436
              ("ALIASED should be before CONSTANT");
1437
            Scan; -- past ALIASED
1438
            Set_Aliased_Present (Decl_Node);
1439
         end if;
1440
 
1441
      elsif Token = Tok_Aliased then
1442
         Scan; -- past ALIASED
1443
         Set_Aliased_Present (Decl_Node);
1444
 
1445
         if Token = Tok_Constant then
1446
            Scan; -- past CONSTANT
1447
            Set_Constant_Present (Decl_Node);
1448
         end if;
1449
      end if;
1450
 
1451
      P_Return_Subtype_Indication (Decl_Node);
1452
 
1453
      if Token = Tok_Colon_Equal then
1454
         Scan; -- past :=
1455
         Set_Expression (Decl_Node, P_Expression_No_Right_Paren);
1456
      end if;
1457
 
1458
      return Decl_Node;
1459
   end P_Return_Object_Declaration;
1460
 
1461
   --  Error recovery: can raise Error_Resync
1462
 
1463
   function P_Return_Statement return Node_Id is
1464
      --  The caller has checked that the initial token is RETURN
1465
 
1466
      function Is_Simple return Boolean;
1467
      --  Scan state is just after RETURN (and is left that way).
1468
      --  Determine whether this is a simple or extended return statement
1469
      --  by looking ahead for "identifier :", which implies extended.
1470
 
1471
      ---------------
1472
      -- Is_Simple --
1473
      ---------------
1474
 
1475
      function Is_Simple return Boolean is
1476
         Scan_State : Saved_Scan_State;
1477
         Result     : Boolean := True;
1478
 
1479
      begin
1480
         if Token = Tok_Identifier then
1481
            Save_Scan_State (Scan_State); -- at identifier
1482
            Scan; -- past identifier
1483
 
1484
            if Token = Tok_Colon then
1485
               Result := False; -- It's an extended_return_statement.
1486
            end if;
1487
 
1488
            Restore_Scan_State (Scan_State); -- to identifier
1489
         end if;
1490
 
1491
         return Result;
1492
      end Is_Simple;
1493
 
1494
      Return_Sloc : constant Source_Ptr := Token_Ptr;
1495
      Return_Node : Node_Id;
1496
 
1497
   --  Start of processing for P_Return_Statement
1498
 
1499
   begin
1500
      Scan; -- past RETURN
1501
 
1502
      --  Simple_return_statement, no expression, return an
1503
      --  N_Simple_Return_Statement node with the expression field left Empty.
1504
 
1505
      if Token = Tok_Semicolon then
1506
         Scan; -- past ;
1507
         Return_Node := New_Node (N_Simple_Return_Statement, Return_Sloc);
1508
 
1509
      --  Non-trivial case
1510
 
1511
      else
1512
         --  Simple_return_statement with expression
1513
 
1514
         --  We avoid trying to scan an expression if we are at an
1515
         --  expression terminator since in that case the best error
1516
         --  message is probably that we have a missing semicolon.
1517
 
1518
         if Is_Simple then
1519
            Return_Node := New_Node (N_Simple_Return_Statement, Return_Sloc);
1520
 
1521
            if Token not in Token_Class_Eterm then
1522
               Set_Expression (Return_Node, P_Expression_No_Right_Paren);
1523
            end if;
1524
 
1525
         --  Extended_return_statement (Ada 2005 only -- AI-318):
1526
 
1527
         else
1528
            if Ada_Version < Ada_05 then
1529
               Error_Msg_SP
1530
                 (" extended_return_statement is an Ada 2005 extension");
1531
               Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
1532
            end if;
1533
 
1534
            Return_Node := New_Node (N_Extended_Return_Statement, Return_Sloc);
1535
            Set_Return_Object_Declarations
1536
              (Return_Node, New_List (P_Return_Object_Declaration));
1537
 
1538
            if Token = Tok_Do then
1539
               Push_Scope_Stack;
1540
               Scope.Table (Scope.Last).Etyp := E_Return;
1541
               Scope.Table (Scope.Last).Ecol := Start_Column;
1542
               Scope.Table (Scope.Last).Sloc := Return_Sloc;
1543
 
1544
               Scan; -- past DO
1545
               Set_Handled_Statement_Sequence
1546
                 (Return_Node, P_Handled_Sequence_Of_Statements);
1547
               End_Statements;
1548
 
1549
               --  Do we need to handle Error_Resync here???
1550
            end if;
1551
         end if;
1552
 
1553
         TF_Semicolon;
1554
      end if;
1555
 
1556
      return Return_Node;
1557
   end P_Return_Statement;
1558
 
1559
end Ch6;

powered by: WebSVN 2.1.0

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