1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
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. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 pragma Style_Checks
(All_Checks
);
27 -- Turn off subprogram body ordering check. Subprograms are in order
28 -- by RM section rather than alphabetical
33 ---------------------------------------------
34 -- 7.1 Package (also 8.5.3, 10.1.3, 12.3) --
35 ---------------------------------------------
37 -- This routine scans out a package declaration, package body, or a
38 -- renaming declaration or generic instantiation starting with PACKAGE
40 -- PACKAGE_DECLARATION ::=
41 -- PACKAGE_SPECIFICATION
42 -- [ASPECT_SPECIFICATIONS];
44 -- PACKAGE_SPECIFICATION ::=
45 -- package DEFINING_PROGRAM_UNIT_NAME is
46 -- {BASIC_DECLARATIVE_ITEM}
48 -- {BASIC_DECLARATIVE_ITEM}]
49 -- end [[PARENT_UNIT_NAME .] IDENTIFIER]
52 -- package body DEFINING_PROGRAM_UNIT_NAME is
55 -- HANDLED_SEQUENCE_OF_STATEMENTS]
56 -- end [[PARENT_UNIT_NAME .] IDENTIFIER]
58 -- PACKAGE_RENAMING_DECLARATION ::=
59 -- package DEFINING_IDENTIFIER renames package_NAME;
61 -- PACKAGE_BODY_STUB ::=
62 -- package body DEFINING_IDENTIFIER is separate;
64 -- PACKAGE_INSTANTIATION ::=
65 -- package DEFINING_PROGRAM_UNIT_NAME is
66 -- new generic_package_NAME [GENERIC_ACTUAL_PART]
67 -- [ASPECT_SPECIFICATIONS];
69 -- The value in Pf_Flags indicates which of these possible declarations
70 -- is acceptable to the caller:
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
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.
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.
91 -- The caller has checked that the initial token is PACKAGE
93 -- Error recovery: cannot raise Error_Resync
95 function P_Package
(Pf_Flags
: Pf_Rec
) return Node_Id
is
96 Package_Node
: Node_Id
;
97 Specification_Node
: Node_Id
;
99 Package_Sloc
: Source_Ptr
;
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.
105 Is_Sloc
: Source_Ptr
;
106 -- Save location of IS token for package declaration
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.
113 Body_Is_Hidden_In_SPARK
: Boolean;
114 Private_Part_Is_Hidden_In_SPARK
: Boolean;
115 Hidden_Region_Start
: Source_Ptr
;
119 Scope
.Table
(Scope
.Last
).Etyp
:= E_Name
;
120 Scope
.Table
(Scope
.Last
).Ecol
:= Start_Column
;
121 Scope
.Table
(Scope
.Last
).Lreq
:= False;
123 Package_Sloc
:= Token_Ptr
;
124 Scan
; -- past PACKAGE
126 if Token
= Tok_Type
then
127 Error_Msg_SC
-- CODEFIX
128 ("TYPE not allowed here");
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)
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!");
141 Name_Node
:= P_Defining_Program_Unit_Name
;
142 Scope
.Table
(Scope
.Last
).Labl
:= Name_Node
;
145 if Separate_Present
then
146 if not Pf_Flags
.Stub
then
147 Error_Msg_SC
("body stub cannot appear here!");
150 Scan
; -- past SEPARATE
154 Package_Node
:= New_Node
(N_Package_Body_Stub
, Package_Sloc
);
155 Set_Defining_Identifier
(Package_Node
, Name_Node
);
158 Package_Node
:= New_Node
(N_Package_Body
, Package_Sloc
);
159 Set_Defining_Unit_Name
(Package_Node
, Name_Node
);
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.
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
172 Body_Is_Hidden_In_SPARK
:= False;
175 Parse_Decls_Begin_End
(Package_Node
);
177 if Body_Is_Hidden_In_SPARK
then
178 Set_Hidden_Part_In_SPARK
(Hidden_Region_Start
, Token_Ptr
);
182 -- Cases other than Package_Body
185 Name_Node
:= P_Defining_Program_Unit_Name
;
186 Scope
.Table
(Scope
.Last
).Labl
:= Name_Node
;
188 -- Case of renaming declaration
190 Check_Misspelling_Of
(Tok_Renames
);
192 if Token
= Tok_Renames
then
193 if not Pf_Flags
.Rnam
then
194 Error_Msg_SC
("renaming declaration cannot appear here!");
197 Scan
; -- past RENAMES;
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
);
208 -- Generic package instantiation or package declaration
211 if Aspect_Specifications_Present
then
212 Aspect_Sloc
:= Token_Ptr
;
213 P_Aspect_Specifications
(Dummy_Node
, Semicolon
=> False);
216 Is_Sloc
:= Token_Ptr
;
219 -- Case of generic instantiation
221 if Token
= Tok_New
then
222 if not Pf_Flags
.Gins
then
224 ("generic instantiation cannot appear here!");
227 if Aspect_Sloc
/= No_Location
then
229 ("misplaced aspects for package instantiation",
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
);
242 if Aspect_Sloc
/= No_Location
243 and then not Aspect_Specifications_Present
245 Error_Msg_SC
("\info: aspect specifications belong here");
246 Move_Aspects
(From
=> Dummy_Node
, To
=> Package_Node
);
249 P_Aspect_Specifications
(Package_Node
);
252 -- Case of package declaration or package specification
255 Specification_Node
:=
256 New_Node
(N_Package_Specification
, Package_Sloc
);
258 Set_Defining_Unit_Name
(Specification_Node
, Name_Node
);
259 Set_Visible_Declarations
260 (Specification_Node
, P_Basic_Declarative_Items
);
262 if Token
= Tok_Private
then
263 Error_Msg_Col
:= Scope
.Table
(Scope
.Last
).Ecol
;
265 if RM_Column_Check
then
266 if Token_Is_At_Start_Of_Line
267 and then Start_Column
/= Error_Msg_Col
270 ("(style) PRIVATE in wrong column, should be@");
274 Scan
; -- past PRIVATE
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
281 Private_Part_Is_Hidden_In_SPARK
:= False;
284 Set_Private_Declarations
285 (Specification_Node
, P_Basic_Declarative_Items
);
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.
293 if Private_Part_Is_Hidden_In_SPARK
then
294 Set_Hidden_Part_In_SPARK
(Hidden_Region_Start
, Token_Ptr
);
297 -- Deal gracefully with multiple PRIVATE parts
299 while Token
= Tok_Private
loop
301 ("only one private part allowed per package");
302 Scan
; -- past PRIVATE
303 Append_List
(P_Basic_Declarative_Items
,
304 Private_Declarations
(Specification_Node
));
308 if Pf_Flags
= Pf_Spcn
then
309 Package_Node
:= Specification_Node
;
312 New_Node
(N_Package_Declaration
, Package_Sloc
);
313 Set_Specification
(Package_Node
, Specification_Node
);
316 if Token
= Tok_Begin
then
317 Error_Msg_SC
("begin block not allowed in package spec");
319 Discard_Junk_List
(P_Sequence_Of_Statements
(SS_None
));
322 End_Statements
(Specification_Node
, Empty
, Is_Sloc
);
323 Move_Aspects
(From
=> Dummy_Node
, To
=> Package_Node
);
331 ------------------------------
332 -- 7.1 Package Declaration --
333 ------------------------------
335 -- Parsed by P_Package (7.1)
337 --------------------------------
338 -- 7.1 Package Specification --
339 --------------------------------
341 -- Parsed by P_Package (7.1)
343 -----------------------
344 -- 7.1 Package Body --
345 -----------------------
347 -- Parsed by P_Package (7.1)
349 -----------------------------------
350 -- 7.3 Private Type Declaration --
351 -----------------------------------
353 -- Parsed by P_Type_Declaration (3.2.1)
355 ----------------------------------------
356 -- 7.3 Private Extension Declaration --
357 ----------------------------------------
359 -- Parsed by P_Type_Declaration (3.2.1)