]>
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 | ||
885c4871 | 187 | -- Ada 2005: 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 | |
ec09f261 AC |
678 | -- intended as a subprogram body. However, if the context |
679 | -- is a function and the unit is a package declaration, a | |
680 | -- body would be illegal, so try for an unparenthesized | |
681 | -- expression function. | |
2e79de51 AC |
682 | |
683 | if Token_Is_At_Start_Of_Line then | |
ec09f261 | 684 | declare |
aeae67ed | 685 | -- The enclosing scope entry is a subprogram spec |
ec09f261 AC |
686 | |
687 | Spec_Node : constant Node_Id := | |
aeae67ed RD |
688 | Parent |
689 | (Scope.Table (Scope.Last).Labl); | |
ec09f261 AC |
690 | Lib_Node : Node_Id := Spec_Node; |
691 | ||
692 | begin | |
ec09f261 AC |
693 | -- Check whether there is an enclosing scope that |
694 | -- is a package declaration. | |
695 | ||
696 | if Scope.Last > 1 then | |
697 | Lib_Node := | |
698 | Parent (Scope.Table (Scope.Last - 1).Labl); | |
699 | end if; | |
700 | ||
701 | if Ada_Version >= Ada_2012 | |
702 | and then | |
703 | Nkind (Lib_Node) = N_Package_Specification | |
704 | and then | |
705 | Nkind (Spec_Node) = N_Function_Specification | |
706 | then | |
707 | null; | |
ec09f261 AC |
708 | else |
709 | return False; | |
710 | end if; | |
711 | end; | |
2e79de51 AC |
712 | |
713 | -- Otherwise we have to scan ahead. If the identifier is | |
714 | -- followed by a colon or a comma, it is a declaration | |
715 | -- and hence we have a subprogram body. Otherwise assume | |
b0186f71 | 716 | -- a expression function. |
2e79de51 AC |
717 | |
718 | else | |
719 | declare | |
720 | Scan_State : Saved_Scan_State; | |
721 | Tok : Token_Type; | |
b0186f71 | 722 | |
2e79de51 AC |
723 | begin |
724 | Save_Scan_State (Scan_State); | |
725 | Scan; -- past identifier | |
726 | Tok := Token; | |
727 | Restore_Scan_State (Scan_State); | |
728 | ||
729 | if Tok = Tok_Colon or else Tok = Tok_Comma then | |
730 | return False; | |
731 | end if; | |
732 | end; | |
733 | end if; | |
ad110ee8 | 734 | end if; |
ad110ee8 | 735 | |
b0186f71 | 736 | -- Fall through if we have a likely expression function |
2e79de51 AC |
737 | |
738 | Error_Msg_SC | |
b0186f71 | 739 | ("expression function must be enclosed in parentheses"); |
2e79de51 | 740 | return True; |
b0186f71 | 741 | end Likely_Expression_Function; |
2e79de51 | 742 | |
b0186f71 | 743 | -- Start of processing for Scan_Body_Or_Expression_Function |
ad110ee8 RD |
744 | |
745 | begin | |
b0186f71 | 746 | -- Expression_Function case |
2e79de51 AC |
747 | |
748 | if Token = Tok_Left_Paren | |
b0186f71 | 749 | or else Likely_Expression_Function |
2e79de51 | 750 | then |
b0186f71 | 751 | -- Check expression function allowed here |
2e79de51 AC |
752 | |
753 | if not Pf_Flags.Pexp then | |
b0186f71 | 754 | Error_Msg_SC ("expression function not allowed here!"); |
2e79de51 AC |
755 | end if; |
756 | ||
757 | -- Check we are in Ada 2012 mode | |
758 | ||
dbe945f1 | 759 | if Ada_Version < Ada_2012 then |
2e79de51 | 760 | Error_Msg_SC |
b0186f71 | 761 | ("expression function is an Ada 2012 feature!"); |
2e79de51 AC |
762 | Error_Msg_SC |
763 | ("\unit must be compiled with -gnat2012 switch!"); | |
764 | end if; | |
765 | ||
b0186f71 | 766 | -- Parse out expression and build expression function |
ad110ee8 | 767 | |
ad110ee8 RD |
768 | Body_Node := |
769 | New_Node | |
b0186f71 | 770 | (N_Expression_Function, Sloc (Specification_Node)); |
ad110ee8 RD |
771 | Set_Specification (Body_Node, Specification_Node); |
772 | Set_Expression (Body_Node, P_Expression); | |
773 | T_Semicolon; | |
774 | Pop_Scope_Stack; | |
775 | ||
776 | -- Subprogram body case | |
777 | ||
778 | else | |
2e79de51 AC |
779 | -- Check body allowed here |
780 | ||
781 | if not Pf_Flags.Pbod then | |
782 | Error_Msg_SP ("subprogram body not allowed here!"); | |
783 | end if; | |
784 | ||
785 | -- Here is the test for a suspicious IS (i.e. one that | |
786 | -- looks like it might more properly be a semicolon). | |
787 | -- See separate section describing use of IS instead | |
788 | -- of semicolon in package Parse. | |
ad110ee8 RD |
789 | |
790 | if (Token in Token_Class_Declk | |
791 | or else | |
792 | Token = Tok_Identifier) | |
793 | and then Start_Column <= Scope.Table (Scope.Last).Ecol | |
794 | and then Scope.Last /= 1 | |
795 | then | |
796 | Scope.Table (Scope.Last).Etyp := E_Suspicious_Is; | |
797 | Scope.Table (Scope.Last).S_Is := Prev_Token_Ptr; | |
798 | end if; | |
799 | ||
800 | -- Build and return subprogram body, parsing declarations | |
2e79de51 | 801 | -- and statement sequence that belong to the body. |
ad110ee8 RD |
802 | |
803 | Body_Node := | |
804 | New_Node (N_Subprogram_Body, Sloc (Specification_Node)); | |
805 | Set_Specification (Body_Node, Specification_Node); | |
4fbad0ba AC |
806 | |
807 | -- In SPARK, a HIDE directive can be placed at the beginning | |
808 | -- of a subprogram implementation, thus hiding the | |
809 | -- subprogram body from SPARK tool-set. No violation of the | |
810 | -- SPARK restriction should be issued on nodes in a hidden | |
811 | -- part, which is obtained by marking such hidden parts. | |
812 | ||
813 | if Token = Tok_SPARK_Hide then | |
814 | Body_Is_Hidden_In_SPARK := True; | |
815 | Hidden_Region_Start := Token_Ptr; | |
816 | Scan; -- past HIDE directive | |
817 | else | |
818 | Body_Is_Hidden_In_SPARK := False; | |
819 | end if; | |
820 | ||
ad110ee8 | 821 | Parse_Decls_Begin_End (Body_Node); |
4fbad0ba AC |
822 | |
823 | if Body_Is_Hidden_In_SPARK then | |
824 | Set_Hidden_Part_In_SPARK (Hidden_Region_Start, Token_Ptr); | |
825 | end if; | |
ad110ee8 | 826 | end if; |
19235870 | 827 | |
ad110ee8 | 828 | return Body_Node; |
b0186f71 | 829 | end Scan_Body_Or_Expression_Function; |
19235870 RK |
830 | end if; |
831 | ||
832 | -- Processing for subprogram declaration | |
833 | ||
834 | <<Subprogram_Declaration>> | |
835 | Decl_Node := | |
836 | New_Node (N_Subprogram_Declaration, Sloc (Specification_Node)); | |
837 | Set_Specification (Decl_Node, Specification_Node); | |
718deaf1 | 838 | P_Aspect_Specifications (Decl_Node); |
19235870 RK |
839 | |
840 | -- If this is a context in which a subprogram body is permitted, | |
841 | -- set active SIS entry in case (see section titled "Handling | |
842 | -- Semicolon Used in Place of IS" in body of Parser package) | |
843 | -- Note that SIS_Missing_Semicolon_Message is already set properly. | |
844 | ||
845 | if Pf_Flags.Pbod then | |
846 | SIS_Labl := Scope.Table (Scope.Last).Labl; | |
847 | SIS_Sloc := Scope.Table (Scope.Last).Sloc; | |
848 | SIS_Ecol := Scope.Table (Scope.Last).Ecol; | |
849 | SIS_Declaration_Node := Decl_Node; | |
850 | SIS_Semicolon_Sloc := Prev_Token_Ptr; | |
851 | SIS_Entry_Active := True; | |
852 | end if; | |
853 | ||
854 | Pop_Scope_Stack; | |
855 | return Decl_Node; | |
19235870 RK |
856 | end P_Subprogram; |
857 | ||
858 | --------------------------------- | |
859 | -- 6.1 Subprogram Declaration -- | |
860 | --------------------------------- | |
861 | ||
862 | -- Parsed by P_Subprogram (6.1) | |
863 | ||
864 | ------------------------------------------ | |
865 | -- 6.1 Abstract Subprogram Declaration -- | |
866 | ------------------------------------------ | |
867 | ||
868 | -- Parsed by P_Subprogram (6.1) | |
869 | ||
870 | ----------------------------------- | |
871 | -- 6.1 Subprogram Specification -- | |
872 | ----------------------------------- | |
873 | ||
874 | -- SUBPROGRAM_SPECIFICATION ::= | |
875 | -- procedure DEFINING_PROGRAM_UNIT_NAME PARAMETER_PROFILE | |
876 | -- | function DEFINING_DESIGNATOR PARAMETER_AND_RESULT_PROFILE | |
877 | ||
878 | -- PARAMETER_PROFILE ::= [FORMAL_PART] | |
879 | ||
880 | -- PARAMETER_AND_RESULT_PROFILE ::= [FORMAL_PART] return SUBTYPE_MARK | |
881 | ||
882 | -- Subprogram specifications that appear in subprogram declarations | |
883 | -- are parsed by P_Subprogram (6.1). This routine is used in other | |
884 | -- contexts where subprogram specifications occur. | |
885 | ||
886 | -- Note: this routine does not affect the scope stack in any way | |
887 | ||
888 | -- Error recovery: can raise Error_Resync | |
889 | ||
890 | function P_Subprogram_Specification return Node_Id is | |
891 | Specification_Node : Node_Id; | |
244480db GD |
892 | Result_Not_Null : Boolean; |
893 | Result_Node : Node_Id; | |
19235870 RK |
894 | |
895 | begin | |
896 | if Token = Tok_Function then | |
897 | Specification_Node := New_Node (N_Function_Specification, Token_Ptr); | |
898 | Scan; -- past FUNCTION | |
899 | Ignore (Tok_Body); | |
900 | Set_Defining_Unit_Name (Specification_Node, P_Defining_Designator); | |
901 | Set_Parameter_Specifications | |
902 | (Specification_Node, P_Parameter_Profile); | |
903 | Check_Junk_Semicolon_Before_Return; | |
904 | TF_Return; | |
244480db GD |
905 | |
906 | Result_Not_Null := P_Null_Exclusion; -- Ada 2005 (AI-231) | |
907 | ||
908 | -- Ada 2005 (AI-318-02) | |
909 | ||
910 | if Token = Tok_Access then | |
0791fbe9 | 911 | if Ada_Version < Ada_2005 then |
244480db GD |
912 | Error_Msg_SC |
913 | ("anonymous access result type is an Ada 2005 extension"); | |
914 | Error_Msg_SC ("\unit must be compiled with -gnat05 switch"); | |
915 | end if; | |
916 | ||
917 | Result_Node := P_Access_Definition (Result_Not_Null); | |
918 | ||
919 | else | |
920 | Result_Node := P_Subtype_Mark; | |
921 | No_Constraint; | |
922 | end if; | |
923 | ||
924 | Set_Null_Exclusion_Present (Specification_Node, Result_Not_Null); | |
925 | Set_Result_Definition (Specification_Node, Result_Node); | |
19235870 RK |
926 | return Specification_Node; |
927 | ||
928 | elsif Token = Tok_Procedure then | |
929 | Specification_Node := New_Node (N_Procedure_Specification, Token_Ptr); | |
930 | Scan; -- past PROCEDURE | |
931 | Ignore (Tok_Body); | |
932 | Set_Defining_Unit_Name | |
933 | (Specification_Node, P_Defining_Program_Unit_Name); | |
934 | Set_Parameter_Specifications | |
935 | (Specification_Node, P_Parameter_Profile); | |
936 | return Specification_Node; | |
937 | ||
938 | else | |
939 | Error_Msg_SC ("subprogram specification expected"); | |
940 | raise Error_Resync; | |
941 | end if; | |
942 | end P_Subprogram_Specification; | |
943 | ||
944 | --------------------- | |
945 | -- 6.1 Designator -- | |
946 | --------------------- | |
947 | ||
948 | -- DESIGNATOR ::= | |
949 | -- [PARENT_UNIT_NAME .] IDENTIFIER | OPERATOR_SYMBOL | |
950 | ||
951 | -- The caller has checked that the initial token is an identifier, | |
952 | -- operator symbol, or string literal. Note that we don't bother to | |
953 | -- do much error diagnosis in this routine, since it is only used for | |
954 | -- the label on END lines, and the routines in package Par.Endh will | |
955 | -- check that the label is appropriate. | |
956 | ||
957 | -- Error recovery: cannot raise Error_Resync | |
958 | ||
959 | function P_Designator return Node_Id is | |
960 | Ident_Node : Node_Id; | |
961 | Name_Node : Node_Id; | |
962 | Prefix_Node : Node_Id; | |
963 | ||
964 | function Real_Dot return Boolean; | |
965 | -- Tests if a current token is an interesting period, i.e. is followed | |
966 | -- by an identifier or operator symbol or string literal. If not, it is | |
967 | -- probably just incorrect punctuation to be caught by our caller. Note | |
968 | -- that the case of an operator symbol or string literal is also an | |
969 | -- error, but that is an error that we catch here. If the result is | |
970 | -- True, a real dot has been scanned and we are positioned past it, | |
971 | -- if the result is False, the scan position is unchanged. | |
972 | ||
bde58e32 AC |
973 | -------------- |
974 | -- Real_Dot -- | |
975 | -------------- | |
976 | ||
19235870 RK |
977 | function Real_Dot return Boolean is |
978 | Scan_State : Saved_Scan_State; | |
979 | ||
980 | begin | |
981 | if Token /= Tok_Dot then | |
982 | return False; | |
983 | ||
984 | else | |
985 | Save_Scan_State (Scan_State); | |
986 | Scan; -- past dot | |
987 | ||
988 | if Token = Tok_Identifier | |
989 | or else Token = Tok_Operator_Symbol | |
990 | or else Token = Tok_String_Literal | |
991 | then | |
992 | return True; | |
993 | ||
994 | else | |
995 | Restore_Scan_State (Scan_State); | |
996 | return False; | |
997 | end if; | |
998 | end if; | |
999 | end Real_Dot; | |
1000 | ||
1001 | -- Start of processing for P_Designator | |
1002 | ||
1003 | begin | |
1004 | Ident_Node := Token_Node; | |
1005 | Scan; -- past initial token | |
1006 | ||
1007 | if Prev_Token = Tok_Operator_Symbol | |
1008 | or else Prev_Token = Tok_String_Literal | |
1009 | or else not Real_Dot | |
1010 | then | |
1011 | return Ident_Node; | |
1012 | ||
1013 | -- Child name case | |
1014 | ||
1015 | else | |
1016 | Prefix_Node := Ident_Node; | |
1017 | ||
1018 | -- Loop through child names, on entry to this loop, Prefix contains | |
1019 | -- the name scanned so far, and Ident_Node is the last identifier. | |
1020 | ||
1021 | loop | |
1022 | Name_Node := New_Node (N_Selected_Component, Prev_Token_Ptr); | |
1023 | Set_Prefix (Name_Node, Prefix_Node); | |
1024 | Ident_Node := P_Identifier; | |
1025 | Set_Selector_Name (Name_Node, Ident_Node); | |
1026 | Prefix_Node := Name_Node; | |
1027 | exit when not Real_Dot; | |
1028 | end loop; | |
1029 | ||
1030 | -- On exit from the loop, Ident_Node is the last identifier scanned, | |
1031 | -- i.e. the defining identifier, and Prefix_Node is a node for the | |
1032 | -- entire name, structured (incorrectly!) as a selected component. | |
1033 | ||
1034 | Name_Node := Prefix (Prefix_Node); | |
1035 | Change_Node (Prefix_Node, N_Designator); | |
1036 | Set_Name (Prefix_Node, Name_Node); | |
1037 | Set_Identifier (Prefix_Node, Ident_Node); | |
1038 | return Prefix_Node; | |
1039 | end if; | |
1040 | ||
1041 | exception | |
1042 | when Error_Resync => | |
1043 | while Token = Tok_Dot or else Token = Tok_Identifier loop | |
1044 | Scan; | |
1045 | end loop; | |
1046 | ||
1047 | return Error; | |
1048 | end P_Designator; | |
1049 | ||
1050 | ------------------------------ | |
1051 | -- 6.1 Defining Designator -- | |
1052 | ------------------------------ | |
1053 | ||
1054 | -- DEFINING_DESIGNATOR ::= | |
1055 | -- DEFINING_PROGRAM_UNIT_NAME | DEFINING_OPERATOR_SYMBOL | |
1056 | ||
1057 | -- Error recovery: cannot raise Error_Resync | |
1058 | ||
1059 | function P_Defining_Designator return Node_Id is | |
1060 | begin | |
1061 | if Token = Tok_Operator_Symbol then | |
1062 | return P_Defining_Operator_Symbol; | |
1063 | ||
1064 | elsif Token = Tok_String_Literal then | |
1065 | Error_Msg_SC ("invalid operator name"); | |
1066 | Scan; -- past junk string | |
1067 | return Error; | |
1068 | ||
1069 | else | |
1070 | return P_Defining_Program_Unit_Name; | |
1071 | end if; | |
1072 | end P_Defining_Designator; | |
1073 | ||
1074 | ------------------------------------- | |
1075 | -- 6.1 Defining Program Unit Name -- | |
1076 | ------------------------------------- | |
1077 | ||
1078 | -- DEFINING_PROGRAM_UNIT_NAME ::= | |
1079 | -- [PARENT_UNIT_NAME .] DEFINING_IDENTIFIER | |
1080 | ||
1081 | -- Note: PARENT_UNIT_NAME may be present only in 95 mode at the outer level | |
1082 | ||
1083 | -- Error recovery: cannot raise Error_Resync | |
1084 | ||
1085 | function P_Defining_Program_Unit_Name return Node_Id is | |
1086 | Ident_Node : Node_Id; | |
1087 | Name_Node : Node_Id; | |
1088 | Prefix_Node : Node_Id; | |
1089 | ||
1090 | begin | |
1091 | -- Set identifier casing if not already set and scan initial identifier | |
1092 | ||
1093 | if Token = Tok_Identifier | |
1094 | and then Identifier_Casing (Current_Source_File) = Unknown | |
1095 | then | |
1096 | Set_Identifier_Casing (Current_Source_File, Determine_Token_Casing); | |
1097 | end if; | |
1098 | ||
bde58e32 | 1099 | Ident_Node := P_Identifier (C_Dot); |
19235870 RK |
1100 | Merge_Identifier (Ident_Node, Tok_Return); |
1101 | ||
1102 | -- Normal case (not child library unit name) | |
1103 | ||
1104 | if Token /= Tok_Dot then | |
1105 | Change_Identifier_To_Defining_Identifier (Ident_Node); | |
1106 | return Ident_Node; | |
1107 | ||
1108 | -- Child library unit name case | |
1109 | ||
1110 | else | |
1111 | if Scope.Last > 1 then | |
1112 | Error_Msg_SP ("child unit allowed only at library level"); | |
1113 | raise Error_Resync; | |
1114 | ||
0ab80019 | 1115 | elsif Ada_Version = Ada_83 then |
19235870 RK |
1116 | Error_Msg_SP ("(Ada 83) child unit not allowed!"); |
1117 | ||
1118 | end if; | |
1119 | ||
1120 | Prefix_Node := Ident_Node; | |
1121 | ||
1122 | -- Loop through child names, on entry to this loop, Prefix contains | |
1123 | -- the name scanned so far, and Ident_Node is the last identifier. | |
1124 | ||
1125 | loop | |
1126 | exit when Token /= Tok_Dot; | |
1127 | Name_Node := New_Node (N_Selected_Component, Token_Ptr); | |
1128 | Scan; -- past period | |
1129 | Set_Prefix (Name_Node, Prefix_Node); | |
bde58e32 | 1130 | Ident_Node := P_Identifier (C_Dot); |
19235870 RK |
1131 | Set_Selector_Name (Name_Node, Ident_Node); |
1132 | Prefix_Node := Name_Node; | |
1133 | end loop; | |
1134 | ||
1135 | -- On exit from the loop, Ident_Node is the last identifier scanned, | |
1136 | -- i.e. the defining identifier, and Prefix_Node is a node for the | |
1137 | -- entire name, structured (incorrectly!) as a selected component. | |
1138 | ||
1139 | Name_Node := Prefix (Prefix_Node); | |
1140 | Change_Node (Prefix_Node, N_Defining_Program_Unit_Name); | |
1141 | Set_Name (Prefix_Node, Name_Node); | |
1142 | Change_Identifier_To_Defining_Identifier (Ident_Node); | |
1143 | Set_Defining_Identifier (Prefix_Node, Ident_Node); | |
1144 | ||
1145 | -- All set with unit name parsed | |
1146 | ||
1147 | return Prefix_Node; | |
1148 | end if; | |
1149 | ||
1150 | exception | |
1151 | when Error_Resync => | |
1152 | while Token = Tok_Dot or else Token = Tok_Identifier loop | |
1153 | Scan; | |
1154 | end loop; | |
1155 | ||
1156 | return Error; | |
1157 | end P_Defining_Program_Unit_Name; | |
1158 | ||
1159 | -------------------------- | |
1160 | -- 6.1 Operator Symbol -- | |
1161 | -------------------------- | |
1162 | ||
1163 | -- OPERATOR_SYMBOL ::= STRING_LITERAL | |
1164 | ||
1165 | -- Operator symbol is returned by the scanner as Tok_Operator_Symbol | |
1166 | ||
1167 | ----------------------------------- | |
1168 | -- 6.1 Defining Operator Symbol -- | |
1169 | ----------------------------------- | |
1170 | ||
1171 | -- DEFINING_OPERATOR_SYMBOL ::= OPERATOR_SYMBOL | |
1172 | ||
1173 | -- The caller has checked that the initial symbol is an operator symbol | |
1174 | ||
1175 | function P_Defining_Operator_Symbol return Node_Id is | |
1176 | Op_Node : Node_Id; | |
1177 | ||
1178 | begin | |
1179 | Op_Node := Token_Node; | |
1180 | Change_Operator_Symbol_To_Defining_Operator_Symbol (Op_Node); | |
1181 | Scan; -- past operator symbol | |
1182 | return Op_Node; | |
1183 | end P_Defining_Operator_Symbol; | |
1184 | ||
1185 | ---------------------------- | |
1186 | -- 6.1 Parameter_Profile -- | |
1187 | ---------------------------- | |
1188 | ||
1189 | -- PARAMETER_PROFILE ::= [FORMAL_PART] | |
1190 | ||
1191 | -- Empty is returned if no formal part is present | |
1192 | ||
1193 | -- Error recovery: cannot raise Error_Resync | |
1194 | ||
1195 | function P_Parameter_Profile return List_Id is | |
1196 | begin | |
1197 | if Token = Tok_Left_Paren then | |
1198 | Scan; -- part left paren | |
1199 | return P_Formal_Part; | |
1200 | else | |
1201 | return No_List; | |
1202 | end if; | |
1203 | end P_Parameter_Profile; | |
1204 | ||
1205 | --------------------------------------- | |
1206 | -- 6.1 Parameter And Result Profile -- | |
1207 | --------------------------------------- | |
1208 | ||
1209 | -- Parsed by its parent construct, which uses P_Parameter_Profile to | |
1210 | -- parse the parameters, and P_Subtype_Mark to parse the return type. | |
1211 | ||
1212 | ---------------------- | |
1213 | -- 6.1 Formal part -- | |
1214 | ---------------------- | |
1215 | ||
1216 | -- FORMAL_PART ::= (PARAMETER_SPECIFICATION {; PARAMETER_SPECIFICATION}) | |
1217 | ||
1218 | -- PARAMETER_SPECIFICATION ::= | |
fecbd779 AC |
1219 | -- DEFINING_IDENTIFIER_LIST : [ALIASED] MODE [NULL_EXCLUSION] |
1220 | -- SUBTYPE_MARK [:= DEFAULT_EXPRESSION] | |
19235870 RK |
1221 | -- | DEFINING_IDENTIFIER_LIST : ACCESS_DEFINITION |
1222 | -- [:= DEFAULT_EXPRESSION] | |
1223 | ||
1224 | -- This scans the construct Formal_Part. The caller has already checked | |
1225 | -- that the initial token is a left parenthesis, and skipped past it, so | |
1226 | -- that on entry Token is the first token following the left parenthesis. | |
1227 | ||
fecbd779 AC |
1228 | -- Note: The ALIASED keyword is allowed only in Ada 2012 mode (AI 142) |
1229 | ||
19235870 RK |
1230 | -- Error recovery: cannot raise Error_Resync |
1231 | ||
1232 | function P_Formal_Part return List_Id is | |
1233 | Specification_List : List_Id; | |
1234 | Specification_Node : Node_Id; | |
1235 | Scan_State : Saved_Scan_State; | |
1236 | Num_Idents : Nat; | |
1237 | Ident : Nat; | |
1238 | Ident_Sloc : Source_Ptr; | |
2820d220 | 1239 | Not_Null_Present : Boolean := False; |
4210c975 | 1240 | Not_Null_Sloc : Source_Ptr; |
19235870 RK |
1241 | |
1242 | Idents : array (Int range 1 .. 4096) of Entity_Id; | |
1243 | -- This array holds the list of defining identifiers. The upper bound | |
1244 | -- of 4096 is intended to be essentially infinite, and we do not even | |
1245 | -- bother to check for it being exceeded. | |
1246 | ||
1247 | begin | |
1248 | Specification_List := New_List; | |
19235870 RK |
1249 | Specification_Loop : loop |
1250 | begin | |
1251 | if Token = Tok_Pragma then | |
470cd9e9 RD |
1252 | Error_Msg_SC ("pragma not allowed in formal part"); |
1253 | Discard_Junk_Node (P_Pragma (Skipping => True)); | |
19235870 RK |
1254 | end if; |
1255 | ||
1256 | Ignore (Tok_Left_Paren); | |
1257 | Ident_Sloc := Token_Ptr; | |
bde58e32 | 1258 | Idents (1) := P_Defining_Identifier (C_Comma_Colon); |
19235870 RK |
1259 | Num_Idents := 1; |
1260 | ||
1261 | Ident_Loop : loop | |
1262 | exit Ident_Loop when Token = Tok_Colon; | |
1263 | ||
1264 | -- The only valid tokens are colon and comma, so if we have | |
1265 | -- neither do a bit of investigation to see which is the | |
1266 | -- better choice for insertion. | |
1267 | ||
1268 | if Token /= Tok_Comma then | |
1269 | ||
fecbd779 | 1270 | -- Assume colon if ALIASED, IN or OUT keyword found |
19235870 | 1271 | |
fecbd779 AC |
1272 | exit Ident_Loop when Token = Tok_Aliased or else |
1273 | Token = Tok_In or else | |
1274 | Token = Tok_Out; | |
19235870 RK |
1275 | |
1276 | -- Otherwise scan ahead | |
1277 | ||
1278 | Save_Scan_State (Scan_State); | |
1279 | Look_Ahead : loop | |
1280 | ||
1281 | -- If we run into a semicolon, then assume that a | |
1282 | -- colon was missing, e.g. Parms (X Y; ...). Also | |
1283 | -- assume missing colon on EOF (a real disaster!) | |
1284 | -- and on a right paren, e.g. Parms (X Y), and also | |
1285 | -- on an assignment symbol, e.g. Parms (X Y := ..) | |
1286 | ||
1287 | if Token = Tok_Semicolon | |
1288 | or else Token = Tok_Right_Paren | |
1289 | or else Token = Tok_EOF | |
1290 | or else Token = Tok_Colon_Equal | |
1291 | then | |
1292 | Restore_Scan_State (Scan_State); | |
1293 | exit Ident_Loop; | |
1294 | ||
1295 | -- If we run into a colon, assume that we had a missing | |
1296 | -- comma, e.g. Parms (A B : ...). Also assume a missing | |
1297 | -- comma if we hit another comma, e.g. Parms (A B, C ..) | |
1298 | ||
1299 | elsif Token = Tok_Colon | |
1300 | or else Token = Tok_Comma | |
1301 | then | |
1302 | Restore_Scan_State (Scan_State); | |
1303 | exit Look_Ahead; | |
1304 | end if; | |
1305 | ||
1306 | Scan; | |
1307 | end loop Look_Ahead; | |
1308 | end if; | |
1309 | ||
1310 | -- Here if a comma is present, or to be assumed | |
1311 | ||
1312 | T_Comma; | |
1313 | Num_Idents := Num_Idents + 1; | |
bde58e32 | 1314 | Idents (Num_Idents) := P_Defining_Identifier (C_Comma_Colon); |
19235870 RK |
1315 | end loop Ident_Loop; |
1316 | ||
1317 | -- Fall through the loop on encountering a colon, or deciding | |
1318 | -- that there is a missing colon. | |
1319 | ||
1320 | T_Colon; | |
1321 | ||
1322 | -- If there are multiple identifiers, we repeatedly scan the | |
1323 | -- type and initialization expression information by resetting | |
1324 | -- the scan pointer (so that we get completely separate trees | |
1325 | -- for each occurrence). | |
1326 | ||
1327 | if Num_Idents > 1 then | |
1328 | Save_Scan_State (Scan_State); | |
1329 | end if; | |
1330 | ||
1331 | -- Loop through defining identifiers in list | |
1332 | ||
1333 | Ident := 1; | |
1334 | ||
1335 | Ident_List_Loop : loop | |
1336 | Specification_Node := | |
1337 | New_Node (N_Parameter_Specification, Ident_Sloc); | |
1338 | Set_Defining_Identifier (Specification_Node, Idents (Ident)); | |
6c929a2e | 1339 | |
fecbd779 AC |
1340 | -- Scan possible ALIASED for Ada 2012 (AI-142) |
1341 | ||
1342 | if Token = Tok_Aliased then | |
1343 | if Ada_Version < Ada_2012 then | |
885c4871 | 1344 | Error_Msg_SC ("ALIASED parameter is an Ada 2012 feature"); |
fecbd779 AC |
1345 | else |
1346 | Set_Aliased_Present (Specification_Node); | |
1347 | end if; | |
1348 | ||
1349 | Scan; -- past ALIASED | |
1350 | end if; | |
1351 | ||
6c929a2e RD |
1352 | -- Scan possible NOT NULL for Ada 2005 (AI-231, AI-447) |
1353 | ||
4210c975 | 1354 | Not_Null_Sloc := Token_Ptr; |
6c929a2e RD |
1355 | Not_Null_Present := |
1356 | P_Null_Exclusion (Allow_Anonymous_In_95 => True); | |
1357 | ||
1358 | -- Case of ACCESS keyword present | |
19235870 RK |
1359 | |
1360 | if Token = Tok_Access then | |
2820d220 AC |
1361 | Set_Null_Exclusion_Present |
1362 | (Specification_Node, Not_Null_Present); | |
1363 | ||
0ab80019 | 1364 | if Ada_Version = Ada_83 then |
19235870 RK |
1365 | Error_Msg_SC ("(Ada 83) access parameters not allowed"); |
1366 | end if; | |
1367 | ||
6c929a2e RD |
1368 | Set_Parameter_Type |
1369 | (Specification_Node, | |
1370 | P_Access_Definition (Not_Null_Present)); | |
1371 | ||
1372 | -- Case of IN or OUT present | |
19235870 RK |
1373 | |
1374 | else | |
2820d220 AC |
1375 | if Token = Tok_In or else Token = Tok_Out then |
1376 | if Not_Null_Present then | |
4210c975 JM |
1377 | Error_Msg |
1378 | ("`NOT NULL` can only be used with `ACCESS`", | |
1379 | Not_Null_Sloc); | |
1380 | ||
1381 | if Token = Tok_In then | |
1382 | Error_Msg | |
1383 | ("\`IN` not allowed together with `ACCESS`", | |
1384 | Not_Null_Sloc); | |
1385 | else | |
1386 | Error_Msg | |
1387 | ("\`OUT` not allowed together with `ACCESS`", | |
1388 | Not_Null_Sloc); | |
1389 | end if; | |
2820d220 AC |
1390 | end if; |
1391 | ||
1392 | P_Mode (Specification_Node); | |
0ab80019 | 1393 | Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231) |
2820d220 AC |
1394 | end if; |
1395 | ||
1396 | Set_Null_Exclusion_Present | |
1397 | (Specification_Node, Not_Null_Present); | |
19235870 RK |
1398 | |
1399 | if Token = Tok_Procedure | |
1400 | or else | |
1401 | Token = Tok_Function | |
1402 | then | |
1403 | Error_Msg_SC ("formal subprogram parameter not allowed"); | |
1404 | Scan; | |
1405 | ||
1406 | if Token = Tok_Left_Paren then | |
1407 | Discard_Junk_List (P_Formal_Part); | |
1408 | end if; | |
1409 | ||
1410 | if Token = Tok_Return then | |
1411 | Scan; | |
1412 | Discard_Junk_Node (P_Subtype_Mark); | |
1413 | end if; | |
1414 | ||
1415 | Set_Parameter_Type (Specification_Node, Error); | |
1416 | ||
1417 | else | |
1418 | Set_Parameter_Type (Specification_Node, P_Subtype_Mark); | |
1419 | No_Constraint; | |
1420 | end if; | |
1421 | end if; | |
1422 | ||
1423 | Set_Expression (Specification_Node, Init_Expr_Opt (True)); | |
1424 | ||
1425 | if Ident > 1 then | |
1426 | Set_Prev_Ids (Specification_Node, True); | |
1427 | end if; | |
1428 | ||
1429 | if Ident < Num_Idents then | |
1430 | Set_More_Ids (Specification_Node, True); | |
1431 | end if; | |
1432 | ||
1433 | Append (Specification_Node, Specification_List); | |
1434 | exit Ident_List_Loop when Ident = Num_Idents; | |
1435 | Ident := Ident + 1; | |
1436 | Restore_Scan_State (Scan_State); | |
1437 | end loop Ident_List_Loop; | |
1438 | ||
1439 | exception | |
1440 | when Error_Resync => | |
1441 | Resync_Semicolon_List; | |
1442 | end; | |
1443 | ||
1444 | if Token = Tok_Semicolon then | |
fbf5a39b | 1445 | Save_Scan_State (Scan_State); |
19235870 RK |
1446 | Scan; -- past semicolon |
1447 | ||
1448 | -- If we have RETURN or IS after the semicolon, then assume | |
1449 | -- that semicolon should have been a right parenthesis and exit | |
1450 | ||
1451 | if Token = Tok_Is or else Token = Tok_Return then | |
ed2233dc AC |
1452 | Error_Msg_SP -- CODEFIX |
1453 | ("|"";"" should be "")"""); | |
19235870 RK |
1454 | exit Specification_Loop; |
1455 | end if; | |
1456 | ||
fbf5a39b AC |
1457 | -- If we have a declaration keyword after the semicolon, then |
1458 | -- assume we had a missing right parenthesis and terminate list | |
1459 | ||
1460 | if Token in Token_Class_Declk then | |
ed2233dc AC |
1461 | Error_Msg_AP -- CODEFIX |
1462 | ("missing "")"""); | |
fbf5a39b AC |
1463 | Restore_Scan_State (Scan_State); |
1464 | exit Specification_Loop; | |
1465 | end if; | |
1466 | ||
19235870 RK |
1467 | elsif Token = Tok_Right_Paren then |
1468 | Scan; -- past right paren | |
1469 | exit Specification_Loop; | |
1470 | ||
1471 | -- Special check for common error of using comma instead of semicolon | |
1472 | ||
1473 | elsif Token = Tok_Comma then | |
1474 | T_Semicolon; | |
1475 | Scan; -- past comma | |
1476 | ||
1477 | -- Special check for omitted separator | |
1478 | ||
1479 | elsif Token = Tok_Identifier then | |
1480 | T_Semicolon; | |
1481 | ||
1482 | -- If nothing sensible, skip to next semicolon or right paren | |
1483 | ||
1484 | else | |
1485 | T_Semicolon; | |
1486 | Resync_Semicolon_List; | |
1487 | ||
1488 | if Token = Tok_Semicolon then | |
1489 | Scan; -- past semicolon | |
1490 | else | |
1491 | T_Right_Paren; | |
1492 | exit Specification_Loop; | |
1493 | end if; | |
1494 | end if; | |
1495 | end loop Specification_Loop; | |
1496 | ||
1497 | return Specification_List; | |
1498 | end P_Formal_Part; | |
1499 | ||
1500 | ---------------------------------- | |
1501 | -- 6.1 Parameter Specification -- | |
1502 | ---------------------------------- | |
1503 | ||
1504 | -- Parsed by P_Formal_Part (6.1) | |
1505 | ||
1506 | --------------- | |
1507 | -- 6.1 Mode -- | |
1508 | --------------- | |
1509 | ||
1510 | -- MODE ::= [in] | in out | out | |
1511 | ||
1512 | -- There is no explicit node in the tree for the Mode. Instead the | |
1513 | -- In_Present and Out_Present flags are set in the parent node to | |
1514 | -- record the presence of keywords specifying the mode. | |
1515 | ||
1516 | -- Error_Recovery: cannot raise Error_Resync | |
1517 | ||
1518 | procedure P_Mode (Node : Node_Id) is | |
1519 | begin | |
1520 | if Token = Tok_In then | |
1521 | Scan; -- past IN | |
1522 | Set_In_Present (Node, True); | |
4f73f89c RD |
1523 | |
1524 | if Style.Mode_In_Check and then Token /= Tok_Out then | |
ed2233dc AC |
1525 | Error_Msg_SP -- CODEFIX |
1526 | ("(style) IN should be omitted"); | |
4f73f89c | 1527 | end if; |
6c929a2e RD |
1528 | |
1529 | if Token = Tok_Access then | |
1530 | Error_Msg_SP ("IN not allowed together with ACCESS"); | |
1531 | Scan; -- past ACCESS | |
1532 | end if; | |
19235870 RK |
1533 | end if; |
1534 | ||
1535 | if Token = Tok_Out then | |
1536 | Scan; -- past OUT | |
1537 | Set_Out_Present (Node, True); | |
1538 | end if; | |
1539 | ||
1540 | if Token = Tok_In then | |
ed2233dc | 1541 | Error_Msg_SC ("IN must precede OUT in parameter mode"); |
19235870 RK |
1542 | Scan; -- past IN |
1543 | Set_In_Present (Node, True); | |
1544 | end if; | |
1545 | end P_Mode; | |
1546 | ||
1547 | -------------------------- | |
1548 | -- 6.3 Subprogram Body -- | |
1549 | -------------------------- | |
1550 | ||
1551 | -- Parsed by P_Subprogram (6.1) | |
1552 | ||
1553 | ----------------------------------- | |
1554 | -- 6.4 Procedure Call Statement -- | |
1555 | ----------------------------------- | |
1556 | ||
1557 | -- Parsed by P_Sequence_Of_Statements (5.1) | |
1558 | ||
1559 | ------------------------ | |
1560 | -- 6.4 Function Call -- | |
1561 | ------------------------ | |
1562 | ||
e24329cd | 1563 | -- Parsed by P_Name (4.1) |
19235870 RK |
1564 | |
1565 | -------------------------------- | |
1566 | -- 6.4 Actual Parameter Part -- | |
1567 | -------------------------------- | |
1568 | ||
e24329cd | 1569 | -- Parsed by P_Name (4.1) |
19235870 RK |
1570 | |
1571 | -------------------------------- | |
1572 | -- 6.4 Parameter Association -- | |
1573 | -------------------------------- | |
1574 | ||
e24329cd | 1575 | -- Parsed by P_Name (4.1) |
19235870 RK |
1576 | |
1577 | ------------------------------------ | |
1578 | -- 6.4 Explicit Actual Parameter -- | |
1579 | ------------------------------------ | |
1580 | ||
e24329cd | 1581 | -- Parsed by P_Name (4.1) |
19235870 RK |
1582 | |
1583 | --------------------------- | |
1584 | -- 6.5 Return Statement -- | |
1585 | --------------------------- | |
1586 | ||
88b32fc3 BD |
1587 | -- SIMPLE_RETURN_STATEMENT ::= return [EXPRESSION]; |
1588 | -- | |
1589 | -- EXTENDED_RETURN_STATEMENT ::= | |
1590 | -- return DEFINING_IDENTIFIER : [aliased] RETURN_SUBTYPE_INDICATION | |
1591 | -- [:= EXPRESSION] [do | |
1592 | -- HANDLED_SEQUENCE_OF_STATEMENTS | |
1593 | -- end return]; | |
1594 | -- | |
1595 | -- RETURN_SUBTYPE_INDICATION ::= SUBTYPE_INDICATION | ACCESS_DEFINITION | |
1596 | ||
19235870 RK |
1597 | -- RETURN_STATEMENT ::= return [EXPRESSION]; |
1598 | ||
88b32fc3 BD |
1599 | -- Error recovery: can raise Error_Resync |
1600 | ||
1601 | procedure P_Return_Subtype_Indication (Decl_Node : Node_Id) is | |
1602 | ||
1603 | -- Note: We don't need to check Ada_Version here, because this is | |
1604 | -- only called in >= Ada 2005 cases anyway. | |
1605 | ||
1606 | Not_Null_Present : constant Boolean := P_Null_Exclusion; | |
1607 | ||
1608 | begin | |
1609 | Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present); | |
1610 | ||
1611 | if Token = Tok_Access then | |
1612 | Set_Object_Definition | |
1613 | (Decl_Node, P_Access_Definition (Not_Null_Present)); | |
1614 | else | |
1615 | Set_Object_Definition | |
1616 | (Decl_Node, P_Subtype_Indication (Not_Null_Present)); | |
1617 | end if; | |
1618 | end P_Return_Subtype_Indication; | |
1619 | ||
1620 | -- Error recovery: can raise Error_Resync | |
1621 | ||
1622 | function P_Return_Object_Declaration return Node_Id is | |
1623 | Return_Obj : Node_Id; | |
1624 | Decl_Node : Node_Id; | |
1625 | ||
1626 | begin | |
1627 | Return_Obj := Token_Node; | |
1628 | Change_Identifier_To_Defining_Identifier (Return_Obj); | |
1629 | Decl_Node := New_Node (N_Object_Declaration, Token_Ptr); | |
1630 | Set_Defining_Identifier (Decl_Node, Return_Obj); | |
1631 | ||
1632 | Scan; -- past identifier | |
1633 | Scan; -- past : | |
1634 | ||
1635 | -- First an error check, if we have two identifiers in a row, a likely | |
1636 | -- possibility is that the first of the identifiers is an incorrectly | |
1637 | -- spelled keyword. See similar check in P_Identifier_Declarations. | |
1638 | ||
1639 | if Token = Tok_Identifier then | |
1640 | declare | |
1641 | SS : Saved_Scan_State; | |
1642 | I2 : Boolean; | |
1643 | ||
1644 | begin | |
1645 | Save_Scan_State (SS); | |
1646 | Scan; -- past initial identifier | |
1647 | I2 := (Token = Tok_Identifier); | |
1648 | Restore_Scan_State (SS); | |
1649 | ||
1650 | if I2 | |
1651 | and then | |
1652 | (Bad_Spelling_Of (Tok_Access) or else | |
1653 | Bad_Spelling_Of (Tok_Aliased) or else | |
1654 | Bad_Spelling_Of (Tok_Constant)) | |
1655 | then | |
1656 | null; | |
1657 | end if; | |
1658 | end; | |
1659 | end if; | |
1660 | ||
1661 | -- We allow "constant" here (as in "return Result : constant | |
1662 | -- T..."). This is not in the latest RM, but the ARG is considering an | |
1663 | -- AI on the subject (see AI05-0015-1), which we expect to be approved. | |
1664 | ||
1665 | if Token = Tok_Constant then | |
1666 | Scan; -- past CONSTANT | |
1667 | Set_Constant_Present (Decl_Node); | |
1668 | ||
1669 | if Token = Tok_Aliased then | |
4e7a4f6e AC |
1670 | Error_Msg_SC -- CODEFIX |
1671 | ("ALIASED should be before CONSTANT"); | |
88b32fc3 BD |
1672 | Scan; -- past ALIASED |
1673 | Set_Aliased_Present (Decl_Node); | |
1674 | end if; | |
1675 | ||
1676 | elsif Token = Tok_Aliased then | |
1677 | Scan; -- past ALIASED | |
1678 | Set_Aliased_Present (Decl_Node); | |
1679 | ||
1680 | if Token = Tok_Constant then | |
1681 | Scan; -- past CONSTANT | |
1682 | Set_Constant_Present (Decl_Node); | |
1683 | end if; | |
1684 | end if; | |
1685 | ||
1686 | P_Return_Subtype_Indication (Decl_Node); | |
1687 | ||
1688 | if Token = Tok_Colon_Equal then | |
1689 | Scan; -- past := | |
1690 | Set_Expression (Decl_Node, P_Expression_No_Right_Paren); | |
1691 | end if; | |
1692 | ||
1693 | return Decl_Node; | |
1694 | end P_Return_Object_Declaration; | |
19235870 RK |
1695 | |
1696 | -- Error recovery: can raise Error_Resync | |
1697 | ||
1698 | function P_Return_Statement return Node_Id is | |
88b32fc3 BD |
1699 | -- The caller has checked that the initial token is RETURN |
1700 | ||
1701 | function Is_Simple return Boolean; | |
1702 | -- Scan state is just after RETURN (and is left that way). | |
1703 | -- Determine whether this is a simple or extended return statement | |
1704 | -- by looking ahead for "identifier :", which implies extended. | |
1705 | ||
1706 | --------------- | |
1707 | -- Is_Simple -- | |
1708 | --------------- | |
1709 | ||
1710 | function Is_Simple return Boolean is | |
1711 | Scan_State : Saved_Scan_State; | |
1712 | Result : Boolean := True; | |
1713 | ||
1714 | begin | |
1715 | if Token = Tok_Identifier then | |
1716 | Save_Scan_State (Scan_State); -- at identifier | |
1717 | Scan; -- past identifier | |
1718 | ||
1719 | if Token = Tok_Colon then | |
1720 | Result := False; -- It's an extended_return_statement. | |
1721 | end if; | |
1722 | ||
1723 | Restore_Scan_State (Scan_State); -- to identifier | |
1724 | end if; | |
1725 | ||
1726 | return Result; | |
1727 | end Is_Simple; | |
1728 | ||
1729 | Return_Sloc : constant Source_Ptr := Token_Ptr; | |
19235870 RK |
1730 | Return_Node : Node_Id; |
1731 | ||
88b32fc3 BD |
1732 | -- Start of processing for P_Return_Statement |
1733 | ||
19235870 | 1734 | begin |
88b32fc3 | 1735 | Scan; -- past RETURN |
19235870 | 1736 | |
4210c975 JM |
1737 | -- Simple_return_statement, no expression, return an |
1738 | -- N_Simple_Return_Statement node with the expression field left Empty. | |
19235870 | 1739 | |
88b32fc3 BD |
1740 | if Token = Tok_Semicolon then |
1741 | Scan; -- past ; | |
4210c975 | 1742 | Return_Node := New_Node (N_Simple_Return_Statement, Return_Sloc); |
19235870 | 1743 | |
4210c975 | 1744 | -- Non-trivial case |
19235870 | 1745 | |
88b32fc3 BD |
1746 | else |
1747 | -- Simple_return_statement with expression | |
1748 | ||
1749 | -- We avoid trying to scan an expression if we are at an | |
19235870 RK |
1750 | -- expression terminator since in that case the best error |
1751 | -- message is probably that we have a missing semicolon. | |
1752 | ||
88b32fc3 | 1753 | if Is_Simple then |
4210c975 | 1754 | Return_Node := New_Node (N_Simple_Return_Statement, Return_Sloc); |
88b32fc3 BD |
1755 | |
1756 | if Token not in Token_Class_Eterm then | |
1757 | Set_Expression (Return_Node, P_Expression_No_Right_Paren); | |
1758 | end if; | |
1759 | ||
1760 | -- Extended_return_statement (Ada 2005 only -- AI-318): | |
1761 | ||
1762 | else | |
0791fbe9 | 1763 | if Ada_Version < Ada_2005 then |
88b32fc3 BD |
1764 | Error_Msg_SP |
1765 | (" extended_return_statement is an Ada 2005 extension"); | |
1766 | Error_Msg_SP ("\unit must be compiled with -gnat05 switch"); | |
1767 | end if; | |
1768 | ||
1769 | Return_Node := New_Node (N_Extended_Return_Statement, Return_Sloc); | |
1770 | Set_Return_Object_Declarations | |
1771 | (Return_Node, New_List (P_Return_Object_Declaration)); | |
1772 | ||
1773 | if Token = Tok_Do then | |
1774 | Push_Scope_Stack; | |
1775 | Scope.Table (Scope.Last).Etyp := E_Return; | |
1776 | Scope.Table (Scope.Last).Ecol := Start_Column; | |
1777 | Scope.Table (Scope.Last).Sloc := Return_Sloc; | |
1778 | ||
1779 | Scan; -- past DO | |
1780 | Set_Handled_Statement_Sequence | |
1781 | (Return_Node, P_Handled_Sequence_Of_Statements); | |
1782 | End_Statements; | |
1783 | ||
1784 | -- Do we need to handle Error_Resync here??? | |
1785 | end if; | |
19235870 | 1786 | end if; |
88b32fc3 BD |
1787 | |
1788 | TF_Semicolon; | |
19235870 RK |
1789 | end if; |
1790 | ||
19235870 RK |
1791 | return Return_Node; |
1792 | end P_Return_Statement; | |
1793 | ||
1794 | end Ch6; |