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