path: root/gcc/ada/par-ch7.adb

------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                              P A R . C H 7                               --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--          Copyright (C) 1992-2011, 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

separate (Par)
package body Ch7 is

   ---------------------------------------------
   -- 7.1  Package (also 8.5.3, 10.1.3, 12.3) --
   ---------------------------------------------

   --  This routine scans out a package declaration, package body, or a
   --  renaming declaration or generic instantiation starting with PACKAGE

   --  PACKAGE_DECLARATION ::=
   --    PACKAGE_SPECIFICATION
   --      [ASPECT_SPECIFICATIONS];

   --  PACKAGE_SPECIFICATION ::=
   --    package DEFINING_PROGRAM_UNIT_NAME is
   --      {BASIC_DECLARATIVE_ITEM}
   --    [private
   --      {BASIC_DECLARATIVE_ITEM}]
   --    end [[PARENT_UNIT_NAME .] IDENTIFIER]

   --  PACKAGE_BODY ::=
   --    package body DEFINING_PROGRAM_UNIT_NAME is
   --      DECLARATIVE_PART
   --    [begin
   --      HANDLED_SEQUENCE_OF_STATEMENTS]
   --    end [[PARENT_UNIT_NAME .] IDENTIFIER]

   --  PACKAGE_RENAMING_DECLARATION ::=
   --    package DEFINING_IDENTIFIER renames package_NAME;

   --  PACKAGE_BODY_STUB ::=
   --    package body DEFINING_IDENTIFIER is separate;

   --  PACKAGE_INSTANTIATION ::=
   --    package DEFINING_PROGRAM_UNIT_NAME is
   --      new generic_package_NAME [GENERIC_ACTUAL_PART]
   --        [ASPECT_SPECIFICATIONS];

   --  The value in Pf_Flags indicates which of these possible declarations
   --  is acceptable to the caller:

   --    Pf_Flags.Spcn                 Set if specification OK
   --    Pf_Flags.Decl                 Set if declaration OK
   --    Pf_Flags.Gins                 Set if generic instantiation OK
   --    Pf_Flags.Pbod                 Set if proper body OK
   --    Pf_Flags.Rnam                 Set if renaming declaration OK
   --    Pf_Flags.Stub                 Set if body stub OK

   --  If an inappropriate form is encountered, it is scanned out but an error
   --  message indicating that it is appearing in an inappropriate context is
   --  issued. The only possible settings for Pf_Flags are those defined as
   --  constants in package Par.

   --  Note: in all contexts where a package specification is required, there
   --  is a terminating semicolon. This semicolon is scanned out in the case
   --  where Pf_Flags is set to Pf_Spcn, even though it is not strictly part
   --  of the package specification (it's just too much trouble, and really
   --  quite unnecessary, to deal with scanning out an END where the semicolon
   --  after the END is not considered to be part of the END.

   --  The caller has checked that the initial token is PACKAGE

   --  Error recovery: cannot raise Error_Resync

   function P_Package (Pf_Flags : Pf_Rec) return Node_Id is
      Package_Node       : Node_Id;
      Specification_Node : Node_Id;
      Name_Node          : Node_Id;
      Package_Sloc       : Source_Ptr;

      Aspect_Sloc : Source_Ptr := No_Location;
      --  Save location of WITH for scanned aspects. Left set to No_Location
      --  if no aspects scanned before the IS keyword.

      Is_Sloc : Source_Ptr;
      --  Save location of IS token for package declaration

      Dummy_Node : constant Node_Id :=
                     New_Node (N_Package_Specification, Token_Ptr);
      --  Dummy node to attach aspect specifications to until we properly
      --  figure out where they eventually belong.

      Body_Is_Hidden_In_SPARK         : Boolean;
      Private_Part_Is_Hidden_In_SPARK : Boolean;
      Hidden_Region_Start             : Source_Ptr;

   begin
      Push_Scope_Stack;
      Scope.Table (Scope.Last).Etyp := E_Name;
      Scope.Table (Scope.Last).Ecol := Start_Column;
      Scope.Table (Scope.Last).Lreq := False;

      Package_Sloc := Token_Ptr;
      Scan; -- past PACKAGE

      if Token = Tok_Type then
         Error_Msg_SC -- CODEFIX
           ("TYPE not allowed here");
         Scan; -- past TYPE
      end if;

      --  Case of package body. Note that we demand a package body if that
      --  is the only possibility (even if the BODY keyword is not present)

      if Token = Tok_Body or else Pf_Flags = Pf_Pbod_Pexp then
         if not Pf_Flags.Pbod then
            Error_Msg_SC ("package body cannot appear here!");
         end if;

         T_Body;
         Name_Node := P_Defining_Program_Unit_Name;
         Scope.Table (Scope.Last).Labl := Name_Node;
         TF_Is;

         if Separate_Present then
            if not Pf_Flags.Stub then
               Error_Msg_SC ("body stub cannot appear here!");
            end if;

            Scan; -- past SEPARATE
            TF_Semicolon;
            Pop_Scope_Stack;

            Package_Node := New_Node (N_Package_Body_Stub, Package_Sloc);
            Set_Defining_Identifier (Package_Node, Name_Node);

         else
            Package_Node := New_Node (N_Package_Body, Package_Sloc);
            Set_Defining_Unit_Name (Package_Node, Name_Node);

            --  In SPARK, a HIDE directive can be placed at the beginning of a
            --  package implementation, thus hiding the package body from SPARK
            --  tool-set. No violation of the SPARK restriction should be
            --  issued on nodes in a hidden part, which is obtained by marking
            --  such hidden parts.

            if Token = Tok_SPARK_Hide then
               Body_Is_Hidden_In_SPARK := True;
               Hidden_Region_Start     := Token_Ptr;
               Scan; -- past HIDE directive
            else
               Body_Is_Hidden_In_SPARK := False;
            end if;

            Parse_Decls_Begin_End (Package_Node);

            if Body_Is_Hidden_In_SPARK then
               Set_Hidden_Part_In_SPARK (Hidden_Region_Start, Token_Ptr);
            end if;
         end if;

      --  Cases other than Package_Body

      else
         Name_Node := P_Defining_Program_Unit_Name;
         Scope.Table (Scope.Last).Labl := Name_Node;

         --  Case of renaming declaration

         Check_Misspelling_Of (Tok_Renames);

         if Token = Tok_Renames then
            if not Pf_Flags.Rnam then
               Error_Msg_SC ("renaming declaration cannot appear here!");
            end if;

            Scan; -- past RENAMES;

            Package_Node :=
              New_Node (N_Package_Renaming_Declaration, Package_Sloc);
            Set_Defining_Unit_Name (Package_Node, Name_Node);
            Set_Name (Package_Node, P_Qualified_Simple_Name);

            No_Constraint;
            TF_Semicolon;
            Pop_Scope_Stack;

         --  Generic package instantiation or package declaration

         else
            if Aspect_Specifications_Present then
               Aspect_Sloc := Token_Ptr;
               P_Aspect_Specifications (Dummy_Node, Semicolon => False);
            end if;

            Is_Sloc := Token_Ptr;
            TF_Is;

            --  Case of generic instantiation

            if Token = Tok_New then
               if not Pf_Flags.Gins then
                  Error_Msg_SC
                     ("generic instantiation cannot appear here!");
               end if;

               if Aspect_Sloc /= No_Location then
                  Error_Msg
                    ("misplaced aspects for package instantiation",
                     Aspect_Sloc);
               end if;

               Scan; -- past NEW

               Package_Node :=
                 New_Node (N_Package_Instantiation, Package_Sloc);
               Set_Defining_Unit_Name (Package_Node, Name_Node);
               Set_Name (Package_Node, P_Qualified_Simple_Name);
               Set_Generic_Associations
                 (Package_Node, P_Generic_Actual_Part_Opt);

               if Aspect_Sloc /= No_Location
                 and then not Aspect_Specifications_Present
               then
                  Error_Msg_SC ("\info: aspect specifications belong here");
                  Move_Aspects (From => Dummy_Node, To => Package_Node);
               end if;

               P_Aspect_Specifications (Package_Node);
               Pop_Scope_Stack;

            --  Case of package declaration or package specification

            else
               Specification_Node :=
                 New_Node (N_Package_Specification, Package_Sloc);

               Set_Defining_Unit_Name (Specification_Node, Name_Node);
               Set_Visible_Declarations
                 (Specification_Node, P_Basic_Declarative_Items);

               if Token = Tok_Private then
                  Error_Msg_Col := Scope.Table (Scope.Last).Ecol;

                  if RM_Column_Check then
                     if Token_Is_At_Start_Of_Line
                       and then Start_Column /= Error_Msg_Col
                     then
                        Error_Msg_SC
                          ("(style) PRIVATE in wrong column, should be@");
                     end if;
                  end if;

                  Scan; -- past PRIVATE

                  if Token = Tok_SPARK_Hide then
                     Private_Part_Is_Hidden_In_SPARK := True;
                     Hidden_Region_Start             := Token_Ptr;
                     Scan; -- past HIDE directive
                  else
                     Private_Part_Is_Hidden_In_SPARK := False;
                  end if;

                  Set_Private_Declarations
                    (Specification_Node, P_Basic_Declarative_Items);

                  --  In SPARK, a HIDE directive can be placed at the beginning
                  --  of a private part, thus hiding all declarations in the
                  --  private part from SPARK tool-set. No violation of the
                  --  SPARK restriction should be issued on nodes in a hidden
                  --  part, which is obtained by marking such hidden parts.

                  if Private_Part_Is_Hidden_In_SPARK then
                     Set_Hidden_Part_In_SPARK (Hidden_Region_Start, Token_Ptr);
                  end if;

                  --  Deal gracefully with multiple PRIVATE parts

                  while Token = Tok_Private loop
                     Error_Msg_SC
                       ("only one private part allowed per package");
                     Scan; -- past PRIVATE
                     Append_List (P_Basic_Declarative_Items,
                       Private_Declarations (Specification_Node));
                  end loop;
               end if;

               if Pf_Flags = Pf_Spcn then
                  Package_Node := Specification_Node;
               else
                  Package_Node :=
                    New_Node (N_Package_Declaration, Package_Sloc);
                  Set_Specification (Package_Node, Specification_Node);
               end if;

               if Token = Tok_Begin then
                  Error_Msg_SC ("begin block not allowed in package spec");
                  Scan; -- past BEGIN
                  Discard_Junk_List (P_Sequence_Of_Statements (SS_None));
               end if;

               End_Statements (Specification_Node, Empty, Is_Sloc);
               Move_Aspects (From => Dummy_Node, To => Package_Node);
            end if;
         end if;
      end if;

      return Package_Node;
   end P_Package;

   ------------------------------
   -- 7.1  Package Declaration --
   ------------------------------

   --  Parsed by P_Package (7.1)

   --------------------------------
   -- 7.1  Package Specification --
   --------------------------------

   --  Parsed by P_Package (7.1)

   -----------------------
   -- 7.1  Package Body --
   -----------------------

   --  Parsed by P_Package (7.1)

   -----------------------------------
   -- 7.3  Private Type Declaration --
   -----------------------------------

   --  Parsed by P_Type_Declaration (3.2.1)

   ----------------------------------------
   -- 7.3  Private Extension Declaration --
   ----------------------------------------

   --  Parsed by P_Type_Declaration (3.2.1)

end Ch7;