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