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-2019, 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 30separate (Par) 31package 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 -- The value in Pf_Flags indicates which of these possible declarations 75 -- is acceptable to the caller: 76 77 -- Pf_Flags.Spcn Set if specification OK 78 -- Pf_Flags.Decl Set if declaration OK 79 -- Pf_Flags.Gins Set if generic instantiation OK 80 -- Pf_Flags.Pbod Set if proper body OK 81 -- Pf_Flags.Rnam Set if renaming declaration OK 82 -- Pf_Flags.Stub Set if body stub OK 83 84 -- If an inappropriate form is encountered, it is scanned out but an error 85 -- message indicating that it is appearing in an inappropriate context is 86 -- issued. The only possible settings for Pf_Flags are those defined as 87 -- constants in package Par. 88 89 -- Note: in all contexts where a package specification is required, there 90 -- is a terminating semicolon. This semicolon is scanned out in the case 91 -- where Pf_Flags is set to Pf_Spcn, even though it is not strictly part 92 -- of the package specification (it's just too much trouble, and really 93 -- quite unnecessary, to deal with scanning out an END where the semicolon 94 -- after the END is not considered to be part of the END. 95 96 -- The caller has checked that the initial token is PACKAGE 97 98 -- Error recovery: cannot raise Error_Resync 99 100 function P_Package (Pf_Flags : Pf_Rec) return Node_Id is 101 Package_Node : Node_Id; 102 Specification_Node : Node_Id; 103 Name_Node : Node_Id; 104 Package_Sloc : Source_Ptr; 105 106 Aspect_Sloc : Source_Ptr := No_Location; 107 -- Save location of WITH for scanned aspects. Left set to No_Location 108 -- if no aspects scanned before the IS keyword. 109 110 Is_Sloc : Source_Ptr; 111 -- Save location of IS token for package declaration 112 113 Dummy_Node : constant Node_Id := 114 New_Node (N_Package_Specification, Token_Ptr); 115 -- Dummy node to attach aspect specifications to until we properly 116 -- figure out where they eventually belong. 117 118 Body_Is_Hidden_In_SPARK : Boolean; 119 Private_Part_Is_Hidden_In_SPARK : Boolean; 120 Hidden_Region_Start : Source_Ptr; 121 122 begin 123 Push_Scope_Stack; 124 Scope.Table (Scope.Last).Etyp := E_Name; 125 Scope.Table (Scope.Last).Ecol := Start_Column; 126 Scope.Table (Scope.Last).Lreq := False; 127 128 Package_Sloc := Token_Ptr; 129 Scan; -- past PACKAGE 130 131 if Token = Tok_Type then 132 Error_Msg_SC -- CODEFIX 133 ("TYPE not allowed here"); 134 Scan; -- past TYPE 135 end if; 136 137 -- Case of package body. Note that we demand a package body if that 138 -- is the only possibility (even if the BODY keyword is not present) 139 140 if Token = Tok_Body or else Pf_Flags = Pf_Pbod_Pexp then 141 if not Pf_Flags.Pbod then 142 Error_Msg_SC ("package body cannot appear here!"); 143 end if; 144 145 T_Body; 146 Scope.Table (Scope.Last).Sloc := Token_Ptr; 147 Name_Node := P_Defining_Program_Unit_Name; 148 Scope.Table (Scope.Last).Labl := Name_Node; 149 Current_Node := Name_Node; 150 151 if Aspect_Specifications_Present then 152 Aspect_Sloc := Token_Ptr; 153 P_Aspect_Specifications (Dummy_Node, Semicolon => False); 154 end if; 155 156 TF_Is; 157 158 if Separate_Present then 159 if not Pf_Flags.Stub then 160 Error_Msg_SC ("body stub cannot appear here!"); 161 end if; 162 163 Scan; -- past SEPARATE 164 165 Package_Node := New_Node (N_Package_Body_Stub, Package_Sloc); 166 Set_Defining_Identifier (Package_Node, Name_Node); 167 168 if Has_Aspects (Dummy_Node) then 169 Error_Msg 170 ("aspect specifications must come after SEPARATE", 171 Aspect_Sloc); 172 end if; 173 174 P_Aspect_Specifications (Package_Node, Semicolon => False); 175 TF_Semicolon; 176 Pop_Scope_Stack; 177 178 else 179 Package_Node := New_Node (N_Package_Body, Package_Sloc); 180 Set_Defining_Unit_Name (Package_Node, Name_Node); 181 182 -- Move the aspect specifications to the body node 183 184 if Has_Aspects (Dummy_Node) then 185 Move_Aspects (From => Dummy_Node, To => Package_Node); 186 end if; 187 188 -- In SPARK, a HIDE directive can be placed at the beginning of a 189 -- package implementation, thus hiding the package body from SPARK 190 -- tool-set. No violation of the SPARK restriction should be 191 -- issued on nodes in a hidden part, which is obtained by marking 192 -- such hidden parts. 193 194 if Token = Tok_SPARK_Hide then 195 Body_Is_Hidden_In_SPARK := True; 196 Hidden_Region_Start := Token_Ptr; 197 Scan; -- past HIDE directive 198 else 199 Body_Is_Hidden_In_SPARK := False; 200 end if; 201 202 Parse_Decls_Begin_End (Package_Node); 203 204 if Body_Is_Hidden_In_SPARK then 205 Set_Hidden_Part_In_SPARK (Hidden_Region_Start, Token_Ptr); 206 end if; 207 end if; 208 209 -- Cases other than Package_Body 210 211 else 212 Scope.Table (Scope.Last).Sloc := Token_Ptr; 213 Name_Node := P_Defining_Program_Unit_Name; 214 Scope.Table (Scope.Last).Labl := Name_Node; 215 Current_Node := Name_Node; 216 217 -- Case of renaming declaration 218 219 Check_Misspelling_Of (Tok_Renames); 220 221 if Token = Tok_Renames then 222 if not Pf_Flags.Rnam then 223 Error_Msg_SC ("renaming declaration cannot appear here!"); 224 end if; 225 226 Scan; -- past RENAMES; 227 228 Package_Node := 229 New_Node (N_Package_Renaming_Declaration, Package_Sloc); 230 Set_Defining_Unit_Name (Package_Node, Name_Node); 231 Set_Name (Package_Node, P_Qualified_Simple_Name); 232 233 No_Constraint; 234 P_Aspect_Specifications (Package_Node, Semicolon => False); 235 TF_Semicolon; 236 Pop_Scope_Stack; 237 238 -- Generic package instantiation or package declaration 239 240 else 241 if Aspect_Specifications_Present then 242 Aspect_Sloc := Token_Ptr; 243 P_Aspect_Specifications (Dummy_Node, Semicolon => False); 244 end if; 245 246 Is_Sloc := Token_Ptr; 247 TF_Is; 248 249 -- Case of generic instantiation 250 251 if Token = Tok_New then 252 if not Pf_Flags.Gins then 253 Error_Msg_SC 254 ("generic instantiation cannot appear here!"); 255 end if; 256 257 if Aspect_Sloc /= No_Location then 258 Error_Msg 259 ("misplaced aspects for package instantiation", 260 Aspect_Sloc); 261 end if; 262 263 Scan; -- past NEW 264 265 Package_Node := 266 New_Node (N_Package_Instantiation, Package_Sloc); 267 Set_Defining_Unit_Name (Package_Node, Name_Node); 268 Set_Name (Package_Node, P_Qualified_Simple_Name); 269 Set_Generic_Associations 270 (Package_Node, P_Generic_Actual_Part_Opt); 271 272 if Aspect_Sloc /= No_Location 273 and then not Aspect_Specifications_Present 274 then 275 Error_Msg_SC ("info: aspect specifications belong here??"); 276 Move_Aspects (From => Dummy_Node, To => Package_Node); 277 end if; 278 279 P_Aspect_Specifications (Package_Node); 280 Pop_Scope_Stack; 281 282 -- Case of package declaration or package specification 283 284 else 285 Specification_Node := 286 New_Node (N_Package_Specification, Package_Sloc); 287 288 Set_Defining_Unit_Name (Specification_Node, Name_Node); 289 Set_Visible_Declarations 290 (Specification_Node, P_Basic_Declarative_Items); 291 292 if Token = Tok_Private then 293 Error_Msg_Col := Scope.Table (Scope.Last).Ecol; 294 295 if RM_Column_Check then 296 if Token_Is_At_Start_Of_Line 297 and then Start_Column /= Error_Msg_Col 298 then 299 Error_Msg_SC 300 ("(style) PRIVATE in wrong column, should be@"); 301 end if; 302 end if; 303 304 Scan; -- past PRIVATE 305 306 if Token = Tok_SPARK_Hide then 307 Private_Part_Is_Hidden_In_SPARK := True; 308 Hidden_Region_Start := Token_Ptr; 309 Scan; -- past HIDE directive 310 else 311 Private_Part_Is_Hidden_In_SPARK := False; 312 end if; 313 314 Set_Private_Declarations 315 (Specification_Node, P_Basic_Declarative_Items); 316 317 -- In SPARK, a HIDE directive can be placed at the beginning 318 -- of a private part, thus hiding all declarations in the 319 -- private part from SPARK tool-set. No violation of the 320 -- SPARK restriction should be issued on nodes in a hidden 321 -- part, which is obtained by marking such hidden parts. 322 323 if Private_Part_Is_Hidden_In_SPARK then 324 Set_Hidden_Part_In_SPARK (Hidden_Region_Start, Token_Ptr); 325 end if; 326 327 -- Deal gracefully with multiple PRIVATE parts 328 329 while Token = Tok_Private loop 330 Error_Msg_SC 331 ("only one private part allowed per package"); 332 Scan; -- past PRIVATE 333 Append_List (P_Basic_Declarative_Items, 334 Private_Declarations (Specification_Node)); 335 end loop; 336 end if; 337 338 if Pf_Flags = Pf_Spcn then 339 Package_Node := Specification_Node; 340 else 341 Package_Node := 342 New_Node (N_Package_Declaration, Package_Sloc); 343 Set_Specification (Package_Node, Specification_Node); 344 end if; 345 346 if Token = Tok_Begin then 347 Error_Msg_SC ("begin block not allowed in package spec"); 348 Scan; -- past BEGIN 349 Discard_Junk_List (P_Sequence_Of_Statements (SS_None)); 350 end if; 351 352 End_Statements (Specification_Node, Empty, Is_Sloc); 353 Move_Aspects (From => Dummy_Node, To => Package_Node); 354 end if; 355 end if; 356 end if; 357 358 return Package_Node; 359 end P_Package; 360 361 ------------------------------ 362 -- 7.1 Package Declaration -- 363 ------------------------------ 364 365 -- Parsed by P_Package (7.1) 366 367 -------------------------------- 368 -- 7.1 Package Specification -- 369 -------------------------------- 370 371 -- Parsed by P_Package (7.1) 372 373 ----------------------- 374 -- 7.1 Package Body -- 375 ----------------------- 376 377 -- Parsed by P_Package (7.1) 378 379 ----------------------------------- 380 -- 7.3 Private Type Declaration -- 381 ----------------------------------- 382 383 -- Parsed by P_Type_Declaration (3.2.1) 384 385 ---------------------------------------- 386 -- 7.3 Private Extension Declaration -- 387 ---------------------------------------- 388 389 -- Parsed by P_Type_Declaration (3.2.1) 390 391end Ch7; 392