|
111
|
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-2014, 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 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. --
|
|
|
20 -- --
|
|
|
21 -- GNAT was originally developed by the GNAT team at New York University. --
|
|
|
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
|
|
|
23 -- --
|
|
|
24 ------------------------------------------------------------------------------
|
|
|
25
|
|
|
26 pragma Style_Checks (All_Checks);
|
|
|
27 -- Turn off subprogram body ordering check. Subprograms are in order
|
|
|
28 -- by RM section rather than alphabetical
|
|
|
29
|
|
|
30 separate (Par)
|
|
|
31 package body Ch7 is
|
|
|
32
|
|
|
33 ---------------------------------------------
|
|
|
34 -- 7.1 Package (also 8.5.3, 10.1.3, 12.3) --
|
|
|
35 ---------------------------------------------
|
|
|
36
|
|
|
37 -- This routine scans out a package declaration, package body, or a
|
|
|
38 -- renaming declaration or generic instantiation starting with PACKAGE
|
|
|
39
|
|
|
40 -- PACKAGE_DECLARATION ::=
|
|
|
41 -- PACKAGE_SPECIFICATION;
|
|
|
42
|
|
|
43 -- PACKAGE_SPECIFICATION ::=
|
|
|
44 -- package DEFINING_PROGRAM_UNIT_NAME
|
|
|
45 -- [ASPECT_SPECIFICATIONS]
|
|
|
46 -- is
|
|
|
47 -- {BASIC_DECLARATIVE_ITEM}
|
|
|
48 -- [private
|
|
|
49 -- {BASIC_DECLARATIVE_ITEM}]
|
|
|
50 -- end [[PARENT_UNIT_NAME .] IDENTIFIER]
|
|
|
51
|
|
|
52 -- PACKAGE_BODY ::=
|
|
|
53 -- package body DEFINING_PROGRAM_UNIT_NAME
|
|
|
54 -- [ASPECT_SPECIFICATIONS]
|
|
|
55 -- is
|
|
|
56 -- DECLARATIVE_PART
|
|
|
57 -- [begin
|
|
|
58 -- HANDLED_SEQUENCE_OF_STATEMENTS]
|
|
|
59 -- end [[PARENT_UNIT_NAME .] IDENTIFIER]
|
|
|
60
|
|
|
61 -- PACKAGE_RENAMING_DECLARATION ::=
|
|
|
62 -- package DEFINING_IDENTIFIER renames package_NAME
|
|
|
63 -- [ASPECT_SPECIFICATIONS];
|
|
|
64
|
|
|
65 -- PACKAGE_BODY_STUB ::=
|
|
|
66 -- package body DEFINING_IDENTIFIER is separate
|
|
|
67 -- [ASPECT_SPECIFICATIONS];
|
|
|
68
|
|
|
69 -- PACKAGE_INSTANTIATION ::=
|
|
|
70 -- package DEFINING_PROGRAM_UNIT_NAME is
|
|
|
71 -- new generic_package_NAME [GENERIC_ACTUAL_PART]
|
|
|
72 -- [ASPECT_SPECIFICATIONS];
|
|
|
73
|
|
|
74 -- The value in Pf_Flags indicates which of these possible declarations
|
|
|
75 -- is acceptable to the caller:
|
|
|
76
|
|
|
77 -- Pf_Flags.Spcn Set if specification OK
|
|
|
78 -- Pf_Flags.Decl Set if declaration OK
|
|
|
79 -- Pf_Flags.Gins Set if generic instantiation OK
|
|
|
80 -- Pf_Flags.Pbod Set if proper body OK
|
|
|
81 -- Pf_Flags.Rnam Set if renaming declaration OK
|
|
|
82 -- Pf_Flags.Stub Set if body stub OK
|
|
|
83
|
|
|
84 -- If an inappropriate form is encountered, it is scanned out but an error
|
|
|
85 -- message indicating that it is appearing in an inappropriate context is
|
|
|
86 -- issued. The only possible settings for Pf_Flags are those defined as
|
|
|
87 -- constants in package Par.
|
|
|
88
|
|
|
89 -- Note: in all contexts where a package specification is required, there
|
|
|
90 -- is a terminating semicolon. This semicolon is scanned out in the case
|
|
|
91 -- where Pf_Flags is set to Pf_Spcn, even though it is not strictly part
|
|
|
92 -- of the package specification (it's just too much trouble, and really
|
|
|
93 -- quite unnecessary, to deal with scanning out an END where the semicolon
|
|
|
94 -- after the END is not considered to be part of the END.
|
|
|
95
|
|
|
96 -- The caller has checked that the initial token is PACKAGE
|
|
|
97
|
|
|
98 -- Error recovery: cannot raise Error_Resync
|
|
|
99
|
|
|
100 function P_Package (Pf_Flags : Pf_Rec) return Node_Id is
|
|
|
101 Package_Node : Node_Id;
|
|
|
102 Specification_Node : Node_Id;
|
|
|
103 Name_Node : Node_Id;
|
|
|
104 Package_Sloc : Source_Ptr;
|
|
|
105
|
|
|
106 Aspect_Sloc : Source_Ptr := No_Location;
|
|
|
107 -- Save location of WITH for scanned aspects. Left set to No_Location
|
|
|
108 -- if no aspects scanned before the IS keyword.
|
|
|
109
|
|
|
110 Is_Sloc : Source_Ptr;
|
|
|
111 -- Save location of IS token for package declaration
|
|
|
112
|
|
|
113 Dummy_Node : constant Node_Id :=
|
|
|
114 New_Node (N_Package_Specification, Token_Ptr);
|
|
|
115 -- Dummy node to attach aspect specifications to until we properly
|
|
|
116 -- figure out where they eventually belong.
|
|
|
117
|
|
|
118 Body_Is_Hidden_In_SPARK : Boolean;
|
|
|
119 Private_Part_Is_Hidden_In_SPARK : Boolean;
|
|
|
120 Hidden_Region_Start : Source_Ptr;
|
|
|
121
|
|
|
122 begin
|
|
|
123 Push_Scope_Stack;
|
|
|
124 Scope.Table (Scope.Last).Etyp := E_Name;
|
|
|
125 Scope.Table (Scope.Last).Ecol := Start_Column;
|
|
|
126 Scope.Table (Scope.Last).Lreq := False;
|
|
|
127
|
|
|
128 Package_Sloc := Token_Ptr;
|
|
|
129 Scan; -- past PACKAGE
|
|
|
130
|
|
|
131 if Token = Tok_Type then
|
|
|
132 Error_Msg_SC -- CODEFIX
|
|
|
133 ("TYPE not allowed here");
|
|
|
134 Scan; -- past TYPE
|
|
|
135 end if;
|
|
|
136
|
|
|
137 -- Case of package body. Note that we demand a package body if that
|
|
|
138 -- is the only possibility (even if the BODY keyword is not present)
|
|
|
139
|
|
|
140 if Token = Tok_Body or else Pf_Flags = Pf_Pbod_Pexp then
|
|
|
141 if not Pf_Flags.Pbod then
|
|
|
142 Error_Msg_SC ("package body cannot appear here!");
|
|
|
143 end if;
|
|
|
144
|
|
|
145 T_Body;
|
|
|
146 Scope.Table (Scope.Last).Sloc := Token_Ptr;
|
|
|
147 Name_Node := P_Defining_Program_Unit_Name;
|
|
|
148 Scope.Table (Scope.Last).Labl := Name_Node;
|
|
|
149
|
|
|
150 if Aspect_Specifications_Present then
|
|
|
151 Aspect_Sloc := Token_Ptr;
|
|
|
152 P_Aspect_Specifications (Dummy_Node, Semicolon => False);
|
|
|
153 end if;
|
|
|
154
|
|
|
155 TF_Is;
|
|
|
156
|
|
|
157 if Separate_Present then
|
|
|
158 if not Pf_Flags.Stub then
|
|
|
159 Error_Msg_SC ("body stub cannot appear here!");
|
|
|
160 end if;
|
|
|
161
|
|
|
162 Scan; -- past SEPARATE
|
|
|
163
|
|
|
164 Package_Node := New_Node (N_Package_Body_Stub, Package_Sloc);
|
|
|
165 Set_Defining_Identifier (Package_Node, Name_Node);
|
|
|
166
|
|
|
167 if Has_Aspects (Dummy_Node) then
|
|
|
168 Error_Msg
|
|
|
169 ("aspect specifications must come after SEPARATE",
|
|
|
170 Aspect_Sloc);
|
|
|
171 end if;
|
|
|
172
|
|
|
173 P_Aspect_Specifications (Package_Node, Semicolon => False);
|
|
|
174 TF_Semicolon;
|
|
|
175 Pop_Scope_Stack;
|
|
|
176
|
|
|
177 else
|
|
|
178 Package_Node := New_Node (N_Package_Body, Package_Sloc);
|
|
|
179 Set_Defining_Unit_Name (Package_Node, Name_Node);
|
|
|
180
|
|
|
181 -- Move the aspect specifications to the body node
|
|
|
182
|
|
|
183 if Has_Aspects (Dummy_Node) then
|
|
|
184 Move_Aspects (From => Dummy_Node, To => Package_Node);
|
|
|
185 end if;
|
|
|
186
|
|
|
187 -- In SPARK, a HIDE directive can be placed at the beginning of a
|
|
|
188 -- package implementation, thus hiding the package body from SPARK
|
|
|
189 -- tool-set. No violation of the SPARK restriction should be
|
|
|
190 -- issued on nodes in a hidden part, which is obtained by marking
|
|
|
191 -- such hidden parts.
|
|
|
192
|
|
|
193 if Token = Tok_SPARK_Hide then
|
|
|
194 Body_Is_Hidden_In_SPARK := True;
|
|
|
195 Hidden_Region_Start := Token_Ptr;
|
|
|
196 Scan; -- past HIDE directive
|
|
|
197 else
|
|
|
198 Body_Is_Hidden_In_SPARK := False;
|
|
|
199 end if;
|
|
|
200
|
|
|
201 Parse_Decls_Begin_End (Package_Node);
|
|
|
202
|
|
|
203 if Body_Is_Hidden_In_SPARK then
|
|
|
204 Set_Hidden_Part_In_SPARK (Hidden_Region_Start, Token_Ptr);
|
|
|
205 end if;
|
|
|
206 end if;
|
|
|
207
|
|
|
208 -- Cases other than Package_Body
|
|
|
209
|
|
|
210 else
|
|
|
211 Scope.Table (Scope.Last).Sloc := Token_Ptr;
|
|
|
212 Name_Node := P_Defining_Program_Unit_Name;
|
|
|
213 Scope.Table (Scope.Last).Labl := Name_Node;
|
|
|
214
|
|
|
215 -- Case of renaming declaration
|
|
|
216
|
|
|
217 Check_Misspelling_Of (Tok_Renames);
|
|
|
218
|
|
|
219 if Token = Tok_Renames then
|
|
|
220 if not Pf_Flags.Rnam then
|
|
|
221 Error_Msg_SC ("renaming declaration cannot appear here!");
|
|
|
222 end if;
|
|
|
223
|
|
|
224 Scan; -- past RENAMES;
|
|
|
225
|
|
|
226 Package_Node :=
|
|
|
227 New_Node (N_Package_Renaming_Declaration, Package_Sloc);
|
|
|
228 Set_Defining_Unit_Name (Package_Node, Name_Node);
|
|
|
229 Set_Name (Package_Node, P_Qualified_Simple_Name);
|
|
|
230
|
|
|
231 No_Constraint;
|
|
|
232 P_Aspect_Specifications (Package_Node, Semicolon => False);
|
|
|
233 TF_Semicolon;
|
|
|
234 Pop_Scope_Stack;
|
|
|
235
|
|
|
236 -- Generic package instantiation or package declaration
|
|
|
237
|
|
|
238 else
|
|
|
239 if Aspect_Specifications_Present then
|
|
|
240 Aspect_Sloc := Token_Ptr;
|
|
|
241 P_Aspect_Specifications (Dummy_Node, Semicolon => False);
|
|
|
242 end if;
|
|
|
243
|
|
|
244 Is_Sloc := Token_Ptr;
|
|
|
245 TF_Is;
|
|
|
246
|
|
|
247 -- Case of generic instantiation
|
|
|
248
|
|
|
249 if Token = Tok_New then
|
|
|
250 if not Pf_Flags.Gins then
|
|
|
251 Error_Msg_SC
|
|
|
252 ("generic instantiation cannot appear here!");
|
|
|
253 end if;
|
|
|
254
|
|
|
255 if Aspect_Sloc /= No_Location then
|
|
|
256 Error_Msg
|
|
|
257 ("misplaced aspects for package instantiation",
|
|
|
258 Aspect_Sloc);
|
|
|
259 end if;
|
|
|
260
|
|
|
261 Scan; -- past NEW
|
|
|
262
|
|
|
263 Package_Node :=
|
|
|
264 New_Node (N_Package_Instantiation, Package_Sloc);
|
|
|
265 Set_Defining_Unit_Name (Package_Node, Name_Node);
|
|
|
266 Set_Name (Package_Node, P_Qualified_Simple_Name);
|
|
|
267 Set_Generic_Associations
|
|
|
268 (Package_Node, P_Generic_Actual_Part_Opt);
|
|
|
269
|
|
|
270 if Aspect_Sloc /= No_Location
|
|
|
271 and then not Aspect_Specifications_Present
|
|
|
272 then
|
|
|
273 Error_Msg_SC ("info: aspect specifications belong here??");
|
|
|
274 Move_Aspects (From => Dummy_Node, To => Package_Node);
|
|
|
275 end if;
|
|
|
276
|
|
|
277 P_Aspect_Specifications (Package_Node);
|
|
|
278 Pop_Scope_Stack;
|
|
|
279
|
|
|
280 -- Case of package declaration or package specification
|
|
|
281
|
|
|
282 else
|
|
|
283 Specification_Node :=
|
|
|
284 New_Node (N_Package_Specification, Package_Sloc);
|
|
|
285
|
|
|
286 Set_Defining_Unit_Name (Specification_Node, Name_Node);
|
|
|
287 Set_Visible_Declarations
|
|
|
288 (Specification_Node, P_Basic_Declarative_Items);
|
|
|
289
|
|
|
290 if Token = Tok_Private then
|
|
|
291 Error_Msg_Col := Scope.Table (Scope.Last).Ecol;
|
|
|
292
|
|
|
293 if RM_Column_Check then
|
|
|
294 if Token_Is_At_Start_Of_Line
|
|
|
295 and then Start_Column /= Error_Msg_Col
|
|
|
296 then
|
|
|
297 Error_Msg_SC
|
|
|
298 ("(style) PRIVATE in wrong column, should be@");
|
|
|
299 end if;
|
|
|
300 end if;
|
|
|
301
|
|
|
302 Scan; -- past PRIVATE
|
|
|
303
|
|
|
304 if Token = Tok_SPARK_Hide then
|
|
|
305 Private_Part_Is_Hidden_In_SPARK := True;
|
|
|
306 Hidden_Region_Start := Token_Ptr;
|
|
|
307 Scan; -- past HIDE directive
|
|
|
308 else
|
|
|
309 Private_Part_Is_Hidden_In_SPARK := False;
|
|
|
310 end if;
|
|
|
311
|
|
|
312 Set_Private_Declarations
|
|
|
313 (Specification_Node, P_Basic_Declarative_Items);
|
|
|
314
|
|
|
315 -- In SPARK, a HIDE directive can be placed at the beginning
|
|
|
316 -- of a private part, thus hiding all declarations in the
|
|
|
317 -- private part from SPARK tool-set. No violation of the
|
|
|
318 -- SPARK restriction should be issued on nodes in a hidden
|
|
|
319 -- part, which is obtained by marking such hidden parts.
|
|
|
320
|
|
|
321 if Private_Part_Is_Hidden_In_SPARK then
|
|
|
322 Set_Hidden_Part_In_SPARK (Hidden_Region_Start, Token_Ptr);
|
|
|
323 end if;
|
|
|
324
|
|
|
325 -- Deal gracefully with multiple PRIVATE parts
|
|
|
326
|
|
|
327 while Token = Tok_Private loop
|
|
|
328 Error_Msg_SC
|
|
|
329 ("only one private part allowed per package");
|
|
|
330 Scan; -- past PRIVATE
|
|
|
331 Append_List (P_Basic_Declarative_Items,
|
|
|
332 Private_Declarations (Specification_Node));
|
|
|
333 end loop;
|
|
|
334 end if;
|
|
|
335
|
|
|
336 if Pf_Flags = Pf_Spcn then
|
|
|
337 Package_Node := Specification_Node;
|
|
|
338 else
|
|
|
339 Package_Node :=
|
|
|
340 New_Node (N_Package_Declaration, Package_Sloc);
|
|
|
341 Set_Specification (Package_Node, Specification_Node);
|
|
|
342 end if;
|
|
|
343
|
|
|
344 if Token = Tok_Begin then
|
|
|
345 Error_Msg_SC ("begin block not allowed in package spec");
|
|
|
346 Scan; -- past BEGIN
|
|
|
347 Discard_Junk_List (P_Sequence_Of_Statements (SS_None));
|
|
|
348 end if;
|
|
|
349
|
|
|
350 End_Statements (Specification_Node, Empty, Is_Sloc);
|
|
|
351 Move_Aspects (From => Dummy_Node, To => Package_Node);
|
|
|
352 end if;
|
|
|
353 end if;
|
|
|
354 end if;
|
|
|
355
|
|
|
356 return Package_Node;
|
|
|
357 end P_Package;
|
|
|
358
|
|
|
359 ------------------------------
|
|
|
360 -- 7.1 Package Declaration --
|
|
|
361 ------------------------------
|
|
|
362
|
|
|
363 -- Parsed by P_Package (7.1)
|
|
|
364
|
|
|
365 --------------------------------
|
|
|
366 -- 7.1 Package Specification --
|
|
|
367 --------------------------------
|
|
|
368
|
|
|
369 -- Parsed by P_Package (7.1)
|
|
|
370
|
|
|
371 -----------------------
|
|
|
372 -- 7.1 Package Body --
|
|
|
373 -----------------------
|
|
|
374
|
|
|
375 -- Parsed by P_Package (7.1)
|
|
|
376
|
|
|
377 -----------------------------------
|
|
|
378 -- 7.3 Private Type Declaration --
|
|
|
379 -----------------------------------
|
|
|
380
|
|
|
381 -- Parsed by P_Type_Declaration (3.2.1)
|
|
|
382
|
|
|
383 ----------------------------------------
|
|
|
384 -- 7.3 Private Extension Declaration --
|
|
|
385 ----------------------------------------
|
|
|
386
|
|
|
387 -- Parsed by P_Type_Declaration (3.2.1)
|
|
|
388
|
|
|
389 end Ch7;
|
