]>
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 | -- -- | |
9 | -- $Revision: 1.81 $ | |
10 | -- -- | |
11 | -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- | |
12 | -- -- | |
13 | -- GNAT is free software; you can redistribute it and/or modify it under -- | |
14 | -- terms of the GNU General Public License as published by the Free Soft- -- | |
15 | -- ware Foundation; either version 2, or (at your option) any later ver- -- | |
16 | -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- | |
17 | -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- | |
18 | -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- | |
19 | -- for more details. You should have received a copy of the GNU General -- | |
20 | -- Public License distributed with GNAT; see file COPYING. If not, write -- | |
21 | -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- | |
22 | -- MA 02111-1307, USA. -- | |
23 | -- -- | |
24 | -- GNAT was originally developed by the GNAT team at New York University. -- | |
25 | -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- | |
26 | -- -- | |
27 | ------------------------------------------------------------------------------ | |
28 | ||
29 | pragma Style_Checks (All_Checks); | |
30 | -- Turn off subprogram body ordering check. Subprograms are in order | |
31 | -- by RM section rather than alphabetical | |
32 | ||
33 | with Sinfo.CN; use Sinfo.CN; | |
34 | ||
35 | separate (Par) | |
36 | package body Ch6 is | |
37 | ||
38 | -- Local subprograms, used only in this chapter | |
39 | ||
40 | function P_Defining_Designator return Node_Id; | |
41 | function P_Defining_Operator_Symbol return Node_Id; | |
42 | ||
43 | procedure Check_Junk_Semicolon_Before_Return; | |
44 | -- Check for common error of junk semicolon before RETURN keyword of | |
45 | -- function specification. If present, skip over it with appropriate | |
46 | -- error message, leaving Scan_Ptr pointing to the RETURN after. This | |
47 | -- routine also deals with a possibly misspelled version of Return. | |
48 | ||
49 | ---------------------------------------- | |
50 | -- Check_Junk_Semicolon_Before_Return -- | |
51 | ---------------------------------------- | |
52 | ||
53 | procedure Check_Junk_Semicolon_Before_Return is | |
54 | Scan_State : Saved_Scan_State; | |
55 | ||
56 | begin | |
57 | if Token = Tok_Semicolon then | |
58 | Save_Scan_State (Scan_State); | |
59 | Scan; -- past the semicolon | |
60 | ||
61 | if Token = Tok_Return then | |
62 | Restore_Scan_State (Scan_State); | |
63 | Error_Msg_SC ("Unexpected semicolon ignored"); | |
64 | Scan; -- rescan past junk semicolon | |
65 | ||
66 | else | |
67 | Restore_Scan_State (Scan_State); | |
68 | end if; | |
69 | ||
70 | elsif Bad_Spelling_Of (Tok_Return) then | |
71 | null; | |
72 | end if; | |
73 | end Check_Junk_Semicolon_Before_Return; | |
74 | ||
75 | ----------------------------------------------------- | |
76 | -- 6.1 Subprogram (Also 6.3, 8.5.4, 10.1.3, 12.3) -- | |
77 | ----------------------------------------------------- | |
78 | ||
79 | -- This routine scans out a subprogram declaration, subprogram body, | |
80 | -- subprogram renaming declaration or subprogram generic instantiation. | |
81 | ||
82 | -- SUBPROGRAM_DECLARATION ::= SUBPROGRAM_SPECIFICATION; | |
83 | ||
84 | -- ABSTRACT_SUBPROGRAM_DECLARATION ::= | |
85 | -- SUBPROGRAM_SPECIFICATION is abstract; | |
86 | ||
87 | -- SUBPROGRAM_SPECIFICATION ::= | |
88 | -- procedure DEFINING_PROGRAM_UNIT_NAME PARAMETER_PROFILE | |
89 | -- | function DEFINING_DESIGNATOR PARAMETER_AND_RESULT_PROFILE | |
90 | ||
91 | -- PARAMETER_PROFILE ::= [FORMAL_PART] | |
92 | ||
93 | -- PARAMETER_AND_RESULT_PROFILE ::= [FORMAL_PART] return SUBTYPE_MARK | |
94 | ||
95 | -- SUBPROGRAM_BODY ::= | |
96 | -- SUBPROGRAM_SPECIFICATION is | |
97 | -- DECLARATIVE_PART | |
98 | -- begin | |
99 | -- HANDLED_SEQUENCE_OF_STATEMENTS | |
100 | -- end [DESIGNATOR]; | |
101 | ||
102 | -- SUBPROGRAM_RENAMING_DECLARATION ::= | |
103 | -- SUBPROGRAM_SPECIFICATION renames callable_entity_NAME; | |
104 | ||
105 | -- SUBPROGRAM_BODY_STUB ::= | |
106 | -- SUBPROGRAM_SPECIFICATION is separate; | |
107 | ||
108 | -- GENERIC_INSTANTIATION ::= | |
109 | -- procedure DEFINING_PROGRAM_UNIT_NAME is | |
110 | -- new generic_procedure_NAME [GENERIC_ACTUAL_PART]; | |
111 | -- | function DEFINING_DESIGNATOR is | |
112 | -- new generic_function_NAME [GENERIC_ACTUAL_PART]; | |
113 | ||
114 | -- The value in Pf_Flags indicates which of these possible declarations | |
115 | -- is acceptable to the caller: | |
116 | ||
117 | -- Pf_Flags.Decl Set if declaration OK | |
118 | -- Pf_Flags.Gins Set if generic instantiation OK | |
119 | -- Pf_Flags.Pbod Set if proper body OK | |
120 | -- Pf_Flags.Rnam Set if renaming declaration OK | |
121 | -- Pf_Flags.Stub Set if body stub OK | |
122 | ||
123 | -- If an inappropriate form is encountered, it is scanned out but an | |
124 | -- error message indicating that it is appearing in an inappropriate | |
125 | -- context is issued. The only possible values for Pf_Flags are those | |
126 | -- defined as constants in the Par package. | |
127 | ||
128 | -- The caller has checked that the initial token is FUNCTION or PROCEDURE | |
129 | ||
130 | -- Error recovery: cannot raise Error_Resync | |
131 | ||
132 | function P_Subprogram (Pf_Flags : Pf_Rec) return Node_Id is | |
133 | Specification_Node : Node_Id; | |
134 | Name_Node : Node_Id; | |
135 | Fpart_List : List_Id; | |
136 | Fpart_Sloc : Source_Ptr; | |
137 | Return_Node : Node_Id; | |
138 | Inst_Node : Node_Id; | |
139 | Body_Node : Node_Id; | |
140 | Decl_Node : Node_Id; | |
141 | Rename_Node : Node_Id; | |
142 | Absdec_Node : Node_Id; | |
143 | Stub_Node : Node_Id; | |
144 | Fproc_Sloc : Source_Ptr; | |
145 | Func : Boolean; | |
146 | Scan_State : Saved_Scan_State; | |
147 | ||
148 | begin | |
149 | -- Set up scope stack entry. Note that the Labl field will be set later | |
150 | ||
151 | SIS_Entry_Active := False; | |
152 | SIS_Missing_Semicolon_Message := No_Error_Msg; | |
153 | Push_Scope_Stack; | |
154 | Scope.Table (Scope.Last).Sloc := Token_Ptr; | |
155 | Scope.Table (Scope.Last).Etyp := E_Name; | |
156 | Scope.Table (Scope.Last).Ecol := Start_Column; | |
157 | Scope.Table (Scope.Last).Lreq := False; | |
158 | ||
159 | Func := (Token = Tok_Function); | |
160 | Fproc_Sloc := Token_Ptr; | |
161 | Scan; -- past FUNCTION or PROCEDURE | |
162 | Ignore (Tok_Type); | |
163 | Ignore (Tok_Body); | |
164 | ||
165 | if Func then | |
166 | Name_Node := P_Defining_Designator; | |
167 | ||
168 | if Nkind (Name_Node) = N_Defining_Operator_Symbol | |
169 | and then Scope.Last = 1 | |
170 | then | |
171 | Error_Msg_SP ("operator symbol not allowed at library level"); | |
172 | Name_Node := New_Entity (N_Defining_Identifier, Sloc (Name_Node)); | |
173 | ||
174 | -- Set name from file name, we need some junk name, and that's | |
175 | -- as good as anything. This is only approximate, since we do | |
176 | -- not do anything with non-standard name translations. | |
177 | ||
178 | Get_Name_String (File_Name (Current_Source_File)); | |
179 | ||
180 | for J in 1 .. Name_Len loop | |
181 | if Name_Buffer (J) = '.' then | |
182 | Name_Len := J - 1; | |
183 | exit; | |
184 | end if; | |
185 | end loop; | |
186 | ||
187 | Set_Chars (Name_Node, Name_Find); | |
188 | Set_Error_Posted (Name_Node); | |
189 | end if; | |
190 | ||
191 | else | |
192 | Name_Node := P_Defining_Program_Unit_Name; | |
193 | end if; | |
194 | ||
195 | Scope.Table (Scope.Last).Labl := Name_Node; | |
196 | ||
197 | if Token = Tok_Colon then | |
198 | Error_Msg_SC ("redundant colon ignored"); | |
199 | Scan; -- past colon | |
200 | end if; | |
201 | ||
202 | -- Deal with generic instantiation, the one case in which we do not | |
203 | -- have a subprogram specification as part of whatever we are parsing | |
204 | ||
205 | if Token = Tok_Is then | |
206 | Save_Scan_State (Scan_State); -- at the IS | |
207 | T_Is; -- checks for redundant IS's | |
208 | ||
209 | if Token = Tok_New then | |
210 | if not Pf_Flags.Gins then | |
211 | Error_Msg_SC ("generic instantation not allowed here!"); | |
212 | end if; | |
213 | ||
214 | Scan; -- past NEW | |
215 | ||
216 | if Func then | |
217 | Inst_Node := New_Node (N_Function_Instantiation, Fproc_Sloc); | |
218 | Set_Name (Inst_Node, P_Function_Name); | |
219 | else | |
220 | Inst_Node := New_Node (N_Procedure_Instantiation, Fproc_Sloc); | |
221 | Set_Name (Inst_Node, P_Qualified_Simple_Name); | |
222 | end if; | |
223 | ||
224 | Set_Defining_Unit_Name (Inst_Node, Name_Node); | |
225 | Set_Generic_Associations (Inst_Node, P_Generic_Actual_Part_Opt); | |
226 | TF_Semicolon; | |
227 | Pop_Scope_Stack; -- Don't need scope stack entry in this case | |
228 | return Inst_Node; | |
229 | ||
230 | else | |
231 | Restore_Scan_State (Scan_State); -- to the IS | |
232 | end if; | |
233 | end if; | |
234 | ||
235 | -- If not a generic instantiation, then we definitely have a subprogram | |
236 | -- specification (all possibilities at this stage include one here) | |
237 | ||
238 | Fpart_Sloc := Token_Ptr; | |
239 | ||
240 | Check_Misspelling_Of (Tok_Return); | |
241 | ||
242 | -- Scan formal part. First a special error check. If we have an | |
243 | -- identifier here, then we have a definite error. If this identifier | |
244 | -- is on the same line as the designator, then we assume it is the | |
245 | -- first formal after a missing left parenthesis | |
246 | ||
247 | if Token = Tok_Identifier | |
248 | and then not Token_Is_At_Start_Of_Line | |
249 | then | |
250 | T_Left_Paren; -- to generate message | |
251 | Fpart_List := P_Formal_Part; | |
252 | ||
253 | -- Otherwise scan out an optional formal part in the usual manner | |
254 | ||
255 | else | |
256 | Fpart_List := P_Parameter_Profile; | |
257 | end if; | |
258 | ||
259 | -- We treat what we have as a function specification if FUNCTION was | |
260 | -- used, or if a RETURN is present. This gives better error recovery | |
261 | -- since later RETURN statements will be valid in either case. | |
262 | ||
263 | Check_Junk_Semicolon_Before_Return; | |
264 | Return_Node := Error; | |
265 | ||
266 | if Token = Tok_Return then | |
267 | if not Func then | |
268 | Error_Msg ("PROCEDURE should be FUNCTION", Fproc_Sloc); | |
269 | Func := True; | |
270 | end if; | |
271 | ||
272 | Scan; -- past RETURN | |
273 | Return_Node := P_Subtype_Mark; | |
274 | No_Constraint; | |
275 | ||
276 | else | |
277 | if Func then | |
278 | Ignore (Tok_Right_Paren); | |
279 | TF_Return; | |
280 | end if; | |
281 | end if; | |
282 | ||
283 | if Func then | |
284 | Specification_Node := | |
285 | New_Node (N_Function_Specification, Fproc_Sloc); | |
286 | Set_Subtype_Mark (Specification_Node, Return_Node); | |
287 | ||
288 | else | |
289 | Specification_Node := | |
290 | New_Node (N_Procedure_Specification, Fproc_Sloc); | |
291 | end if; | |
292 | ||
293 | Set_Defining_Unit_Name (Specification_Node, Name_Node); | |
294 | Set_Parameter_Specifications (Specification_Node, Fpart_List); | |
295 | ||
296 | -- Error check: barriers not allowed on protected functions/procedures | |
297 | ||
298 | if Token = Tok_When then | |
299 | if Func then | |
300 | Error_Msg_SC ("barrier not allowed on function, only on entry"); | |
301 | else | |
302 | Error_Msg_SC ("barrier not allowed on procedure, only on entry"); | |
303 | end if; | |
304 | ||
305 | Scan; -- past WHEN | |
306 | Discard_Junk_Node (P_Expression); | |
307 | end if; | |
308 | ||
309 | -- Deal with case of semicolon ending a subprogram declaration | |
310 | ||
311 | if Token = Tok_Semicolon then | |
312 | if not Pf_Flags.Decl then | |
313 | T_Is; | |
314 | end if; | |
315 | ||
316 | Scan; -- past semicolon | |
317 | ||
318 | -- If semicolon is immediately followed by IS, then ignore the | |
319 | -- semicolon, and go process the body. | |
320 | ||
321 | if Token = Tok_Is then | |
322 | Error_Msg_SP ("unexpected semicolon ignored"); | |
323 | T_Is; -- ignroe redundant IS's | |
324 | goto Subprogram_Body; | |
325 | ||
326 | -- If BEGIN follows in an appropriate column, we immediately | |
327 | -- commence the error action of assuming that the previous | |
328 | -- subprogram declaration should have been a subprogram body, | |
329 | -- i.e. that the terminating semicolon should have been IS. | |
330 | ||
331 | elsif Token = Tok_Begin | |
332 | and then Start_Column >= Scope.Table (Scope.Last).Ecol | |
333 | then | |
334 | Error_Msg_SP (""";"" should be IS!"); | |
335 | goto Subprogram_Body; | |
336 | ||
337 | else | |
338 | goto Subprogram_Declaration; | |
339 | end if; | |
340 | ||
341 | -- Case of not followed by semicolon | |
342 | ||
343 | else | |
344 | -- Subprogram renaming declaration case | |
345 | ||
346 | Check_Misspelling_Of (Tok_Renames); | |
347 | ||
348 | if Token = Tok_Renames then | |
349 | if not Pf_Flags.Rnam then | |
350 | Error_Msg_SC ("renaming declaration not allowed here!"); | |
351 | end if; | |
352 | ||
353 | Rename_Node := | |
354 | New_Node (N_Subprogram_Renaming_Declaration, Token_Ptr); | |
355 | Scan; -- past RENAMES | |
356 | Set_Name (Rename_Node, P_Name); | |
357 | Set_Specification (Rename_Node, Specification_Node); | |
358 | TF_Semicolon; | |
359 | Pop_Scope_Stack; | |
360 | return Rename_Node; | |
361 | ||
362 | -- Case of IS following subprogram specification | |
363 | ||
364 | elsif Token = Tok_Is then | |
365 | T_Is; -- ignore redundant Is's | |
366 | ||
367 | if Token_Name = Name_Abstract then | |
368 | Check_95_Keyword (Tok_Abstract, Tok_Semicolon); | |
369 | end if; | |
370 | ||
371 | -- Deal nicely with (now obsolete) use of <> in place of abstract | |
372 | ||
373 | if Token = Tok_Box then | |
374 | Error_Msg_SC ("ABSTRACT expected"); | |
375 | Token := Tok_Abstract; | |
376 | end if; | |
377 | ||
378 | -- Abstract subprogram declaration case | |
379 | ||
380 | if Token = Tok_Abstract then | |
381 | Absdec_Node := | |
382 | New_Node (N_Abstract_Subprogram_Declaration, Token_Ptr); | |
383 | Set_Specification (Absdec_Node, Specification_Node); | |
384 | Pop_Scope_Stack; -- discard unneeded entry | |
385 | Scan; -- past ABSTRACT | |
386 | TF_Semicolon; | |
387 | return Absdec_Node; | |
388 | ||
389 | -- Check for IS NEW with Formal_Part present and handle nicely | |
390 | ||
391 | elsif Token = Tok_New then | |
392 | Error_Msg | |
393 | ("formal part not allowed in instantiation", Fpart_Sloc); | |
394 | Scan; -- past NEW | |
395 | ||
396 | if Func then | |
397 | Inst_Node := New_Node (N_Function_Instantiation, Fproc_Sloc); | |
398 | else | |
399 | Inst_Node := | |
400 | New_Node (N_Procedure_Instantiation, Fproc_Sloc); | |
401 | end if; | |
402 | ||
403 | Set_Defining_Unit_Name (Inst_Node, Name_Node); | |
404 | Set_Name (Inst_Node, P_Name); | |
405 | Set_Generic_Associations (Inst_Node, P_Generic_Actual_Part_Opt); | |
406 | TF_Semicolon; | |
407 | Pop_Scope_Stack; -- Don't need scope stack entry in this case | |
408 | return Inst_Node; | |
409 | ||
410 | else | |
411 | goto Subprogram_Body; | |
412 | end if; | |
413 | ||
414 | -- Here we have a missing IS or missing semicolon, we always guess | |
415 | -- a missing semicolon, since we are pretty good at fixing up a | |
416 | -- semicolon which should really be an IS | |
417 | ||
418 | else | |
419 | Error_Msg_AP ("missing "";"""); | |
420 | SIS_Missing_Semicolon_Message := Get_Msg_Id; | |
421 | goto Subprogram_Declaration; | |
422 | end if; | |
423 | end if; | |
424 | ||
425 | -- Processing for subprogram body | |
426 | ||
427 | <<Subprogram_Body>> | |
428 | if not Pf_Flags.Pbod then | |
429 | Error_Msg_SP ("subprogram body not allowed here!"); | |
430 | end if; | |
431 | ||
432 | -- Subprogram body stub case | |
433 | ||
434 | if Separate_Present then | |
435 | if not Pf_Flags.Stub then | |
436 | Error_Msg_SC ("body stub not allowed here!"); | |
437 | end if; | |
438 | ||
439 | if Nkind (Name_Node) = N_Defining_Operator_Symbol then | |
440 | Error_Msg | |
441 | ("operator symbol cannot be used as subunit name", | |
442 | Sloc (Name_Node)); | |
443 | end if; | |
444 | ||
445 | Stub_Node := | |
446 | New_Node (N_Subprogram_Body_Stub, Sloc (Specification_Node)); | |
447 | Set_Specification (Stub_Node, Specification_Node); | |
448 | Scan; -- past SEPARATE | |
449 | Pop_Scope_Stack; | |
450 | TF_Semicolon; | |
451 | return Stub_Node; | |
452 | ||
453 | -- Subprogram body case | |
454 | ||
455 | else | |
456 | -- Here is the test for a suspicious IS (i.e. one that looks | |
457 | -- like it might more properly be a semicolon). See separate | |
458 | -- section discussing use of IS instead of semicolon in | |
459 | -- package Parse. | |
460 | ||
461 | if (Token in Token_Class_Declk | |
462 | or else | |
463 | Token = Tok_Identifier) | |
464 | and then Start_Column <= Scope.Table (Scope.Last).Ecol | |
465 | and then Scope.Last /= 1 | |
466 | then | |
467 | Scope.Table (Scope.Last).Etyp := E_Suspicious_Is; | |
468 | Scope.Table (Scope.Last).S_Is := Prev_Token_Ptr; | |
469 | end if; | |
470 | ||
471 | Body_Node := | |
472 | New_Node (N_Subprogram_Body, Sloc (Specification_Node)); | |
473 | Set_Specification (Body_Node, Specification_Node); | |
474 | Parse_Decls_Begin_End (Body_Node); | |
475 | return Body_Node; | |
476 | end if; | |
477 | ||
478 | -- Processing for subprogram declaration | |
479 | ||
480 | <<Subprogram_Declaration>> | |
481 | Decl_Node := | |
482 | New_Node (N_Subprogram_Declaration, Sloc (Specification_Node)); | |
483 | Set_Specification (Decl_Node, Specification_Node); | |
484 | ||
485 | -- If this is a context in which a subprogram body is permitted, | |
486 | -- set active SIS entry in case (see section titled "Handling | |
487 | -- Semicolon Used in Place of IS" in body of Parser package) | |
488 | -- Note that SIS_Missing_Semicolon_Message is already set properly. | |
489 | ||
490 | if Pf_Flags.Pbod then | |
491 | SIS_Labl := Scope.Table (Scope.Last).Labl; | |
492 | SIS_Sloc := Scope.Table (Scope.Last).Sloc; | |
493 | SIS_Ecol := Scope.Table (Scope.Last).Ecol; | |
494 | SIS_Declaration_Node := Decl_Node; | |
495 | SIS_Semicolon_Sloc := Prev_Token_Ptr; | |
496 | SIS_Entry_Active := True; | |
497 | end if; | |
498 | ||
499 | Pop_Scope_Stack; | |
500 | return Decl_Node; | |
501 | ||
502 | end P_Subprogram; | |
503 | ||
504 | --------------------------------- | |
505 | -- 6.1 Subprogram Declaration -- | |
506 | --------------------------------- | |
507 | ||
508 | -- Parsed by P_Subprogram (6.1) | |
509 | ||
510 | ------------------------------------------ | |
511 | -- 6.1 Abstract Subprogram Declaration -- | |
512 | ------------------------------------------ | |
513 | ||
514 | -- Parsed by P_Subprogram (6.1) | |
515 | ||
516 | ----------------------------------- | |
517 | -- 6.1 Subprogram Specification -- | |
518 | ----------------------------------- | |
519 | ||
520 | -- SUBPROGRAM_SPECIFICATION ::= | |
521 | -- procedure DEFINING_PROGRAM_UNIT_NAME PARAMETER_PROFILE | |
522 | -- | function DEFINING_DESIGNATOR PARAMETER_AND_RESULT_PROFILE | |
523 | ||
524 | -- PARAMETER_PROFILE ::= [FORMAL_PART] | |
525 | ||
526 | -- PARAMETER_AND_RESULT_PROFILE ::= [FORMAL_PART] return SUBTYPE_MARK | |
527 | ||
528 | -- Subprogram specifications that appear in subprogram declarations | |
529 | -- are parsed by P_Subprogram (6.1). This routine is used in other | |
530 | -- contexts where subprogram specifications occur. | |
531 | ||
532 | -- Note: this routine does not affect the scope stack in any way | |
533 | ||
534 | -- Error recovery: can raise Error_Resync | |
535 | ||
536 | function P_Subprogram_Specification return Node_Id is | |
537 | Specification_Node : Node_Id; | |
538 | ||
539 | begin | |
540 | if Token = Tok_Function then | |
541 | Specification_Node := New_Node (N_Function_Specification, Token_Ptr); | |
542 | Scan; -- past FUNCTION | |
543 | Ignore (Tok_Body); | |
544 | Set_Defining_Unit_Name (Specification_Node, P_Defining_Designator); | |
545 | Set_Parameter_Specifications | |
546 | (Specification_Node, P_Parameter_Profile); | |
547 | Check_Junk_Semicolon_Before_Return; | |
548 | TF_Return; | |
549 | Set_Subtype_Mark (Specification_Node, P_Subtype_Mark); | |
550 | No_Constraint; | |
551 | return Specification_Node; | |
552 | ||
553 | elsif Token = Tok_Procedure then | |
554 | Specification_Node := New_Node (N_Procedure_Specification, Token_Ptr); | |
555 | Scan; -- past PROCEDURE | |
556 | Ignore (Tok_Body); | |
557 | Set_Defining_Unit_Name | |
558 | (Specification_Node, P_Defining_Program_Unit_Name); | |
559 | Set_Parameter_Specifications | |
560 | (Specification_Node, P_Parameter_Profile); | |
561 | return Specification_Node; | |
562 | ||
563 | else | |
564 | Error_Msg_SC ("subprogram specification expected"); | |
565 | raise Error_Resync; | |
566 | end if; | |
567 | end P_Subprogram_Specification; | |
568 | ||
569 | --------------------- | |
570 | -- 6.1 Designator -- | |
571 | --------------------- | |
572 | ||
573 | -- DESIGNATOR ::= | |
574 | -- [PARENT_UNIT_NAME .] IDENTIFIER | OPERATOR_SYMBOL | |
575 | ||
576 | -- The caller has checked that the initial token is an identifier, | |
577 | -- operator symbol, or string literal. Note that we don't bother to | |
578 | -- do much error diagnosis in this routine, since it is only used for | |
579 | -- the label on END lines, and the routines in package Par.Endh will | |
580 | -- check that the label is appropriate. | |
581 | ||
582 | -- Error recovery: cannot raise Error_Resync | |
583 | ||
584 | function P_Designator return Node_Id is | |
585 | Ident_Node : Node_Id; | |
586 | Name_Node : Node_Id; | |
587 | Prefix_Node : Node_Id; | |
588 | ||
589 | function Real_Dot return Boolean; | |
590 | -- Tests if a current token is an interesting period, i.e. is followed | |
591 | -- by an identifier or operator symbol or string literal. If not, it is | |
592 | -- probably just incorrect punctuation to be caught by our caller. Note | |
593 | -- that the case of an operator symbol or string literal is also an | |
594 | -- error, but that is an error that we catch here. If the result is | |
595 | -- True, a real dot has been scanned and we are positioned past it, | |
596 | -- if the result is False, the scan position is unchanged. | |
597 | ||
598 | function Real_Dot return Boolean is | |
599 | Scan_State : Saved_Scan_State; | |
600 | ||
601 | begin | |
602 | if Token /= Tok_Dot then | |
603 | return False; | |
604 | ||
605 | else | |
606 | Save_Scan_State (Scan_State); | |
607 | Scan; -- past dot | |
608 | ||
609 | if Token = Tok_Identifier | |
610 | or else Token = Tok_Operator_Symbol | |
611 | or else Token = Tok_String_Literal | |
612 | then | |
613 | return True; | |
614 | ||
615 | else | |
616 | Restore_Scan_State (Scan_State); | |
617 | return False; | |
618 | end if; | |
619 | end if; | |
620 | end Real_Dot; | |
621 | ||
622 | -- Start of processing for P_Designator | |
623 | ||
624 | begin | |
625 | Ident_Node := Token_Node; | |
626 | Scan; -- past initial token | |
627 | ||
628 | if Prev_Token = Tok_Operator_Symbol | |
629 | or else Prev_Token = Tok_String_Literal | |
630 | or else not Real_Dot | |
631 | then | |
632 | return Ident_Node; | |
633 | ||
634 | -- Child name case | |
635 | ||
636 | else | |
637 | Prefix_Node := Ident_Node; | |
638 | ||
639 | -- Loop through child names, on entry to this loop, Prefix contains | |
640 | -- the name scanned so far, and Ident_Node is the last identifier. | |
641 | ||
642 | loop | |
643 | Name_Node := New_Node (N_Selected_Component, Prev_Token_Ptr); | |
644 | Set_Prefix (Name_Node, Prefix_Node); | |
645 | Ident_Node := P_Identifier; | |
646 | Set_Selector_Name (Name_Node, Ident_Node); | |
647 | Prefix_Node := Name_Node; | |
648 | exit when not Real_Dot; | |
649 | end loop; | |
650 | ||
651 | -- On exit from the loop, Ident_Node is the last identifier scanned, | |
652 | -- i.e. the defining identifier, and Prefix_Node is a node for the | |
653 | -- entire name, structured (incorrectly!) as a selected component. | |
654 | ||
655 | Name_Node := Prefix (Prefix_Node); | |
656 | Change_Node (Prefix_Node, N_Designator); | |
657 | Set_Name (Prefix_Node, Name_Node); | |
658 | Set_Identifier (Prefix_Node, Ident_Node); | |
659 | return Prefix_Node; | |
660 | end if; | |
661 | ||
662 | exception | |
663 | when Error_Resync => | |
664 | while Token = Tok_Dot or else Token = Tok_Identifier loop | |
665 | Scan; | |
666 | end loop; | |
667 | ||
668 | return Error; | |
669 | end P_Designator; | |
670 | ||
671 | ------------------------------ | |
672 | -- 6.1 Defining Designator -- | |
673 | ------------------------------ | |
674 | ||
675 | -- DEFINING_DESIGNATOR ::= | |
676 | -- DEFINING_PROGRAM_UNIT_NAME | DEFINING_OPERATOR_SYMBOL | |
677 | ||
678 | -- Error recovery: cannot raise Error_Resync | |
679 | ||
680 | function P_Defining_Designator return Node_Id is | |
681 | begin | |
682 | if Token = Tok_Operator_Symbol then | |
683 | return P_Defining_Operator_Symbol; | |
684 | ||
685 | elsif Token = Tok_String_Literal then | |
686 | Error_Msg_SC ("invalid operator name"); | |
687 | Scan; -- past junk string | |
688 | return Error; | |
689 | ||
690 | else | |
691 | return P_Defining_Program_Unit_Name; | |
692 | end if; | |
693 | end P_Defining_Designator; | |
694 | ||
695 | ------------------------------------- | |
696 | -- 6.1 Defining Program Unit Name -- | |
697 | ------------------------------------- | |
698 | ||
699 | -- DEFINING_PROGRAM_UNIT_NAME ::= | |
700 | -- [PARENT_UNIT_NAME .] DEFINING_IDENTIFIER | |
701 | ||
702 | -- Note: PARENT_UNIT_NAME may be present only in 95 mode at the outer level | |
703 | ||
704 | -- Error recovery: cannot raise Error_Resync | |
705 | ||
706 | function P_Defining_Program_Unit_Name return Node_Id is | |
707 | Ident_Node : Node_Id; | |
708 | Name_Node : Node_Id; | |
709 | Prefix_Node : Node_Id; | |
710 | ||
711 | begin | |
712 | -- Set identifier casing if not already set and scan initial identifier | |
713 | ||
714 | if Token = Tok_Identifier | |
715 | and then Identifier_Casing (Current_Source_File) = Unknown | |
716 | then | |
717 | Set_Identifier_Casing (Current_Source_File, Determine_Token_Casing); | |
718 | end if; | |
719 | ||
720 | Ident_Node := P_Identifier; | |
721 | Merge_Identifier (Ident_Node, Tok_Return); | |
722 | ||
723 | -- Normal case (not child library unit name) | |
724 | ||
725 | if Token /= Tok_Dot then | |
726 | Change_Identifier_To_Defining_Identifier (Ident_Node); | |
727 | return Ident_Node; | |
728 | ||
729 | -- Child library unit name case | |
730 | ||
731 | else | |
732 | if Scope.Last > 1 then | |
733 | Error_Msg_SP ("child unit allowed only at library level"); | |
734 | raise Error_Resync; | |
735 | ||
736 | elsif Ada_83 then | |
737 | Error_Msg_SP ("(Ada 83) child unit not allowed!"); | |
738 | ||
739 | end if; | |
740 | ||
741 | Prefix_Node := Ident_Node; | |
742 | ||
743 | -- Loop through child names, on entry to this loop, Prefix contains | |
744 | -- the name scanned so far, and Ident_Node is the last identifier. | |
745 | ||
746 | loop | |
747 | exit when Token /= Tok_Dot; | |
748 | Name_Node := New_Node (N_Selected_Component, Token_Ptr); | |
749 | Scan; -- past period | |
750 | Set_Prefix (Name_Node, Prefix_Node); | |
751 | Ident_Node := P_Identifier; | |
752 | Set_Selector_Name (Name_Node, Ident_Node); | |
753 | Prefix_Node := Name_Node; | |
754 | end loop; | |
755 | ||
756 | -- On exit from the loop, Ident_Node is the last identifier scanned, | |
757 | -- i.e. the defining identifier, and Prefix_Node is a node for the | |
758 | -- entire name, structured (incorrectly!) as a selected component. | |
759 | ||
760 | Name_Node := Prefix (Prefix_Node); | |
761 | Change_Node (Prefix_Node, N_Defining_Program_Unit_Name); | |
762 | Set_Name (Prefix_Node, Name_Node); | |
763 | Change_Identifier_To_Defining_Identifier (Ident_Node); | |
764 | Set_Defining_Identifier (Prefix_Node, Ident_Node); | |
765 | ||
766 | -- All set with unit name parsed | |
767 | ||
768 | return Prefix_Node; | |
769 | end if; | |
770 | ||
771 | exception | |
772 | when Error_Resync => | |
773 | while Token = Tok_Dot or else Token = Tok_Identifier loop | |
774 | Scan; | |
775 | end loop; | |
776 | ||
777 | return Error; | |
778 | end P_Defining_Program_Unit_Name; | |
779 | ||
780 | -------------------------- | |
781 | -- 6.1 Operator Symbol -- | |
782 | -------------------------- | |
783 | ||
784 | -- OPERATOR_SYMBOL ::= STRING_LITERAL | |
785 | ||
786 | -- Operator symbol is returned by the scanner as Tok_Operator_Symbol | |
787 | ||
788 | ----------------------------------- | |
789 | -- 6.1 Defining Operator Symbol -- | |
790 | ----------------------------------- | |
791 | ||
792 | -- DEFINING_OPERATOR_SYMBOL ::= OPERATOR_SYMBOL | |
793 | ||
794 | -- The caller has checked that the initial symbol is an operator symbol | |
795 | ||
796 | function P_Defining_Operator_Symbol return Node_Id is | |
797 | Op_Node : Node_Id; | |
798 | ||
799 | begin | |
800 | Op_Node := Token_Node; | |
801 | Change_Operator_Symbol_To_Defining_Operator_Symbol (Op_Node); | |
802 | Scan; -- past operator symbol | |
803 | return Op_Node; | |
804 | end P_Defining_Operator_Symbol; | |
805 | ||
806 | ---------------------------- | |
807 | -- 6.1 Parameter_Profile -- | |
808 | ---------------------------- | |
809 | ||
810 | -- PARAMETER_PROFILE ::= [FORMAL_PART] | |
811 | ||
812 | -- Empty is returned if no formal part is present | |
813 | ||
814 | -- Error recovery: cannot raise Error_Resync | |
815 | ||
816 | function P_Parameter_Profile return List_Id is | |
817 | begin | |
818 | if Token = Tok_Left_Paren then | |
819 | Scan; -- part left paren | |
820 | return P_Formal_Part; | |
821 | else | |
822 | return No_List; | |
823 | end if; | |
824 | end P_Parameter_Profile; | |
825 | ||
826 | --------------------------------------- | |
827 | -- 6.1 Parameter And Result Profile -- | |
828 | --------------------------------------- | |
829 | ||
830 | -- Parsed by its parent construct, which uses P_Parameter_Profile to | |
831 | -- parse the parameters, and P_Subtype_Mark to parse the return type. | |
832 | ||
833 | ---------------------- | |
834 | -- 6.1 Formal part -- | |
835 | ---------------------- | |
836 | ||
837 | -- FORMAL_PART ::= (PARAMETER_SPECIFICATION {; PARAMETER_SPECIFICATION}) | |
838 | ||
839 | -- PARAMETER_SPECIFICATION ::= | |
840 | -- DEFINING_IDENTIFIER_LIST : MODE SUBTYPE_MARK | |
841 | -- [:= DEFAULT_EXPRESSION] | |
842 | -- | DEFINING_IDENTIFIER_LIST : ACCESS_DEFINITION | |
843 | -- [:= DEFAULT_EXPRESSION] | |
844 | ||
845 | -- This scans the construct Formal_Part. The caller has already checked | |
846 | -- that the initial token is a left parenthesis, and skipped past it, so | |
847 | -- that on entry Token is the first token following the left parenthesis. | |
848 | ||
849 | -- Error recovery: cannot raise Error_Resync | |
850 | ||
851 | function P_Formal_Part return List_Id is | |
852 | Specification_List : List_Id; | |
853 | Specification_Node : Node_Id; | |
854 | Scan_State : Saved_Scan_State; | |
855 | Num_Idents : Nat; | |
856 | Ident : Nat; | |
857 | Ident_Sloc : Source_Ptr; | |
858 | ||
859 | Idents : array (Int range 1 .. 4096) of Entity_Id; | |
860 | -- This array holds the list of defining identifiers. The upper bound | |
861 | -- of 4096 is intended to be essentially infinite, and we do not even | |
862 | -- bother to check for it being exceeded. | |
863 | ||
864 | begin | |
865 | Specification_List := New_List; | |
866 | ||
867 | Specification_Loop : loop | |
868 | begin | |
869 | if Token = Tok_Pragma then | |
870 | P_Pragmas_Misplaced; | |
871 | end if; | |
872 | ||
873 | Ignore (Tok_Left_Paren); | |
874 | Ident_Sloc := Token_Ptr; | |
875 | Idents (1) := P_Defining_Identifier; | |
876 | Num_Idents := 1; | |
877 | ||
878 | Ident_Loop : loop | |
879 | exit Ident_Loop when Token = Tok_Colon; | |
880 | ||
881 | -- The only valid tokens are colon and comma, so if we have | |
882 | -- neither do a bit of investigation to see which is the | |
883 | -- better choice for insertion. | |
884 | ||
885 | if Token /= Tok_Comma then | |
886 | ||
887 | -- Assume colon if IN or OUT keyword found | |
888 | ||
889 | exit Ident_Loop when Token = Tok_In or else Token = Tok_Out; | |
890 | ||
891 | -- Otherwise scan ahead | |
892 | ||
893 | Save_Scan_State (Scan_State); | |
894 | Look_Ahead : loop | |
895 | ||
896 | -- If we run into a semicolon, then assume that a | |
897 | -- colon was missing, e.g. Parms (X Y; ...). Also | |
898 | -- assume missing colon on EOF (a real disaster!) | |
899 | -- and on a right paren, e.g. Parms (X Y), and also | |
900 | -- on an assignment symbol, e.g. Parms (X Y := ..) | |
901 | ||
902 | if Token = Tok_Semicolon | |
903 | or else Token = Tok_Right_Paren | |
904 | or else Token = Tok_EOF | |
905 | or else Token = Tok_Colon_Equal | |
906 | then | |
907 | Restore_Scan_State (Scan_State); | |
908 | exit Ident_Loop; | |
909 | ||
910 | -- If we run into a colon, assume that we had a missing | |
911 | -- comma, e.g. Parms (A B : ...). Also assume a missing | |
912 | -- comma if we hit another comma, e.g. Parms (A B, C ..) | |
913 | ||
914 | elsif Token = Tok_Colon | |
915 | or else Token = Tok_Comma | |
916 | then | |
917 | Restore_Scan_State (Scan_State); | |
918 | exit Look_Ahead; | |
919 | end if; | |
920 | ||
921 | Scan; | |
922 | end loop Look_Ahead; | |
923 | end if; | |
924 | ||
925 | -- Here if a comma is present, or to be assumed | |
926 | ||
927 | T_Comma; | |
928 | Num_Idents := Num_Idents + 1; | |
929 | Idents (Num_Idents) := P_Defining_Identifier; | |
930 | end loop Ident_Loop; | |
931 | ||
932 | -- Fall through the loop on encountering a colon, or deciding | |
933 | -- that there is a missing colon. | |
934 | ||
935 | T_Colon; | |
936 | ||
937 | -- If there are multiple identifiers, we repeatedly scan the | |
938 | -- type and initialization expression information by resetting | |
939 | -- the scan pointer (so that we get completely separate trees | |
940 | -- for each occurrence). | |
941 | ||
942 | if Num_Idents > 1 then | |
943 | Save_Scan_State (Scan_State); | |
944 | end if; | |
945 | ||
946 | -- Loop through defining identifiers in list | |
947 | ||
948 | Ident := 1; | |
949 | ||
950 | Ident_List_Loop : loop | |
951 | Specification_Node := | |
952 | New_Node (N_Parameter_Specification, Ident_Sloc); | |
953 | Set_Defining_Identifier (Specification_Node, Idents (Ident)); | |
954 | ||
955 | if Token = Tok_Access then | |
956 | if Ada_83 then | |
957 | Error_Msg_SC ("(Ada 83) access parameters not allowed"); | |
958 | end if; | |
959 | ||
960 | Set_Parameter_Type | |
961 | (Specification_Node, P_Access_Definition); | |
962 | ||
963 | else | |
964 | P_Mode (Specification_Node); | |
965 | ||
966 | if Token = Tok_Procedure | |
967 | or else | |
968 | Token = Tok_Function | |
969 | then | |
970 | Error_Msg_SC ("formal subprogram parameter not allowed"); | |
971 | Scan; | |
972 | ||
973 | if Token = Tok_Left_Paren then | |
974 | Discard_Junk_List (P_Formal_Part); | |
975 | end if; | |
976 | ||
977 | if Token = Tok_Return then | |
978 | Scan; | |
979 | Discard_Junk_Node (P_Subtype_Mark); | |
980 | end if; | |
981 | ||
982 | Set_Parameter_Type (Specification_Node, Error); | |
983 | ||
984 | else | |
985 | Set_Parameter_Type (Specification_Node, P_Subtype_Mark); | |
986 | No_Constraint; | |
987 | end if; | |
988 | end if; | |
989 | ||
990 | Set_Expression (Specification_Node, Init_Expr_Opt (True)); | |
991 | ||
992 | if Ident > 1 then | |
993 | Set_Prev_Ids (Specification_Node, True); | |
994 | end if; | |
995 | ||
996 | if Ident < Num_Idents then | |
997 | Set_More_Ids (Specification_Node, True); | |
998 | end if; | |
999 | ||
1000 | Append (Specification_Node, Specification_List); | |
1001 | exit Ident_List_Loop when Ident = Num_Idents; | |
1002 | Ident := Ident + 1; | |
1003 | Restore_Scan_State (Scan_State); | |
1004 | end loop Ident_List_Loop; | |
1005 | ||
1006 | exception | |
1007 | when Error_Resync => | |
1008 | Resync_Semicolon_List; | |
1009 | end; | |
1010 | ||
1011 | if Token = Tok_Semicolon then | |
1012 | Scan; -- past semicolon | |
1013 | ||
1014 | -- If we have RETURN or IS after the semicolon, then assume | |
1015 | -- that semicolon should have been a right parenthesis and exit | |
1016 | ||
1017 | if Token = Tok_Is or else Token = Tok_Return then | |
1018 | Error_Msg_SP ("expected "")"" in place of "";"""); | |
1019 | exit Specification_Loop; | |
1020 | end if; | |
1021 | ||
1022 | elsif Token = Tok_Right_Paren then | |
1023 | Scan; -- past right paren | |
1024 | exit Specification_Loop; | |
1025 | ||
1026 | -- Special check for common error of using comma instead of semicolon | |
1027 | ||
1028 | elsif Token = Tok_Comma then | |
1029 | T_Semicolon; | |
1030 | Scan; -- past comma | |
1031 | ||
1032 | -- Special check for omitted separator | |
1033 | ||
1034 | elsif Token = Tok_Identifier then | |
1035 | T_Semicolon; | |
1036 | ||
1037 | -- If nothing sensible, skip to next semicolon or right paren | |
1038 | ||
1039 | else | |
1040 | T_Semicolon; | |
1041 | Resync_Semicolon_List; | |
1042 | ||
1043 | if Token = Tok_Semicolon then | |
1044 | Scan; -- past semicolon | |
1045 | else | |
1046 | T_Right_Paren; | |
1047 | exit Specification_Loop; | |
1048 | end if; | |
1049 | end if; | |
1050 | end loop Specification_Loop; | |
1051 | ||
1052 | return Specification_List; | |
1053 | end P_Formal_Part; | |
1054 | ||
1055 | ---------------------------------- | |
1056 | -- 6.1 Parameter Specification -- | |
1057 | ---------------------------------- | |
1058 | ||
1059 | -- Parsed by P_Formal_Part (6.1) | |
1060 | ||
1061 | --------------- | |
1062 | -- 6.1 Mode -- | |
1063 | --------------- | |
1064 | ||
1065 | -- MODE ::= [in] | in out | out | |
1066 | ||
1067 | -- There is no explicit node in the tree for the Mode. Instead the | |
1068 | -- In_Present and Out_Present flags are set in the parent node to | |
1069 | -- record the presence of keywords specifying the mode. | |
1070 | ||
1071 | -- Error_Recovery: cannot raise Error_Resync | |
1072 | ||
1073 | procedure P_Mode (Node : Node_Id) is | |
1074 | begin | |
1075 | if Token = Tok_In then | |
1076 | Scan; -- past IN | |
1077 | Set_In_Present (Node, True); | |
1078 | end if; | |
1079 | ||
1080 | if Token = Tok_Out then | |
1081 | Scan; -- past OUT | |
1082 | Set_Out_Present (Node, True); | |
1083 | end if; | |
1084 | ||
1085 | if Token = Tok_In then | |
1086 | Error_Msg_SC ("IN must preceed OUT in parameter mode"); | |
1087 | Scan; -- past IN | |
1088 | Set_In_Present (Node, True); | |
1089 | end if; | |
1090 | end P_Mode; | |
1091 | ||
1092 | -------------------------- | |
1093 | -- 6.3 Subprogram Body -- | |
1094 | -------------------------- | |
1095 | ||
1096 | -- Parsed by P_Subprogram (6.1) | |
1097 | ||
1098 | ----------------------------------- | |
1099 | -- 6.4 Procedure Call Statement -- | |
1100 | ----------------------------------- | |
1101 | ||
1102 | -- Parsed by P_Sequence_Of_Statements (5.1) | |
1103 | ||
1104 | ------------------------ | |
1105 | -- 6.4 Function Call -- | |
1106 | ------------------------ | |
1107 | ||
1108 | -- Parsed by P_Call_Or_Name (4.1) | |
1109 | ||
1110 | -------------------------------- | |
1111 | -- 6.4 Actual Parameter Part -- | |
1112 | -------------------------------- | |
1113 | ||
1114 | -- Parsed by P_Call_Or_Name (4.1) | |
1115 | ||
1116 | -------------------------------- | |
1117 | -- 6.4 Parameter Association -- | |
1118 | -------------------------------- | |
1119 | ||
1120 | -- Parsed by P_Call_Or_Name (4.1) | |
1121 | ||
1122 | ------------------------------------ | |
1123 | -- 6.4 Explicit Actual Parameter -- | |
1124 | ------------------------------------ | |
1125 | ||
1126 | -- Parsed by P_Call_Or_Name (4.1) | |
1127 | ||
1128 | --------------------------- | |
1129 | -- 6.5 Return Statement -- | |
1130 | --------------------------- | |
1131 | ||
1132 | -- RETURN_STATEMENT ::= return [EXPRESSION]; | |
1133 | ||
1134 | -- The caller has checked that the initial token is RETURN | |
1135 | ||
1136 | -- Error recovery: can raise Error_Resync | |
1137 | ||
1138 | function P_Return_Statement return Node_Id is | |
1139 | Return_Node : Node_Id; | |
1140 | ||
1141 | begin | |
1142 | Return_Node := New_Node (N_Return_Statement, Token_Ptr); | |
1143 | ||
1144 | -- Sloc points to RETURN | |
1145 | -- Expression (Op3) | |
1146 | ||
1147 | Scan; -- past RETURN | |
1148 | ||
1149 | if Token /= Tok_Semicolon then | |
1150 | ||
1151 | -- If no semicolon, then scan an expression, except that | |
1152 | -- we avoid trying to scan an expression if we are at an | |
1153 | -- expression terminator since in that case the best error | |
1154 | -- message is probably that we have a missing semicolon. | |
1155 | ||
1156 | if Token not in Token_Class_Eterm then | |
1157 | Set_Expression (Return_Node, P_Expression_No_Right_Paren); | |
1158 | end if; | |
1159 | end if; | |
1160 | ||
1161 | TF_Semicolon; | |
1162 | return Return_Node; | |
1163 | end P_Return_Statement; | |
1164 | ||
1165 | end Ch6; |