File : par-ch10.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- P A R . C H 1 0 --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
10 -- --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
20 -- --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
23 -- --
24 ------------------------------------------------------------------------------
25
26 pragma Style_Checks (All_Checks);
27 -- Turn off subprogram body ordering check. Subprograms are in order
28 -- by RM section rather than alphabetical
29
30 with Fname.UF; use Fname.UF;
31 with Uname; use Uname;
32
33 separate (Par)
34 package body Ch10 is
35
36 -- Local functions, used only in this chapter
37
38 function P_Context_Clause return List_Id;
39 function P_Subunit return Node_Id;
40
41 function Set_Location return Source_Ptr;
42 -- The current compilation unit starts with Token at Token_Ptr. This
43 -- function determines the corresponding source location for the start
44 -- of the unit, including any preceding comment lines.
45
46 procedure Unit_Display
47 (Cunit : Node_Id;
48 Loc : Source_Ptr;
49 SR_Present : Boolean);
50 -- This procedure is used to generate a line of output for a unit in
51 -- the source program. Cunit is the node for the compilation unit, and
52 -- Loc is the source location for the start of the unit in the source
53 -- file (which is not necessarily the Sloc of the Cunit node). This
54 -- output is written to the standard output file for use by gnatchop.
55
56 procedure Unit_Location (Sind : Source_File_Index; Loc : Source_Ptr);
57 -- This routine has the same calling sequence as Unit_Display, but
58 -- it outputs only the line number and offset of the location, Loc,
59 -- using Cunit to obtain the proper source file index.
60
61 -------------------------
62 -- 10.1.1 Compilation --
63 -------------------------
64
65 -- COMPILATION ::= {COMPILATION_UNIT}
66
67 -- There is no specific parsing routine for a compilation, since we only
68 -- permit a single compilation in a source file, so there is no explicit
69 -- occurrence of compilations as such (our representation of a compilation
70 -- is a series of separate source files).
71
72 ------------------------------
73 -- 10.1.1 Compilation unit --
74 ------------------------------
75
76 -- COMPILATION_UNIT ::=
77 -- CONTEXT_CLAUSE LIBRARY_ITEM
78 -- | CONTEXT_CLAUSE SUBUNIT
79
80 -- LIBRARY_ITEM ::=
81 -- private LIBRARY_UNIT_DECLARATION
82 -- | LIBRARY_UNIT_BODY
83 -- | [private] LIBRARY_UNIT_RENAMING_DECLARATION
84
85 -- LIBRARY_UNIT_DECLARATION ::=
86 -- SUBPROGRAM_DECLARATION | PACKAGE_DECLARATION
87 -- | GENERIC_DECLARATION | GENERIC_INSTANTIATION
88
89 -- LIBRARY_UNIT_RENAMING_DECLARATION ::=
90 -- PACKAGE_RENAMING_DECLARATION
91 -- | GENERIC_RENAMING_DECLARATION
92 -- | SUBPROGRAM_RENAMING_DECLARATION
93
94 -- LIBRARY_UNIT_BODY ::= SUBPROGRAM_BODY | PACKAGE_BODY
95
96 -- Error recovery: cannot raise Error_Resync. If an error occurs, tokens
97 -- are skipped up to the next possible beginning of a compilation unit.
98
99 -- Note: if only configuration pragmas are found, Empty is returned
100
101 -- Note: in syntax-only mode, it is possible for P_Compilation_Unit
102 -- to return strange things that are not really compilation units.
103 -- This is done to help out gnatchop when it is faced with nonsense.
104
105 function P_Compilation_Unit return Node_Id is
106 Scan_State : Saved_Scan_State;
107 Body_Node : Node_Id;
108 Specification_Node : Node_Id;
109 Unit_Node : Node_Id;
110 Comp_Unit_Node : Node_Id;
111 Name_Node : Node_Id;
112 Item : Node_Id;
113 Private_Sloc : Source_Ptr := No_Location;
114 Config_Pragmas : List_Id;
115 P : Node_Id;
116 SR_Present : Boolean;
117 No_Body : Boolean;
118
119 Cunit_Error_Flag : Boolean := False;
120 -- This flag is set True if we have to scan for a compilation unit
121 -- token. It is used to ensure clean termination in such cases by
122 -- not insisting on being at the end of file, and, in the syntax only
123 -- case by not scanning for additional compilation units.
124
125 Cunit_Location : Source_Ptr;
126 -- Location of unit for unit identification output (List_Unit option)
127
128 begin
129 Num_Library_Units := Num_Library_Units + 1;
130
131 -- Set location of the compilation unit if unit list option set
132 -- and we are in syntax check only mode
133
134 if List_Units and then Operating_Mode = Check_Syntax then
135 Cunit_Location := Set_Location;
136 else
137 Cunit_Location := No_Location;
138 end if;
139
140 -- Deal with initial pragmas
141
142 Config_Pragmas := No_List;
143
144 -- If we have an initial Source_Reference pragma, then remember the fact
145 -- to generate an NR parameter in the output line.
146
147 SR_Present := False;
148
149 -- If we see a pragma No_Body, remember not to complain about no body
150
151 No_Body := False;
152
153 if Token = Tok_Pragma then
154 Save_Scan_State (Scan_State);
155 Item := P_Pragma;
156
157 if Item = Error
158 or else Pragma_Name (Item) /= Name_Source_Reference
159 then
160 Restore_Scan_State (Scan_State);
161
162 else
163 SR_Present := True;
164
165 -- If first unit, record the file name for gnatchop use
166
167 if Operating_Mode = Check_Syntax
168 and then List_Units
169 and then Num_Library_Units = 1
170 then
171 Write_Str ("Source_Reference pragma for file """);
172 Write_Name (Full_Ref_Name (Current_Source_File));
173 Write_Char ('"');
174 Write_Eol;
175 end if;
176
177 Config_Pragmas := New_List (Item);
178 end if;
179 end if;
180
181 -- Scan out any configuration pragmas
182
183 while Token = Tok_Pragma loop
184 Save_Scan_State (Scan_State);
185 Item := P_Pragma;
186
187 if Item /= Error and then Pragma_Name (Item) = Name_No_Body then
188 No_Body := True;
189 end if;
190
191 if Item = Error
192 or else not Is_Configuration_Pragma_Name (Pragma_Name (Item))
193 then
194 Restore_Scan_State (Scan_State);
195 exit;
196 end if;
197
198 if Config_Pragmas = No_List then
199 Config_Pragmas := Empty_List;
200
201 if Operating_Mode = Check_Syntax and then List_Units then
202 Write_Str ("Configuration pragmas at");
203 Unit_Location (Current_Source_File, Cunit_Location);
204 Write_Eol;
205 end if;
206 end if;
207
208 Append (Item, Config_Pragmas);
209 Cunit_Location := Set_Location;
210 end loop;
211
212 -- Establish compilation unit node and scan context items
213
214 Comp_Unit_Node := New_Node (N_Compilation_Unit, No_Location);
215 Set_Cunit (Current_Source_Unit, Comp_Unit_Node);
216 Set_Context_Items (Comp_Unit_Node, P_Context_Clause);
217 Set_Aux_Decls_Node
218 (Comp_Unit_Node, New_Node (N_Compilation_Unit_Aux, No_Location));
219
220 if Present (Config_Pragmas) then
221
222 -- Check for case of only configuration pragmas present
223
224 if Token = Tok_EOF
225 and then Is_Empty_List (Context_Items (Comp_Unit_Node))
226 then
227 if Operating_Mode = Check_Syntax then
228 return Empty;
229
230 else
231 Item := First (Config_Pragmas);
232 Error_Msg_N
233 ("cannot compile configuration pragmas with gcc!", Item);
234 Error_Msg_N
235 ("\use gnatchop -c to process configuration pragmas!", Item);
236 raise Unrecoverable_Error;
237 end if;
238
239 -- Otherwise configuration pragmas are simply prepended to the
240 -- context of the current unit.
241
242 else
243 Append_List (Context_Items (Comp_Unit_Node), Config_Pragmas);
244 Set_Context_Items (Comp_Unit_Node, Config_Pragmas);
245 end if;
246 end if;
247
248 -- Check for PRIVATE. Note that for the moment we allow this in
249 -- Ada_83 mode, since we do not yet know if we are compiling a
250 -- predefined unit, and if we are then it would be allowed anyway.
251
252 if Token = Tok_Private then
253 Private_Sloc := Token_Ptr;
254 Set_Keyword_Casing (Current_Source_File, Determine_Token_Casing);
255
256 if Style_Check then
257 Style.Check_Indentation;
258 end if;
259
260 Save_Scan_State (Scan_State); -- at PRIVATE
261 Scan; -- past PRIVATE
262
263 if Token = Tok_Separate then
264 Error_Msg_SP ("cannot have private subunits!");
265
266 elsif Token = Tok_Package then
267 Scan; -- past PACKAGE
268
269 if Token = Tok_Body then
270 Restore_Scan_State (Scan_State); -- to PRIVATE
271 Error_Msg_SC ("cannot have private package body!");
272 Scan; -- ignore PRIVATE
273
274 else
275 Restore_Scan_State (Scan_State); -- to PRIVATE
276 Scan; -- past PRIVATE
277 Set_Private_Present (Comp_Unit_Node, True);
278 end if;
279
280 elsif Token = Tok_Procedure
281 or else Token = Tok_Function
282 or else Token = Tok_Generic
283 then
284 Set_Private_Present (Comp_Unit_Node, True);
285 end if;
286 end if;
287
288 -- Loop to find our way to a compilation unit token
289
290 loop
291 exit when Token in Token_Class_Cunit and then Token /= Tok_With;
292
293 exit when Bad_Spelling_Of (Tok_Package)
294 or else Bad_Spelling_Of (Tok_Function)
295 or else Bad_Spelling_Of (Tok_Generic)
296 or else Bad_Spelling_Of (Tok_Separate)
297 or else Bad_Spelling_Of (Tok_Procedure);
298
299 -- Allow task and protected for nice error recovery purposes
300
301 exit when Token = Tok_Task
302 or else Token = Tok_Protected;
303
304 if Token = Tok_With then
305 Error_Msg_SC ("misplaced WITH");
306 Append_List (P_Context_Clause, Context_Items (Comp_Unit_Node));
307
308 elsif Bad_Spelling_Of (Tok_With) then
309 Append_List (P_Context_Clause, Context_Items (Comp_Unit_Node));
310
311 else
312 if Operating_Mode = Check_Syntax and then Token = Tok_EOF then
313
314 -- Do not complain if there is a pragma No_Body
315
316 if not No_Body then
317 Error_Msg_SC ("??file contains no compilation units");
318 end if;
319
320 else
321 Error_Msg_SC ("compilation unit expected");
322 Cunit_Error_Flag := True;
323 Resync_Cunit;
324 end if;
325
326 -- If we are at an end of file, then just quit, the above error
327 -- message was complaint enough.
328
329 if Token = Tok_EOF then
330 return Error;
331 end if;
332 end if;
333 end loop;
334
335 -- We have a compilation unit token, so that's a reasonable choice for
336 -- determining the standard casing convention used for keywords in case
337 -- it hasn't already been done on seeing a WITH or PRIVATE.
338
339 Set_Keyword_Casing (Current_Source_File, Determine_Token_Casing);
340
341 if Style_Check then
342 Style.Check_Indentation;
343 end if;
344
345 -- Remaining processing depends on particular type of compilation unit
346
347 if Token = Tok_Package then
348
349 -- A common error is to omit the body keyword after package. We can
350 -- often diagnose this early on (before getting loads of errors from
351 -- contained subprogram bodies), by knowing that the file we
352 -- are compiling has a name that requires a body to be found.
353
354 Save_Scan_State (Scan_State);
355 Scan; -- past Package keyword
356
357 if Token /= Tok_Body
358 and then
359 Get_Expected_Unit_Type
360 (File_Name (Current_Source_File)) = Expect_Body
361 then
362 Error_Msg_BC -- CODEFIX
363 ("keyword BODY expected here '[see file name']");
364 Restore_Scan_State (Scan_State);
365 Set_Unit (Comp_Unit_Node, P_Package (Pf_Pbod_Pexp));
366 else
367 Restore_Scan_State (Scan_State);
368 Set_Unit (Comp_Unit_Node, P_Package (Pf_Decl_Gins_Pbod_Rnam_Pexp));
369 end if;
370
371 elsif Token = Tok_Generic then
372 Set_Unit (Comp_Unit_Node, P_Generic);
373
374 elsif Token = Tok_Separate then
375 Set_Unit (Comp_Unit_Node, P_Subunit);
376
377 elsif Token = Tok_Function
378 or else Token = Tok_Not
379 or else Token = Tok_Overriding
380 or else Token = Tok_Procedure
381 then
382 Set_Unit (Comp_Unit_Node, P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Pexp));
383
384 -- A little bit of an error recovery check here. If we just scanned
385 -- a subprogram declaration (as indicated by an SIS entry being
386 -- active), then if the following token is BEGIN or an identifier,
387 -- or a token which can reasonably start a declaration but cannot
388 -- start a compilation unit, then we assume that the semicolon in
389 -- the declaration should have been IS.
390
391 if SIS_Entry_Active then
392
393 if Token = Tok_Begin
394 or else Token = Tok_Identifier
395 or else Token in Token_Class_Deckn
396 then
397 Push_Scope_Stack;
398 Scope.Table (Scope.Last).Etyp := E_Name;
399 Scope.Table (Scope.Last).Sloc := SIS_Sloc;
400 Scope.Table (Scope.Last).Ecol := SIS_Ecol;
401 Scope.Table (Scope.Last).Lreq := False;
402 SIS_Entry_Active := False;
403
404 -- If we had a missing semicolon in the declaration, then
405 -- change the message to from <missing ";"> to <missing "is">
406
407 if SIS_Missing_Semicolon_Message /= No_Error_Msg then
408 Change_Error_Text -- Replace: "missing "";"" "
409 (SIS_Missing_Semicolon_Message, "missing IS");
410
411 -- Otherwise we saved the semicolon position, so complain
412
413 else
414 Error_Msg -- CODEFIX
415 (""";"" should be IS", SIS_Semicolon_Sloc);
416 end if;
417
418 Body_Node := Unit (Comp_Unit_Node);
419 Specification_Node := Specification (Body_Node);
420 Change_Node (Body_Node, N_Subprogram_Body);
421 Set_Specification (Body_Node, Specification_Node);
422 Parse_Decls_Begin_End (Body_Node);
423 Set_Unit (Comp_Unit_Node, Body_Node);
424 end if;
425
426 -- If we scanned a subprogram body, make sure we did not have private
427
428 elsif Private_Sloc /= No_Location
429 and then
430 Nkind (Unit (Comp_Unit_Node)) not in N_Subprogram_Instantiation
431 and then
432 Nkind (Unit (Comp_Unit_Node)) /= N_Subprogram_Renaming_Declaration
433 then
434 Error_Msg ("cannot have private subprogram body", Private_Sloc);
435
436 -- P_Subprogram can yield an abstract subprogram, but this cannot
437 -- be a compilation unit. Treat as a subprogram declaration.
438
439 elsif
440 Nkind (Unit (Comp_Unit_Node)) = N_Abstract_Subprogram_Declaration
441 then
442 Error_Msg_N
443 ("compilation unit cannot be abstract subprogram",
444 Unit (Comp_Unit_Node));
445
446 Unit_Node :=
447 New_Node (N_Subprogram_Declaration, Sloc (Comp_Unit_Node));
448 Set_Specification (Unit_Node,
449 Specification (Unit (Comp_Unit_Node)));
450 Set_Unit (Comp_Unit_Node, Unit_Node);
451 end if;
452
453 -- Otherwise we have TASK. This is not really an acceptable token,
454 -- but we accept it to improve error recovery.
455
456 elsif Token = Tok_Task then
457 Scan; -- Past TASK
458
459 if Token = Tok_Type then
460 Error_Msg_SP
461 ("task type cannot be used as compilation unit");
462 else
463 Error_Msg_SP
464 ("task declaration cannot be used as compilation unit");
465 end if;
466
467 -- If in check syntax mode, accept the task anyway. This is done
468 -- particularly to improve the behavior of GNATCHOP in this case.
469
470 if Operating_Mode = Check_Syntax then
471 Set_Unit (Comp_Unit_Node, P_Task);
472
473 -- If not in syntax only mode, treat this as horrible error
474
475 else
476 Cunit_Error_Flag := True;
477 return Error;
478 end if;
479
480 else pragma Assert (Token = Tok_Protected);
481 Scan; -- Past PROTECTED
482
483 if Token = Tok_Type then
484 Error_Msg_SP
485 ("protected type cannot be used as compilation unit");
486 else
487 Error_Msg_SP
488 ("protected declaration cannot be used as compilation unit");
489 end if;
490
491 -- If in check syntax mode, accept protected anyway. This is done
492 -- particularly to improve the behavior of GNATCHOP in this case.
493
494 if Operating_Mode = Check_Syntax then
495 Set_Unit (Comp_Unit_Node, P_Protected);
496
497 -- If not in syntax only mode, treat this as horrible error
498
499 else
500 Cunit_Error_Flag := True;
501 return Error;
502 end if;
503 end if;
504
505 -- Here is where locate the compilation unit entity. This is a little
506 -- tricky, since it is buried in various places.
507
508 Unit_Node := Unit (Comp_Unit_Node);
509
510 -- Another error from which it is hard to recover
511
512 if Nkind_In (Unit_Node, N_Subprogram_Body_Stub, N_Package_Body_Stub) then
513 Cunit_Error_Flag := True;
514 return Error;
515 end if;
516
517 -- Only try this if we got an OK unit
518
519 if Unit_Node /= Error then
520 if Nkind (Unit_Node) = N_Subunit then
521 Unit_Node := Proper_Body (Unit_Node);
522 end if;
523
524 if Nkind (Unit_Node) in N_Generic_Declaration then
525 Unit_Node := Specification (Unit_Node);
526 end if;
527
528 if Nkind_In (Unit_Node, N_Package_Declaration,
529 N_Subprogram_Declaration,
530 N_Subprogram_Body,
531 N_Subprogram_Renaming_Declaration)
532 then
533 Unit_Node := Specification (Unit_Node);
534
535 elsif Nkind (Unit_Node) = N_Subprogram_Renaming_Declaration then
536 if Ada_Version = Ada_83 then
537 Error_Msg_N
538 ("(Ada 83) library unit renaming not allowed", Unit_Node);
539 end if;
540 end if;
541
542 if Nkind_In (Unit_Node, N_Task_Body,
543 N_Protected_Body,
544 N_Task_Type_Declaration,
545 N_Protected_Type_Declaration,
546 N_Single_Task_Declaration,
547 N_Single_Protected_Declaration)
548 then
549 Name_Node := Defining_Identifier (Unit_Node);
550
551 elsif Nkind_In (Unit_Node, N_Function_Instantiation,
552 N_Function_Specification,
553 N_Generic_Function_Renaming_Declaration,
554 N_Generic_Package_Renaming_Declaration,
555 N_Generic_Procedure_Renaming_Declaration)
556 or else
557 Nkind_In (Unit_Node, N_Package_Body,
558 N_Package_Instantiation,
559 N_Package_Renaming_Declaration,
560 N_Package_Specification,
561 N_Procedure_Instantiation,
562 N_Procedure_Specification)
563 then
564 Name_Node := Defining_Unit_Name (Unit_Node);
565
566 elsif Nkind (Unit_Node) = N_Expression_Function then
567 Error_Msg_SP
568 ("expression function cannot be used as compilation unit");
569 return Comp_Unit_Node;
570
571 -- Anything else is a serious error, abandon scan
572
573 else
574 raise Error_Resync;
575 end if;
576
577 Set_Sloc (Comp_Unit_Node, Sloc (Name_Node));
578 Set_Sloc (Aux_Decls_Node (Comp_Unit_Node), Sloc (Name_Node));
579
580 -- Set Entity field in file table. Easier now that we have name.
581 -- Note that this is also skipped if we had a bad unit
582
583 if Nkind (Name_Node) = N_Defining_Program_Unit_Name then
584 Set_Cunit_Entity
585 (Current_Source_Unit, Defining_Identifier (Name_Node));
586 else
587 Set_Cunit_Entity (Current_Source_Unit, Name_Node);
588 end if;
589
590 Set_Unit_Name
591 (Current_Source_Unit, Get_Unit_Name (Unit (Comp_Unit_Node)));
592
593 -- If we had a bad unit, make sure the fatal flag is set in the file
594 -- table entry, since this is surely a fatal error and also set our
595 -- flag to inhibit the requirement that we be at end of file.
596
597 else
598 Cunit_Error_Flag := True;
599 Set_Fatal_Error (Current_Source_Unit, Error_Detected);
600 end if;
601
602 -- Clear away any missing semicolon indication, we are done with that
603 -- unit, so what's done is done, and we don't want anything hanging
604 -- around from the attempt to parse it.
605
606 SIS_Entry_Active := False;
607
608 -- Scan out pragmas after unit
609
610 while Token = Tok_Pragma loop
611 Save_Scan_State (Scan_State);
612
613 -- If we are in syntax scan mode allowing multiple units, then start
614 -- the next unit if we encounter a configuration pragma, or a source
615 -- reference pragma. We take care not to actually scan the pragma in
616 -- this case (we don't want it to take effect for the current unit).
617
618 if Operating_Mode = Check_Syntax then
619 Scan; -- past Pragma
620
621 if Token = Tok_Identifier
622 and then
623 (Is_Configuration_Pragma_Name (Token_Name)
624 or else Token_Name = Name_Source_Reference)
625 then
626 Restore_Scan_State (Scan_State); -- to Pragma
627 exit;
628 end if;
629 end if;
630
631 -- Otherwise eat the pragma, it definitely belongs with the
632 -- current unit, and not with the following unit.
633
634 Restore_Scan_State (Scan_State); -- to Pragma
635 P := P_Pragma;
636
637 if No (Pragmas_After (Aux_Decls_Node (Comp_Unit_Node))) then
638 Set_Pragmas_After
639 (Aux_Decls_Node (Comp_Unit_Node), New_List);
640 end if;
641
642 Append (P, Pragmas_After (Aux_Decls_Node (Comp_Unit_Node)));
643 end loop;
644
645 -- Cancel effect of any outstanding pragma Warnings (Off)
646
647 Set_Warnings_Mode_On (Scan_Ptr);
648
649 -- Ada 83 error checks
650
651 if Ada_Version = Ada_83 then
652
653 -- Check we did not with any child units
654
655 Item := First (Context_Items (Comp_Unit_Node));
656 while Present (Item) loop
657 if Nkind (Item) = N_With_Clause
658 and then Nkind (Name (Item)) /= N_Identifier
659 then
660 Error_Msg_N ("(Ada 83) child units not allowed", Item);
661 end if;
662
663 Next (Item);
664 end loop;
665
666 -- Check that we did not have a PRIVATE keyword present
667
668 if Private_Present (Comp_Unit_Node) then
669 Error_Msg
670 ("(Ada 83) private units not allowed", Private_Sloc);
671 end if;
672 end if;
673
674 -- If no serious error, then output possible unit information line
675 -- for gnatchop if we are in syntax only, list units mode.
676
677 if not Cunit_Error_Flag
678 and then List_Units
679 and then Operating_Mode = Check_Syntax
680 then
681 Unit_Display (Comp_Unit_Node, Cunit_Location, SR_Present);
682 end if;
683
684 -- And now we should be at the end of file
685
686 if Token /= Tok_EOF then
687
688 -- If we already had to scan for a compilation unit, then don't
689 -- give any further error message, since it just seems to make
690 -- things worse, and we already gave a serious error message.
691
692 if Cunit_Error_Flag then
693 null;
694
695 -- If we are in check syntax mode, then we allow multiple units
696 -- so we just return with Token not set to Tok_EOF and no message.
697
698 elsif Operating_Mode = Check_Syntax then
699 return Comp_Unit_Node;
700
701 -- We also allow multiple units if we are in multiple unit mode
702
703 elsif Multiple_Unit_Index /= 0 then
704
705 -- Skip tokens to end of file, so that the -gnatl listing
706 -- will be complete in this situation, but no need to parse
707 -- the remaining units; no style checking either.
708
709 declare
710 Save_Style_Check : constant Boolean := Style_Check;
711
712 begin
713 Style_Check := False;
714
715 while Token /= Tok_EOF loop
716 Scan;
717 end loop;
718
719 Style_Check := Save_Style_Check;
720 end;
721
722 return Comp_Unit_Node;
723
724 -- Otherwise we have an error. We suppress the error message
725 -- if we already had a fatal error, since this stops junk
726 -- cascaded messages in some situations.
727
728 else
729 if Fatal_Error (Current_Source_Unit) /= Error_Detected then
730 if Token in Token_Class_Cunit then
731 Error_Msg_SC
732 ("end of file expected, " &
733 "file can have only one compilation unit");
734 else
735 Error_Msg_SC ("end of file expected");
736 end if;
737 end if;
738 end if;
739
740 -- Skip tokens to end of file, so that the -gnatl listing
741 -- will be complete in this situation, but no error checking
742 -- other than that provided at the token level.
743
744 while Token /= Tok_EOF loop
745 Scan;
746 end loop;
747
748 return Error;
749
750 -- Normal return (we were at the end of file as expected)
751
752 else
753 return Comp_Unit_Node;
754 end if;
755
756 exception
757
758 -- An error resync is a serious bomb, so indicate result unit no good
759
760 when Error_Resync =>
761 Set_Fatal_Error (Current_Source_Unit, Error_Detected);
762 return Error;
763 end P_Compilation_Unit;
764
765 --------------------------
766 -- 10.1.1 Library Item --
767 --------------------------
768
769 -- Parsed by P_Compilation_Unit (10.1.1)
770
771 --------------------------------------
772 -- 10.1.1 Library Unit Declaration --
773 --------------------------------------
774
775 -- Parsed by P_Compilation_Unit (10.1.1)
776
777 ------------------------------------------------
778 -- 10.1.1 Library Unit Renaming Declaration --
779 ------------------------------------------------
780
781 -- Parsed by P_Compilation_Unit (10.1.1)
782
783 -------------------------------
784 -- 10.1.1 Library Unit Body --
785 -------------------------------
786
787 -- Parsed by P_Compilation_Unit (10.1.1)
788
789 ------------------------------
790 -- 10.1.1 Parent Unit Name --
791 ------------------------------
792
793 -- Parsed (as a name) by its parent construct
794
795 ----------------------------
796 -- 10.1.2 Context Clause --
797 ----------------------------
798
799 -- CONTEXT_CLAUSE ::= {CONTEXT_ITEM}
800
801 -- CONTEXT_ITEM ::= WITH_CLAUSE | USE_CLAUSE | WITH_TYPE_CLAUSE
802
803 -- WITH_CLAUSE ::=
804 -- [LIMITED] [PRIVATE] with library_unit_NAME {,library_unit_NAME};
805 -- Note: the two qualifiers are Ada 2005 extensions.
806
807 -- WITH_TYPE_CLAUSE ::=
808 -- with type type_NAME is access; | with type type_NAME is tagged;
809 -- Note: this form is obsolete (old GNAT extension).
810
811 -- Error recovery: Cannot raise Error_Resync
812
813 function P_Context_Clause return List_Id is
814 Item_List : List_Id;
815 Has_Limited : Boolean := False;
816 Has_Private : Boolean := False;
817 Scan_State : Saved_Scan_State;
818 With_Node : Node_Id;
819 First_Flag : Boolean;
820
821 begin
822 Item_List := New_List;
823
824 -- Get keyword casing from WITH keyword in case not set yet
825
826 if Token = Tok_With then
827 Set_Keyword_Casing (Current_Source_File, Determine_Token_Casing);
828 end if;
829
830 -- Loop through context items
831
832 loop
833 if Style_Check then
834 Style.Check_Indentation;
835 end if;
836
837 -- Gather any pragmas appearing in the context clause
838
839 P_Pragmas_Opt (Item_List);
840
841 -- Processing for WITH clause
842
843 -- Ada 2005 (AI-50217, AI-262): First check for LIMITED WITH,
844 -- PRIVATE WITH, or both.
845
846 if Token = Tok_Limited then
847 Has_Limited := True;
848 Has_Private := False;
849 Scan; -- past LIMITED
850
851 -- In the context, LIMITED can only appear in a with_clause
852
853 if Token = Tok_Private then
854 Has_Private := True;
855 Scan; -- past PRIVATE
856 end if;
857
858 if Token /= Tok_With then
859 Error_Msg_SC -- CODEFIX
860 ("unexpected LIMITED ignored");
861 end if;
862
863 if Ada_Version < Ada_2005 then
864 Error_Msg_SP ("LIMITED WITH is an Ada 2005 extension");
865 Error_Msg_SP
866 ("\unit must be compiled with -gnat05 switch");
867 end if;
868
869 elsif Token = Tok_Private then
870 Has_Limited := False;
871 Has_Private := True;
872 Save_Scan_State (Scan_State);
873 Scan; -- past PRIVATE
874
875 if Token /= Tok_With then
876
877 -- Keyword is beginning of private child unit
878
879 Restore_Scan_State (Scan_State); -- to PRIVATE
880 return Item_List;
881
882 elsif Ada_Version < Ada_2005 then
883 Error_Msg_SP ("`PRIVATE WITH` is an Ada 2005 extension");
884 Error_Msg_SP
885 ("\unit must be compiled with -gnat05 switch");
886 end if;
887
888 else
889 Has_Limited := False;
890 Has_Private := False;
891 end if;
892
893 if Token = Tok_With then
894 Scan; -- past WITH
895
896 if Token = Tok_Type then
897
898 -- WITH TYPE is an obsolete GNAT specific extension
899
900 Error_Msg_SP ("`WITH TYPE` is an obsolete 'G'N'A'T extension");
901 Error_Msg_SP ("\use Ada 2005 `LIMITED WITH` clause instead");
902
903 Scan; -- past TYPE
904
905 T_Is;
906
907 if Token = Tok_Tagged then
908 Scan;
909
910 elsif Token = Tok_Access then
911 Scan;
912
913 else
914 Error_Msg_SC ("expect tagged or access qualifier");
915 end if;
916
917 TF_Semicolon;
918
919 else
920 First_Flag := True;
921
922 -- Loop through names in one with clause, generating a separate
923 -- N_With_Clause node for each name encountered.
924
925 loop
926 With_Node := New_Node (N_With_Clause, Token_Ptr);
927 Append (With_Node, Item_List);
928
929 -- Note that we allow with'ing of child units, even in
930 -- Ada 83 mode, since presumably if this is not desired,
931 -- then the compilation of the child unit itself is the
932 -- place where such an "error" should be caught.
933
934 Set_Name (With_Node, P_Qualified_Simple_Name);
935 if Name (With_Node) = Error then
936 Remove (With_Node);
937 end if;
938
939 Set_First_Name (With_Node, First_Flag);
940 Set_Limited_Present (With_Node, Has_Limited);
941 Set_Private_Present (With_Node, Has_Private);
942 First_Flag := False;
943
944 -- All done if no comma
945
946 exit when Token /= Tok_Comma;
947
948 -- If comma is followed by compilation unit token
949 -- or by USE, or PRAGMA, then it should have been a
950 -- semicolon after all
951
952 Save_Scan_State (Scan_State);
953 Scan; -- past comma
954
955 if Token in Token_Class_Cunit
956 or else Token = Tok_Use
957 or else Token = Tok_Pragma
958 then
959 Restore_Scan_State (Scan_State);
960 exit;
961 end if;
962 end loop;
963
964 Set_Last_Name (With_Node, True);
965 TF_Semicolon;
966 end if;
967
968 -- Processing for USE clause
969
970 elsif Token = Tok_Use then
971 Append (P_Use_Clause, Item_List);
972
973 -- Anything else is end of context clause
974
975 else
976 exit;
977 end if;
978 end loop;
979
980 return Item_List;
981 end P_Context_Clause;
982
983 --------------------------
984 -- 10.1.2 Context Item --
985 --------------------------
986
987 -- Parsed by P_Context_Clause (10.1.2)
988
989 -------------------------
990 -- 10.1.2 With Clause --
991 -------------------------
992
993 -- Parsed by P_Context_Clause (10.1.2)
994
995 -----------------------
996 -- 10.1.3 Body Stub --
997 -----------------------
998
999 -- Subprogram stub parsed by P_Subprogram (6.1)
1000 -- Package stub parsed by P_Package (7.1)
1001 -- Task stub parsed by P_Task (9.1)
1002 -- Protected stub parsed by P_Protected (9.4)
1003
1004 ----------------------------------
1005 -- 10.1.3 Subprogram Body Stub --
1006 ----------------------------------
1007
1008 -- Parsed by P_Subprogram (6.1)
1009
1010 -------------------------------
1011 -- 10.1.3 Package Body Stub --
1012 -------------------------------
1013
1014 -- Parsed by P_Package (7.1)
1015
1016 ----------------------------
1017 -- 10.1.3 Task Body Stub --
1018 ----------------------------
1019
1020 -- Parsed by P_Task (9.1)
1021
1022 ---------------------------------
1023 -- 10.1.3 Protected Body Stub --
1024 ---------------------------------
1025
1026 -- Parsed by P_Protected (9.4)
1027
1028 ---------------------
1029 -- 10.1.3 Subunit --
1030 ---------------------
1031
1032 -- SUBUNIT ::= separate (PARENT_UNIT_NAME) PROPER_BODY
1033
1034 -- PARENT_UNIT_NAME ::= NAME
1035
1036 -- The caller has checked that the initial token is SEPARATE
1037
1038 -- Error recovery: cannot raise Error_Resync
1039
1040 function P_Subunit return Node_Id is
1041 Subunit_Node : Node_Id;
1042 Body_Node : Node_Id;
1043
1044 begin
1045 Subunit_Node := New_Node (N_Subunit, Token_Ptr);
1046 Body_Node := Error; -- in case no good body found
1047 Scan; -- past SEPARATE;
1048
1049 U_Left_Paren;
1050 Set_Name (Subunit_Node, P_Qualified_Simple_Name);
1051 U_Right_Paren;
1052
1053 Ignore (Tok_Semicolon);
1054
1055 if Token = Tok_Function
1056 or else Token = Tok_Not
1057 or else Token = Tok_Overriding
1058 or else Token = Tok_Procedure
1059 then
1060 Body_Node := P_Subprogram (Pf_Pbod_Pexp);
1061
1062 elsif Token = Tok_Package then
1063 Body_Node := P_Package (Pf_Pbod_Pexp);
1064
1065 elsif Token = Tok_Protected then
1066 Scan; -- past PROTECTED
1067
1068 if Token = Tok_Body then
1069 Body_Node := P_Protected;
1070 else
1071 Error_Msg_AP ("BODY expected");
1072 return Error;
1073 end if;
1074
1075 elsif Token = Tok_Task then
1076 Scan; -- past TASK
1077
1078 if Token = Tok_Body then
1079 Body_Node := P_Task;
1080 else
1081 Error_Msg_AP ("BODY expected");
1082 return Error;
1083 end if;
1084
1085 else
1086 Error_Msg_SC ("proper body expected");
1087 return Error;
1088 end if;
1089
1090 Set_Proper_Body (Subunit_Node, Body_Node);
1091 return Subunit_Node;
1092 end P_Subunit;
1093
1094 ------------------
1095 -- Set_Location --
1096 ------------------
1097
1098 function Set_Location return Source_Ptr is
1099 Physical : Boolean;
1100 Loc : Source_Ptr;
1101 Scan_State : Saved_Scan_State;
1102
1103 begin
1104 -- A special check. If the first token is pragma, and this is a
1105 -- Source_Reference pragma, then do NOT eat previous comments, since
1106 -- the Source_Reference pragma is required to be the first line in
1107 -- the source file.
1108
1109 if Token = Tok_Pragma then
1110 Save_Scan_State (Scan_State);
1111 Scan; -- past Pragma
1112
1113 if Token = Tok_Identifier
1114 and then Token_Name = Name_Source_Reference
1115 then
1116 Restore_Scan_State (Scan_State);
1117 return Token_Ptr;
1118 end if;
1119
1120 Restore_Scan_State (Scan_State);
1121 end if;
1122
1123 -- Otherwise acquire previous comments and blank lines
1124
1125 if Prev_Token = No_Token then
1126 return Source_First (Current_Source_File);
1127
1128 else
1129 Loc := Prev_Token_Ptr;
1130 loop
1131 exit when Loc = Token_Ptr;
1132
1133 -- Should we worry about UTF_32 line terminators here
1134
1135 if Source (Loc) in Line_Terminator then
1136 Skip_Line_Terminators (Loc, Physical);
1137 exit when Physical;
1138 end if;
1139
1140 Loc := Loc + 1;
1141 end loop;
1142
1143 return Loc;
1144 end if;
1145 end Set_Location;
1146
1147 ------------------
1148 -- Unit_Display --
1149 ------------------
1150
1151 -- The format of the generated line, as expected by GNATCHOP is
1152
1153 -- Unit {unit} line {line}, file offset {offs} [, SR], file name {file}
1154
1155 -- where
1156
1157 -- {unit} unit name with terminating (spec) or (body)
1158 -- {line} starting line number
1159 -- {offs} offset to start of text in file
1160 -- {file} source file name
1161
1162 -- The SR parameter is present only if a source reference pragma was
1163 -- scanned for this unit. The significance is that gnatchop should not
1164 -- attempt to add another one.
1165
1166 procedure Unit_Display
1167 (Cunit : Node_Id;
1168 Loc : Source_Ptr;
1169 SR_Present : Boolean)
1170 is
1171 Unum : constant Unit_Number_Type := Get_Cunit_Unit_Number (Cunit);
1172 Sind : constant Source_File_Index := Source_Index (Unum);
1173 Unam : constant Unit_Name_Type := Unit_Name (Unum);
1174
1175 begin
1176 if List_Units then
1177 Write_Str ("Unit ");
1178 Write_Unit_Name (Unit_Name (Unum));
1179 Unit_Location (Sind, Loc);
1180
1181 if SR_Present then
1182 Write_Str (", SR");
1183 end if;
1184
1185 Write_Str (", file name ");
1186 Write_Name (Get_File_Name (Unam, Nkind (Unit (Cunit)) = N_Subunit));
1187 Write_Eol;
1188 end if;
1189 end Unit_Display;
1190
1191 -------------------
1192 -- Unit_Location --
1193 -------------------
1194
1195 procedure Unit_Location (Sind : Source_File_Index; Loc : Source_Ptr) is
1196 Line : constant Logical_Line_Number := Get_Logical_Line_Number (Loc);
1197 -- Should the above be the physical line number ???
1198
1199 begin
1200 Write_Str (" line ");
1201 Write_Int (Int (Line));
1202
1203 Write_Str (", file offset ");
1204 Write_Int (Int (Loc) - Int (Source_First (Sind)));
1205 end Unit_Location;
1206
1207 end Ch10;