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