1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2010, 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 ::= PACKAGE_SPECIFICATION;
42 -- PACKAGE_SPECIFICATION ::=
43 -- package DEFINING_PROGRAM_UNIT_NAME is
44 -- {BASIC_DECLARATIVE_ITEM}
46 -- {BASIC_DECLARATIVE_ITEM}]
47 -- end [[PARENT_UNIT_NAME .] IDENTIFIER]
50 -- package body DEFINING_PROGRAM_UNIT_NAME is
53 -- HANDLED_SEQUENCE_OF_STATEMENTS]
54 -- end [[PARENT_UNIT_NAME .] IDENTIFIER]
56 -- PACKAGE_RENAMING_DECLARATION ::=
57 -- package DEFINING_IDENTIFIER renames package_NAME;
59 -- PACKAGE_BODY_STUB ::=
60 -- package body DEFINING_IDENTIFIER is separate;
62 -- The value in Pf_Flags indicates which of these possible declarations
63 -- is acceptable to the caller:
65 -- Pf_Flags.Spcn Set if specification OK
66 -- Pf_Flags.Decl Set if declaration OK
67 -- Pf_Flags.Gins Set if generic instantiation OK
68 -- Pf_Flags.Pbod Set if proper body OK
69 -- Pf_Flags.Rnam Set if renaming declaration OK
70 -- Pf_Flags.Stub Set if body stub OK
72 -- If an inappropriate form is encountered, it is scanned out but an error
73 -- message indicating that it is appearing in an inappropriate context is
74 -- issued. The only possible settings for Pf_Flags are those defined as
75 -- constants in package Par.
77 -- Note: in all contexts where a package specification is required, there
78 -- is a terminating semicolon. This semicolon is scanned out in the case
79 -- where Pf_Flags is set to Pf_Spcn, even though it is not strictly part
80 -- of the package specification (it's just too much trouble, and really
81 -- quite unnecessary, to deal with scanning out an END where the semicolon
82 -- after the END is not considered to be part of the END.
84 -- The caller has checked that the initial token is PACKAGE
86 -- Error recovery: cannot raise Error_Resync
88 function P_Package
(Pf_Flags
: Pf_Rec
) return Node_Id
is
89 Package_Node
: Node_Id
;
90 Specification_Node
: Node_Id
;
92 Package_Sloc
: Source_Ptr
;
96 Scope
.Table
(Scope
.Last
).Etyp
:= E_Name
;
97 Scope
.Table
(Scope
.Last
).Ecol
:= Start_Column
;
98 Scope
.Table
(Scope
.Last
).Lreq
:= False;
100 Package_Sloc
:= Token_Ptr
;
101 Scan
; -- past PACKAGE
103 if Token
= Tok_Type
then
104 Error_Msg_SC
-- CODEFIX
105 ("TYPE not allowed here");
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)
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!");
118 Name_Node
:= P_Defining_Program_Unit_Name
;
119 Scope
.Table
(Scope
.Last
).Labl
:= Name_Node
;
122 if Separate_Present
then
123 if not Pf_Flags
.Stub
then
124 Error_Msg_SC
("body stub cannot appear here!");
127 Scan
; -- past SEPARATE
131 Package_Node
:= New_Node
(N_Package_Body_Stub
, Package_Sloc
);
132 Set_Defining_Identifier
(Package_Node
, Name_Node
);
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
);
142 -- Cases other than Package_Body
145 Name_Node
:= P_Defining_Program_Unit_Name
;
146 Scope
.Table
(Scope
.Last
).Labl
:= Name_Node
;
148 -- Case of renaming declaration
150 Check_Misspelling_Of
(Tok_Renames
);
152 if Token
= Tok_Renames
then
153 if not Pf_Flags
.Rnam
then
154 Error_Msg_SC
("renaming declaration cannot appear here!");
157 Scan
; -- past RENAMES;
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
);
172 -- Case of generic instantiation
174 if Token
= Tok_New
then
175 if not Pf_Flags
.Gins
then
177 ("generic instantiation cannot appear here!");
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
);
191 -- Case of package declaration or package specification
194 Specification_Node
:=
195 New_Node
(N_Package_Specification
, Package_Sloc
);
197 Set_Defining_Unit_Name
(Specification_Node
, Name_Node
);
198 Set_Visible_Declarations
199 (Specification_Node
, P_Basic_Declarative_Items
);
201 if Token
= Tok_Private
then
202 Error_Msg_Col
:= Scope
.Table
(Scope
.Last
).Ecol
;
204 if RM_Column_Check
then
205 if Token_Is_At_Start_Of_Line
206 and then Start_Column
/= Error_Msg_Col
209 ("(style) PRIVATE in wrong column, should be@");
213 Scan
; -- past PRIVATE
214 Set_Private_Declarations
215 (Specification_Node
, P_Basic_Declarative_Items
);
217 -- Deal gracefully with multiple PRIVATE parts
219 while Token
= Tok_Private
loop
221 ("only one private part allowed per package");
222 Scan
; -- past PRIVATE
223 Append_List
(P_Basic_Declarative_Items
,
224 Private_Declarations
(Specification_Node
));
228 if Pf_Flags
= Pf_Spcn
then
229 Package_Node
:= Specification_Node
;
232 New_Node
(N_Package_Declaration
, Package_Sloc
);
233 Set_Specification
(Package_Node
, Specification_Node
);
236 if Token
= Tok_Begin
then
237 Error_Msg_SC
("begin block not allowed in package spec");
239 Discard_Junk_List
(P_Sequence_Of_Statements
(SS_None
));
242 End_Statements
(Specification_Node
);
250 ------------------------------
251 -- 7.1 Package Declaration --
252 ------------------------------
254 -- Parsed by P_Package (7.1)
256 --------------------------------
257 -- 7.1 Package Specification --
258 --------------------------------
260 -- Parsed by P_Package (7.1)
262 -----------------------
263 -- 7.1 Package Body --
264 -----------------------
266 -- Parsed by P_Package (7.1)
268 -----------------------------------
269 -- 7.3 Private Type Declaration --
270 -----------------------------------
272 -- Parsed by P_Type_Declaration (3.2.1)
274 ----------------------------------------
275 -- 7.3 Private Extension Declaration --
276 ----------------------------------------
278 -- Parsed by P_Type_Declaration (3.2.1)