1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
10 -- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
12 -- GNAT is free software; you can redistribute it and/or modify it under --
13 -- terms of the GNU General Public License as published by the Free Soft- --
14 -- ware Foundation; either version 2, or (at your option) any later ver- --
15 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
16 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
17 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
18 -- for more details. You should have received a copy of the GNU General --
19 -- Public License distributed with GNAT; see file COPYING. If not, write --
20 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
21 -- MA 02111-1307, USA. --
23 -- GNAT was originally developed by the GNAT team at New York University. --
24 -- Extensive contributions were provided by Ada Core Technologies Inc. --
26 ------------------------------------------------------------------------------
28 pragma Style_Checks
(All_Checks
);
29 -- Turn off subprogram body ordering check. Subprograms are in order
30 -- by RM section rather than alphabetical
35 ---------------------------------------------
36 -- 7.1 Package (also 8.5.3, 10.1.3, 12.3) --
37 ---------------------------------------------
39 -- This routine scans out a package declaration, package body, or a
40 -- renaming declaration or generic instantiation starting with PACKAGE
42 -- PACKAGE_DECLARATION ::= PACKAGE_SPECIFICATION;
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 -- The value in Pf_Flags indicates which of these possible declarations
65 -- is acceptable to the caller:
67 -- Pf_Flags.Spcn Set if specification OK
68 -- Pf_Flags.Decl Set if declaration OK
69 -- Pf_Flags.Gins Set if generic instantiation OK
70 -- Pf_Flags.Pbod Set if proper body OK
71 -- Pf_Flags.Rnam Set if renaming declaration OK
72 -- Pf_Flags.Stub Set if body stub OK
74 -- If an inappropriate form is encountered, it is scanned out but an
75 -- error message indicating that it is appearing in an inappropriate
76 -- context is issued. The only possible settings for Pf_Flags are those
77 -- defined as constants in package Par.
79 -- Note: in all contexts where a package specification is required, there
80 -- is a terminating semicolon. This semicolon is scanned out in the case
81 -- where Pf_Flags is set to Pf_Spcn, even though it is not strictly part
82 -- of the package specification (it's just too much trouble, and really
83 -- quite unnecessary, to deal with scanning out an END where the semicolon
84 -- after the END is not considered to be part of the END.
86 -- The caller has checked that the initial token is PACKAGE
88 -- Error recovery: cannot raise Error_Resync
90 function P_Package
(Pf_Flags
: Pf_Rec
) return Node_Id
is
91 Package_Node
: Node_Id
;
92 Specification_Node
: Node_Id
;
94 Package_Sloc
: Source_Ptr
;
98 Scope
.Table
(Scope
.Last
).Etyp
:= E_Name
;
99 Scope
.Table
(Scope
.Last
).Ecol
:= Start_Column
;
100 Scope
.Table
(Scope
.Last
).Lreq
:= False;
102 Package_Sloc
:= Token_Ptr
;
103 Scan
; -- past PACKAGE
105 if Token
= Tok_Type
then
106 Error_Msg_SC
("TYPE not allowed here");
110 -- Case of package body. Note that we demand a package body if that
111 -- is the only possibility (even if the BODY keyword is not present)
113 if Token
= Tok_Body
or else Pf_Flags
= Pf_Pbod
then
114 if not Pf_Flags
.Pbod
then
115 Error_Msg_SC
("package body cannot appear here!");
119 Name_Node
:= P_Defining_Program_Unit_Name
;
120 Scope
.Table
(Scope
.Last
).Labl
:= Name_Node
;
123 if Separate_Present
then
124 if not Pf_Flags
.Stub
then
125 Error_Msg_SC
("body stub cannot appear here!");
128 Scan
; -- past SEPARATE
132 Package_Node
:= New_Node
(N_Package_Body_Stub
, Package_Sloc
);
133 Set_Defining_Identifier
(Package_Node
, Name_Node
);
136 Package_Node
:= New_Node
(N_Package_Body
, Package_Sloc
);
137 Set_Defining_Unit_Name
(Package_Node
, Name_Node
);
138 Parse_Decls_Begin_End
(Package_Node
);
143 -- Cases other than Package_Body
146 Name_Node
:= P_Defining_Program_Unit_Name
;
147 Scope
.Table
(Scope
.Last
).Labl
:= Name_Node
;
149 -- Case of renaming declaration
151 Check_Misspelling_Of
(Tok_Renames
);
153 if Token
= Tok_Renames
then
154 if not Pf_Flags
.Rnam
then
155 Error_Msg_SC
("renaming declaration cannot appear here!");
158 Scan
; -- past RENAMES;
161 New_Node
(N_Package_Renaming_Declaration
, Package_Sloc
);
162 Set_Defining_Unit_Name
(Package_Node
, Name_Node
);
163 Set_Name
(Package_Node
, P_Qualified_Simple_Name
);
173 -- Case of generic instantiation
175 if Token
= Tok_New
then
176 if not Pf_Flags
.Gins
then
178 ("generic instantiation cannot appear here!");
184 New_Node
(N_Package_Instantiation
, Package_Sloc
);
185 Set_Defining_Unit_Name
(Package_Node
, Name_Node
);
186 Set_Name
(Package_Node
, P_Qualified_Simple_Name
);
187 Set_Generic_Associations
188 (Package_Node
, P_Generic_Actual_Part_Opt
);
192 -- Case of package declaration or package specification
195 Specification_Node
:=
196 New_Node
(N_Package_Specification
, Package_Sloc
);
198 Set_Defining_Unit_Name
(Specification_Node
, Name_Node
);
199 Set_Visible_Declarations
200 (Specification_Node
, P_Basic_Declarative_Items
);
202 if Token
= Tok_Private
then
203 Error_Msg_Col
:= Scope
.Table
(Scope
.Last
).Ecol
;
205 if Style
.RM_Column_Check
then
206 if Token_Is_At_Start_Of_Line
207 and then Start_Column
/= Error_Msg_Col
210 ("(style) PRIVATE in wrong column, should be@");
214 Scan
; -- past PRIVATE
215 Set_Private_Declarations
216 (Specification_Node
, P_Basic_Declarative_Items
);
218 -- Deal gracefully with multiple PRIVATE parts
220 while Token
= Tok_Private
loop
222 ("only one private part allowed per package");
223 Scan
; -- past PRIVATE
224 Append_List
(P_Basic_Declarative_Items
,
225 Private_Declarations
(Specification_Node
));
229 if Pf_Flags
= Pf_Spcn
then
230 Package_Node
:= Specification_Node
;
233 New_Node
(N_Package_Declaration
, Package_Sloc
);
234 Set_Specification
(Package_Node
, Specification_Node
);
237 if Token
= Tok_Begin
then
238 Error_Msg_SC
("begin block not allowed in package spec");
240 Discard_Junk_List
(P_Sequence_Of_Statements
(SS_None
));
243 End_Statements
(Specification_Node
);
251 ------------------------------
252 -- 7.1 Package Declaration --
253 ------------------------------
255 -- Parsed by P_Package (7.1)
257 --------------------------------
258 -- 7.1 Package Specification --
259 --------------------------------
261 -- Parsed by P_Package (7.1)
263 -----------------------
264 -- 7.1 Package Body --
265 -----------------------
267 -- Parsed by P_Package (7.1)
269 -----------------------------------
270 -- 7.3 Private Type Declaration --
271 -----------------------------------
273 -- Parsed by P_Type_Declaration (3.2.1)
275 ----------------------------------------
276 -- 7.3 Private Extension Declaration --
277 ----------------------------------------
279 -- Parsed by P_Type_Declaration (3.2.1)