Subversion Repositories openrisc

------------------------------------------------------------------------------

--                                                                          --

--                         GNAT COMPILER COMPONENTS                         --

--                                                                          --

--                             P A R . C H 1 0                              --

--                                                                          --

--                                 B o d y                                  --

--                                                                          --

--          Copyright (C) 1992-2009, Free Software Foundation, Inc.         --

--                                                                          --

-- GNAT is free software;  you can  redistribute it  and/or modify it under --

-- terms of the  GNU General Public License as published  by the Free Soft- --

-- ware  Foundation;  either version 3,  or (at your option) any later ver- --

-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --

-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --

-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --

-- for  more details.  You should have  received  a copy of the GNU General --

-- Public License  distributed with GNAT; see file COPYING3.  If not, go to --

-- http://www.gnu.org/licenses for a complete copy of the license.          --

--                                                                          --

-- GNAT was originally developed  by the GNAT team at  New York University. --

-- Extensive contributions were provided by Ada Core Technologies Inc.      --

--                                                                          --

------------------------------------------------------------------------------

pragma Style_Checks (All_Checks);

--  Turn off subprogram body ordering check. Subprograms are in order

--  by RM section rather than alphabetical

with Fname.UF; use Fname.UF;

with Uname;    use Uname;

separate (Par)

package body Ch10 is

   --  Local functions, used only in this chapter

   function P_Context_Clause    return List_Id;

   function P_Subunit           return Node_Id;

   function Set_Location return Source_Ptr;

   --  The current compilation unit starts with Token at Token_Ptr. This

   --  function determines the corresponding source location for the start

   --  of the unit, including any preceding comment lines.

   procedure Unit_Display

     (Cunit      : Node_Id;

      Loc        : Source_Ptr;

      SR_Present : Boolean);

   --  This procedure is used to generate a line of output for a unit in

   --  the source program. Cunit is the node for the compilation unit, and

   --  Loc is the source location for the start of the unit in the source

   --  file (which is not necessarily the Sloc of the Cunit node). This

   --  output is written to the standard output file for use by gnatchop.

   procedure Unit_Location (Sind : Source_File_Index; Loc : Source_Ptr);

   --  This routine has the same calling sequence as Unit_Display, but

   --  it outputs only the line number and offset of the location, Loc,

   --  using Cunit to obtain the proper source file index.

   -------------------------

   -- 10.1.1  Compilation --

   -------------------------

   --  COMPILATION ::= {COMPILATION_UNIT}

   --  There is no specific parsing routine for a compilation, since we only

   --  permit a single compilation in a source file, so there is no explicit

   --  occurrence of compilations as such (our representation of a compilation

   --  is a series of separate source files).

   ------------------------------

   -- 10.1.1  Compilation unit --

   ------------------------------

   --  COMPILATION_UNIT ::=

   --    CONTEXT_CLAUSE LIBRARY_ITEM

   --  | CONTEXT_CLAUSE SUBUNIT

   --  LIBRARY_ITEM ::=

   --    private LIBRARY_UNIT_DECLARATION

   --  | LIBRARY_UNIT_BODY

   --  | [private] LIBRARY_UNIT_RENAMING_DECLARATION

   --  LIBRARY_UNIT_DECLARATION ::=

   --    SUBPROGRAM_DECLARATION | PACKAGE_DECLARATION

   --  | GENERIC_DECLARATION    | GENERIC_INSTANTIATION

   --  LIBRARY_UNIT_RENAMING_DECLARATION ::=

   --    PACKAGE_RENAMING_DECLARATION

   --  | GENERIC_RENAMING_DECLARATION

   --  | SUBPROGRAM_RENAMING_DECLARATION

   --  LIBRARY_UNIT_BODY ::= SUBPROGRAM_BODY | PACKAGE_BODY

   --  Error recovery: cannot raise Error_Resync. If an error occurs, tokens

   --  are skipped up to the next possible beginning of a compilation unit.

   --  Note: if only configuration pragmas are found, Empty is returned

   --  Note: in syntax-only mode, it is possible for P_Compilation_Unit

   --  to return strange things that are not really compilation units.

   --  This is done to help out gnatchop when it is faced with nonsense.

   function P_Compilation_Unit return Node_Id is

      Scan_State         : Saved_Scan_State;

      Body_Node          : Node_Id;

      Specification_Node : Node_Id;

      Unit_Node          : Node_Id;

      Comp_Unit_Node     : Node_Id;

      Name_Node          : Node_Id;

      Item               : Node_Id;

      Private_Sloc       : Source_Ptr := No_Location;

      Config_Pragmas     : List_Id;

      P                  : Node_Id;

      SR_Present         : Boolean;

      Cunit_Error_Flag : Boolean := False;

      --  This flag is set True if we have to scan for a compilation unit

      --  token. It is used to ensure clean termination in such cases by

      --  not insisting on being at the end of file, and, in the syntax only

      --  case by not scanning for additional compilation units.

      Cunit_Location : Source_Ptr;

      --  Location of unit for unit identification output (List_Unit option)

   begin

      Num_Library_Units := Num_Library_Units + 1;

      --  Set location of the compilation unit if unit list option set

      --  and we are in syntax check only mode

      if List_Units and then Operating_Mode = Check_Syntax then

         Cunit_Location := Set_Location;

      else

         Cunit_Location := No_Location;

      end if;

      --  Deal with initial pragmas

      Config_Pragmas := No_List;

      --  If we have an initial Source_Reference pragma, then remember the fact

      --  to generate an NR parameter in the output line.

      SR_Present := False;

      if Token = Tok_Pragma then

         Save_Scan_State (Scan_State);

         Item := P_Pragma;

         if Item = Error

           or else Pragma_Name (Item) /= Name_Source_Reference

         then

            Restore_Scan_State (Scan_State);

         else

            SR_Present := True;

            --  If first unit, record the file name for gnatchop use

            if Operating_Mode = Check_Syntax

              and then List_Units

              and then Num_Library_Units = 1

            then

               Write_Str ("Source_Reference pragma for file """);

               Write_Name (Full_Ref_Name (Current_Source_File));

               Write_Char ('"');

               Write_Eol;

            end if;

            Config_Pragmas := New_List (Item);

         end if;

      end if;

      --  Scan out any configuration pragmas

      while Token = Tok_Pragma loop

         Save_Scan_State (Scan_State);

         Item := P_Pragma;

         if Item = Error

           or else not Is_Configuration_Pragma_Name (Pragma_Name (Item))

         then

            Restore_Scan_State (Scan_State);

            exit;

         end if;

         if Config_Pragmas = No_List then

            Config_Pragmas := Empty_List;

            if Operating_Mode = Check_Syntax and then List_Units then

               Write_Str ("Configuration pragmas at");

               Unit_Location (Current_Source_File, Cunit_Location);

               Write_Eol;

            end if;

         end if;

         Append (Item, Config_Pragmas);

         Cunit_Location := Set_Location;

      end loop;

      --  Establish compilation unit node and scan context items

      Comp_Unit_Node := New_Node (N_Compilation_Unit, No_Location);

      Set_Cunit (Current_Source_Unit, Comp_Unit_Node);

      Set_Context_Items (Comp_Unit_Node, P_Context_Clause);

      Set_Aux_Decls_Node

        (Comp_Unit_Node, New_Node (N_Compilation_Unit_Aux, No_Location));

      if Present (Config_Pragmas) then

         --  Check for case of only configuration pragmas present

         if Token = Tok_EOF

           and then Is_Empty_List (Context_Items (Comp_Unit_Node))

         then

            if Operating_Mode = Check_Syntax then

               return Empty;

            else

               Item := First (Config_Pragmas);

               Error_Msg_N

                 ("cannot compile configuration pragmas with gcc!", Item);

               Error_Msg_N

                 ("\use gnatchop -c to process configuration pragmas!", Item);

               raise Unrecoverable_Error;

            end if;

         --  Otherwise configuration pragmas are simply prepended to the

         --  context of the current unit.

         else

            Append_List (Context_Items (Comp_Unit_Node), Config_Pragmas);

            Set_Context_Items (Comp_Unit_Node, Config_Pragmas);

         end if;

      end if;

      --  Check for PRIVATE. Note that for the moment we allow this in

      --  Ada_83 mode, since we do not yet know if we are compiling a

      --  predefined unit, and if we are then it would be allowed anyway.

      if Token = Tok_Private then

         Private_Sloc := Token_Ptr;

         Set_Keyword_Casing (Current_Source_File, Determine_Token_Casing);

         if Style_Check then

            Style.Check_Indentation;

         end if;

         Save_Scan_State (Scan_State); -- at PRIVATE

         Scan; -- past PRIVATE

         if Token = Tok_Separate then

            Error_Msg_SP ("cannot have private subunits!");

         elsif Token = Tok_Package then

            Scan; -- past PACKAGE

            if Token = Tok_Body then

               Restore_Scan_State (Scan_State); -- to PRIVATE

               Error_Msg_SC ("cannot have private package body!");

               Scan; -- ignore PRIVATE

            else

               Restore_Scan_State (Scan_State); -- to PRIVATE

               Scan; -- past PRIVATE

               Set_Private_Present (Comp_Unit_Node, True);

            end if;

         elsif Token = Tok_Procedure

           or else Token = Tok_Function

           or else Token = Tok_Generic

         then

            Set_Private_Present (Comp_Unit_Node, True);

         end if;

      end if;

      --  Loop to find our way to a compilation unit token

      loop

         exit when Token in Token_Class_Cunit and then Token /= Tok_With;

         exit when Bad_Spelling_Of (Tok_Package)

           or else Bad_Spelling_Of (Tok_Function)

           or else Bad_Spelling_Of (Tok_Generic)

           or else Bad_Spelling_Of (Tok_Separate)

           or else Bad_Spelling_Of (Tok_Procedure);

         --  Allow task and protected for nice error recovery purposes

         exit when Token = Tok_Task

           or else Token = Tok_Protected;

         if Token = Tok_With then

            Error_Msg_SC ("misplaced WITH");

            Append_List (P_Context_Clause, Context_Items (Comp_Unit_Node));

         elsif Bad_Spelling_Of (Tok_With) then

            Append_List (P_Context_Clause, Context_Items (Comp_Unit_Node));

         else

            if Operating_Mode = Check_Syntax and then Token = Tok_EOF then

               Error_Msg_SC ("?file contains no compilation units");

            else

               Error_Msg_SC ("compilation unit expected");

               Cunit_Error_Flag := True;

               Resync_Cunit;

            end if;

            --  If we are at an end of file, then just quit, the above error

            --  message was complaint enough.

            if Token = Tok_EOF then

               return Error;

            end if;

         end if;

      end loop;

      --  We have a compilation unit token, so that's a reasonable choice for

      --  determining the standard casing convention used for keywords in case

      --  it hasn't already been done on seeing a WITH or PRIVATE.

      Set_Keyword_Casing (Current_Source_File, Determine_Token_Casing);

      if Style_Check then

         Style.Check_Indentation;

      end if;

      --  Remaining processing depends on particular type of compilation unit

      if Token = Tok_Package then

         --  A common error is to omit the body keyword after package. We can

         --  often diagnose this early on (before getting loads of errors from

         --  contained subprogram bodies), by knowing that the file we

         --  are compiling has a name that requires a body to be found.

         Save_Scan_State (Scan_State);

         Scan; -- past Package keyword

         if Token /= Tok_Body

           and then

             Get_Expected_Unit_Type

               (File_Name (Current_Source_File)) = Expect_Body

         then

            Error_Msg_BC ("keyword BODY expected here [see file name]");

            Restore_Scan_State (Scan_State);

            Set_Unit (Comp_Unit_Node, P_Package (Pf_Pbod));

         else

            Restore_Scan_State (Scan_State);

            Set_Unit (Comp_Unit_Node, P_Package (Pf_Decl_Gins_Pbod_Rnam));

         end if;

      elsif Token = Tok_Generic then

         Set_Unit (Comp_Unit_Node, P_Generic);

      elsif Token = Tok_Separate then

         Set_Unit (Comp_Unit_Node, P_Subunit);

      elsif Token = Tok_Function

        or else Token = Tok_Not

        or else Token = Tok_Overriding

        or else Token = Tok_Procedure

      then

         Set_Unit (Comp_Unit_Node, P_Subprogram (Pf_Decl_Gins_Pbod_Rnam));

         --  A little bit of an error recovery check here. If we just scanned

         --  a subprogram declaration (as indicated by an SIS entry being

         --  active), then if the following token is BEGIN or an identifier,

         --  or a token which can reasonably start a declaration but cannot

         --  start a compilation unit, then we assume that the semicolon in

         --  the declaration should have been IS.

         if SIS_Entry_Active then

            if Token = Tok_Begin

               or else Token = Tok_Identifier

               or else Token in Token_Class_Deckn

            then

               Push_Scope_Stack;

               Scope.Table (Scope.Last).Etyp := E_Name;

               Scope.Table (Scope.Last).Sloc := SIS_Sloc;

               Scope.Table (Scope.Last).Ecol := SIS_Ecol;

               Scope.Table (Scope.Last).Lreq := False;

               SIS_Entry_Active := False;

               --  If we had a missing semicolon in the declaration, then

               --  change the message to from <missing ";"> to <missing "is">

               if SIS_Missing_Semicolon_Message /= No_Error_Msg then

                  Change_Error_Text     -- Replace: "missing "";"" "

                    (SIS_Missing_Semicolon_Message, "missing IS");

               --  Otherwise we saved the semicolon position, so complain

               else

                  Error_Msg (""";"" should be IS", SIS_Semicolon_Sloc);

               end if;

               Body_Node := Unit (Comp_Unit_Node);

               Specification_Node := Specification (Body_Node);

               Change_Node (Body_Node, N_Subprogram_Body);

               Set_Specification (Body_Node, Specification_Node);

               Parse_Decls_Begin_End (Body_Node);

               Set_Unit (Comp_Unit_Node, Body_Node);

            end if;

         --  If we scanned a subprogram body, make sure we did not have private

         elsif Private_Sloc /= No_Location

           and then

             Nkind (Unit (Comp_Unit_Node)) not in N_Subprogram_Instantiation

           and then

             Nkind (Unit (Comp_Unit_Node)) /= N_Subprogram_Renaming_Declaration

         then

            Error_Msg ("cannot have private subprogram body", Private_Sloc);

         --  P_Subprogram can yield an abstract subprogram, but this cannot

         --  be a compilation unit. Treat as a subprogram declaration.

         elsif

           Nkind (Unit (Comp_Unit_Node)) = N_Abstract_Subprogram_Declaration

         then

            Error_Msg_N

              ("compilation unit cannot be abstract subprogram",

                 Unit (Comp_Unit_Node));

            Unit_Node :=

              New_Node (N_Subprogram_Declaration, Sloc (Comp_Unit_Node));

            Set_Specification (Unit_Node,

              Specification (Unit (Comp_Unit_Node)));

            Set_Unit (Comp_Unit_Node, Unit_Node);

         end if;

      --  Otherwise we have TASK. This is not really an acceptable token,

      --  but we accept it to improve error recovery.

      elsif Token = Tok_Task then

         Scan; -- Past TASK

         if Token = Tok_Type then

            Error_Msg_SP

              ("task type cannot be used as compilation unit");

         else

            Error_Msg_SP

              ("task declaration cannot be used as compilation unit");

         end if;

         --  If in check syntax mode, accept the task anyway. This is done

         --  particularly to improve the behavior of GNATCHOP in this case.

         if Operating_Mode = Check_Syntax then

            Set_Unit (Comp_Unit_Node, P_Task);

         --  If not in syntax only mode, treat this as horrible error

         else

            Cunit_Error_Flag := True;

            return Error;

         end if;

      else pragma Assert (Token = Tok_Protected);

         Scan; -- Past PROTECTED

         if Token = Tok_Type then

            Error_Msg_SP

              ("protected type cannot be used as compilation unit");

         else

            Error_Msg_SP

              ("protected declaration cannot be used as compilation unit");

         end if;

         --  If in check syntax mode, accept protected anyway. This is done

         --  particularly to improve the behavior of GNATCHOP in this case.

         if Operating_Mode = Check_Syntax then

            Set_Unit (Comp_Unit_Node, P_Protected);

         --  If not in syntax only mode, treat this as horrible error

         else

            Cunit_Error_Flag := True;

            return Error;

         end if;

      end if;

      --  Here is where locate the compilation unit entity. This is a little

      --  tricky, since it is buried in various places.

      Unit_Node := Unit (Comp_Unit_Node);

      --  Another error from which it is hard to recover

      if Nkind (Unit_Node) = N_Subprogram_Body_Stub

        or else Nkind (Unit_Node) = N_Package_Body_Stub

      then

         Cunit_Error_Flag := True;

         return Error;

      end if;

      --  Only try this if we got an OK unit!

      if Unit_Node /= Error then

         if Nkind (Unit_Node) = N_Subunit then

            Unit_Node := Proper_Body (Unit_Node);

         end if;

         if Nkind (Unit_Node) in N_Generic_Declaration then

            Unit_Node := Specification (Unit_Node);

         end if;

         if Nkind (Unit_Node) = N_Package_Declaration

           or else Nkind (Unit_Node) = N_Subprogram_Declaration

           or else Nkind (Unit_Node) = N_Subprogram_Body

           or else Nkind (Unit_Node) = N_Subprogram_Renaming_Declaration

         then

            Unit_Node := Specification (Unit_Node);

         elsif Nkind (Unit_Node) = N_Subprogram_Renaming_Declaration then

            if Ada_Version = Ada_83 then

               Error_Msg_N

                 ("(Ada 83) library unit renaming not allowed", Unit_Node);

            end if;

         end if;

         if Nkind (Unit_Node) = N_Task_Body

           or else Nkind (Unit_Node) = N_Protected_Body

           or else Nkind (Unit_Node) = N_Task_Type_Declaration

           or else Nkind (Unit_Node) = N_Protected_Type_Declaration

           or else Nkind (Unit_Node) = N_Single_Task_Declaration

           or else Nkind (Unit_Node) = N_Single_Protected_Declaration

         then

            Name_Node := Defining_Identifier (Unit_Node);

         elsif Nkind (Unit_Node) = N_Function_Instantiation

           or else Nkind (Unit_Node) = N_Function_Specification

           or else Nkind (Unit_Node) = N_Generic_Function_Renaming_Declaration

           or else Nkind (Unit_Node) = N_Generic_Package_Renaming_Declaration

           or else Nkind (Unit_Node) = N_Generic_Procedure_Renaming_Declaration

           or else Nkind (Unit_Node) = N_Package_Body

           or else Nkind (Unit_Node) = N_Package_Instantiation

           or else Nkind (Unit_Node) = N_Package_Renaming_Declaration

           or else Nkind (Unit_Node) = N_Package_Specification

           or else Nkind (Unit_Node) = N_Procedure_Instantiation

           or else Nkind (Unit_Node) = N_Procedure_Specification

         then

            Name_Node := Defining_Unit_Name (Unit_Node);

         --  Anything else is a serious error, abandon scan

         else

            raise Error_Resync;

         end if;

         Set_Sloc (Comp_Unit_Node, Sloc (Name_Node));

         Set_Sloc (Aux_Decls_Node (Comp_Unit_Node), Sloc (Name_Node));

         --  Set Entity field in file table. Easier now that we have name!

         --  Note that this is also skipped if we had a bad unit

         if Nkind (Name_Node) = N_Defining_Program_Unit_Name then

            Set_Cunit_Entity

              (Current_Source_Unit, Defining_Identifier (Name_Node));

         else

            Set_Cunit_Entity (Current_Source_Unit, Name_Node);

         end if;

         Set_Unit_Name

           (Current_Source_Unit, Get_Unit_Name (Unit (Comp_Unit_Node)));

      --  If we had a bad unit, make sure the fatal flag is set in the file

      --  table entry, since this is surely a fatal error and also set our

      --  flag to inhibit the requirement that we be at end of file.

      else

         Cunit_Error_Flag := True;

         Set_Fatal_Error (Current_Source_Unit);

      end if;

      --  Clear away any missing semicolon indication, we are done with that

      --  unit, so what's done is done, and we don't want anything hanging

      --  around from the attempt to parse it!

      SIS_Entry_Active := False;

      --  Scan out pragmas after unit

      while Token = Tok_Pragma loop

         Save_Scan_State (Scan_State);

         --  If we are in syntax scan mode allowing multiple units, then start

         --  the next unit if we encounter a configuration pragma, or a source

         --  reference pragma. We take care not to actually scan the pragma in

         --  this case (we don't want it to take effect for the current unit).

         if Operating_Mode = Check_Syntax then

            Scan;  -- past Pragma

            if Token = Tok_Identifier

              and then

                (Is_Configuration_Pragma_Name (Token_Name)

                   or else Token_Name = Name_Source_Reference)

            then

               Restore_Scan_State (Scan_State); -- to Pragma

               exit;

            end if;

         end if;

         --  Otherwise eat the pragma, it definitely belongs with the

         --  current unit, and not with the following unit.

         Restore_Scan_State (Scan_State); -- to Pragma

         P := P_Pragma;

         if No (Pragmas_After (Aux_Decls_Node (Comp_Unit_Node))) then

            Set_Pragmas_After

              (Aux_Decls_Node (Comp_Unit_Node), New_List);

         end if;

         Append (P, Pragmas_After (Aux_Decls_Node (Comp_Unit_Node)));

      end loop;

      --  Cancel effect of any outstanding pragma Warnings (Off)

      Set_Warnings_Mode_On (Scan_Ptr);

      --  Ada 83 error checks

      if Ada_Version = Ada_83 then

         --  Check we did not with any child units

         Item := First (Context_Items (Comp_Unit_Node));

         while Present (Item) loop

            if Nkind (Item) = N_With_Clause

              and then Nkind (Name (Item)) /= N_Identifier

            then

               Error_Msg_N ("(Ada 83) child units not allowed", Item);

            end if;

            Next (Item);

         end loop;

         --  Check that we did not have a PRIVATE keyword present

         if Private_Present (Comp_Unit_Node) then

            Error_Msg

              ("(Ada 83) private units not allowed", Private_Sloc);

         end if;

      end if;

      --  If no serious error, then output possible unit information line

      --  for gnatchop if we are in syntax only, list units mode.

      if not Cunit_Error_Flag

        and then List_Units

        and then Operating_Mode = Check_Syntax

      then

         Unit_Display (Comp_Unit_Node, Cunit_Location, SR_Present);

      end if;

      --  And now we should be at the end of file

      if Token /= Tok_EOF then

         --  If we already had to scan for a compilation unit, then don't

         --  give any further error message, since it just seems to make

         --  things worse, and we already gave a serious error message.

         if Cunit_Error_Flag then

            null;

         --  If we are in check syntax mode, then we allow multiple units

         --  so we just return with Token not set to Tok_EOF and no message.

         elsif Operating_Mode = Check_Syntax then

            return Comp_Unit_Node;

         --  We also allow multiple units if we are in multiple unit mode

         elsif Multiple_Unit_Index /= 0 then

            --  Skip tokens to end of file, so that the -gnatl listing

            --  will be complete in this situation, but no need to parse

            --  the remaining units; no style checking either.

            declare

               Save_Style_Check : constant Boolean := Style_Check;

            begin

               Style_Check := False;

               while Token /= Tok_EOF loop

                  Scan;

               end loop;

               Style_Check := Save_Style_Check;

            end;

            return Comp_Unit_Node;

         --  Otherwise we have an error. We suppress the error message

         --  if we already had a fatal error, since this stops junk

         --  cascaded messages in some situations.

         else

            if not Fatal_Error (Current_Source_Unit) then

               if Token in Token_Class_Cunit then

                  Error_Msg_SC

                    ("end of file expected, " &

                     "file can have only one compilation unit");

               else

                  Error_Msg_SC ("end of file expected");

               end if;

            end if;

         end if;

         --  Skip tokens to end of file, so that the -gnatl listing

         --  will be complete in this situation, but no error checking

         --  other than that provided at the token level.

         while Token /= Tok_EOF loop

            Scan;

         end loop;

         return Error;

      --  Normal return (we were at the end of file as expected)

      else

         return Comp_Unit_Node;

      end if;

   exception

      --  An error resync is a serious bomb, so indicate result unit no good

      when Error_Resync =>

         Set_Fatal_Error (Current_Source_Unit);

         return Error;

   end P_Compilation_Unit;

   --------------------------

   -- 10.1.1  Library Item --

   --------------------------

   --  Parsed by P_Compilation_Unit (10.1.1)

   --------------------------------------

   -- 10.1.1  Library Unit Declaration --

   --------------------------------------

   --  Parsed by P_Compilation_Unit (10.1.1)

   ------------------------------------------------

   -- 10.1.1  Library Unit Renaming Declaration  --

   ------------------------------------------------

   --  Parsed by P_Compilation_Unit (10.1.1)

   -------------------------------

   -- 10.1.1  Library Unit Body --

   -------------------------------

   --  Parsed by P_Compilation_Unit (10.1.1)

   ------------------------------

   -- 10.1.1  Parent Unit Name --

   ------------------------------

   --  Parsed (as a name) by its parent construct

   ----------------------------

   -- 10.1.2  Context Clause --

   ----------------------------

   --  CONTEXT_CLAUSE ::= {CONTEXT_ITEM}

   --  CONTEXT_ITEM ::= WITH_CLAUSE | USE_CLAUSE | WITH_TYPE_CLAUSE

   --  WITH_CLAUSE ::=

   --  [LIMITED] [PRIVATE]  with library_unit_NAME {,library_unit_NAME};

   --  Note: the two qualifiers are Ada 2005 extensions.

   --  WITH_TYPE_CLAUSE ::=

   --    with type type_NAME is access; | with type type_NAME is tagged;

   --  Note: this form is obsolete (old GNAT extension).

   --  Error recovery: Cannot raise Error_Resync

   function P_Context_Clause return List_Id is

      Item_List   : List_Id;

      Has_Limited : Boolean := False;

      Has_Private : Boolean := False;

      Scan_State  : Saved_Scan_State;

      With_Node   : Node_Id;

      First_Flag  : Boolean;

   begin

      Item_List := New_List;

      --  Get keyword casing from WITH keyword in case not set yet

      if Token = Tok_With then

         Set_Keyword_Casing (Current_Source_File, Determine_Token_Casing);

      end if;

      --  Loop through context items

      loop

         if Style_Check then

            Style.Check_Indentation;

         end if;

         --  Gather any pragmas appearing in the context clause

         P_Pragmas_Opt (Item_List);

         --  Processing for WITH clause

         --  Ada 2005 (AI-50217, AI-262): First check for LIMITED WITH,

         --  PRIVATE WITH, or both.

         if Token = Tok_Limited then

            Has_Limited := True;

            Has_Private := False;

            Scan; -- past LIMITED

            --  In the context, LIMITED can only appear in a with_clause

            if Token = Tok_Private then

               Has_Private := True;

               Scan;  -- past PRIVATE

            end if;

            if Token /= Tok_With then

               Error_Msg_SC ("unexpected LIMITED ignored");

            end if;

            if Ada_Version < Ada_05 then

               Error_Msg_SP ("LIMITED WITH is an Ada 2005 extension");

               Error_Msg_SP

                 ("\unit must be compiled with -gnat05 switch");

            end if;

         elsif Token = Tok_Private then

            Has_Limited := False;

            Has_Private := True;

            Save_Scan_State (Scan_State);

            Scan;  -- past PRIVATE

            if Token /= Tok_With then

               --  Keyword is beginning of private child unit

               Restore_Scan_State (Scan_State); -- to PRIVATE

               return Item_List;

            elsif Ada_Version < Ada_05 then

               Error_Msg_SP ("`PRIVATE WITH` is an Ada 2005 extension");

               Error_Msg_SP

                 ("\unit must be compiled with -gnat05 switch");

            end if;

         else

            Has_Limited := False;

            Has_Private := False;

         end if;

         if Token = Tok_With then

            Scan; -- past WITH

            if Token = Tok_Type then

               --  WITH TYPE is an obsolete GNAT specific extension

               Error_Msg_SP

                 ("`WITH TYPE` is an obsolete 'G'N'A'T extension");

               Error_Msg_SP ("\use Ada 2005 `LIMITED WITH` clause instead");

               Scan;  -- past TYPE

               T_Is;

               if Token = Tok_Tagged then

                  Scan;

               elsif Token = Tok_Access then

                  Scan;

               else

                  Error_Msg_SC ("expect tagged or access qualifier");

               end if;

               TF_Semicolon;

            else

               First_Flag := True;

               --  Loop through names in one with clause, generating a separate

               --  N_With_Clause node for each name encountered.