gcc/ada/par-ch7.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                              P A R . C H 7                               --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2023, 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 separate (Par)
  31 package body Ch7 is
  32
  33    ---------------------------------------------
  34    -- 7.1  Package (also 8.5.3, 10.1.3, 12.3) --
  35    ---------------------------------------------
  36
  37    --  This routine scans out a package declaration, package body, or a
  38    --  renaming declaration or generic instantiation starting with PACKAGE
  39
  40    --  PACKAGE_DECLARATION ::=
  41    --    PACKAGE_SPECIFICATION;
  42
  43    --  PACKAGE_SPECIFICATION ::=
  44    --    package DEFINING_PROGRAM_UNIT_NAME
  45    --      [ASPECT_SPECIFICATIONS]
  46    --    is
  47    --      {BASIC_DECLARATIVE_ITEM}
  48    --    [private
  49    --      {BASIC_DECLARATIVE_ITEM}]
  50    --    end [[PARENT_UNIT_NAME .] IDENTIFIER]
  51
  52    --  PACKAGE_BODY ::=
  53    --    package body DEFINING_PROGRAM_UNIT_NAME
  54    --      [ASPECT_SPECIFICATIONS]
  55    --    is
  56    --      DECLARATIVE_PART
  57    --    [begin
  58    --      HANDLED_SEQUENCE_OF_STATEMENTS]
  59    --    end [[PARENT_UNIT_NAME .] IDENTIFIER]
  60
  61    --  PACKAGE_RENAMING_DECLARATION ::=
  62    --    package DEFINING_IDENTIFIER renames package_NAME
  63    --      [ASPECT_SPECIFICATIONS];
  64
  65    --  PACKAGE_BODY_STUB ::=
  66    --    package body DEFINING_IDENTIFIER is separate
  67    --      [ASPECT_SPECIFICATIONS];
  68
  69    --  PACKAGE_INSTANTIATION ::=
  70    --    package DEFINING_PROGRAM_UNIT_NAME is
  71    --      new generic_package_NAME [GENERIC_ACTUAL_PART]
  72    --        [ASPECT_SPECIFICATIONS];
  73
  74    --  Note: in all contexts where a package specification is required, there
  75    --  is a terminating semicolon. This semicolon is scanned out in the case
  76    --  where Pf_Flags is set to Pf_Spcn, even though it is not strictly part
  77    --  of the package specification (it's just too much trouble, and really
  78    --  quite unnecessary, to deal with scanning out an END where the semicolon
  79    --  after the END is not considered to be part of the END.
  80
  81    --  The caller has checked that the initial token is PACKAGE
  82
  83    --  Error recovery: cannot raise Error_Resync
  84
  85    function P_Package (Pf_Flags : Pf_Rec) return Node_Id is
  86       Package_Node       : Node_Id;
  87       Specification_Node : Node_Id;
  88       Name_Node          : Node_Id;
  89       Package_Sloc       : Source_Ptr;
  90
  91       Aspect_Sloc : Source_Ptr := No_Location;
  92       --  Save location of WITH for scanned aspects. Left set to No_Location
  93       --  if no aspects scanned before the IS keyword.
  94
  95       Is_Sloc : Source_Ptr;
  96       --  Save location of IS token for package declaration
  97
  98       Dummy_Node : constant Node_Id :=
  99                      New_Node (N_Package_Specification, Token_Ptr);
 100       --  Dummy node to attach aspect specifications to until we properly
 101       --  figure out where they eventually belong.
 102
 103    begin
 104       Push_Scope_Stack;
 105       Scopes (Scope.Last).Etyp := E_Name;
 106       Scopes (Scope.Last).Ecol := Start_Column;
 107       Scopes (Scope.Last).Lreq := False;
 108
 109       Package_Sloc := Token_Ptr;
 110       Scan; -- past PACKAGE
 111
 112       if Token = Tok_Type then
 113          Error_Msg_SC -- CODEFIX
 114            ("TYPE not allowed here");
 115          Scan; -- past TYPE
 116       end if;
 117
 118       --  Case of package body. Note that we demand a package body if that
 119       --  is the only possibility (even if the BODY keyword is not present)
 120
 121       if Token = Tok_Body or else Pf_Flags = Pf_Pbod_Pexp then
 122          if not Pf_Flags.Pbod then
 123             Error_Msg_SC ("package body cannot appear here!");
 124          end if;
 125
 126          T_Body;
 127          Scopes (Scope.Last).Sloc := Token_Ptr;
 128          Name_Node := P_Defining_Program_Unit_Name;
 129          Scopes (Scope.Last).Labl := Name_Node;
 130          Current_Node := Name_Node;
 131
 132          if Aspect_Specifications_Present then
 133             Aspect_Sloc := Token_Ptr;
 134             P_Aspect_Specifications (Dummy_Node, Semicolon => False);
 135          end if;
 136
 137          TF_Is;
 138
 139          if Separate_Present then
 140             if not Pf_Flags.Stub then
 141                Error_Msg_SC ("body stub cannot appear here!");
 142             end if;
 143
 144             Scan; -- past SEPARATE
 145
 146             Package_Node := New_Node (N_Package_Body_Stub, Package_Sloc);
 147             Set_Defining_Identifier (Package_Node, Name_Node);
 148
 149             if Has_Aspects (Dummy_Node) then
 150                Error_Msg
 151                  ("aspect specifications must come after SEPARATE",
 152                   Aspect_Sloc);
 153             end if;
 154
 155             P_Aspect_Specifications (Package_Node, Semicolon => False);
 156             TF_Semicolon;
 157             Pop_Scope_Stack;
 158
 159          else
 160             Package_Node := New_Node (N_Package_Body, Package_Sloc);
 161             Set_Defining_Unit_Name (Package_Node, Name_Node);
 162
 163             --  Move the aspect specifications to the body node
 164
 165             if Has_Aspects (Dummy_Node) then
 166                Move_Aspects (From => Dummy_Node, To => Package_Node);
 167             end if;
 168
 169             Parse_Decls_Begin_End (Package_Node);
 170          end if;
 171
 172       --  Cases other than Package_Body
 173
 174       else
 175          Scopes (Scope.Last).Sloc := Token_Ptr;
 176          Name_Node := P_Defining_Program_Unit_Name;
 177          Scopes (Scope.Last).Labl := Name_Node;
 178          Current_Node := Name_Node;
 179
 180          --  Case of renaming declaration
 181
 182          Check_Misspelling_Of (Tok_Renames);
 183
 184          if Token = Tok_Renames then
 185             if not Pf_Flags.Rnam then
 186                Error_Msg_SC ("renaming declaration cannot appear here!");
 187             end if;
 188
 189             Scan; -- past RENAMES;
 190
 191             Package_Node :=
 192               New_Node (N_Package_Renaming_Declaration, Package_Sloc);
 193             Set_Defining_Unit_Name (Package_Node, Name_Node);
 194             Set_Name (Package_Node, P_Qualified_Simple_Name);
 195
 196             No_Constraint;
 197             P_Aspect_Specifications (Package_Node, Semicolon => False);
 198             TF_Semicolon;
 199             Pop_Scope_Stack;
 200
 201          --  Generic package instantiation or package declaration
 202
 203          else
 204             if Aspect_Specifications_Present then
 205                Aspect_Sloc := Token_Ptr;
 206                P_Aspect_Specifications (Dummy_Node, Semicolon => False);
 207             end if;
 208
 209             Is_Sloc := Token_Ptr;
 210             TF_Is;
 211
 212             --  Case of generic instantiation
 213
 214             if Token = Tok_New then
 215                if not Pf_Flags.Gins then
 216                   Error_Msg_SC
 217                      ("generic instantiation cannot appear here!");
 218                end if;
 219
 220                if Aspect_Sloc /= No_Location then
 221                   Error_Msg
 222                     ("misplaced aspects for package instantiation",
 223                      Aspect_Sloc);
 224                end if;
 225
 226                Scan; -- past NEW
 227
 228                Package_Node :=
 229                  New_Node (N_Package_Instantiation, Package_Sloc);
 230                Set_Defining_Unit_Name (Package_Node, Name_Node);
 231                Set_Name (Package_Node, P_Qualified_Simple_Name);
 232                Set_Generic_Associations
 233                  (Package_Node, P_Generic_Actual_Part_Opt);
 234
 235                if Aspect_Sloc /= No_Location
 236                  and then not Aspect_Specifications_Present
 237                then
 238                   Error_Msg_SC ("info: aspect specifications belong here??");
 239                   Move_Aspects (From => Dummy_Node, To => Package_Node);
 240                end if;
 241
 242                P_Aspect_Specifications (Package_Node);
 243                Pop_Scope_Stack;
 244
 245             --  Case of package declaration or package specification
 246
 247             else
 248                Specification_Node :=
 249                  New_Node (N_Package_Specification, Package_Sloc);
 250
 251                Set_Defining_Unit_Name (Specification_Node, Name_Node);
 252                Set_Visible_Declarations
 253                  (Specification_Node,
 254                   P_Basic_Declarative_Items (Declare_Expression => False));
 255
 256                if Token = Tok_Private then
 257                   Error_Msg_Col := Scopes (Scope.Last).Ecol;
 258
 259                   if RM_Column_Check then
 260                      if Token_Is_At_Start_Of_Line
 261                        and then Start_Column /= Error_Msg_Col
 262                      then
 263                         Error_Msg_SC
 264                           ("(style) PRIVATE in wrong column, should be@");
 265                      end if;
 266                   end if;
 267
 268                   Scan; -- past PRIVATE
 269
 270                   Set_Private_Declarations
 271                     (Specification_Node,
 272                      P_Basic_Declarative_Items (Declare_Expression => False));
 273
 274                   --  Deal gracefully with multiple PRIVATE parts
 275
 276                   while Token = Tok_Private loop
 277                      Error_Msg_SC
 278                        ("only one private part allowed per package");
 279                      Scan; -- past PRIVATE
 280                      Append_List
 281                        (P_Basic_Declarative_Items
 282                           (Declare_Expression => False),
 283                         Private_Declarations (Specification_Node));
 284                   end loop;
 285                end if;
 286
 287                if Pf_Flags = Pf_Spcn then
 288                   Package_Node := Specification_Node;
 289                else
 290                   Package_Node :=
 291                     New_Node (N_Package_Declaration, Package_Sloc);
 292                   Set_Specification (Package_Node, Specification_Node);
 293                end if;
 294
 295                if Token = Tok_Begin then
 296                   Error_Msg_SC ("begin block not allowed in package spec");
 297                   Scan; -- past BEGIN
 298                   Discard_Junk_List (P_Sequence_Of_Statements (SS_None));
 299                end if;
 300
 301                End_Statements (Specification_Node, Empty, Is_Sloc);
 302                Move_Aspects (From => Dummy_Node, To => Package_Node);
 303             end if;
 304          end if;
 305       end if;
 306
 307       return Package_Node;
 308    end P_Package;
 309
 310    ------------------------------
 311    -- 7.1  Package Declaration --
 312    ------------------------------
 313
 314    --  Parsed by P_Package (7.1)
 315
 316    --------------------------------
 317    -- 7.1  Package Specification --
 318    --------------------------------
 319
 320    --  Parsed by P_Package (7.1)
 321
 322    -----------------------
 323    -- 7.1  Package Body --
 324    -----------------------
 325
 326    --  Parsed by P_Package (7.1)
 327
 328    -----------------------------------
 329    -- 7.3  Private Type Declaration --
 330    -----------------------------------
 331
 332    --  Parsed by P_Type_Declaration (3.2.1)
 333
 334    ----------------------------------------
 335    -- 7.3  Private Extension Declaration --
 336    ----------------------------------------
 337
 338    --  Parsed by P_Type_Declaration (3.2.1)
 339
 340 end Ch7;