Mark ChangeLog
[official-gcc.git] / gcc / ada / par-ch7.adb
blob4363a649f14fba1a234e781b330f2174c3df15e8
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 ------------------------------------------------------------------------------
27 pragma Style_Checks (All_Checks);
28 -- Turn off subprogram body ordering check. Subprograms are in order
29 -- by RM section rather than alphabetical
31 separate (Par)
32 package body Ch7 is
34 ---------------------------------------------
35 -- 7.1 Package (also 8.5.3, 10.1.3, 12.3) --
36 ---------------------------------------------
38 -- This routine scans out a package declaration, package body, or a
39 -- renaming declaration or generic instantiation starting with PACKAGE
41 -- PACKAGE_DECLARATION ::= PACKAGE_SPECIFICATION;
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]
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]
57 -- PACKAGE_RENAMING_DECLARATION ::=
58 -- package DEFINING_IDENTIFIER renames package_NAME;
60 -- PACKAGE_BODY_STUB ::=
61 -- package body DEFINING_IDENTIFIER is separate;
63 -- The value in Pf_Flags indicates which of these possible declarations
64 -- is acceptable to the caller:
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
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.
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.
85 -- The caller has checked that the initial token is PACKAGE
87 -- Error recovery: cannot raise Error_Resync
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;
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;
101 Package_Sloc := Token_Ptr;
102 Scan; -- past PACKAGE
104 if Token = Tok_Type then
105 Error_Msg_SC ("TYPE not allowed here");
106 Scan; -- past TYPE
107 end if;
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!");
115 end if;
117 T_Body;
118 Name_Node := P_Defining_Program_Unit_Name;
119 Scope.Table (Scope.Last).Labl := Name_Node;
120 TF_Is;
122 if Separate_Present then
123 if not Pf_Flags.Stub then
124 Error_Msg_SC ("body stub cannot appear here!");
125 end if;
127 Scan; -- past SEPARATE
128 TF_Semicolon;
129 Pop_Scope_Stack;
131 Package_Node := New_Node (N_Package_Body_Stub, Package_Sloc);
132 Set_Defining_Identifier (Package_Node, Name_Node);
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;
140 return Package_Node;
142 -- Cases other than Package_Body
144 else
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!");
155 end if;
157 Scan; -- past RENAMES;
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);
164 No_Constraint;
165 TF_Semicolon;
166 Pop_Scope_Stack;
167 return Package_Node;
169 else
170 TF_Is;
172 -- Case of generic instantiation
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;
180 Scan; -- past NEW
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;
191 -- Case of package declaration or package specification
193 else
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 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;
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
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;
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;
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;
242 End_Statements (Specification_Node);
243 end if;
245 return Package_Node;
246 end if;
247 end if;
248 end P_Package;
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)
280 end Ch7;