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-2001 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 2, 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 COPYING. If not, write -- 19-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- 20-- MA 02111-1307, USA. -- 21-- -- 22-- GNAT was originally developed by the GNAT team at New York University. -- 23-- Extensive contributions were provided by Ada Core Technologies Inc. -- 24-- -- 25------------------------------------------------------------------------------ 26 27pragma Style_Checks (All_Checks); 28-- Turn off subprogram body ordering check. Subprograms are in order 29-- by RM section rather than alphabetical 30 31separate (Par) 32package body Ch7 is 33 34 --------------------------------------------- 35 -- 7.1 Package (also 8.5.3, 10.1.3, 12.3) -- 36 --------------------------------------------- 37 38 -- This routine scans out a package declaration, package body, or a 39 -- renaming declaration or generic instantiation starting with PACKAGE 40 41 -- PACKAGE_DECLARATION ::= PACKAGE_SPECIFICATION; 42 43 -- PACKAGE_SPECIFICATION ::= 44 -- package DEFINING_PROGRAM_UNIT_NAME is 45 -- {BASIC_DECLARATIVE_ITEM} 46 -- [private 47 -- {BASIC_DECLARATIVE_ITEM}] 48 -- end [[PARENT_UNIT_NAME .] IDENTIFIER] 49 50 -- PACKAGE_BODY ::= 51 -- package body DEFINING_PROGRAM_UNIT_NAME is 52 -- DECLARATIVE_PART 53 -- [begin 54 -- HANDLED_SEQUENCE_OF_STATEMENTS] 55 -- end [[PARENT_UNIT_NAME .] IDENTIFIER] 56 57 -- PACKAGE_RENAMING_DECLARATION ::= 58 -- package DEFINING_IDENTIFIER renames package_NAME; 59 60 -- PACKAGE_BODY_STUB ::= 61 -- package body DEFINING_IDENTIFIER is separate; 62 63 -- The value in Pf_Flags indicates which of these possible declarations 64 -- is acceptable to the caller: 65 66 -- Pf_Flags.Spcn Set if specification OK 67 -- Pf_Flags.Decl Set if declaration OK 68 -- Pf_Flags.Gins Set if generic instantiation OK 69 -- Pf_Flags.Pbod Set if proper body OK 70 -- Pf_Flags.Rnam Set if renaming declaration OK 71 -- Pf_Flags.Stub Set if body stub OK 72 73 -- If an inappropriate form is encountered, it is scanned out but an 74 -- error message indicating that it is appearing in an inappropriate 75 -- context is issued. The only possible settings for Pf_Flags are those 76 -- defined as constants in package Par. 77 78 -- Note: in all contexts where a package specification is required, there 79 -- is a terminating semicolon. This semicolon is scanned out in the case 80 -- where Pf_Flags is set to Pf_Spcn, even though it is not strictly part 81 -- of the package specification (it's just too much trouble, and really 82 -- quite unnecessary, to deal with scanning out an END where the semicolon 83 -- after the END is not considered to be part of the END. 84 85 -- The caller has checked that the initial token is PACKAGE 86 87 -- Error recovery: cannot raise Error_Resync 88 89 function P_Package (Pf_Flags : Pf_Rec) return Node_Id is 90 Package_Node : Node_Id; 91 Specification_Node : Node_Id; 92 Name_Node : Node_Id; 93 Package_Sloc : Source_Ptr; 94 95 begin 96 Push_Scope_Stack; 97 Scope.Table (Scope.Last).Etyp := E_Name; 98 Scope.Table (Scope.Last).Ecol := Start_Column; 99 Scope.Table (Scope.Last).Lreq := False; 100 101 Package_Sloc := Token_Ptr; 102 Scan; -- past PACKAGE 103 104 if Token = Tok_Type then 105 Error_Msg_SC ("TYPE not allowed here"); 106 Scan; -- past TYPE 107 end if; 108 109 -- Case of package body. Note that we demand a package body if that 110 -- is the only possibility (even if the BODY keyword is not present) 111 112 if Token = Tok_Body or else Pf_Flags = Pf_Pbod then 113 if not Pf_Flags.Pbod then 114 Error_Msg_SC ("package body cannot appear here!"); 115 end if; 116 117 T_Body; 118 Name_Node := P_Defining_Program_Unit_Name; 119 Scope.Table (Scope.Last).Labl := Name_Node; 120 TF_Is; 121 122 if Separate_Present then 123 if not Pf_Flags.Stub then 124 Error_Msg_SC ("body stub cannot appear here!"); 125 end if; 126 127 Scan; -- past SEPARATE 128 TF_Semicolon; 129 Pop_Scope_Stack; 130 131 Package_Node := New_Node (N_Package_Body_Stub, Package_Sloc); 132 Set_Defining_Identifier (Package_Node, Name_Node); 133 134 else 135 Package_Node := New_Node (N_Package_Body, Package_Sloc); 136 Set_Defining_Unit_Name (Package_Node, Name_Node); 137 Parse_Decls_Begin_End (Package_Node); 138 end if; 139 140 return Package_Node; 141 142 -- Cases other than Package_Body 143 144 else 145 Name_Node := P_Defining_Program_Unit_Name; 146 Scope.Table (Scope.Last).Labl := Name_Node; 147 148 -- Case of renaming declaration 149 150 Check_Misspelling_Of (Tok_Renames); 151 152 if Token = Tok_Renames then 153 if not Pf_Flags.Rnam then 154 Error_Msg_SC ("renaming declaration cannot appear here!"); 155 end if; 156 157 Scan; -- past RENAMES; 158 159 Package_Node := 160 New_Node (N_Package_Renaming_Declaration, Package_Sloc); 161 Set_Defining_Unit_Name (Package_Node, Name_Node); 162 Set_Name (Package_Node, P_Qualified_Simple_Name); 163 164 No_Constraint; 165 TF_Semicolon; 166 Pop_Scope_Stack; 167 return Package_Node; 168 169 else 170 TF_Is; 171 172 -- Case of generic instantiation 173 174 if Token = Tok_New then 175 if not Pf_Flags.Gins then 176 Error_Msg_SC 177 ("generic instantiation cannot appear here!"); 178 end if; 179 180 Scan; -- past NEW 181 182 Package_Node := 183 New_Node (N_Package_Instantiation, Package_Sloc); 184 Set_Defining_Unit_Name (Package_Node, Name_Node); 185 Set_Name (Package_Node, P_Qualified_Simple_Name); 186 Set_Generic_Associations 187 (Package_Node, P_Generic_Actual_Part_Opt); 188 TF_Semicolon; 189 Pop_Scope_Stack; 190 191 -- Case of package declaration or package specification 192 193 else 194 Specification_Node := 195 New_Node (N_Package_Specification, Package_Sloc); 196 197 Set_Defining_Unit_Name (Specification_Node, Name_Node); 198 Set_Visible_Declarations 199 (Specification_Node, P_Basic_Declarative_Items); 200 201 if Token = Tok_Private then 202 Error_Msg_Col := Scope.Table (Scope.Last).Ecol; 203 204 if Style.RM_Column_Check then 205 if Token_Is_At_Start_Of_Line 206 and then Start_Column /= Error_Msg_Col 207 then 208 Error_Msg_SC 209 ("(style) PRIVATE in wrong column, should be@"); 210 end if; 211 end if; 212 213 Scan; -- past PRIVATE 214 Set_Private_Declarations 215 (Specification_Node, P_Basic_Declarative_Items); 216 217 -- Deal gracefully with multiple PRIVATE parts 218 219 while Token = Tok_Private loop 220 Error_Msg_SC 221 ("only one private part allowed per package"); 222 Scan; -- past PRIVATE 223 Append_List (P_Basic_Declarative_Items, 224 Private_Declarations (Specification_Node)); 225 end loop; 226 end if; 227 228 if Pf_Flags = Pf_Spcn then 229 Package_Node := Specification_Node; 230 else 231 Package_Node := 232 New_Node (N_Package_Declaration, Package_Sloc); 233 Set_Specification (Package_Node, Specification_Node); 234 end if; 235 236 if Token = Tok_Begin then 237 Error_Msg_SC ("begin block not allowed in package spec"); 238 Scan; -- past BEGIN 239 Discard_Junk_List (P_Sequence_Of_Statements (SS_None)); 240 end if; 241 242 End_Statements (Specification_Node); 243 end if; 244 245 return Package_Node; 246 end if; 247 end if; 248 end P_Package; 249 250 ------------------------------ 251 -- 7.1 Package Declaration -- 252 ------------------------------ 253 254 -- Parsed by P_Package (7.1) 255 256 -------------------------------- 257 -- 7.1 Package Specification -- 258 -------------------------------- 259 260 -- Parsed by P_Package (7.1) 261 262 ----------------------- 263 -- 7.1 Package Body -- 264 ----------------------- 265 266 -- Parsed by P_Package (7.1) 267 268 ----------------------------------- 269 -- 7.3 Private Type Declaration -- 270 ----------------------------------- 271 272 -- Parsed by P_Type_Declaration (3.2.1) 273 274 ---------------------------------------- 275 -- 7.3 Private Extension Declaration -- 276 ---------------------------------------- 277 278 -- Parsed by P_Type_Declaration (3.2.1) 279 280end Ch7; 281