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