]>
Commit | Line | Data |
---|---|---|
996ae0b0 RK |
1 | ------------------------------------------------------------------------------ |
2 | -- -- | |
3 | -- GNAT COMPILER COMPONENTS -- | |
4 | -- -- | |
d4129bfa | 5 | -- S E M _ C H 7 -- |
996ae0b0 RK |
6 | -- -- |
7 | -- B o d y -- | |
8 | -- -- | |
4dfba737 | 9 | -- Copyright (C) 1992-2018, Free Software Foundation, Inc. -- |
996ae0b0 RK |
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- -- | |
b5c84c3c | 13 | -- ware Foundation; either version 3, or (at your option) any later ver- -- |
996ae0b0 RK |
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 -- | |
b5c84c3c RD |
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. -- | |
996ae0b0 RK |
20 | -- -- |
21 | -- GNAT was originally developed by the GNAT team at New York University. -- | |
71ff80dc | 22 | -- Extensive contributions were provided by Ada Core Technologies Inc. -- |
996ae0b0 RK |
23 | -- -- |
24 | ------------------------------------------------------------------------------ | |
25 | ||
26 | -- This package contains the routines to process package specifications and | |
27 | -- bodies. The most important semantic aspects of package processing are the | |
cec29135 ES |
28 | -- handling of private and full declarations, and the construction of dispatch |
29 | -- tables for tagged types. | |
996ae0b0 | 30 | |
879ac954 AC |
31 | with Aspects; use Aspects; |
32 | with Atree; use Atree; | |
33 | with Contracts; use Contracts; | |
34 | with Debug; use Debug; | |
35 | with Einfo; use Einfo; | |
36 | with Elists; use Elists; | |
37 | with Errout; use Errout; | |
38 | with Exp_Disp; use Exp_Disp; | |
39 | with Exp_Dist; use Exp_Dist; | |
40 | with Exp_Dbug; use Exp_Dbug; | |
136236bd | 41 | with Freeze; use Freeze; |
879ac954 AC |
42 | with Ghost; use Ghost; |
43 | with Lib; use Lib; | |
44 | with Lib.Xref; use Lib.Xref; | |
45 | with Namet; use Namet; | |
46 | with Nmake; use Nmake; | |
47 | with Nlists; use Nlists; | |
48 | with Opt; use Opt; | |
49 | with Output; use Output; | |
50 | with Restrict; use Restrict; | |
4969efdf | 51 | with Rtsfind; use Rtsfind; |
879ac954 AC |
52 | with Sem; use Sem; |
53 | with Sem_Aux; use Sem_Aux; | |
54 | with Sem_Cat; use Sem_Cat; | |
55 | with Sem_Ch3; use Sem_Ch3; | |
56 | with Sem_Ch6; use Sem_Ch6; | |
57 | with Sem_Ch8; use Sem_Ch8; | |
58 | with Sem_Ch10; use Sem_Ch10; | |
59 | with Sem_Ch12; use Sem_Ch12; | |
60 | with Sem_Ch13; use Sem_Ch13; | |
61 | with Sem_Disp; use Sem_Disp; | |
62 | with Sem_Eval; use Sem_Eval; | |
63 | with Sem_Prag; use Sem_Prag; | |
64 | with Sem_Util; use Sem_Util; | |
65 | with Sem_Warn; use Sem_Warn; | |
66 | with Snames; use Snames; | |
67 | with Stand; use Stand; | |
68 | with Sinfo; use Sinfo; | |
69 | with Sinput; use Sinput; | |
996ae0b0 | 70 | with Style; |
879ac954 | 71 | with Uintp; use Uintp; |
996ae0b0 | 72 | |
7ec25b2b AC |
73 | with GNAT.HTable; |
74 | ||
996ae0b0 RK |
75 | package body Sem_Ch7 is |
76 | ||
77 | ----------------------------------- | |
78 | -- Handling private declarations -- | |
79 | ----------------------------------- | |
80 | ||
81 | -- The principle that each entity has a single defining occurrence clashes | |
82 | -- with the presence of two separate definitions for private types: the | |
83 | -- first is the private type declaration, and the second is the full type | |
84 | -- declaration. It is important that all references to the type point to | |
44d6a706 | 85 | -- the same defining occurrence, namely the first one. To enforce the two |
996ae0b0 RK |
86 | -- separate views of the entity, the corresponding information is swapped |
87 | -- between the two declarations. Outside of the package, the defining | |
44d6a706 | 88 | -- occurrence only contains the private declaration information, while in |
996ae0b0 RK |
89 | -- the private part and the body of the package the defining occurrence |
90 | -- contains the full declaration. To simplify the swap, the defining | |
91 | -- occurrence that currently holds the private declaration points to the | |
b6434700 RH |
92 | -- full declaration. During semantic processing the defining occurrence |
93 | -- also points to a list of private dependents, that is to say access types | |
94 | -- or composite types whose designated types or component types are | |
95 | -- subtypes or derived types of the private type in question. After the | |
96 | -- full declaration has been seen, the private dependents are updated to | |
97 | -- indicate that they have full definitions. | |
996ae0b0 RK |
98 | |
99 | ----------------------- | |
100 | -- Local Subprograms -- | |
101 | ----------------------- | |
102 | ||
b1b543d2 BD |
103 | procedure Analyze_Package_Body_Helper (N : Node_Id); |
104 | -- Does all the real work of Analyze_Package_Body | |
105 | ||
3b75bcab ES |
106 | procedure Check_Anonymous_Access_Types |
107 | (Spec_Id : Entity_Id; | |
13bbad84 | 108 | P_Body : Node_Id); |
3b75bcab | 109 | -- If the spec of a package has a limited_with_clause, it may declare |
13bbad84 ES |
110 | -- anonymous access types whose designated type is a limited view, such an |
111 | -- anonymous access return type for a function. This access type cannot be | |
112 | -- elaborated in the spec itself, but it may need an itype reference if it | |
113 | -- is used within a nested scope. In that case the itype reference is | |
114 | -- created at the beginning of the corresponding package body and inserted | |
115 | -- before other body declarations. | |
116 | ||
996ae0b0 | 117 | procedure Declare_Inherited_Private_Subprograms (Id : Entity_Id); |
3b75bcab ES |
118 | -- Called upon entering the private part of a public child package and the |
119 | -- body of a nested package, to potentially declare certain inherited | |
120 | -- subprograms that were inherited by types in the visible part, but whose | |
121 | -- declaration was deferred because the parent operation was private and | |
122 | -- not visible at that point. These subprograms are located by traversing | |
123 | -- the visible part declarations looking for non-private type extensions | |
124 | -- and then examining each of the primitive operations of such types to | |
125 | -- find those that were inherited but declared with a special internal | |
126 | -- name. Each such operation is now declared as an operation with a normal | |
127 | -- name (using the name of the parent operation) and replaces the previous | |
128 | -- implicit operation in the primitive operations list of the type. If the | |
129 | -- inherited private operation has been overridden, then it's replaced by | |
130 | -- the overriding operation. | |
996ae0b0 | 131 | |
c5cec2fe AC |
132 | procedure Install_Package_Entity (Id : Entity_Id); |
133 | -- Supporting procedure for Install_{Visible,Private}_Declarations. Places | |
134 | -- one entity on its visibility chain, and recurses on the visible part if | |
135 | -- the entity is an inner package. | |
136 | ||
137 | function Is_Private_Base_Type (E : Entity_Id) return Boolean; | |
138 | -- True for a private type that is not a subtype | |
139 | ||
140 | function Is_Visible_Dependent (Dep : Entity_Id) return Boolean; | |
141 | -- If the private dependent is a private type whose full view is derived | |
142 | -- from the parent type, its full properties are revealed only if we are in | |
143 | -- the immediate scope of the private dependent. Should this predicate be | |
144 | -- tightened further??? | |
145 | ||
146 | function Requires_Completion_In_Body | |
22a4f9d5 AC |
147 | (Id : Entity_Id; |
148 | Pack_Id : Entity_Id; | |
149 | Do_Abstract_States : Boolean := False) return Boolean; | |
c5cec2fe AC |
150 | -- Subsidiary to routines Unit_Requires_Body and Unit_Requires_Body_Info. |
151 | -- Determine whether entity Id declared in package spec Pack_Id requires | |
22a4f9d5 AC |
152 | -- completion in a package body. Flag Do_Abstract_Stats should be set when |
153 | -- abstract states are to be considered in the completion test. | |
c5cec2fe AC |
154 | |
155 | procedure Unit_Requires_Body_Info (Pack_Id : Entity_Id); | |
156 | -- Outputs info messages showing why package Pack_Id requires a body. The | |
157 | -- caller has checked that the switch requesting this information is set, | |
158 | -- and that the package does indeed require a body. | |
98779361 | 159 | |
996ae0b0 RK |
160 | -------------------------- |
161 | -- Analyze_Package_Body -- | |
162 | -------------------------- | |
163 | ||
164 | procedure Analyze_Package_Body (N : Node_Id) is | |
b1b543d2 BD |
165 | Loc : constant Source_Ptr := Sloc (N); |
166 | ||
167 | begin | |
168 | if Debug_Flag_C then | |
169 | Write_Str ("==> package body "); | |
170 | Write_Name (Chars (Defining_Entity (N))); | |
171 | Write_Str (" from "); | |
172 | Write_Location (Loc); | |
173 | Write_Eol; | |
174 | Indent; | |
175 | end if; | |
176 | ||
177 | -- The real work is split out into the helper, so it can do "return;" | |
178 | -- without skipping the debug output. | |
179 | ||
180 | Analyze_Package_Body_Helper (N); | |
181 | ||
182 | if Debug_Flag_C then | |
183 | Outdent; | |
184 | Write_Str ("<== package body "); | |
185 | Write_Name (Chars (Defining_Entity (N))); | |
186 | Write_Str (" from "); | |
187 | Write_Location (Loc); | |
188 | Write_Eol; | |
189 | end if; | |
190 | end Analyze_Package_Body; | |
191 | ||
7ec25b2b AC |
192 | ------------------------------------------------------ |
193 | -- Analyze_Package_Body_Helper Data and Subprograms -- | |
194 | ------------------------------------------------------ | |
195 | ||
5efb89d0 | 196 | Entity_Table_Size : constant := 4093; |
7ec25b2b AC |
197 | -- Number of headers in hash table |
198 | ||
199 | subtype Entity_Header_Num is Integer range 0 .. Entity_Table_Size - 1; | |
200 | -- Range of headers in hash table | |
201 | ||
5168a9b3 | 202 | function Node_Hash (Id : Entity_Id) return Entity_Header_Num; |
7ec25b2b AC |
203 | -- Simple hash function for Entity_Ids |
204 | ||
205 | package Subprogram_Table is new GNAT.Htable.Simple_HTable | |
206 | (Header_Num => Entity_Header_Num, | |
207 | Element => Boolean, | |
208 | No_Element => False, | |
209 | Key => Entity_Id, | |
5168a9b3 | 210 | Hash => Node_Hash, |
7ec25b2b AC |
211 | Equal => "="); |
212 | -- Hash table to record which subprograms are referenced. It is declared | |
213 | -- at library level to avoid elaborating it for every call to Analyze. | |
214 | ||
5168a9b3 PMR |
215 | package Traversed_Table is new GNAT.Htable.Simple_HTable |
216 | (Header_Num => Entity_Header_Num, | |
217 | Element => Boolean, | |
218 | No_Element => False, | |
219 | Key => Node_Id, | |
220 | Hash => Node_Hash, | |
221 | Equal => "="); | |
222 | -- Hash table to record which nodes we have traversed, so we can avoid | |
223 | -- traversing the same nodes repeatedly. | |
224 | ||
7ec25b2b | 225 | ----------------- |
5168a9b3 | 226 | -- Node_Hash -- |
7ec25b2b AC |
227 | ----------------- |
228 | ||
5168a9b3 | 229 | function Node_Hash (Id : Entity_Id) return Entity_Header_Num is |
7ec25b2b AC |
230 | begin |
231 | return Entity_Header_Num (Id mod Entity_Table_Size); | |
5168a9b3 | 232 | end Node_Hash; |
7ec25b2b | 233 | |
b1b543d2 BD |
234 | --------------------------------- |
235 | -- Analyze_Package_Body_Helper -- | |
236 | --------------------------------- | |
237 | ||
b0bf18ad AC |
238 | -- WARNING: This routine manages Ghost regions. Return statements must be |
239 | -- replaced by gotos which jump to the end of the routine and restore the | |
240 | -- Ghost mode. | |
241 | ||
b1b543d2 | 242 | procedure Analyze_Package_Body_Helper (N : Node_Id) is |
13fa2acb AC |
243 | procedure Hide_Public_Entities (Decls : List_Id); |
244 | -- Attempt to hide all public entities found in declarative list Decls | |
245 | -- by resetting their Is_Public flag to False depending on whether the | |
246 | -- entities are not referenced by inlined or generic bodies. This kind | |
7ec25b2b AC |
247 | -- of processing is a conservative approximation and will still leave |
248 | -- entities externally visible if the package is not simple enough. | |
996ae0b0 | 249 | |
fbf5a39b | 250 | procedure Install_Composite_Operations (P : Entity_Id); |
cec29135 ES |
251 | -- Composite types declared in the current scope may depend on types |
252 | -- that were private at the point of declaration, and whose full view | |
253 | -- is now in scope. Indicate that the corresponding operations on the | |
254 | -- composite type are available. | |
fbf5a39b | 255 | |
13fa2acb AC |
256 | -------------------------- |
257 | -- Hide_Public_Entities -- | |
258 | -------------------------- | |
259 | ||
260 | procedure Hide_Public_Entities (Decls : List_Id) is | |
13fa2acb AC |
261 | function Has_Referencer |
262 | (Decls : List_Id; | |
263 | Top_Level : Boolean := False) return Boolean; | |
264 | -- A "referencer" is a construct which may reference a previous | |
265 | -- declaration. Examine all declarations in list Decls in reverse | |
266 | -- and determine whether once such referencer exists. All entities | |
267 | -- in the range Last (Decls) .. Referencer are hidden from external | |
268 | -- visibility. | |
269 | ||
7ec25b2b AC |
270 | function Scan_Subprogram_Ref (N : Node_Id) return Traverse_Result; |
271 | -- Determine whether a node denotes a reference to a subprogram | |
13fa2acb | 272 | |
5168a9b3 | 273 | procedure Traverse_And_Scan_Subprogram_Refs is |
7ec25b2b AC |
274 | new Traverse_Proc (Scan_Subprogram_Ref); |
275 | -- Subsidiary to routine Has_Referencer. Determine whether a node | |
276 | -- contains references to a subprogram and record them. | |
277 | -- WARNING: this is a very expensive routine as it performs a full | |
278 | -- tree traversal. | |
13fa2acb | 279 | |
5168a9b3 PMR |
280 | procedure Scan_Subprogram_Refs (Node : Node_Id); |
281 | -- If we haven't already traversed Node, then mark it and traverse | |
282 | -- it. | |
283 | ||
13fa2acb AC |
284 | -------------------- |
285 | -- Has_Referencer -- | |
286 | -------------------- | |
287 | ||
288 | function Has_Referencer | |
289 | (Decls : List_Id; | |
290 | Top_Level : Boolean := False) return Boolean | |
291 | is | |
292 | Decl : Node_Id; | |
293 | Decl_Id : Entity_Id; | |
294 | Spec : Node_Id; | |
295 | ||
6e9e35e1 | 296 | Has_Non_Subprograms_Referencer : Boolean := False; |
7ec25b2b AC |
297 | -- Set if an inlined subprogram body was detected as a referencer. |
298 | -- In this case, we do not return True immediately but keep hiding | |
299 | -- subprograms from external visibility. | |
13fa2acb AC |
300 | |
301 | begin | |
302 | if No (Decls) then | |
303 | return False; | |
304 | end if; | |
305 | ||
306 | -- Examine all declarations in reverse order, hiding all entities | |
307 | -- from external visibility until a referencer has been found. The | |
308 | -- algorithm recurses into nested packages. | |
309 | ||
310 | Decl := Last (Decls); | |
311 | while Present (Decl) loop | |
312 | ||
313 | -- A stub is always considered a referencer | |
314 | ||
315 | if Nkind (Decl) in N_Body_Stub then | |
316 | return True; | |
317 | ||
318 | -- Package declaration | |
319 | ||
6e9e35e1 | 320 | elsif Nkind (Decl) = N_Package_Declaration then |
13fa2acb AC |
321 | Spec := Specification (Decl); |
322 | ||
323 | -- Inspect the declarations of a non-generic package to try | |
324 | -- and hide more entities from external visibility. | |
325 | ||
326 | if not Is_Generic_Unit (Defining_Entity (Spec)) then | |
327 | if Has_Referencer (Private_Declarations (Spec)) | |
328 | or else Has_Referencer (Visible_Declarations (Spec)) | |
329 | then | |
330 | return True; | |
331 | end if; | |
332 | end if; | |
333 | ||
334 | -- Package body | |
335 | ||
336 | elsif Nkind (Decl) = N_Package_Body | |
337 | and then Present (Corresponding_Spec (Decl)) | |
338 | then | |
339 | Decl_Id := Corresponding_Spec (Decl); | |
340 | ||
341 | -- A generic package body is a referencer. It would seem | |
342 | -- that we only have to consider generics that can be | |
343 | -- exported, i.e. where the corresponding spec is the | |
344 | -- spec of the current package, but because of nested | |
345 | -- instantiations, a fully private generic body may export | |
346 | -- other private body entities. Furthermore, regardless of | |
347 | -- whether there was a previous inlined subprogram, (an | |
348 | -- instantiation of) the generic package may reference any | |
349 | -- entity declared before it. | |
350 | ||
351 | if Is_Generic_Unit (Decl_Id) then | |
352 | return True; | |
353 | ||
354 | -- Inspect the declarations of a non-generic package body to | |
355 | -- try and hide more entities from external visibility. | |
356 | ||
6e9e35e1 | 357 | elsif Has_Referencer (Declarations (Decl)) then |
13fa2acb AC |
358 | return True; |
359 | end if; | |
360 | ||
361 | -- Subprogram body | |
362 | ||
363 | elsif Nkind (Decl) = N_Subprogram_Body then | |
364 | if Present (Corresponding_Spec (Decl)) then | |
365 | Decl_Id := Corresponding_Spec (Decl); | |
366 | ||
367 | -- A generic subprogram body acts as a referencer | |
368 | ||
369 | if Is_Generic_Unit (Decl_Id) then | |
370 | return True; | |
371 | end if; | |
372 | ||
373 | -- An inlined subprogram body acts as a referencer | |
374 | ||
7c15c6dd AC |
375 | -- Note that we test Has_Pragma_Inline here in addition |
376 | -- to Is_Inlined. We are doing this for a client, since | |
377 | -- we are computing which entities should be public, and | |
378 | -- it is the client who will decide if actual inlining | |
379 | -- should occur, so we need to catch all cases where the | |
380 | -- subprogram may be inlined by the client. | |
381 | ||
13fa2acb AC |
382 | if Is_Inlined (Decl_Id) |
383 | or else Has_Pragma_Inline (Decl_Id) | |
384 | then | |
7ec25b2b AC |
385 | Has_Non_Subprograms_Referencer := True; |
386 | ||
13fa2acb AC |
387 | -- Inspect the statements of the subprogram body |
388 | -- to determine whether the body references other | |
6e9e35e1 | 389 | -- subprograms. |
13fa2acb | 390 | |
7ec25b2b | 391 | Scan_Subprogram_Refs (Decl); |
13fa2acb AC |
392 | end if; |
393 | ||
394 | -- Otherwise this is a stand alone subprogram body | |
395 | ||
396 | else | |
397 | Decl_Id := Defining_Entity (Decl); | |
398 | ||
7ec25b2b | 399 | -- An inlined subprogram body acts as a referencer |
13fa2acb | 400 | |
7c15c6dd AC |
401 | if Is_Inlined (Decl_Id) |
402 | or else Has_Pragma_Inline (Decl_Id) | |
403 | then | |
7ec25b2b AC |
404 | Has_Non_Subprograms_Referencer := True; |
405 | ||
406 | -- Inspect the statements of the subprogram body | |
407 | -- to determine whether the body references other | |
408 | -- subprograms. | |
409 | ||
410 | Scan_Subprogram_Refs (Decl); | |
411 | ||
412 | -- Otherwise we can reset Is_Public right away | |
413 | ||
414 | elsif not Subprogram_Table.Get (Decl_Id) then | |
13fa2acb AC |
415 | Set_Is_Public (Decl_Id, False); |
416 | end if; | |
417 | end if; | |
418 | ||
0691ed6b AC |
419 | -- Freeze node |
420 | ||
421 | elsif Nkind (Decl) = N_Freeze_Entity then | |
422 | declare | |
423 | Discard : Boolean; | |
424 | pragma Unreferenced (Discard); | |
425 | begin | |
426 | -- Inspect the actions to find references to subprograms | |
427 | ||
428 | Discard := Has_Referencer (Actions (Decl)); | |
429 | end; | |
430 | ||
13fa2acb AC |
431 | -- Exceptions, objects and renamings do not need to be public |
432 | -- if they are not followed by a construct which can reference | |
433 | -- and export them. The Is_Public flag is reset on top level | |
434 | -- entities only as anything nested is local to its context. | |
7ec25b2b | 435 | -- Likewise for subprograms, but we work harder for them. |
13fa2acb AC |
436 | |
437 | elsif Nkind_In (Decl, N_Exception_Declaration, | |
438 | N_Object_Declaration, | |
439 | N_Object_Renaming_Declaration, | |
440 | N_Subprogram_Declaration, | |
441 | N_Subprogram_Renaming_Declaration) | |
442 | then | |
443 | Decl_Id := Defining_Entity (Decl); | |
444 | ||
445 | if Top_Level | |
446 | and then not Is_Imported (Decl_Id) | |
447 | and then not Is_Exported (Decl_Id) | |
448 | and then No (Interface_Name (Decl_Id)) | |
449 | and then | |
6e9e35e1 | 450 | (not Has_Non_Subprograms_Referencer |
7ec25b2b AC |
451 | or else (Nkind (Decl) = N_Subprogram_Declaration |
452 | and then not Subprogram_Table.Get (Decl_Id))) | |
13fa2acb AC |
453 | then |
454 | Set_Is_Public (Decl_Id, False); | |
455 | end if; | |
1155ae01 AC |
456 | |
457 | -- For a subprogram renaming, if the entity is referenced, | |
458 | -- then so is the renamed subprogram. But there is an issue | |
459 | -- with generic bodies because instantiations are not done | |
460 | -- yet and, therefore, cannot be scanned for referencers. | |
461 | -- That's why we use an approximation and test that we have | |
462 | -- at least one subprogram referenced by an inlined body | |
463 | -- instead of precisely the entity of this renaming. | |
464 | ||
465 | if Nkind (Decl) = N_Subprogram_Renaming_Declaration | |
466 | and then Subprogram_Table.Get_First | |
467 | and then Is_Entity_Name (Name (Decl)) | |
468 | and then Present (Entity (Name (Decl))) | |
469 | and then Is_Subprogram (Entity (Name (Decl))) | |
470 | then | |
471 | Subprogram_Table.Set (Entity (Name (Decl)), True); | |
472 | end if; | |
13fa2acb AC |
473 | end if; |
474 | ||
475 | Prev (Decl); | |
476 | end loop; | |
477 | ||
6e9e35e1 | 478 | return Has_Non_Subprograms_Referencer; |
13fa2acb AC |
479 | end Has_Referencer; |
480 | ||
7ec25b2b AC |
481 | ------------------------- |
482 | -- Scan_Subprogram_Ref -- | |
483 | ------------------------- | |
484 | ||
485 | function Scan_Subprogram_Ref (N : Node_Id) return Traverse_Result is | |
486 | begin | |
487 | -- Detect a reference of the form | |
488 | -- Subp_Call | |
489 | ||
490 | if Nkind (N) in N_Subprogram_Call | |
491 | and then Is_Entity_Name (Name (N)) | |
492 | and then Present (Entity (Name (N))) | |
493 | and then Is_Subprogram (Entity (Name (N))) | |
494 | then | |
495 | Subprogram_Table.Set (Entity (Name (N)), True); | |
496 | ||
497 | -- Detect a reference of the form | |
498 | -- Subp'Some_Attribute | |
499 | ||
500 | elsif Nkind (N) = N_Attribute_Reference | |
501 | and then Is_Entity_Name (Prefix (N)) | |
502 | and then Present (Entity (Prefix (N))) | |
503 | and then Is_Subprogram (Entity (Prefix (N))) | |
504 | then | |
505 | Subprogram_Table.Set (Entity (Prefix (N)), True); | |
506 | ||
507 | -- Constants can be substituted by their value in gigi, which may | |
508 | -- contain a reference, so scan the value recursively. | |
509 | ||
510 | elsif Is_Entity_Name (N) | |
511 | and then Present (Entity (N)) | |
512 | and then Ekind (Entity (N)) = E_Constant | |
513 | then | |
514 | declare | |
515 | Val : constant Node_Id := Constant_Value (Entity (N)); | |
516 | begin | |
517 | if Present (Val) | |
518 | and then not Compile_Time_Known_Value (Val) | |
519 | then | |
520 | Scan_Subprogram_Refs (Val); | |
521 | end if; | |
522 | end; | |
523 | end if; | |
524 | ||
525 | return OK; | |
526 | end Scan_Subprogram_Ref; | |
527 | ||
3fc40cd7 PMR |
528 | -------------------------- |
529 | -- Scan_Subprogram_Refs -- | |
530 | -------------------------- | |
531 | ||
532 | procedure Scan_Subprogram_Refs (Node : Node_Id) is | |
533 | begin | |
534 | if not Traversed_Table.Get (Node) then | |
535 | Traversed_Table.Set (Node, True); | |
536 | Traverse_And_Scan_Subprogram_Refs (Node); | |
537 | end if; | |
538 | end Scan_Subprogram_Refs; | |
539 | ||
13fa2acb AC |
540 | -- Local variables |
541 | ||
0691ed6b | 542 | Discard : Boolean; |
13fa2acb AC |
543 | pragma Unreferenced (Discard); |
544 | ||
545 | -- Start of processing for Hide_Public_Entities | |
546 | ||
547 | begin | |
548 | -- The algorithm examines the top level declarations of a package | |
549 | -- body in reverse looking for a construct that may export entities | |
550 | -- declared prior to it. If such a scenario is encountered, then all | |
551 | -- entities in the range Last (Decls) .. construct are hidden from | |
552 | -- external visibility. Consider: | |
553 | ||
554 | -- package Pack is | |
555 | -- generic | |
556 | -- package Gen is | |
557 | -- end Gen; | |
558 | -- end Pack; | |
559 | ||
560 | -- package body Pack is | |
561 | -- External_Obj : ...; -- (1) | |
562 | ||
563 | -- package body Gen is -- (2) | |
564 | -- ... External_Obj ... -- (3) | |
565 | -- end Gen; | |
566 | ||
567 | -- Local_Obj : ...; -- (4) | |
568 | -- end Pack; | |
569 | ||
570 | -- In this example Local_Obj (4) must not be externally visible as | |
571 | -- it cannot be exported by anything in Pack. The body of generic | |
572 | -- package Gen (2) on the other hand acts as a "referencer" and may | |
573 | -- export anything declared before it. Since the compiler does not | |
574 | -- perform flow analysis, it is not possible to determine precisely | |
575 | -- which entities will be exported when Gen is instantiated. In the | |
576 | -- example above External_Obj (1) is exported at (3), but this may | |
577 | -- not always be the case. The algorithm takes a conservative stance | |
578 | -- and leaves entity External_Obj public. | |
579 | ||
7ec25b2b AC |
580 | -- This very conservative algorithm is supplemented by a more precise |
581 | -- processing for inlined bodies. For them, we traverse the syntactic | |
582 | -- tree and record which subprograms are actually referenced from it. | |
583 | -- This makes it possible to compute a much smaller set of externally | |
66f95f60 AC |
584 | -- visible subprograms in the absence of generic bodies, which can |
585 | -- have a significant impact on the inlining decisions made in the | |
586 | -- back end and the removal of out-of-line bodies from the object | |
587 | -- code. We do it only for inlined bodies because they are supposed | |
588 | -- to be reasonably small and tree traversal is very expensive. | |
7ec25b2b AC |
589 | |
590 | -- Note that even this special processing is not optimal for inlined | |
591 | -- bodies, because we treat all inlined subprograms alike. An optimal | |
592 | -- algorithm would require computing the transitive closure of the | |
593 | -- inlined subprograms that can really be referenced from other units | |
594 | -- in the source code. | |
595 | ||
596 | -- We could extend this processing for inlined bodies and record all | |
597 | -- entities, not just subprograms, referenced from them, which would | |
598 | -- make it possible to compute a much smaller set of all externally | |
599 | -- visible entities in the absence of generic bodies. But this would | |
600 | -- mean implementing a more thorough tree traversal of the bodies, | |
601 | -- i.e. not just syntactic, and the gain would very likely be worth | |
602 | -- neither the hassle nor the slowdown of the compiler. | |
603 | ||
fe683ef6 AC |
604 | -- Finally, an important thing to be aware of is that, at this point, |
605 | -- instantiations are not done yet so we cannot directly see inlined | |
606 | -- bodies coming from them. That's not catastrophic because only the | |
607 | -- actual parameters of the instantiations matter here, and they are | |
608 | -- present in the declarations list of the instantiated packages. | |
609 | ||
5168a9b3 | 610 | Traversed_Table.Reset; |
7ec25b2b | 611 | Subprogram_Table.Reset; |
13fa2acb AC |
612 | Discard := Has_Referencer (Decls, Top_Level => True); |
613 | end Hide_Public_Entities; | |
614 | ||
fbf5a39b AC |
615 | ---------------------------------- |
616 | -- Install_Composite_Operations -- | |
617 | ---------------------------------- | |
618 | ||
619 | procedure Install_Composite_Operations (P : Entity_Id) is | |
620 | Id : Entity_Id; | |
621 | ||
622 | begin | |
623 | Id := First_Entity (P); | |
fbf5a39b | 624 | while Present (Id) loop |
fbf5a39b AC |
625 | if Is_Type (Id) |
626 | and then (Is_Limited_Composite (Id) | |
627 | or else Is_Private_Composite (Id)) | |
628 | and then No (Private_Component (Id)) | |
629 | then | |
630 | Set_Is_Limited_Composite (Id, False); | |
631 | Set_Is_Private_Composite (Id, False); | |
632 | end if; | |
633 | ||
634 | Next_Entity (Id); | |
635 | end loop; | |
636 | end Install_Composite_Operations; | |
637 | ||
13fa2acb AC |
638 | -- Local variables |
639 | ||
f9a8f910 | 640 | Saved_GM : constant Ghost_Mode_Type := Ghost_Mode; |
9057bd6a | 641 | Saved_IGR : constant Node_Id := Ignored_Ghost_Region; |
f9a8f910 HK |
642 | Saved_ISMP : constant Boolean := |
643 | Ignore_SPARK_Mode_Pragmas_In_Instance; | |
644 | -- Save the Ghost and SPARK mode-related data to restore on exit | |
cf9a473e | 645 | |
13fa2acb AC |
646 | Body_Id : Entity_Id; |
647 | HSS : Node_Id; | |
648 | Last_Spec_Entity : Entity_Id; | |
649 | New_N : Node_Id; | |
650 | Pack_Decl : Node_Id; | |
651 | Spec_Id : Entity_Id; | |
652 | ||
b1b543d2 | 653 | -- Start of processing for Analyze_Package_Body_Helper |
fbf5a39b | 654 | |
996ae0b0 | 655 | begin |
cec29135 ES |
656 | -- Find corresponding package specification, and establish the current |
657 | -- scope. The visible defining entity for the package is the defining | |
658 | -- occurrence in the spec. On exit from the package body, all body | |
659 | -- declarations are attached to the defining entity for the body, but | |
660 | -- the later is never used for name resolution. In this fashion there | |
661 | -- is only one visible entity that denotes the package. | |
996ae0b0 | 662 | |
cdcf1c7a | 663 | -- Set Body_Id. Note that this will be reset to point to the generic |
cec29135 | 664 | -- copy later on in the generic case. |
996ae0b0 RK |
665 | |
666 | Body_Id := Defining_Entity (N); | |
667 | ||
54e28df2 HK |
668 | -- Body is body of package instantiation. Corresponding spec has already |
669 | -- been set. | |
cdcf1c7a | 670 | |
996ae0b0 | 671 | if Present (Corresponding_Spec (N)) then |
c5cec2fe | 672 | Spec_Id := Corresponding_Spec (N); |
996ae0b0 RK |
673 | Pack_Decl := Unit_Declaration_Node (Spec_Id); |
674 | ||
675 | else | |
676 | Spec_Id := Current_Entity_In_Scope (Defining_Entity (N)); | |
677 | ||
c5cec2fe AC |
678 | if Present (Spec_Id) |
679 | and then Is_Package_Or_Generic_Package (Spec_Id) | |
996ae0b0 RK |
680 | then |
681 | Pack_Decl := Unit_Declaration_Node (Spec_Id); | |
682 | ||
683 | if Nkind (Pack_Decl) = N_Package_Renaming_Declaration then | |
684 | Error_Msg_N ("cannot supply body for package renaming", N); | |
685 | return; | |
686 | ||
687 | elsif Present (Corresponding_Body (Pack_Decl)) then | |
688 | Error_Msg_N ("redefinition of package body", N); | |
689 | return; | |
690 | end if; | |
691 | ||
692 | else | |
693 | Error_Msg_N ("missing specification for package body", N); | |
694 | return; | |
695 | end if; | |
696 | ||
a59e9305 | 697 | if Is_Package_Or_Generic_Package (Spec_Id) |
0877856b AC |
698 | and then (Scope (Spec_Id) = Standard_Standard |
699 | or else Is_Child_Unit (Spec_Id)) | |
996ae0b0 RK |
700 | and then not Unit_Requires_Body (Spec_Id) |
701 | then | |
0ab80019 | 702 | if Ada_Version = Ada_83 then |
996ae0b0 | 703 | Error_Msg_N |
dbfeb4fa | 704 | ("optional package body (not allowed in Ada 95)??", N); |
996ae0b0 | 705 | else |
ed2233dc | 706 | Error_Msg_N ("spec of this package does not allow a body", N); |
996ae0b0 RK |
707 | end if; |
708 | end if; | |
709 | end if; | |
710 | ||
65e5747e PMR |
711 | -- A [generic] package body freezes the contract of the nearest |
712 | -- enclosing package body and all other contracts encountered in | |
713 | -- the same declarative part up to and excluding the package body: | |
680d5f61 AC |
714 | |
715 | -- package body Nearest_Enclosing_Package | |
716 | -- with Refined_State => (State => Constit) | |
717 | -- is | |
718 | -- Constit : ...; | |
719 | ||
720 | -- package body Freezes_Enclosing_Package_Body | |
721 | -- with Refined_State => (State_2 => Constit_2) | |
722 | -- is | |
723 | -- Constit_2 : ...; | |
724 | ||
725 | -- procedure Proc | |
726 | -- with Refined_Depends => (Input => (Constit, Constit_2)) ... | |
727 | ||
728 | -- This ensures that any annotations referenced by the contract of a | |
729 | -- [generic] subprogram body declared within the current package body | |
65e5747e | 730 | -- are available. This form of freezing is decoupled from the usual |
680d5f61 AC |
731 | -- Freeze_xxx mechanism because it must also work in the context of |
732 | -- generics where normal freezing is disabled. | |
733 | ||
65e5747e | 734 | -- Only bodies coming from source should cause this type of freezing. |
680d5f61 AC |
735 | -- Instantiated generic bodies are excluded because their processing is |
736 | -- performed in a separate compilation pass which lacks enough semantic | |
737 | -- information with respect to contract analysis. It is safe to suppress | |
65e5747e | 738 | -- the freezing of contracts in this case because this action already |
680d5f61 AC |
739 | -- took place at the end of the enclosing declarative part. |
740 | ||
741 | if Comes_From_Source (N) | |
742 | and then not Is_Generic_Instance (Spec_Id) | |
743 | then | |
65e5747e | 744 | Freeze_Previous_Contracts (N); |
680d5f61 AC |
745 | end if; |
746 | ||
1af4455a HK |
747 | -- A package body is Ghost when the corresponding spec is Ghost. Set |
748 | -- the mode now to ensure that any nodes generated during analysis and | |
749 | -- expansion are properly flagged as ignored Ghost. | |
8636f52f | 750 | |
f9a8f910 | 751 | Mark_And_Set_Ghost_Body (N, Spec_Id); |
8636f52f | 752 | |
7255f3c3 HK |
753 | -- If the body completes the initial declaration of a compilation unit |
754 | -- which is subject to pragma Elaboration_Checks, set the model of the | |
755 | -- pragma because it applies to all parts of the unit. | |
756 | ||
757 | Install_Elaboration_Model (Spec_Id); | |
758 | ||
996ae0b0 RK |
759 | Set_Is_Compilation_Unit (Body_Id, Is_Compilation_Unit (Spec_Id)); |
760 | Style.Check_Identifier (Body_Id, Spec_Id); | |
761 | ||
762 | if Is_Child_Unit (Spec_Id) then | |
996ae0b0 RK |
763 | if Nkind (Parent (N)) /= N_Compilation_Unit then |
764 | Error_Msg_NE | |
765 | ("body of child unit& cannot be an inner package", N, Spec_Id); | |
766 | end if; | |
767 | ||
768 | Set_Is_Child_Unit (Body_Id); | |
769 | end if; | |
770 | ||
771 | -- Generic package case | |
772 | ||
773 | if Ekind (Spec_Id) = E_Generic_Package then | |
774 | ||
cec29135 ES |
775 | -- Disable expansion and perform semantic analysis on copy. The |
776 | -- unannotated body will be used in all instantiations. | |
996ae0b0 RK |
777 | |
778 | Body_Id := Defining_Entity (N); | |
779 | Set_Ekind (Body_Id, E_Package_Body); | |
780 | Set_Scope (Body_Id, Scope (Spec_Id)); | |
3b75bcab | 781 | Set_Is_Obsolescent (Body_Id, Is_Obsolescent (Spec_Id)); |
996ae0b0 RK |
782 | Set_Body_Entity (Spec_Id, Body_Id); |
783 | Set_Spec_Entity (Body_Id, Spec_Id); | |
784 | ||
785 | New_N := Copy_Generic_Node (N, Empty, Instantiating => False); | |
786 | Rewrite (N, New_N); | |
787 | ||
c0cdbd39 AC |
788 | -- Once the contents of the generic copy and the template are |
789 | -- swapped, do the same for their respective aspect specifications. | |
790 | ||
791 | Exchange_Aspects (N, New_N); | |
792 | ||
caf07df9 AC |
793 | -- Collect all contract-related source pragmas found within the |
794 | -- template and attach them to the contract of the package body. | |
795 | -- This contract is used in the capture of global references within | |
796 | -- annotations. | |
797 | ||
798 | Create_Generic_Contract (N); | |
799 | ||
cec29135 ES |
800 | -- Update Body_Id to point to the copied node for the remainder of |
801 | -- the processing. | |
996ae0b0 RK |
802 | |
803 | Body_Id := Defining_Entity (N); | |
804 | Start_Generic; | |
805 | end if; | |
806 | ||
807 | -- The Body_Id is that of the copied node in the generic case, the | |
cec29135 ES |
808 | -- current node otherwise. Note that N was rewritten above, so we must |
809 | -- be sure to get the latest Body_Id value. | |
996ae0b0 RK |
810 | |
811 | Set_Ekind (Body_Id, E_Package_Body); | |
812 | Set_Body_Entity (Spec_Id, Body_Id); | |
813 | Set_Spec_Entity (Body_Id, Spec_Id); | |
814 | ||
cec29135 ES |
815 | -- Defining name for the package body is not a visible entity: Only the |
816 | -- defining name for the declaration is visible. | |
996ae0b0 RK |
817 | |
818 | Set_Etype (Body_Id, Standard_Void_Type); | |
819 | Set_Scope (Body_Id, Scope (Spec_Id)); | |
820 | Set_Corresponding_Spec (N, Spec_Id); | |
821 | Set_Corresponding_Body (Pack_Decl, Body_Id); | |
822 | ||
823 | -- The body entity is not used for semantics or code generation, but | |
824 | -- it is attached to the entity list of the enclosing scope to simplify | |
825 | -- the listing of back-annotations for the types it main contain. | |
826 | ||
827 | if Scope (Spec_Id) /= Standard_Standard then | |
828 | Append_Entity (Body_Id, Scope (Spec_Id)); | |
829 | end if; | |
830 | ||
a5b62485 | 831 | -- Indicate that we are currently compiling the body of the package |
996ae0b0 RK |
832 | |
833 | Set_In_Package_Body (Spec_Id); | |
834 | Set_Has_Completion (Spec_Id); | |
835 | Last_Spec_Entity := Last_Entity (Spec_Id); | |
836 | ||
54e28df2 HK |
837 | if Has_Aspects (N) then |
838 | Analyze_Aspect_Specifications (N, Body_Id); | |
839 | end if; | |
840 | ||
495d6dd6 | 841 | Push_Scope (Spec_Id); |
996ae0b0 | 842 | |
f90d14ac | 843 | -- Set SPARK_Mode only for non-generic package |
579847c2 | 844 | |
f90d14ac | 845 | if Ekind (Spec_Id) = E_Package then |
877a5a12 AC |
846 | Set_SPARK_Pragma (Body_Id, SPARK_Mode_Pragma); |
847 | Set_SPARK_Aux_Pragma (Body_Id, SPARK_Mode_Pragma); | |
848 | Set_SPARK_Pragma_Inherited (Body_Id); | |
f145ece7 | 849 | Set_SPARK_Aux_Pragma_Inherited (Body_Id); |
cf9a473e AC |
850 | |
851 | -- A package body may be instantiated or inlined at a later pass. | |
852 | -- Restore the state of Ignore_SPARK_Mode_Pragmas_In_Instance when | |
853 | -- it applied to the package spec. | |
854 | ||
855 | if Ignore_SPARK_Mode_Pragmas (Spec_Id) then | |
856 | Ignore_SPARK_Mode_Pragmas_In_Instance := True; | |
857 | end if; | |
f90d14ac | 858 | end if; |
579847c2 | 859 | |
996ae0b0 RK |
860 | Set_Categorization_From_Pragmas (N); |
861 | ||
862 | Install_Visible_Declarations (Spec_Id); | |
863 | Install_Private_Declarations (Spec_Id); | |
8a6a52dc | 864 | Install_Private_With_Clauses (Spec_Id); |
996ae0b0 RK |
865 | Install_Composite_Operations (Spec_Id); |
866 | ||
3b75bcab ES |
867 | Check_Anonymous_Access_Types (Spec_Id, N); |
868 | ||
996ae0b0 RK |
869 | if Ekind (Spec_Id) = E_Generic_Package then |
870 | Set_Use (Generic_Formal_Declarations (Pack_Decl)); | |
871 | end if; | |
872 | ||
873 | Set_Use (Visible_Declarations (Specification (Pack_Decl))); | |
874 | Set_Use (Private_Declarations (Specification (Pack_Decl))); | |
875 | ||
13bbad84 ES |
876 | -- This is a nested package, so it may be necessary to declare certain |
877 | -- inherited subprograms that are not yet visible because the parent | |
878 | -- type's subprograms are now visible. | |
996ae0b0 RK |
879 | |
880 | if Ekind (Scope (Spec_Id)) = E_Package | |
881 | and then Scope (Spec_Id) /= Standard_Standard | |
882 | then | |
883 | Declare_Inherited_Private_Subprograms (Spec_Id); | |
884 | end if; | |
885 | ||
886 | if Present (Declarations (N)) then | |
887 | Analyze_Declarations (Declarations (N)); | |
13bbad84 ES |
888 | Inspect_Deferred_Constant_Completion (Declarations (N)); |
889 | end if; | |
890 | ||
f3124d8f | 891 | -- Verify that the SPARK_Mode of the body agrees with that of its spec |
f90d14ac | 892 | |
f1c7be38 | 893 | if Present (SPARK_Pragma (Body_Id)) then |
df910722 | 894 | if Present (SPARK_Aux_Pragma (Spec_Id)) then |
933aa0ac AC |
895 | if Get_SPARK_Mode_From_Annotation (SPARK_Aux_Pragma (Spec_Id)) = |
896 | Off | |
897 | and then | |
898 | Get_SPARK_Mode_From_Annotation (SPARK_Pragma (Body_Id)) = On | |
f90d14ac AC |
899 | then |
900 | Error_Msg_Sloc := Sloc (SPARK_Pragma (Body_Id)); | |
901 | Error_Msg_N ("incorrect application of SPARK_Mode#", N); | |
902 | Error_Msg_Sloc := Sloc (SPARK_Aux_Pragma (Spec_Id)); | |
cf3e6845 AC |
903 | Error_Msg_NE |
904 | ("\value Off was set for SPARK_Mode on & #", N, Spec_Id); | |
f90d14ac AC |
905 | end if; |
906 | ||
907 | else | |
908 | Error_Msg_Sloc := Sloc (SPARK_Pragma (Body_Id)); | |
909 | Error_Msg_N ("incorrect application of SPARK_Mode#", N); | |
910 | Error_Msg_Sloc := Sloc (Spec_Id); | |
cf3e6845 AC |
911 | Error_Msg_NE |
912 | ("\no value was set for SPARK_Mode on & #", N, Spec_Id); | |
f90d14ac AC |
913 | end if; |
914 | end if; | |
915 | ||
cec29135 | 916 | -- Analyze_Declarations has caused freezing of all types. Now generate |
13bbad84 ES |
917 | -- bodies for RACW primitives and stream attributes, if any. |
918 | ||
919 | if Ekind (Spec_Id) = E_Package and then Has_RACW (Spec_Id) then | |
920 | ||
921 | -- Attach subprogram bodies to support RACWs declared in spec | |
922 | ||
923 | Append_RACW_Bodies (Declarations (N), Spec_Id); | |
924 | Analyze_List (Declarations (N)); | |
996ae0b0 RK |
925 | end if; |
926 | ||
927 | HSS := Handled_Statement_Sequence (N); | |
928 | ||
929 | if Present (HSS) then | |
07fc65c4 | 930 | Process_End_Label (HSS, 't', Spec_Id); |
996ae0b0 RK |
931 | Analyze (HSS); |
932 | ||
933 | -- Check that elaboration code in a preelaborable package body is | |
934 | -- empty other than null statements and labels (RM 10.2.1(6)). | |
935 | ||
936 | Validate_Null_Statement_Sequence (N); | |
937 | end if; | |
938 | ||
939 | Validate_Categorization_Dependency (N, Spec_Id); | |
940 | Check_Completion (Body_Id); | |
941 | ||
942 | -- Generate start of body reference. Note that we do this fairly late, | |
943 | -- because the call will use In_Extended_Main_Source_Unit as a check, | |
944 | -- and we want to make sure that Corresponding_Stub links are set | |
945 | ||
07fc65c4 | 946 | Generate_Reference (Spec_Id, Body_Id, 'b', Set_Ref => False); |
996ae0b0 | 947 | |
3b75bcab ES |
948 | -- For a generic package, collect global references and mark them on |
949 | -- the original body so that they are not resolved again at the point | |
950 | -- of instantiation. | |
996ae0b0 RK |
951 | |
952 | if Ekind (Spec_Id) /= E_Package then | |
953 | Save_Global_References (Original_Node (N)); | |
954 | End_Generic; | |
955 | end if; | |
956 | ||
3b75bcab ES |
957 | -- The entities of the package body have so far been chained onto the |
958 | -- declaration chain for the spec. That's been fine while we were in the | |
959 | -- body, since we wanted them to be visible, but now that we are leaving | |
960 | -- the package body, they are no longer visible, so we remove them from | |
961 | -- the entity chain of the package spec entity, and copy them to the | |
962 | -- entity chain of the package body entity, where they will never again | |
963 | -- be visible. | |
996ae0b0 RK |
964 | |
965 | if Present (Last_Spec_Entity) then | |
966 | Set_First_Entity (Body_Id, Next_Entity (Last_Spec_Entity)); | |
967 | Set_Next_Entity (Last_Spec_Entity, Empty); | |
968 | Set_Last_Entity (Body_Id, Last_Entity (Spec_Id)); | |
969 | Set_Last_Entity (Spec_Id, Last_Spec_Entity); | |
970 | ||
971 | else | |
972 | Set_First_Entity (Body_Id, First_Entity (Spec_Id)); | |
973 | Set_Last_Entity (Body_Id, Last_Entity (Spec_Id)); | |
974 | Set_First_Entity (Spec_Id, Empty); | |
975 | Set_Last_Entity (Spec_Id, Empty); | |
976 | end if; | |
977 | ||
851e9f19 | 978 | Update_Use_Clause_Chain; |
996ae0b0 RK |
979 | End_Package_Scope (Spec_Id); |
980 | ||
a5b62485 | 981 | -- All entities declared in body are not visible |
996ae0b0 RK |
982 | |
983 | declare | |
984 | E : Entity_Id; | |
985 | ||
986 | begin | |
987 | E := First_Entity (Body_Id); | |
996ae0b0 RK |
988 | while Present (E) loop |
989 | Set_Is_Immediately_Visible (E, False); | |
990 | Set_Is_Potentially_Use_Visible (E, False); | |
991 | Set_Is_Hidden (E); | |
992 | ||
cec29135 ES |
993 | -- Child units may appear on the entity list (e.g. if they appear |
994 | -- in the context of a subunit) but they are not body entities. | |
996ae0b0 RK |
995 | |
996 | if not Is_Child_Unit (E) then | |
997 | Set_Is_Package_Body_Entity (E); | |
998 | end if; | |
999 | ||
1000 | Next_Entity (E); | |
1001 | end loop; | |
1002 | end; | |
1003 | ||
1004 | Check_References (Body_Id); | |
1005 | ||
fbf5a39b AC |
1006 | -- For a generic unit, check that the formal parameters are referenced, |
1007 | -- and that local variables are used, as for regular packages. | |
1008 | ||
1009 | if Ekind (Spec_Id) = E_Generic_Package then | |
1010 | Check_References (Spec_Id); | |
1011 | end if; | |
1012 | ||
13fa2acb AC |
1013 | -- At this point all entities of the package body are externally visible |
1014 | -- to the linker as their Is_Public flag is set to True. This proactive | |
1015 | -- approach is necessary because an inlined or a generic body for which | |
1016 | -- code is generated in other units may need to see these entities. Cut | |
1017 | -- down the number of global symbols that do not neet public visibility | |
1018 | -- as this has two beneficial effects: | |
1019 | -- (1) It makes the compilation process more efficient. | |
7c15c6dd | 1020 | -- (2) It gives the code generator more leeway to optimize within each |
13fa2acb AC |
1021 | -- unit, especially subprograms. |
1022 | ||
7c15c6dd AC |
1023 | -- This is done only for top-level library packages or child units as |
1024 | -- the algorithm does a top-down traversal of the package body. | |
996ae0b0 RK |
1025 | |
1026 | if (Scope (Spec_Id) = Standard_Standard or else Is_Child_Unit (Spec_Id)) | |
1027 | and then not Is_Generic_Unit (Spec_Id) | |
996ae0b0 | 1028 | then |
13fa2acb | 1029 | Hide_Public_Entities (Declarations (N)); |
996ae0b0 RK |
1030 | end if; |
1031 | ||
1032 | -- If expander is not active, then here is where we turn off the | |
cec29135 ES |
1033 | -- In_Package_Body flag, otherwise it is turned off at the end of the |
1034 | -- corresponding expansion routine. If this is an instance body, we need | |
1035 | -- to qualify names of local entities, because the body may have been | |
1036 | -- compiled as a preliminary to another instantiation. | |
996ae0b0 RK |
1037 | |
1038 | if not Expander_Active then | |
1039 | Set_In_Package_Body (Spec_Id, False); | |
1040 | ||
1041 | if Is_Generic_Instance (Spec_Id) | |
1042 | and then Operating_Mode = Generate_Code | |
1043 | then | |
1044 | Qualify_Entity_Names (N); | |
1045 | end if; | |
1046 | end if; | |
241ebe89 | 1047 | |
f9a8f910 | 1048 | Ignore_SPARK_Mode_Pragmas_In_Instance := Saved_ISMP; |
9057bd6a | 1049 | Restore_Ghost_Region (Saved_GM, Saved_IGR); |
b1b543d2 | 1050 | end Analyze_Package_Body_Helper; |
996ae0b0 RK |
1051 | |
1052 | --------------------------------- | |
1053 | -- Analyze_Package_Declaration -- | |
1054 | --------------------------------- | |
1055 | ||
1056 | procedure Analyze_Package_Declaration (N : Node_Id) is | |
b35e5dcb | 1057 | Id : constant Node_Id := Defining_Entity (N); |
13bbad84 | 1058 | |
22a4f9d5 AC |
1059 | Is_Comp_Unit : constant Boolean := |
1060 | Nkind (Parent (N)) = N_Compilation_Unit; | |
1061 | ||
13bbad84 ES |
1062 | Body_Required : Boolean; |
1063 | -- True when this package declaration requires a corresponding body | |
1064 | ||
996ae0b0 | 1065 | begin |
54e28df2 HK |
1066 | if Debug_Flag_C then |
1067 | Write_Str ("==> package spec "); | |
1068 | Write_Name (Chars (Id)); | |
1069 | Write_Str (" from "); | |
1070 | Write_Location (Sloc (N)); | |
1071 | Write_Eol; | |
1072 | Indent; | |
1073 | end if; | |
1074 | ||
1075 | Generate_Definition (Id); | |
1076 | Enter_Name (Id); | |
c9d70ab1 AC |
1077 | Set_Ekind (Id, E_Package); |
1078 | Set_Etype (Id, Standard_Void_Type); | |
54e28df2 | 1079 | |
6dd86c75 | 1080 | -- Set SPARK_Mode from context |
579847c2 | 1081 | |
6dd86c75 AC |
1082 | Set_SPARK_Pragma (Id, SPARK_Mode_Pragma); |
1083 | Set_SPARK_Aux_Pragma (Id, SPARK_Mode_Pragma); | |
1084 | Set_SPARK_Pragma_Inherited (Id); | |
1085 | Set_SPARK_Aux_Pragma_Inherited (Id); | |
cf9a473e | 1086 | |
6dd86c75 | 1087 | -- Save the state of flag Ignore_SPARK_Mode_Pragmas_In_Instance in case |
3b2249aa HK |
1088 | -- the body of this package is instantiated or inlined later and out of |
1089 | -- context. The body uses this attribute to restore the value of the | |
1090 | -- global flag. | |
cf9a473e | 1091 | |
6dd86c75 AC |
1092 | if Ignore_SPARK_Mode_Pragmas_In_Instance then |
1093 | Set_Ignore_SPARK_Mode_Pragmas (Id); | |
f90d14ac | 1094 | end if; |
579847c2 | 1095 | |
cdcf1c7a | 1096 | -- Analyze aspect specifications immediately, since we need to recognize |
1c54829e AC |
1097 | -- things like Pure early enough to diagnose violations during analysis. |
1098 | ||
eaba57fb RD |
1099 | if Has_Aspects (N) then |
1100 | Analyze_Aspect_Specifications (N, Id); | |
1101 | end if; | |
1c54829e | 1102 | |
22a4f9d5 AC |
1103 | -- Ada 2005 (AI-217): Check if the package has been illegally named in |
1104 | -- a limited-with clause of its own context. In this case the error has | |
1105 | -- been previously notified by Analyze_Context. | |
28be29ce ES |
1106 | |
1107 | -- limited with Pkg; -- ERROR | |
1108 | -- package Pkg is ... | |
1109 | ||
7b56a91b | 1110 | if From_Limited_With (Id) then |
1c54829e | 1111 | return; |
28be29ce ES |
1112 | end if; |
1113 | ||
495d6dd6 | 1114 | Push_Scope (Id); |
996ae0b0 | 1115 | |
22a4f9d5 | 1116 | Set_Is_Pure (Id, Is_Pure (Enclosing_Lib_Unit_Entity)); |
996ae0b0 RK |
1117 | Set_Categorization_From_Pragmas (N); |
1118 | ||
996ae0b0 RK |
1119 | Analyze (Specification (N)); |
1120 | Validate_Categorization_Dependency (N, Id); | |
996ae0b0 | 1121 | |
22a4f9d5 AC |
1122 | -- Determine whether the package requires a body. Abstract states are |
1123 | -- intentionally ignored because they do require refinement which can | |
1124 | -- only come in a body, but at the same time they do not force the need | |
1125 | -- for a body on their own (SPARK RM 7.1.4(4) and 7.2.2(3)). | |
13bbad84 | 1126 | |
22a4f9d5 | 1127 | Body_Required := Unit_Requires_Body (Id); |
13bbad84 ES |
1128 | |
1129 | if not Body_Required then | |
22a4f9d5 AC |
1130 | |
1131 | -- If the package spec does not require an explicit body, then there | |
1132 | -- are not entities requiring completion in the language sense. Call | |
1133 | -- Check_Completion now to ensure that nested package declarations | |
1134 | -- that require an implicit body get one. (In the case where a body | |
1135 | -- is required, Check_Completion is called at the end of the body's | |
1136 | -- declarative part.) | |
1137 | ||
13bbad84 | 1138 | Check_Completion; |
13bbad84 | 1139 | |
22a4f9d5 AC |
1140 | -- If the package spec does not require an explicit body, then all |
1141 | -- abstract states declared in nested packages cannot possibly get | |
1142 | -- a proper refinement (SPARK RM 7.2.2(3)). This check is performed | |
1143 | -- only when the compilation unit is the main unit to allow for | |
1144 | -- modular SPARK analysis where packages do not necessarily have | |
1145 | -- bodies. | |
1146 | ||
1147 | if Is_Comp_Unit then | |
1148 | Check_State_Refinements | |
1149 | (Context => N, | |
1150 | Is_Main_Unit => Parent (N) = Cunit (Main_Unit)); | |
1151 | end if; | |
1152 | end if; | |
241ebe89 | 1153 | |
90e491a7 | 1154 | -- Set Body_Required indication on the compilation unit node |
996ae0b0 | 1155 | |
90e491a7 | 1156 | if Is_Comp_Unit then |
13bbad84 | 1157 | Set_Body_Required (Parent (N), Body_Required); |
967947ed PMR |
1158 | |
1159 | if Legacy_Elaboration_Checks and not Body_Required then | |
1160 | Set_Suppress_Elaboration_Warnings (Id); | |
1161 | end if; | |
13bbad84 ES |
1162 | end if; |
1163 | ||
1164 | End_Package_Scope (Id); | |
1165 | ||
1166 | -- For the declaration of a library unit that is a remote types package, | |
1167 | -- check legality rules regarding availability of stream attributes for | |
1168 | -- types that contain non-remote access values. This subprogram performs | |
1169 | -- visibility tests that rely on the fact that we have exited the scope | |
1170 | -- of Id. | |
1171 | ||
22a4f9d5 | 1172 | if Is_Comp_Unit then |
996ae0b0 RK |
1173 | Validate_RT_RAT_Component (N); |
1174 | end if; | |
b1b543d2 BD |
1175 | |
1176 | if Debug_Flag_C then | |
1177 | Outdent; | |
1178 | Write_Str ("<== package spec "); | |
1179 | Write_Name (Chars (Id)); | |
1180 | Write_Str (" from "); | |
1181 | Write_Location (Sloc (N)); | |
1182 | Write_Eol; | |
1183 | end if; | |
996ae0b0 RK |
1184 | end Analyze_Package_Declaration; |
1185 | ||
1186 | ----------------------------------- | |
1187 | -- Analyze_Package_Specification -- | |
1188 | ----------------------------------- | |
1189 | ||
cec29135 ES |
1190 | -- Note that this code is shared for the analysis of generic package specs |
1191 | -- (see Sem_Ch12.Analyze_Generic_Package_Declaration for details). | |
fbf5a39b | 1192 | |
996ae0b0 RK |
1193 | procedure Analyze_Package_Specification (N : Node_Id) is |
1194 | Id : constant Entity_Id := Defining_Entity (N); | |
1195 | Orig_Decl : constant Node_Id := Original_Node (Parent (N)); | |
1196 | Vis_Decls : constant List_Id := Visible_Declarations (N); | |
1197 | Priv_Decls : constant List_Id := Private_Declarations (N); | |
1198 | E : Entity_Id; | |
1199 | L : Entity_Id; | |
fbf5a39b AC |
1200 | Public_Child : Boolean; |
1201 | ||
3b75bcab ES |
1202 | Private_With_Clauses_Installed : Boolean := False; |
1203 | -- In Ada 2005, private with_clauses are visible in the private part | |
1204 | -- of a nested package, even if it appears in the public part of the | |
1205 | -- enclosing package. This requires a separate step to install these | |
1206 | -- private_with_clauses, and remove them at the end of the nested | |
1207 | -- package. | |
1208 | ||
e24329cd | 1209 | procedure Check_One_Tagged_Type_Or_Extension_At_Most; |
975c6896 YM |
1210 | -- Issue an error in SPARK mode if a package specification contains |
1211 | -- more than one tagged type or type extension. | |
e24329cd | 1212 | |
fbf5a39b | 1213 | procedure Clear_Constants (Id : Entity_Id; FE : Entity_Id); |
cec29135 ES |
1214 | -- Clears constant indications (Never_Set_In_Source, Constant_Value, and |
1215 | -- Is_True_Constant) on all variables that are entities of Id, and on | |
1216 | -- the chain whose first element is FE. A recursive call is made for all | |
1217 | -- packages and generic packages. | |
fbf5a39b AC |
1218 | |
1219 | procedure Generate_Parent_References; | |
1220 | -- For a child unit, generate references to parent units, for | |
1221 | -- GPS navigation purposes. | |
996ae0b0 RK |
1222 | |
1223 | function Is_Public_Child (Child, Unit : Entity_Id) return Boolean; | |
1224 | -- Child and Unit are entities of compilation units. True if Child | |
1225 | -- is a public child of Parent as defined in 10.1.1 | |
1226 | ||
5d09245e | 1227 | procedure Inspect_Unchecked_Union_Completion (Decls : List_Id); |
02f58834 AC |
1228 | -- Reject completion of an incomplete or private type declarations |
1229 | -- having a known discriminant part by an unchecked union. | |
5453d5bd | 1230 | |
a59e9305 GD |
1231 | procedure Install_Parent_Private_Declarations (Inst_Id : Entity_Id); |
1232 | -- Given the package entity of a generic package instantiation or | |
1233 | -- formal package whose corresponding generic is a child unit, installs | |
1234 | -- the private declarations of each of the child unit's parents. | |
1235 | -- This has to be done at the point of entering the instance package's | |
1236 | -- private part rather than being done in Sem_Ch12.Install_Parent | |
1237 | -- (which is where the parents' visible declarations are installed). | |
1238 | ||
e24329cd YM |
1239 | ------------------------------------------------ |
1240 | -- Check_One_Tagged_Type_Or_Extension_At_Most -- | |
1241 | ------------------------------------------------ | |
1242 | ||
1243 | procedure Check_One_Tagged_Type_Or_Extension_At_Most is | |
1244 | Previous : Node_Id; | |
1245 | ||
1246 | procedure Check_Decls (Decls : List_Id); | |
1247 | -- Check that either Previous is Empty and Decls does not contain | |
1248 | -- more than one tagged type or type extension, or Previous is | |
1249 | -- already set and Decls contains no tagged type or type extension. | |
1250 | ||
1251 | ----------------- | |
1252 | -- Check_Decls -- | |
1253 | ----------------- | |
1254 | ||
1255 | procedure Check_Decls (Decls : List_Id) is | |
1256 | Decl : Node_Id; | |
6320f5e1 | 1257 | |
e24329cd YM |
1258 | begin |
1259 | Decl := First (Decls); | |
1260 | while Present (Decl) loop | |
1261 | if Nkind (Decl) = N_Full_Type_Declaration | |
1262 | and then Is_Tagged_Type (Defining_Identifier (Decl)) | |
1263 | then | |
1264 | if No (Previous) then | |
1265 | Previous := Decl; | |
6320f5e1 | 1266 | |
e24329cd YM |
1267 | else |
1268 | Error_Msg_Sloc := Sloc (Previous); | |
ce5ba43a | 1269 | Check_SPARK_05_Restriction |
e24329cd YM |
1270 | ("at most one tagged type or type extension allowed", |
1271 | "\\ previous declaration#", | |
1272 | Decl); | |
1273 | end if; | |
1274 | end if; | |
1275 | ||
1276 | Next (Decl); | |
1277 | end loop; | |
1278 | end Check_Decls; | |
1279 | ||
1280 | -- Start of processing for Check_One_Tagged_Type_Or_Extension_At_Most | |
1281 | ||
1282 | begin | |
1283 | Previous := Empty; | |
1284 | Check_Decls (Vis_Decls); | |
1285 | ||
1286 | if Present (Priv_Decls) then | |
1287 | Check_Decls (Priv_Decls); | |
1288 | end if; | |
1289 | end Check_One_Tagged_Type_Or_Extension_At_Most; | |
1290 | ||
fbf5a39b AC |
1291 | --------------------- |
1292 | -- Clear_Constants -- | |
1293 | --------------------- | |
1294 | ||
1295 | procedure Clear_Constants (Id : Entity_Id; FE : Entity_Id) is | |
1296 | E : Entity_Id; | |
1297 | ||
1298 | begin | |
cec29135 ES |
1299 | -- Ignore package renamings, not interesting and they can cause self |
1300 | -- referential loops in the code below. | |
fbf5a39b AC |
1301 | |
1302 | if Nkind (Parent (Id)) = N_Package_Renaming_Declaration then | |
1303 | return; | |
1304 | end if; | |
1305 | ||
cec29135 ES |
1306 | -- Note: in the loop below, the check for Next_Entity pointing back |
1307 | -- to the package entity may seem odd, but it is needed, because a | |
1308 | -- package can contain a renaming declaration to itself, and such | |
1309 | -- renamings are generated automatically within package instances. | |
fbf5a39b AC |
1310 | |
1311 | E := FE; | |
1312 | while Present (E) and then E /= Id loop | |
67ce0d7e | 1313 | if Is_Assignable (E) then |
fbf5a39b AC |
1314 | Set_Never_Set_In_Source (E, False); |
1315 | Set_Is_True_Constant (E, False); | |
1316 | Set_Current_Value (E, Empty); | |
ba673907 | 1317 | Set_Is_Known_Null (E, False); |
3b75bcab | 1318 | Set_Last_Assignment (E, Empty); |
ba673907 JM |
1319 | |
1320 | if not Can_Never_Be_Null (E) then | |
1321 | Set_Is_Known_Non_Null (E, False); | |
1322 | end if; | |
fbf5a39b | 1323 | |
b9b2405f | 1324 | elsif Is_Package_Or_Generic_Package (E) then |
fbf5a39b AC |
1325 | Clear_Constants (E, First_Entity (E)); |
1326 | Clear_Constants (E, First_Private_Entity (E)); | |
1327 | end if; | |
1328 | ||
1329 | Next_Entity (E); | |
1330 | end loop; | |
1331 | end Clear_Constants; | |
1332 | ||
1333 | -------------------------------- | |
1334 | -- Generate_Parent_References -- | |
1335 | -------------------------------- | |
1336 | ||
1337 | procedure Generate_Parent_References is | |
91b1417d | 1338 | Decl : constant Node_Id := Parent (N); |
fbf5a39b AC |
1339 | |
1340 | begin | |
1341 | if Id = Cunit_Entity (Main_Unit) | |
1342 | or else Parent (Decl) = Library_Unit (Cunit (Main_Unit)) | |
1343 | then | |
1344 | Generate_Reference (Id, Scope (Id), 'k', False); | |
1345 | ||
ac4d6407 RD |
1346 | elsif not Nkind_In (Unit (Cunit (Main_Unit)), N_Subprogram_Body, |
1347 | N_Subunit) | |
fbf5a39b | 1348 | then |
cec29135 ES |
1349 | -- If current unit is an ancestor of main unit, generate a |
1350 | -- reference to its own parent. | |
fbf5a39b AC |
1351 | |
1352 | declare | |
1353 | U : Node_Id; | |
1354 | Main_Spec : Node_Id := Unit (Cunit (Main_Unit)); | |
1355 | ||
1356 | begin | |
1357 | if Nkind (Main_Spec) = N_Package_Body then | |
1358 | Main_Spec := Unit (Library_Unit (Cunit (Main_Unit))); | |
1359 | end if; | |
1360 | ||
1361 | U := Parent_Spec (Main_Spec); | |
1362 | while Present (U) loop | |
1363 | if U = Parent (Decl) then | |
1364 | Generate_Reference (Id, Scope (Id), 'k', False); | |
1365 | exit; | |
1366 | ||
1367 | elsif Nkind (Unit (U)) = N_Package_Body then | |
1368 | exit; | |
1369 | ||
1370 | else | |
1371 | U := Parent_Spec (Unit (U)); | |
1372 | end if; | |
1373 | end loop; | |
1374 | end; | |
1375 | end if; | |
1376 | end Generate_Parent_References; | |
1377 | ||
1378 | --------------------- | |
1379 | -- Is_Public_Child -- | |
1380 | --------------------- | |
1381 | ||
996ae0b0 RK |
1382 | function Is_Public_Child (Child, Unit : Entity_Id) return Boolean is |
1383 | begin | |
1384 | if not Is_Private_Descendant (Child) then | |
1385 | return True; | |
1386 | else | |
1387 | if Child = Unit then | |
1388 | return not Private_Present ( | |
1389 | Parent (Unit_Declaration_Node (Child))); | |
1390 | else | |
1391 | return Is_Public_Child (Scope (Child), Unit); | |
1392 | end if; | |
1393 | end if; | |
1394 | end Is_Public_Child; | |
1395 | ||
5d09245e AC |
1396 | ---------------------------------------- |
1397 | -- Inspect_Unchecked_Union_Completion -- | |
1398 | ---------------------------------------- | |
1399 | ||
1400 | procedure Inspect_Unchecked_Union_Completion (Decls : List_Id) is | |
3b75bcab | 1401 | Decl : Node_Id; |
5d09245e AC |
1402 | |
1403 | begin | |
3b75bcab | 1404 | Decl := First (Decls); |
5d09245e AC |
1405 | while Present (Decl) loop |
1406 | ||
1407 | -- We are looking at an incomplete or private type declaration | |
1408 | -- with a known_discriminant_part whose full view is an | |
689751d2 PT |
1409 | -- Unchecked_Union. The seemingly useless check with Is_Type |
1410 | -- prevents cascaded errors when routines defined only for type | |
1411 | -- entities are called with non-type entities. | |
5d09245e | 1412 | |
ac4d6407 RD |
1413 | if Nkind_In (Decl, N_Incomplete_Type_Declaration, |
1414 | N_Private_Type_Declaration) | |
689751d2 | 1415 | and then Is_Type (Defining_Identifier (Decl)) |
5d09245e AC |
1416 | and then Has_Discriminants (Defining_Identifier (Decl)) |
1417 | and then Present (Full_View (Defining_Identifier (Decl))) | |
ac4d6407 RD |
1418 | and then |
1419 | Is_Unchecked_Union (Full_View (Defining_Identifier (Decl))) | |
5d09245e | 1420 | then |
ac4d6407 RD |
1421 | Error_Msg_N |
1422 | ("completion of discriminated partial view " | |
02f58834 | 1423 | & "cannot be an unchecked union", |
5d09245e AC |
1424 | Full_View (Defining_Identifier (Decl))); |
1425 | end if; | |
1426 | ||
1427 | Next (Decl); | |
1428 | end loop; | |
1429 | end Inspect_Unchecked_Union_Completion; | |
1430 | ||
a59e9305 GD |
1431 | ----------------------------------------- |
1432 | -- Install_Parent_Private_Declarations -- | |
1433 | ----------------------------------------- | |
1434 | ||
1435 | procedure Install_Parent_Private_Declarations (Inst_Id : Entity_Id) is | |
3b75bcab | 1436 | Inst_Par : Entity_Id; |
a59e9305 GD |
1437 | Gen_Par : Entity_Id; |
1438 | Inst_Node : Node_Id; | |
1439 | ||
1440 | begin | |
3b75bcab | 1441 | Inst_Par := Inst_Id; |
f7d5442e | 1442 | |
a59e9305 GD |
1443 | Gen_Par := |
1444 | Generic_Parent (Specification (Unit_Declaration_Node (Inst_Par))); | |
1445 | while Present (Gen_Par) and then Is_Child_Unit (Gen_Par) loop | |
ed323421 | 1446 | Inst_Node := Get_Unit_Instantiation_Node (Inst_Par); |
a59e9305 | 1447 | |
ac4d6407 RD |
1448 | if Nkind_In (Inst_Node, N_Package_Instantiation, |
1449 | N_Formal_Package_Declaration) | |
a59e9305 GD |
1450 | and then Nkind (Name (Inst_Node)) = N_Expanded_Name |
1451 | then | |
1452 | Inst_Par := Entity (Prefix (Name (Inst_Node))); | |
1453 | ||
1454 | if Present (Renamed_Entity (Inst_Par)) then | |
1455 | Inst_Par := Renamed_Entity (Inst_Par); | |
1456 | end if; | |
1457 | ||
1458 | Gen_Par := | |
1459 | Generic_Parent | |
1460 | (Specification (Unit_Declaration_Node (Inst_Par))); | |
1461 | ||
1462 | -- Install the private declarations and private use clauses | |
3b75bcab ES |
1463 | -- of a parent instance of the child instance, unless the |
1464 | -- parent instance private declarations have already been | |
1465 | -- installed earlier in Analyze_Package_Specification, which | |
1466 | -- happens when a generic child is instantiated, and the | |
1467 | -- instance is a child of the parent instance. | |
1468 | ||
7d823354 ES |
1469 | -- Installing the use clauses of the parent instance twice |
1470 | -- is both unnecessary and wrong, because it would cause the | |
1471 | -- clauses to be chained to themselves in the use clauses | |
1472 | -- list of the scope stack entry. That in turn would cause | |
f3d0f304 | 1473 | -- an endless loop from End_Use_Clauses upon scope exit. |
7d823354 ES |
1474 | |
1475 | -- The parent is now fully visible. It may be a hidden open | |
1476 | -- scope if we are currently compiling some child instance | |
1477 | -- declared within it, but while the current instance is being | |
1478 | -- compiled the parent is immediately visible. In particular | |
1479 | -- its entities must remain visible if a stack save/restore | |
1480 | -- takes place through a call to Rtsfind. | |
a59e9305 GD |
1481 | |
1482 | if Present (Gen_Par) then | |
3b75bcab ES |
1483 | if not In_Private_Part (Inst_Par) then |
1484 | Install_Private_Declarations (Inst_Par); | |
1485 | Set_Use (Private_Declarations | |
1486 | (Specification | |
1487 | (Unit_Declaration_Node (Inst_Par)))); | |
7d823354 | 1488 | Set_Is_Hidden_Open_Scope (Inst_Par, False); |
3b75bcab | 1489 | end if; |
a59e9305 GD |
1490 | |
1491 | -- If we've reached the end of the generic instance parents, | |
1492 | -- then finish off by looping through the nongeneric parents | |
1493 | -- and installing their private declarations. | |
1494 | ||
11d59a86 AC |
1495 | -- If one of the non-generic parents is itself on the scope |
1496 | -- stack, do not install its private declarations: they are | |
1497 | -- installed in due time when the private part of that parent | |
c70cf4f8 | 1498 | -- is analyzed. |
11d59a86 | 1499 | |
a59e9305 GD |
1500 | else |
1501 | while Present (Inst_Par) | |
1502 | and then Inst_Par /= Standard_Standard | |
1503 | and then (not In_Open_Scopes (Inst_Par) | |
09a078a1 | 1504 | or else not In_Private_Part (Inst_Par)) |
a59e9305 | 1505 | loop |
c70cf4f8 AC |
1506 | if Nkind (Inst_Node) = N_Formal_Package_Declaration |
1507 | or else | |
1508 | not Is_Ancestor_Package | |
1509 | (Inst_Par, Cunit_Entity (Current_Sem_Unit)) | |
1510 | then | |
1511 | Install_Private_Declarations (Inst_Par); | |
1512 | Set_Use | |
1513 | (Private_Declarations | |
1514 | (Specification | |
1515 | (Unit_Declaration_Node (Inst_Par)))); | |
1516 | Inst_Par := Scope (Inst_Par); | |
1517 | else | |
1518 | exit; | |
1519 | end if; | |
a59e9305 GD |
1520 | end loop; |
1521 | ||
1522 | exit; | |
1523 | end if; | |
1524 | ||
1525 | else | |
1526 | exit; | |
1527 | end if; | |
1528 | end loop; | |
1529 | end Install_Parent_Private_Declarations; | |
1530 | ||
996ae0b0 RK |
1531 | -- Start of processing for Analyze_Package_Specification |
1532 | ||
1533 | begin | |
1534 | if Present (Vis_Decls) then | |
1535 | Analyze_Declarations (Vis_Decls); | |
1536 | end if; | |
1537 | ||
e477d718 AC |
1538 | -- Inspect the entities defined in the package and ensure that all |
1539 | -- incomplete types have received full declarations. Build default | |
ff7a5bcb | 1540 | -- initial condition and invariant procedures for all qualifying types. |
996ae0b0 RK |
1541 | |
1542 | E := First_Entity (Id); | |
996ae0b0 | 1543 | while Present (E) loop |
f2264ac2 RD |
1544 | |
1545 | -- Check on incomplete types | |
646e2823 | 1546 | |
c23c86bb AC |
1547 | -- AI05-0213: A formal incomplete type has no completion, and neither |
1548 | -- does the corresponding subtype in an instance. | |
f2264ac2 | 1549 | |
dd89dddf | 1550 | if Is_Incomplete_Type (E) |
996ae0b0 | 1551 | and then No (Full_View (E)) |
d3cb4cc0 | 1552 | and then not Is_Generic_Type (E) |
dd89dddf AC |
1553 | and then not From_Limited_With (E) |
1554 | and then not Is_Generic_Actual_Type (E) | |
996ae0b0 RK |
1555 | then |
1556 | Error_Msg_N ("no declaration in visible part for incomplete}", E); | |
1557 | end if; | |
1558 | ||
1559 | Next_Entity (E); | |
1560 | end loop; | |
1561 | ||
1562 | if Is_Remote_Call_Interface (Id) | |
3ddfabe3 | 1563 | and then Nkind (Parent (Parent (N))) = N_Compilation_Unit |
996ae0b0 RK |
1564 | then |
1565 | Validate_RCI_Declarations (Id); | |
1566 | end if; | |
1567 | ||
cec29135 ES |
1568 | -- Save global references in the visible declarations, before installing |
1569 | -- private declarations of parent unit if there is one, because the | |
1570 | -- privacy status of types defined in the parent will change. This is | |
1571 | -- only relevant for generic child units, but is done in all cases for | |
1572 | -- uniformity. | |
996ae0b0 RK |
1573 | |
1574 | if Ekind (Id) = E_Generic_Package | |
1575 | and then Nkind (Orig_Decl) = N_Generic_Package_Declaration | |
1576 | then | |
1577 | declare | |
495d6dd6 | 1578 | Orig_Spec : constant Node_Id := Specification (Orig_Decl); |
996ae0b0 | 1579 | Save_Priv : constant List_Id := Private_Declarations (Orig_Spec); |
136236bd | 1580 | |
996ae0b0 | 1581 | begin |
136236bd JM |
1582 | -- Insert the freezing nodes after the visible declarations to |
1583 | -- ensure that we analyze its aspects; needed to ensure that | |
1584 | -- global entities referenced in the aspects are properly handled. | |
1585 | ||
1586 | if Ada_Version >= Ada_2012 | |
1587 | and then Is_Non_Empty_List (Vis_Decls) | |
1588 | and then Is_Empty_List (Priv_Decls) | |
1589 | then | |
1590 | Insert_List_After_And_Analyze | |
1591 | (Last (Vis_Decls), Freeze_Entity (Id, Last (Vis_Decls))); | |
1592 | end if; | |
1593 | ||
996ae0b0 RK |
1594 | Set_Private_Declarations (Orig_Spec, Empty_List); |
1595 | Save_Global_References (Orig_Decl); | |
1596 | Set_Private_Declarations (Orig_Spec, Save_Priv); | |
1597 | end; | |
1598 | end if; | |
1599 | ||
3b75bcab ES |
1600 | -- If package is a public child unit, then make the private declarations |
1601 | -- of the parent visible. | |
996ae0b0 | 1602 | |
fbf5a39b AC |
1603 | Public_Child := False; |
1604 | ||
523456db AC |
1605 | declare |
1606 | Par : Entity_Id; | |
1607 | Pack_Decl : Node_Id; | |
1608 | Par_Spec : Node_Id; | |
fbf5a39b | 1609 | |
523456db AC |
1610 | begin |
1611 | Par := Id; | |
1612 | Par_Spec := Parent_Spec (Parent (N)); | |
1613 | ||
3b75bcab | 1614 | -- If the package is formal package of an enclosing generic, it is |
523456db AC |
1615 | -- transformed into a local generic declaration, and compiled to make |
1616 | -- its spec available. We need to retrieve the original generic to | |
1617 | -- determine whether it is a child unit, and install its parents. | |
1618 | ||
1619 | if No (Par_Spec) | |
1620 | and then | |
1621 | Nkind (Original_Node (Parent (N))) = N_Formal_Package_Declaration | |
1622 | then | |
1623 | Par := Entity (Name (Original_Node (Parent (N)))); | |
1624 | Par_Spec := Parent_Spec (Unit_Declaration_Node (Par)); | |
1625 | end if; | |
1626 | ||
1627 | if Present (Par_Spec) then | |
1628 | Generate_Parent_References; | |
996ae0b0 | 1629 | |
996ae0b0 RK |
1630 | while Scope (Par) /= Standard_Standard |
1631 | and then Is_Public_Child (Id, Par) | |
3b75bcab | 1632 | and then In_Open_Scopes (Par) |
996ae0b0 RK |
1633 | loop |
1634 | Public_Child := True; | |
1635 | Par := Scope (Par); | |
1636 | Install_Private_Declarations (Par); | |
8a6a52dc | 1637 | Install_Private_With_Clauses (Par); |
996ae0b0 RK |
1638 | Pack_Decl := Unit_Declaration_Node (Par); |
1639 | Set_Use (Private_Declarations (Specification (Pack_Decl))); | |
1640 | end loop; | |
523456db AC |
1641 | end if; |
1642 | end; | |
996ae0b0 | 1643 | |
8a6a52dc AC |
1644 | if Is_Compilation_Unit (Id) then |
1645 | Install_Private_With_Clauses (Id); | |
3b75bcab | 1646 | else |
3b75bcab ES |
1647 | -- The current compilation unit may include private with_clauses, |
1648 | -- which are visible in the private part of the current nested | |
33c423c8 AC |
1649 | -- package, and have to be installed now. This is not done for |
1650 | -- nested instantiations, where the private with_clauses of the | |
1651 | -- enclosing unit have no effect once the instantiation info is | |
1652 | -- established and we start analyzing the package declaration. | |
3b75bcab ES |
1653 | |
1654 | declare | |
1655 | Comp_Unit : constant Entity_Id := Cunit_Entity (Current_Sem_Unit); | |
1656 | begin | |
b9b2405f | 1657 | if Is_Package_Or_Generic_Package (Comp_Unit) |
3b75bcab | 1658 | and then not In_Private_Part (Comp_Unit) |
33c423c8 | 1659 | and then not In_Instance |
3b75bcab ES |
1660 | then |
1661 | Install_Private_With_Clauses (Comp_Unit); | |
1662 | Private_With_Clauses_Installed := True; | |
1663 | end if; | |
1664 | end; | |
8a6a52dc AC |
1665 | end if; |
1666 | ||
a59e9305 GD |
1667 | -- If this is a package associated with a generic instance or formal |
1668 | -- package, then the private declarations of each of the generic's | |
1669 | -- parents must be installed at this point. | |
1670 | ||
3b75bcab | 1671 | if Is_Generic_Instance (Id) then |
a59e9305 GD |
1672 | Install_Parent_Private_Declarations (Id); |
1673 | end if; | |
1674 | ||
3b75bcab ES |
1675 | -- Analyze private part if present. The flag In_Private_Part is reset |
1676 | -- in End_Package_Scope. | |
996ae0b0 RK |
1677 | |
1678 | L := Last_Entity (Id); | |
1679 | ||
1680 | if Present (Priv_Decls) then | |
996ae0b0 RK |
1681 | Set_In_Private_Part (Id); |
1682 | ||
3b75bcab ES |
1683 | -- Upon entering a public child's private part, it may be necessary |
1684 | -- to declare subprograms that were derived in the package's visible | |
1685 | -- part but not yet made visible. | |
996ae0b0 RK |
1686 | |
1687 | if Public_Child then | |
1688 | Declare_Inherited_Private_Subprograms (Id); | |
1689 | end if; | |
1690 | ||
1691 | Analyze_Declarations (Priv_Decls); | |
1692 | ||
cc335f43 | 1693 | -- Check the private declarations for incomplete deferred constants |
5453d5bd | 1694 | |
13bbad84 | 1695 | Inspect_Deferred_Constant_Completion (Priv_Decls); |
5453d5bd | 1696 | |
996ae0b0 RK |
1697 | -- The first private entity is the immediate follower of the last |
1698 | -- visible entity, if there was one. | |
1699 | ||
1700 | if Present (L) then | |
1701 | Set_First_Private_Entity (Id, Next_Entity (L)); | |
1702 | else | |
1703 | Set_First_Private_Entity (Id, First_Entity (Id)); | |
1704 | end if; | |
1705 | ||
3b75bcab ES |
1706 | -- There may be inherited private subprograms that need to be declared, |
1707 | -- even in the absence of an explicit private part. If there are any | |
1708 | -- public declarations in the package and the package is a public child | |
1709 | -- unit, then an implicit private part is assumed. | |
996ae0b0 RK |
1710 | |
1711 | elsif Present (L) and then Public_Child then | |
1712 | Set_In_Private_Part (Id); | |
1713 | Declare_Inherited_Private_Subprograms (Id); | |
1714 | Set_First_Private_Entity (Id, Next_Entity (L)); | |
1715 | end if; | |
1716 | ||
996ae0b0 RK |
1717 | E := First_Entity (Id); |
1718 | while Present (E) loop | |
31b5873d GD |
1719 | |
1720 | -- Check rule of 3.6(11), which in general requires waiting till all | |
1721 | -- full types have been seen. | |
1722 | ||
996ae0b0 RK |
1723 | if Ekind (E) = E_Record_Type or else Ekind (E) = E_Array_Type then |
1724 | Check_Aliased_Component_Types (E); | |
1725 | end if; | |
1726 | ||
31b5873d GD |
1727 | -- Check preelaborable initialization for full type completing a |
1728 | -- private type for which pragma Preelaborable_Initialization given. | |
1729 | ||
1730 | if Is_Type (E) | |
1731 | and then Must_Have_Preelab_Init (E) | |
1732 | and then not Has_Preelaborable_Initialization (E) | |
1733 | then | |
1734 | Error_Msg_N | |
1735 | ("full view of & does not have preelaborable initialization", E); | |
1736 | end if; | |
1737 | ||
996ae0b0 RK |
1738 | Next_Entity (E); |
1739 | end loop; | |
1740 | ||
5d09245e AC |
1741 | -- Ada 2005 (AI-216): The completion of an incomplete or private type |
1742 | -- declaration having a known_discriminant_part shall not be an | |
02f58834 | 1743 | -- unchecked union type. |
5d09245e AC |
1744 | |
1745 | if Present (Vis_Decls) then | |
1746 | Inspect_Unchecked_Union_Completion (Vis_Decls); | |
1747 | end if; | |
1748 | ||
1749 | if Present (Priv_Decls) then | |
1750 | Inspect_Unchecked_Union_Completion (Priv_Decls); | |
1751 | end if; | |
1752 | ||
996ae0b0 RK |
1753 | if Ekind (Id) = E_Generic_Package |
1754 | and then Nkind (Orig_Decl) = N_Generic_Package_Declaration | |
1755 | and then Present (Priv_Decls) | |
1756 | then | |
1757 | -- Save global references in private declarations, ignoring the | |
1758 | -- visible declarations that were processed earlier. | |
1759 | ||
1760 | declare | |
1761 | Orig_Spec : constant Node_Id := Specification (Orig_Decl); | |
1762 | Save_Vis : constant List_Id := Visible_Declarations (Orig_Spec); | |
1763 | Save_Form : constant List_Id := | |
1764 | Generic_Formal_Declarations (Orig_Decl); | |
1765 | ||
1766 | begin | |
136236bd JM |
1767 | -- Insert the freezing nodes after the private declarations to |
1768 | -- ensure that we analyze its aspects; needed to ensure that | |
1769 | -- global entities referenced in the aspects are properly handled. | |
1770 | ||
1771 | if Ada_Version >= Ada_2012 | |
1772 | and then Is_Non_Empty_List (Priv_Decls) | |
1773 | then | |
1774 | Insert_List_After_And_Analyze | |
1775 | (Last (Priv_Decls), Freeze_Entity (Id, Last (Priv_Decls))); | |
1776 | end if; | |
1777 | ||
996ae0b0 RK |
1778 | Set_Visible_Declarations (Orig_Spec, Empty_List); |
1779 | Set_Generic_Formal_Declarations (Orig_Decl, Empty_List); | |
1780 | Save_Global_References (Orig_Decl); | |
1781 | Set_Generic_Formal_Declarations (Orig_Decl, Save_Form); | |
1782 | Set_Visible_Declarations (Orig_Spec, Save_Vis); | |
1783 | end; | |
1784 | end if; | |
1785 | ||
07fc65c4 | 1786 | Process_End_Label (N, 'e', Id); |
fbf5a39b | 1787 | |
3b75bcab ES |
1788 | -- Remove private_with_clauses of enclosing compilation unit, if they |
1789 | -- were installed. | |
1790 | ||
1791 | if Private_With_Clauses_Installed then | |
1792 | Remove_Private_With_Clauses (Cunit (Current_Sem_Unit)); | |
1793 | end if; | |
1794 | ||
1795 | -- For the case of a library level package, we must go through all the | |
1796 | -- entities clearing the indications that the value may be constant and | |
1797 | -- not modified. Why? Because any client of this package may modify | |
1798 | -- these values freely from anywhere. This also applies to any nested | |
1799 | -- packages or generic packages. | |
fbf5a39b | 1800 | |
3b75bcab ES |
1801 | -- For now we unconditionally clear constants for packages that are |
1802 | -- instances of generic packages. The reason is that we do not have the | |
1803 | -- body yet, and we otherwise think things are unreferenced when they | |
1804 | -- are not. This should be fixed sometime (the effect is not terrible, | |
1805 | -- we just lose some warnings, and also some cases of value propagation) | |
1806 | -- ??? | |
fbf5a39b AC |
1807 | |
1808 | if Is_Library_Level_Entity (Id) | |
1809 | or else Is_Generic_Instance (Id) | |
1810 | then | |
1811 | Clear_Constants (Id, First_Entity (Id)); | |
1812 | Clear_Constants (Id, First_Private_Entity (Id)); | |
1813 | end if; | |
e24329cd | 1814 | |
7569f697 AC |
1815 | -- Issue an error in SPARK mode if a package specification contains |
1816 | -- more than one tagged type or type extension. | |
1817 | ||
e24329cd | 1818 | Check_One_Tagged_Type_Or_Extension_At_Most; |
7569f697 | 1819 | |
1f8766d3 AC |
1820 | -- Output relevant information as to why the package requires a body. |
1821 | -- Do not consider generated packages as this exposes internal symbols | |
1822 | -- and leads to confusing messages. | |
98779361 RD |
1823 | |
1824 | if List_Body_Required_Info | |
1825 | and then In_Extended_Main_Source_Unit (Id) | |
1826 | and then Unit_Requires_Body (Id) | |
1f8766d3 | 1827 | and then Comes_From_Source (Id) |
98779361 RD |
1828 | then |
1829 | Unit_Requires_Body_Info (Id); | |
1830 | end if; | |
851e9f19 PMR |
1831 | |
1832 | -- Nested package specs that do not require bodies are not checked for | |
1833 | -- ineffective use clauses due to the possbility of subunits. This is | |
1834 | -- because at this stage it is impossible to tell whether there will be | |
1835 | -- a separate body. | |
1836 | ||
1837 | if not Unit_Requires_Body (Id) | |
1838 | and then Is_Compilation_Unit (Id) | |
1839 | and then not Is_Private_Descendant (Id) | |
1840 | then | |
1841 | Update_Use_Clause_Chain; | |
1842 | end if; | |
996ae0b0 RK |
1843 | end Analyze_Package_Specification; |
1844 | ||
1845 | -------------------------------------- | |
1846 | -- Analyze_Private_Type_Declaration -- | |
1847 | -------------------------------------- | |
1848 | ||
1849 | procedure Analyze_Private_Type_Declaration (N : Node_Id) is | |
fbf5a39b | 1850 | Id : constant Entity_Id := Defining_Identifier (N); |
241ebe89 | 1851 | PF : constant Boolean := Is_Pure (Enclosing_Lib_Unit_Entity); |
996ae0b0 RK |
1852 | |
1853 | begin | |
1854 | Generate_Definition (Id); | |
1855 | Set_Is_Pure (Id, PF); | |
1856 | Init_Size_Align (Id); | |
1857 | ||
b9b2405f | 1858 | if not Is_Package_Or_Generic_Package (Current_Scope) |
996ae0b0 RK |
1859 | or else In_Private_Part (Current_Scope) |
1860 | then | |
1861 | Error_Msg_N ("invalid context for private declaration", N); | |
1862 | end if; | |
1863 | ||
1864 | New_Private_Type (N, Id, N); | |
1865 | Set_Depends_On_Private (Id); | |
eaba57fb | 1866 | |
8dce7371 PMR |
1867 | -- Set the SPARK mode from the current context |
1868 | ||
1869 | Set_SPARK_Pragma (Id, SPARK_Mode_Pragma); | |
1870 | Set_SPARK_Pragma_Inherited (Id); | |
1871 | ||
eaba57fb RD |
1872 | if Has_Aspects (N) then |
1873 | Analyze_Aspect_Specifications (N, Id); | |
1874 | end if; | |
996ae0b0 RK |
1875 | end Analyze_Private_Type_Declaration; |
1876 | ||
3b75bcab ES |
1877 | ---------------------------------- |
1878 | -- Check_Anonymous_Access_Types -- | |
1879 | ---------------------------------- | |
1880 | ||
1881 | procedure Check_Anonymous_Access_Types | |
1882 | (Spec_Id : Entity_Id; | |
1883 | P_Body : Node_Id) | |
1884 | is | |
1885 | E : Entity_Id; | |
1886 | IR : Node_Id; | |
1887 | ||
1888 | begin | |
1889 | -- Itype references are only needed by gigi, to force elaboration of | |
1890 | -- itypes. In the absence of code generation, they are not needed. | |
1891 | ||
1892 | if not Expander_Active then | |
1893 | return; | |
1894 | end if; | |
1895 | ||
1896 | E := First_Entity (Spec_Id); | |
1897 | while Present (E) loop | |
1898 | if Ekind (E) = E_Anonymous_Access_Type | |
7b56a91b | 1899 | and then From_Limited_With (E) |
3b75bcab ES |
1900 | then |
1901 | IR := Make_Itype_Reference (Sloc (P_Body)); | |
1902 | Set_Itype (IR, E); | |
1903 | ||
1904 | if No (Declarations (P_Body)) then | |
495d6dd6 RD |
1905 | Set_Declarations (P_Body, New_List (IR)); |
1906 | else | |
1907 | Prepend (IR, Declarations (P_Body)); | |
3b75bcab | 1908 | end if; |
3b75bcab ES |
1909 | end if; |
1910 | ||
1911 | Next_Entity (E); | |
1912 | end loop; | |
1913 | end Check_Anonymous_Access_Types; | |
1914 | ||
996ae0b0 RK |
1915 | ------------------------------------------- |
1916 | -- Declare_Inherited_Private_Subprograms -- | |
1917 | ------------------------------------------- | |
1918 | ||
1919 | procedure Declare_Inherited_Private_Subprograms (Id : Entity_Id) is | |
07fc65c4 GB |
1920 | |
1921 | function Is_Primitive_Of (T : Entity_Id; S : Entity_Id) return Boolean; | |
686d0984 AC |
1922 | -- Check whether an inherited subprogram S is an operation of an |
1923 | -- untagged derived type T. | |
07fc65c4 GB |
1924 | |
1925 | --------------------- | |
1926 | -- Is_Primitive_Of -- | |
1927 | --------------------- | |
1928 | ||
1929 | function Is_Primitive_Of (T : Entity_Id; S : Entity_Id) return Boolean is | |
1930 | Formal : Entity_Id; | |
1931 | ||
1932 | begin | |
cec29135 ES |
1933 | -- If the full view is a scalar type, the type is the anonymous base |
1934 | -- type, but the operation mentions the first subtype, so check the | |
1935 | -- signature against the base type. | |
f7d5442e ES |
1936 | |
1937 | if Base_Type (Etype (S)) = Base_Type (T) then | |
07fc65c4 GB |
1938 | return True; |
1939 | ||
1940 | else | |
1941 | Formal := First_Formal (S); | |
07fc65c4 | 1942 | while Present (Formal) loop |
f7d5442e | 1943 | if Base_Type (Etype (Formal)) = Base_Type (T) then |
07fc65c4 GB |
1944 | return True; |
1945 | end if; | |
1946 | ||
1947 | Next_Formal (Formal); | |
1948 | end loop; | |
1949 | ||
1950 | return False; | |
1951 | end if; | |
1952 | end Is_Primitive_Of; | |
1953 | ||
495d6dd6 RD |
1954 | -- Local variables |
1955 | ||
1956 | E : Entity_Id; | |
1957 | Op_List : Elist_Id; | |
1958 | Op_Elmt : Elmt_Id; | |
1959 | Op_Elmt_2 : Elmt_Id; | |
1960 | Prim_Op : Entity_Id; | |
1961 | New_Op : Entity_Id := Empty; | |
1962 | Parent_Subp : Entity_Id; | |
1963 | Tag : Entity_Id; | |
1964 | ||
07fc65c4 | 1965 | -- Start of processing for Declare_Inherited_Private_Subprograms |
996ae0b0 RK |
1966 | |
1967 | begin | |
1968 | E := First_Entity (Id); | |
996ae0b0 RK |
1969 | while Present (E) loop |
1970 | ||
cec29135 ES |
1971 | -- If the entity is a nonprivate type extension whose parent type |
1972 | -- is declared in an open scope, then the type may have inherited | |
1973 | -- operations that now need to be made visible. Ditto if the entity | |
1974 | -- is a formal derived type in a child unit. | |
996ae0b0 | 1975 | |
07fc65c4 | 1976 | if ((Is_Derived_Type (E) and then not Is_Private_Type (E)) |
996ae0b0 | 1977 | or else |
fbf5a39b AC |
1978 | (Nkind (Parent (E)) = N_Private_Extension_Declaration |
1979 | and then Is_Generic_Type (E))) | |
996ae0b0 | 1980 | and then In_Open_Scopes (Scope (Etype (E))) |
d347f572 | 1981 | and then Is_Base_Type (E) |
996ae0b0 | 1982 | then |
07fc65c4 | 1983 | if Is_Tagged_Type (E) then |
495d6dd6 RD |
1984 | Op_List := Primitive_Operations (E); |
1985 | New_Op := Empty; | |
1986 | Tag := First_Tag_Component (E); | |
996ae0b0 | 1987 | |
fbf5a39b | 1988 | Op_Elmt := First_Elmt (Op_List); |
996ae0b0 RK |
1989 | while Present (Op_Elmt) loop |
1990 | Prim_Op := Node (Op_Elmt); | |
1991 | ||
495d6dd6 RD |
1992 | -- Search primitives that are implicit operations with an |
1993 | -- internal name whose parent operation has a normal name. | |
996ae0b0 RK |
1994 | |
1995 | if Present (Alias (Prim_Op)) | |
3b75bcab | 1996 | and then Find_Dispatching_Type (Alias (Prim_Op)) /= E |
996ae0b0 RK |
1997 | and then not Comes_From_Source (Prim_Op) |
1998 | and then Is_Internal_Name (Chars (Prim_Op)) | |
1999 | and then not Is_Internal_Name (Chars (Alias (Prim_Op))) | |
2000 | then | |
2001 | Parent_Subp := Alias (Prim_Op); | |
2002 | ||
495d6dd6 RD |
2003 | -- Case 1: Check if the type has also an explicit |
2004 | -- overriding for this primitive. | |
2005 | ||
996ae0b0 RK |
2006 | Op_Elmt_2 := Next_Elmt (Op_Elmt); |
2007 | while Present (Op_Elmt_2) loop | |
ce09f8b3 AC |
2008 | |
2009 | -- Skip entities with attribute Interface_Alias since | |
2010 | -- they are not overriding primitives (these entities | |
2011 | -- link an interface primitive with their covering | |
2012 | -- primitive) | |
2013 | ||
996ae0b0 RK |
2014 | if Chars (Node (Op_Elmt_2)) = Chars (Parent_Subp) |
2015 | and then Type_Conformant (Prim_Op, Node (Op_Elmt_2)) | |
ce09f8b3 | 2016 | and then No (Interface_Alias (Node (Op_Elmt_2))) |
996ae0b0 RK |
2017 | then |
2018 | -- The private inherited operation has been | |
98779361 RD |
2019 | -- overridden by an explicit subprogram: |
2020 | -- replace the former by the latter. | |
996ae0b0 RK |
2021 | |
2022 | New_Op := Node (Op_Elmt_2); | |
2023 | Replace_Elmt (Op_Elmt, New_Op); | |
495d6dd6 | 2024 | Remove_Elmt (Op_List, Op_Elmt_2); |
f7d5442e | 2025 | Set_Overridden_Operation (New_Op, Parent_Subp); |
fbf5a39b | 2026 | |
495d6dd6 RD |
2027 | -- We don't need to inherit its dispatching slot. |
2028 | -- Set_All_DT_Position has previously ensured that | |
2029 | -- the same slot was assigned to the two primitives | |
2030 | ||
2031 | if Present (Tag) | |
2032 | and then Present (DTC_Entity (New_Op)) | |
2033 | and then Present (DTC_Entity (Prim_Op)) | |
2034 | then | |
09a078a1 RD |
2035 | pragma Assert |
2036 | (DT_Position (New_Op) = DT_Position (Prim_Op)); | |
495d6dd6 RD |
2037 | null; |
2038 | end if; | |
2039 | ||
2040 | goto Next_Primitive; | |
996ae0b0 RK |
2041 | end if; |
2042 | ||
2043 | Next_Elmt (Op_Elmt_2); | |
2044 | end loop; | |
2045 | ||
5e39baa6 TQ |
2046 | -- Case 2: We have not found any explicit overriding and |
2047 | -- hence we need to declare the operation (i.e., make it | |
2048 | -- visible). | |
996ae0b0 | 2049 | |
495d6dd6 | 2050 | Derive_Subprogram (New_Op, Alias (Prim_Op), E, Etype (E)); |
996ae0b0 | 2051 | |
495d6dd6 | 2052 | -- Inherit the dispatching slot if E is already frozen |
996ae0b0 | 2053 | |
495d6dd6 RD |
2054 | if Is_Frozen (E) |
2055 | and then Present (DTC_Entity (Alias (Prim_Op))) | |
2056 | then | |
2057 | Set_DTC_Entity_Value (E, New_Op); | |
024d33d8 | 2058 | Set_DT_Position_Value (New_Op, |
495d6dd6 | 2059 | DT_Position (Alias (Prim_Op))); |
996ae0b0 | 2060 | end if; |
495d6dd6 RD |
2061 | |
2062 | pragma Assert | |
2063 | (Is_Dispatching_Operation (New_Op) | |
2064 | and then Node (Last_Elmt (Op_List)) = New_Op); | |
2065 | ||
cec29135 ES |
2066 | -- Substitute the new operation for the old one in the |
2067 | -- type's primitive operations list. Since the new | |
2068 | -- operation was also just added to the end of list, | |
2069 | -- the last element must be removed. | |
495d6dd6 | 2070 | |
cec29135 ES |
2071 | -- (Question: is there a simpler way of declaring the |
2072 | -- operation, say by just replacing the name of the | |
2073 | -- earlier operation, reentering it in the in the symbol | |
2074 | -- table (how?), and marking it as private???) | |
495d6dd6 RD |
2075 | |
2076 | Replace_Elmt (Op_Elmt, New_Op); | |
2077 | Remove_Last_Elmt (Op_List); | |
996ae0b0 RK |
2078 | end if; |
2079 | ||
495d6dd6 | 2080 | <<Next_Primitive>> |
996ae0b0 RK |
2081 | Next_Elmt (Op_Elmt); |
2082 | end loop; | |
2083 | ||
495d6dd6 RD |
2084 | -- Generate listing showing the contents of the dispatch table |
2085 | ||
2086 | if Debug_Flag_ZZ then | |
2087 | Write_DT (E); | |
996ae0b0 | 2088 | end if; |
07fc65c4 GB |
2089 | |
2090 | else | |
1fb63e89 | 2091 | -- For untagged type, scan forward to locate inherited hidden |
5e39baa6 | 2092 | -- operations. |
07fc65c4 GB |
2093 | |
2094 | Prim_Op := Next_Entity (E); | |
07fc65c4 GB |
2095 | while Present (Prim_Op) loop |
2096 | if Is_Subprogram (Prim_Op) | |
2097 | and then Present (Alias (Prim_Op)) | |
2098 | and then not Comes_From_Source (Prim_Op) | |
2099 | and then Is_Internal_Name (Chars (Prim_Op)) | |
2100 | and then not Is_Internal_Name (Chars (Alias (Prim_Op))) | |
2101 | and then Is_Primitive_Of (E, Prim_Op) | |
2102 | then | |
2103 | Derive_Subprogram (New_Op, Alias (Prim_Op), E, Etype (E)); | |
2104 | end if; | |
2105 | ||
2106 | Next_Entity (Prim_Op); | |
1ae70618 ES |
2107 | |
2108 | -- Derived operations appear immediately after the type | |
2109 | -- declaration (or the following subtype indication for | |
2110 | -- a derived scalar type). Further declarations cannot | |
2111 | -- include inherited operations of the type. | |
2112 | ||
2113 | if Present (Prim_Op) then | |
2114 | exit when Ekind (Prim_Op) not in Overloadable_Kind; | |
2115 | end if; | |
07fc65c4 GB |
2116 | end loop; |
2117 | end if; | |
996ae0b0 RK |
2118 | end if; |
2119 | ||
2120 | Next_Entity (E); | |
2121 | end loop; | |
2122 | end Declare_Inherited_Private_Subprograms; | |
2123 | ||
2124 | ----------------------- | |
2125 | -- End_Package_Scope -- | |
2126 | ----------------------- | |
2127 | ||
2128 | procedure End_Package_Scope (P : Entity_Id) is | |
2129 | begin | |
2130 | Uninstall_Declarations (P); | |
2131 | Pop_Scope; | |
2132 | end End_Package_Scope; | |
2133 | ||
2134 | --------------------------- | |
2135 | -- Exchange_Declarations -- | |
2136 | --------------------------- | |
2137 | ||
2138 | procedure Exchange_Declarations (Id : Entity_Id) is | |
2139 | Full_Id : constant Entity_Id := Full_View (Id); | |
2140 | H1 : constant Entity_Id := Homonym (Id); | |
2141 | Next1 : constant Entity_Id := Next_Entity (Id); | |
2142 | H2 : Entity_Id; | |
2143 | Next2 : Entity_Id; | |
2144 | ||
2145 | begin | |
2146 | -- If missing full declaration for type, nothing to exchange | |
2147 | ||
2148 | if No (Full_Id) then | |
2149 | return; | |
2150 | end if; | |
2151 | ||
2152 | -- Otherwise complete the exchange, and preserve semantic links | |
2153 | ||
2154 | Next2 := Next_Entity (Full_Id); | |
2155 | H2 := Homonym (Full_Id); | |
2156 | ||
cec29135 ES |
2157 | -- Reset full declaration pointer to reflect the switched entities and |
2158 | -- readjust the next entity chains. | |
996ae0b0 RK |
2159 | |
2160 | Exchange_Entities (Id, Full_Id); | |
2161 | ||
2162 | Set_Next_Entity (Id, Next1); | |
2163 | Set_Homonym (Id, H1); | |
2164 | ||
2165 | Set_Full_View (Full_Id, Id); | |
2166 | Set_Next_Entity (Full_Id, Next2); | |
2167 | Set_Homonym (Full_Id, H2); | |
2168 | end Exchange_Declarations; | |
2169 | ||
996ae0b0 RK |
2170 | ---------------------------- |
2171 | -- Install_Package_Entity -- | |
2172 | ---------------------------- | |
2173 | ||
2174 | procedure Install_Package_Entity (Id : Entity_Id) is | |
2175 | begin | |
2176 | if not Is_Internal (Id) then | |
2177 | if Debug_Flag_E then | |
2178 | Write_Str ("Install: "); | |
2179 | Write_Name (Chars (Id)); | |
2180 | Write_Eol; | |
2181 | end if; | |
2182 | ||
09c954dc AC |
2183 | if Is_Child_Unit (Id) then |
2184 | null; | |
2185 | ||
2186 | -- Do not enter implicitly inherited non-overridden subprograms of | |
2187 | -- a tagged type back into visibility if they have non-conformant | |
2188 | -- homographs (Ada RM 8.3 12.3/2). | |
2189 | ||
7b4ebba5 | 2190 | elsif Is_Hidden_Non_Overridden_Subpgm (Id) then |
09c954dc AC |
2191 | null; |
2192 | ||
2193 | else | |
996ae0b0 RK |
2194 | Set_Is_Immediately_Visible (Id); |
2195 | end if; | |
996ae0b0 RK |
2196 | end if; |
2197 | end Install_Package_Entity; | |
2198 | ||
2199 | ---------------------------------- | |
2200 | -- Install_Private_Declarations -- | |
2201 | ---------------------------------- | |
2202 | ||
2203 | procedure Install_Private_Declarations (P : Entity_Id) is | |
2204 | Id : Entity_Id; | |
996ae0b0 | 2205 | Full : Entity_Id; |
24778dbb AC |
2206 | Priv_Deps : Elist_Id; |
2207 | ||
2208 | procedure Swap_Private_Dependents (Priv_Deps : Elist_Id); | |
2209 | -- When the full view of a private type is made available, we do the | |
2210 | -- same for its private dependents under proper visibility conditions. | |
2211 | -- When compiling a grand-chid unit this needs to be done recursively. | |
2212 | ||
70861157 AC |
2213 | ----------------------------- |
2214 | -- Swap_Private_Dependents -- | |
2215 | ----------------------------- | |
2216 | ||
24778dbb AC |
2217 | procedure Swap_Private_Dependents (Priv_Deps : Elist_Id) is |
2218 | Deps : Elist_Id; | |
2219 | Priv : Entity_Id; | |
2220 | Priv_Elmt : Elmt_Id; | |
2221 | Is_Priv : Boolean; | |
2222 | ||
2223 | begin | |
2224 | Priv_Elmt := First_Elmt (Priv_Deps); | |
24778dbb AC |
2225 | while Present (Priv_Elmt) loop |
2226 | Priv := Node (Priv_Elmt); | |
2227 | ||
70861157 AC |
2228 | -- Before the exchange, verify that the presence of the Full_View |
2229 | -- field. This field will be empty if the entity has already been | |
2230 | -- installed due to a previous call. | |
24778dbb | 2231 | |
09c954dc | 2232 | if Present (Full_View (Priv)) and then Is_Visible_Dependent (Priv) |
24778dbb AC |
2233 | then |
2234 | if Is_Private_Type (Priv) then | |
2235 | Deps := Private_Dependents (Priv); | |
2236 | Is_Priv := True; | |
2237 | else | |
2238 | Is_Priv := False; | |
2239 | end if; | |
2240 | ||
70861157 AC |
2241 | -- For each subtype that is swapped, we also swap the reference |
2242 | -- to it in Private_Dependents, to allow access to it when we | |
2243 | -- swap them out in End_Package_Scope. | |
24778dbb AC |
2244 | |
2245 | Replace_Elmt (Priv_Elmt, Full_View (Priv)); | |
e8c84c8f AC |
2246 | |
2247 | -- Ensure that both views of the dependent private subtype are | |
b68cf874 AC |
2248 | -- immediately visible if within some open scope. Check full |
2249 | -- view before exchanging views. | |
e8c84c8f AC |
2250 | |
2251 | if In_Open_Scopes (Scope (Full_View (Priv))) then | |
2252 | Set_Is_Immediately_Visible (Priv); | |
e8c84c8f AC |
2253 | end if; |
2254 | ||
24778dbb | 2255 | Exchange_Declarations (Priv); |
b68cf874 AC |
2256 | Set_Is_Immediately_Visible |
2257 | (Priv, In_Open_Scopes (Scope (Priv))); | |
2258 | ||
24778dbb AC |
2259 | Set_Is_Potentially_Use_Visible |
2260 | (Priv, Is_Potentially_Use_Visible (Node (Priv_Elmt))); | |
2261 | ||
09a078a1 RD |
2262 | -- Within a child unit, recurse, except in generic child unit, |
2263 | -- which (unfortunately) handle private_dependents separately. | |
24778dbb AC |
2264 | |
2265 | if Is_Priv | |
2266 | and then Is_Child_Unit (Cunit_Entity (Current_Sem_Unit)) | |
9f6aaa5c AC |
2267 | and then not Is_Empty_Elmt_List (Deps) |
2268 | and then not Inside_A_Generic | |
24778dbb AC |
2269 | then |
2270 | Swap_Private_Dependents (Deps); | |
2271 | end if; | |
2272 | end if; | |
2273 | ||
2274 | Next_Elmt (Priv_Elmt); | |
2275 | end loop; | |
2276 | end Swap_Private_Dependents; | |
996ae0b0 | 2277 | |
0d1f9820 | 2278 | -- Start of processing for Install_Private_Declarations |
70861157 | 2279 | |
996ae0b0 | 2280 | begin |
cec29135 ES |
2281 | -- First exchange declarations for private types, so that the full |
2282 | -- declaration is visible. For each private type, we check its | |
2283 | -- Private_Dependents list and also exchange any subtypes of or derived | |
2284 | -- types from it. Finally, if this is a Taft amendment type, the | |
2285 | -- incomplete declaration is irrelevant, and we want to link the | |
70861157 AC |
2286 | -- eventual full declaration with the original private one so we |
2287 | -- also skip the exchange. | |
996ae0b0 RK |
2288 | |
2289 | Id := First_Entity (P); | |
996ae0b0 | 2290 | while Present (Id) and then Id /= First_Private_Entity (P) loop |
996ae0b0 | 2291 | if Is_Private_Base_Type (Id) |
996ae0b0 | 2292 | and then Present (Full_View (Id)) |
4887624e | 2293 | and then Comes_From_Source (Full_View (Id)) |
996ae0b0 RK |
2294 | and then Scope (Full_View (Id)) = Scope (Id) |
2295 | and then Ekind (Full_View (Id)) /= E_Incomplete_Type | |
2296 | then | |
70861157 AC |
2297 | -- If there is a use-type clause on the private type, set the full |
2298 | -- view accordingly. | |
996ae0b0 RK |
2299 | |
2300 | Set_In_Use (Full_View (Id), In_Use (Id)); | |
2301 | Full := Full_View (Id); | |
2302 | ||
2303 | if Is_Private_Base_Type (Full) | |
2304 | and then Has_Private_Declaration (Full) | |
2305 | and then Nkind (Parent (Full)) = N_Full_Type_Declaration | |
2306 | and then In_Open_Scopes (Scope (Etype (Full))) | |
2307 | and then In_Package_Body (Current_Scope) | |
2308 | and then not Is_Private_Type (Etype (Full)) | |
2309 | then | |
2310 | -- This is the completion of a private type by a derivation | |
2311 | -- from another private type which is not private anymore. This | |
2312 | -- can only happen in a package nested within a child package, | |
2313 | -- when the parent type is defined in the parent unit. At this | |
70861157 AC |
2314 | -- point the current type is not private either, and we have |
2315 | -- to install the underlying full view, which is now visible. | |
2316 | -- Save the current full view as well, so that all views can be | |
cec29135 ES |
2317 | -- restored on exit. It may seem that after compiling the child |
2318 | -- body there are not environments to restore, but the back-end | |
2319 | -- expects those links to be valid, and freeze nodes depend on | |
2320 | -- them. | |
996ae0b0 RK |
2321 | |
2322 | if No (Full_View (Full)) | |
2323 | and then Present (Underlying_Full_View (Full)) | |
2324 | then | |
2325 | Set_Full_View (Id, Underlying_Full_View (Full)); | |
f7d5442e | 2326 | Set_Underlying_Full_View (Id, Full); |
ce06d641 | 2327 | Set_Is_Underlying_Full_View (Full); |
f7d5442e | 2328 | |
996ae0b0 RK |
2329 | Set_Underlying_Full_View (Full, Empty); |
2330 | Set_Is_Frozen (Full_View (Id)); | |
2331 | end if; | |
2332 | end if; | |
2333 | ||
24778dbb | 2334 | Priv_Deps := Private_Dependents (Id); |
996ae0b0 RK |
2335 | Exchange_Declarations (Id); |
2336 | Set_Is_Immediately_Visible (Id); | |
24778dbb | 2337 | Swap_Private_Dependents (Priv_Deps); |
996ae0b0 RK |
2338 | end if; |
2339 | ||
2340 | Next_Entity (Id); | |
2341 | end loop; | |
2342 | ||
a5b62485 | 2343 | -- Next make other declarations in the private part visible as well |
996ae0b0 RK |
2344 | |
2345 | Id := First_Private_Entity (P); | |
996ae0b0 RK |
2346 | while Present (Id) loop |
2347 | Install_Package_Entity (Id); | |
5d09245e | 2348 | Set_Is_Hidden (Id, False); |
996ae0b0 RK |
2349 | Next_Entity (Id); |
2350 | end loop; | |
2351 | ||
d89ce432 AC |
2352 | -- An abstract state is partially refined when it has at least one |
2353 | -- Part_Of constituent. Since these constituents are being installed | |
2354 | -- into visibility, update the partial refinement status of any state | |
2355 | -- defined in the associated package, subject to at least one Part_Of | |
2356 | -- constituent. | |
2357 | ||
2358 | if Ekind_In (P, E_Generic_Package, E_Package) then | |
2359 | declare | |
2360 | States : constant Elist_Id := Abstract_States (P); | |
2361 | State_Elmt : Elmt_Id; | |
2362 | State_Id : Entity_Id; | |
2363 | ||
2364 | begin | |
2365 | if Present (States) then | |
2366 | State_Elmt := First_Elmt (States); | |
2367 | while Present (State_Elmt) loop | |
2368 | State_Id := Node (State_Elmt); | |
2369 | ||
2370 | if Present (Part_Of_Constituents (State_Id)) then | |
2371 | Set_Has_Partial_Visible_Refinement (State_Id); | |
2372 | end if; | |
2373 | ||
2374 | Next_Elmt (State_Elmt); | |
2375 | end loop; | |
2376 | end if; | |
2377 | end; | |
2378 | end if; | |
2379 | ||
996ae0b0 RK |
2380 | -- Indicate that the private part is currently visible, so it can be |
2381 | -- properly reset on exit. | |
2382 | ||
2383 | Set_In_Private_Part (P); | |
2384 | end Install_Private_Declarations; | |
2385 | ||
2386 | ---------------------------------- | |
2387 | -- Install_Visible_Declarations -- | |
2388 | ---------------------------------- | |
2389 | ||
2390 | procedure Install_Visible_Declarations (P : Entity_Id) is | |
7b1da1d0 JM |
2391 | Id : Entity_Id; |
2392 | Last_Entity : Entity_Id; | |
996ae0b0 RK |
2393 | |
2394 | begin | |
a59e9305 GD |
2395 | pragma Assert |
2396 | (Is_Package_Or_Generic_Package (P) or else Is_Record_Type (P)); | |
7b1da1d0 | 2397 | |
a59e9305 | 2398 | if Is_Package_Or_Generic_Package (P) then |
7b1da1d0 JM |
2399 | Last_Entity := First_Private_Entity (P); |
2400 | else | |
2401 | Last_Entity := Empty; | |
2402 | end if; | |
2403 | ||
996ae0b0 | 2404 | Id := First_Entity (P); |
7b1da1d0 | 2405 | while Present (Id) and then Id /= Last_Entity loop |
996ae0b0 RK |
2406 | Install_Package_Entity (Id); |
2407 | Next_Entity (Id); | |
2408 | end loop; | |
2409 | end Install_Visible_Declarations; | |
2410 | ||
996ae0b0 RK |
2411 | -------------------------- |
2412 | -- Is_Private_Base_Type -- | |
2413 | -------------------------- | |
2414 | ||
2415 | function Is_Private_Base_Type (E : Entity_Id) return Boolean is | |
2416 | begin | |
2417 | return Ekind (E) = E_Private_Type | |
2418 | or else Ekind (E) = E_Limited_Private_Type | |
2419 | or else Ekind (E) = E_Record_Type_With_Private; | |
2420 | end Is_Private_Base_Type; | |
2421 | ||
2422 | -------------------------- | |
2423 | -- Is_Visible_Dependent -- | |
2424 | -------------------------- | |
2425 | ||
2426 | function Is_Visible_Dependent (Dep : Entity_Id) return Boolean | |
2427 | is | |
2428 | S : constant Entity_Id := Scope (Dep); | |
2429 | ||
2430 | begin | |
cec29135 | 2431 | -- Renamings created for actual types have the visibility of the actual |
996ae0b0 RK |
2432 | |
2433 | if Ekind (S) = E_Package | |
2434 | and then Is_Generic_Instance (S) | |
2435 | and then (Is_Generic_Actual_Type (Dep) | |
2436 | or else Is_Generic_Actual_Type (Full_View (Dep))) | |
2437 | then | |
2438 | return True; | |
2439 | ||
2440 | elsif not (Is_Derived_Type (Dep)) | |
2441 | and then Is_Derived_Type (Full_View (Dep)) | |
2442 | then | |
cec29135 ES |
2443 | -- When instantiating a package body, the scope stack is empty, so |
2444 | -- check instead whether the dependent type is defined in the same | |
2445 | -- scope as the instance itself. | |
fbf5a39b AC |
2446 | |
2447 | return In_Open_Scopes (S) | |
2448 | or else (Is_Generic_Instance (Current_Scope) | |
09a078a1 | 2449 | and then Scope (Dep) = Scope (Current_Scope)); |
996ae0b0 RK |
2450 | else |
2451 | return True; | |
2452 | end if; | |
2453 | end Is_Visible_Dependent; | |
2454 | ||
2455 | ---------------------------- | |
2456 | -- May_Need_Implicit_Body -- | |
2457 | ---------------------------- | |
2458 | ||
2459 | procedure May_Need_Implicit_Body (E : Entity_Id) is | |
2460 | P : constant Node_Id := Unit_Declaration_Node (E); | |
2461 | S : constant Node_Id := Parent (P); | |
2462 | B : Node_Id; | |
2463 | Decls : List_Id; | |
2464 | ||
2465 | begin | |
2466 | if not Has_Completion (E) | |
2467 | and then Nkind (P) = N_Package_Declaration | |
13bbad84 | 2468 | and then (Present (Activation_Chain_Entity (P)) or else Has_RACW (E)) |
996ae0b0 RK |
2469 | then |
2470 | B := | |
2471 | Make_Package_Body (Sloc (E), | |
2472 | Defining_Unit_Name => Make_Defining_Identifier (Sloc (E), | |
2473 | Chars => Chars (E)), | |
2474 | Declarations => New_List); | |
2475 | ||
2476 | if Nkind (S) = N_Package_Specification then | |
2477 | if Present (Private_Declarations (S)) then | |
2478 | Decls := Private_Declarations (S); | |
2479 | else | |
2480 | Decls := Visible_Declarations (S); | |
2481 | end if; | |
2482 | else | |
2483 | Decls := Declarations (S); | |
2484 | end if; | |
2485 | ||
2486 | Append (B, Decls); | |
2487 | Analyze (B); | |
2488 | end if; | |
2489 | end May_Need_Implicit_Body; | |
2490 | ||
2491 | ---------------------- | |
2492 | -- New_Private_Type -- | |
2493 | ---------------------- | |
2494 | ||
2495 | procedure New_Private_Type (N : Node_Id; Id : Entity_Id; Def : Node_Id) is | |
2496 | begin | |
308e6f3a | 2497 | -- For other than Ada 2012, enter the name in the current scope |
e606088a | 2498 | |
6191e212 AC |
2499 | if Ada_Version < Ada_2012 then |
2500 | Enter_Name (Id); | |
2501 | ||
24778dbb AC |
2502 | -- Ada 2012 (AI05-0162): Enter the name in the current scope. Note that |
2503 | -- there may be an incomplete previous view. | |
6191e212 AC |
2504 | |
2505 | else | |
2506 | declare | |
2507 | Prev : Entity_Id; | |
6191e212 AC |
2508 | begin |
2509 | Prev := Find_Type_Name (N); | |
6191e212 AC |
2510 | pragma Assert (Prev = Id |
2511 | or else (Ekind (Prev) = E_Incomplete_Type | |
e606088a AC |
2512 | and then Present (Full_View (Prev)) |
2513 | and then Full_View (Prev) = Id)); | |
6191e212 AC |
2514 | end; |
2515 | end if; | |
996ae0b0 RK |
2516 | |
2517 | if Limited_Present (Def) then | |
2518 | Set_Ekind (Id, E_Limited_Private_Type); | |
2519 | else | |
2520 | Set_Ekind (Id, E_Private_Type); | |
2521 | end if; | |
2522 | ||
2523 | Set_Etype (Id, Id); | |
2524 | Set_Has_Delayed_Freeze (Id); | |
2525 | Set_Is_First_Subtype (Id); | |
2526 | Init_Size_Align (Id); | |
2527 | ||
2528 | Set_Is_Constrained (Id, | |
2529 | No (Discriminant_Specifications (N)) | |
2530 | and then not Unknown_Discriminants_Present (N)); | |
2531 | ||
cec29135 ES |
2532 | -- Set tagged flag before processing discriminants, to catch illegal |
2533 | -- usage. | |
c0def2ad ES |
2534 | |
2535 | Set_Is_Tagged_Type (Id, Tagged_Present (Def)); | |
2536 | ||
996ae0b0 | 2537 | Set_Discriminant_Constraint (Id, No_Elist); |
fbf5a39b | 2538 | Set_Stored_Constraint (Id, No_Elist); |
996ae0b0 RK |
2539 | |
2540 | if Present (Discriminant_Specifications (N)) then | |
495d6dd6 | 2541 | Push_Scope (Id); |
996ae0b0 RK |
2542 | Process_Discriminants (N); |
2543 | End_Scope; | |
2544 | ||
2545 | elsif Unknown_Discriminants_Present (N) then | |
2546 | Set_Has_Unknown_Discriminants (Id); | |
2547 | end if; | |
2548 | ||
2549 | Set_Private_Dependents (Id, New_Elmt_List); | |
2550 | ||
2551 | if Tagged_Present (Def) then | |
ef2a63ba JM |
2552 | Set_Ekind (Id, E_Record_Type_With_Private); |
2553 | Set_Direct_Primitive_Operations (Id, New_Elmt_List); | |
2554 | Set_Is_Abstract_Type (Id, Abstract_Present (Def)); | |
2555 | Set_Is_Limited_Record (Id, Limited_Present (Def)); | |
2556 | Set_Has_Delayed_Freeze (Id, True); | |
996ae0b0 | 2557 | |
4969efdf AC |
2558 | -- Recognize Ada.Real_Time.Timing_Events.Timing_Events here |
2559 | ||
2560 | if Is_RTE (Id, RE_Timing_Event) then | |
2561 | Set_Has_Timing_Event (Id); | |
2562 | end if; | |
2563 | ||
16c5f1c6 | 2564 | -- Create a class-wide type with the same attributes |
a73734f5 | 2565 | |
24778dbb | 2566 | Make_Class_Wide_Type (Id); |
a73734f5 | 2567 | |
996ae0b0 RK |
2568 | elsif Abstract_Present (Def) then |
2569 | Error_Msg_N ("only a tagged type can be abstract", N); | |
2570 | end if; | |
2571 | end New_Private_Type; | |
2572 | ||
c5cec2fe AC |
2573 | --------------------------------- |
2574 | -- Requires_Completion_In_Body -- | |
2575 | --------------------------------- | |
2576 | ||
2577 | function Requires_Completion_In_Body | |
22a4f9d5 AC |
2578 | (Id : Entity_Id; |
2579 | Pack_Id : Entity_Id; | |
2580 | Do_Abstract_States : Boolean := False) return Boolean | |
3cb9a885 | 2581 | is |
c5cec2fe AC |
2582 | begin |
2583 | -- Always ignore child units. Child units get added to the entity list | |
2584 | -- of a parent unit, but are not original entities of the parent, and | |
2585 | -- so do not affect whether the parent needs a body. | |
2586 | ||
2587 | if Is_Child_Unit (Id) then | |
2588 | return False; | |
2589 | ||
2590 | -- Ignore formal packages and their renamings | |
2591 | ||
2592 | elsif Ekind (Id) = E_Package | |
2593 | and then Nkind (Original_Node (Unit_Declaration_Node (Id))) = | |
08f52d9f | 2594 | N_Formal_Package_Declaration |
c5cec2fe AC |
2595 | then |
2596 | return False; | |
2597 | ||
c5cec2fe AC |
2598 | -- Otherwise test to see if entity requires a completion. Note that |
2599 | -- subprogram entities whose declaration does not come from source are | |
2600 | -- ignored here on the basis that we assume the expander will provide an | |
2601 | -- implicit completion at some point. | |
2602 | ||
2603 | elsif (Is_Overloadable (Id) | |
08f52d9f | 2604 | and then not Ekind_In (Id, E_Enumeration_Literal, E_Operator) |
c5cec2fe AC |
2605 | and then not Is_Abstract_Subprogram (Id) |
2606 | and then not Has_Completion (Id) | |
2607 | and then Comes_From_Source (Parent (Id))) | |
2608 | ||
2609 | or else | |
2610 | (Ekind (Id) = E_Package | |
2611 | and then Id /= Pack_Id | |
2612 | and then not Has_Completion (Id) | |
22a4f9d5 | 2613 | and then Unit_Requires_Body (Id, Do_Abstract_States)) |
c5cec2fe AC |
2614 | |
2615 | or else | |
2616 | (Ekind (Id) = E_Incomplete_Type | |
2617 | and then No (Full_View (Id)) | |
2618 | and then not Is_Generic_Type (Id)) | |
2619 | ||
2620 | or else | |
2621 | (Ekind_In (Id, E_Task_Type, E_Protected_Type) | |
2622 | and then not Has_Completion (Id)) | |
2623 | ||
2624 | or else | |
2625 | (Ekind (Id) = E_Generic_Package | |
2626 | and then Id /= Pack_Id | |
2627 | and then not Has_Completion (Id) | |
22a4f9d5 | 2628 | and then Unit_Requires_Body (Id, Do_Abstract_States)) |
c5cec2fe AC |
2629 | |
2630 | or else | |
2631 | (Is_Generic_Subprogram (Id) | |
2632 | and then not Has_Completion (Id)) | |
c5cec2fe AC |
2633 | then |
2634 | return True; | |
2635 | ||
2636 | -- Otherwise the entity does not require completion in a package body | |
2637 | ||
2638 | else | |
2639 | return False; | |
2640 | end if; | |
2641 | end Requires_Completion_In_Body; | |
2642 | ||
fbf5a39b AC |
2643 | ---------------------------- |
2644 | -- Uninstall_Declarations -- | |
2645 | ---------------------------- | |
2646 | ||
2647 | procedure Uninstall_Declarations (P : Entity_Id) is | |
2648 | Decl : constant Node_Id := Unit_Declaration_Node (P); | |
2649 | Id : Entity_Id; | |
2650 | Full : Entity_Id; | |
2651 | Priv_Elmt : Elmt_Id; | |
2652 | Priv_Sub : Entity_Id; | |
996ae0b0 | 2653 | |
3ddfabe3 | 2654 | procedure Preserve_Full_Attributes (Priv : Entity_Id; Full : Entity_Id); |
cec29135 ES |
2655 | -- Copy to the private declaration the attributes of the full view that |
2656 | -- need to be available for the partial view also. | |
996ae0b0 | 2657 | |
fbf5a39b | 2658 | function Type_In_Use (T : Entity_Id) return Boolean; |
a5b62485 | 2659 | -- Check whether type or base type appear in an active use_type clause |
996ae0b0 | 2660 | |
fbf5a39b AC |
2661 | ------------------------------ |
2662 | -- Preserve_Full_Attributes -- | |
2663 | ------------------------------ | |
996ae0b0 | 2664 | |
3ddfabe3 AC |
2665 | procedure Preserve_Full_Attributes |
2666 | (Priv : Entity_Id; | |
2667 | Full : Entity_Id) | |
2668 | is | |
2669 | Full_Base : constant Entity_Id := Base_Type (Full); | |
2670 | Priv_Is_Base_Type : constant Boolean := Is_Base_Type (Priv); | |
fbf5a39b AC |
2671 | |
2672 | begin | |
3ddfabe3 AC |
2673 | Set_Size_Info (Priv, Full); |
2674 | Set_RM_Size (Priv, RM_Size (Full)); | |
13bbad84 ES |
2675 | Set_Size_Known_At_Compile_Time |
2676 | (Priv, Size_Known_At_Compile_Time (Full)); | |
2677 | Set_Is_Volatile (Priv, Is_Volatile (Full)); | |
2678 | Set_Treat_As_Volatile (Priv, Treat_As_Volatile (Full)); | |
2679 | Set_Is_Ada_2005_Only (Priv, Is_Ada_2005_Only (Full)); | |
599a7411 | 2680 | Set_Is_Ada_2012_Only (Priv, Is_Ada_2012_Only (Full)); |
4a214958 | 2681 | Set_Has_Pragma_Unmodified (Priv, Has_Pragma_Unmodified (Full)); |
13bbad84 ES |
2682 | Set_Has_Pragma_Unreferenced (Priv, Has_Pragma_Unreferenced (Full)); |
2683 | Set_Has_Pragma_Unreferenced_Objects | |
2684 | (Priv, Has_Pragma_Unreferenced_Objects | |
2685 | (Full)); | |
edd63e9b ES |
2686 | if Is_Unchecked_Union (Full) then |
2687 | Set_Is_Unchecked_Union (Base_Type (Priv)); | |
2688 | end if; | |
728c3084 | 2689 | -- Why is atomic not copied here ??? |
fbf5a39b AC |
2690 | |
2691 | if Referenced (Full) then | |
2692 | Set_Referenced (Priv); | |
2693 | end if; | |
996ae0b0 | 2694 | |
996ae0b0 | 2695 | if Priv_Is_Base_Type then |
0cb81445 PMR |
2696 | Set_Is_Controlled_Active |
2697 | (Priv, Is_Controlled_Active (Full_Base)); | |
96e90ac1 | 2698 | Set_Finalize_Storage_Only |
3ddfabe3 | 2699 | (Priv, Finalize_Storage_Only (Full_Base)); |
96e90ac1 | 2700 | Set_Has_Controlled_Component |
3ddfabe3 AC |
2701 | (Priv, Has_Controlled_Component (Full_Base)); |
2702 | ||
2703 | Propagate_Concurrent_Flags (Priv, Base_Type (Full)); | |
996ae0b0 RK |
2704 | end if; |
2705 | ||
fbf5a39b | 2706 | Set_Freeze_Node (Priv, Freeze_Node (Full)); |
996ae0b0 | 2707 | |
f63d601b HK |
2708 | -- Propagate Default_Initial_Condition-related attributes from the |
2709 | -- base type of the full view to the full view and vice versa. This | |
2710 | -- may seem strange, but is necessary depending on which type | |
2711 | -- triggered the generation of the DIC procedure body. As a result, | |
2712 | -- both the full view and its base type carry the same DIC-related | |
2713 | -- information. | |
2714 | ||
2715 | Propagate_DIC_Attributes (Full, From_Typ => Full_Base); | |
2716 | Propagate_DIC_Attributes (Full_Base, From_Typ => Full); | |
2717 | ||
b619c88e AC |
2718 | -- Propagate Default_Initial_Condition-related attributes from the |
2719 | -- full view to the private view. | |
2720 | ||
2721 | Propagate_DIC_Attributes (Priv, From_Typ => Full); | |
2722 | ||
3ddfabe3 AC |
2723 | -- Propagate invariant-related attributes from the base type of the |
2724 | -- full view to the full view and vice versa. This may seem strange, | |
2725 | -- but is necessary depending on which type triggered the generation | |
2726 | -- of the invariant procedure body. As a result, both the full view | |
2727 | -- and its base type carry the same invariant-related information. | |
95081e99 | 2728 | |
3ddfabe3 AC |
2729 | Propagate_Invariant_Attributes (Full, From_Typ => Full_Base); |
2730 | Propagate_Invariant_Attributes (Full_Base, From_Typ => Full); | |
2731 | ||
2732 | -- Propagate invariant-related attributes from the full view to the | |
2733 | -- private view. | |
2734 | ||
2735 | Propagate_Invariant_Attributes (Priv, From_Typ => Full); | |
95081e99 | 2736 | |
fbf5a39b AC |
2737 | if Is_Tagged_Type (Priv) |
2738 | and then Is_Tagged_Type (Full) | |
2739 | and then not Error_Posted (Full) | |
2740 | then | |
13bbad84 ES |
2741 | if Is_Tagged_Type (Priv) then |
2742 | ||
cec29135 ES |
2743 | -- If the type is tagged, the tag itself must be available on |
2744 | -- the partial view, for expansion purposes. | |
13bbad84 ES |
2745 | |
2746 | Set_First_Entity (Priv, First_Entity (Full)); | |
2747 | ||
2748 | -- If there are discriminants in the partial view, these remain | |
2749 | -- visible. Otherwise only the tag itself is visible, and there | |
2750 | -- are no nameable components in the partial view. | |
2751 | ||
2752 | if No (Last_Entity (Priv)) then | |
2753 | Set_Last_Entity (Priv, First_Entity (Priv)); | |
2754 | end if; | |
2755 | end if; | |
2756 | ||
8a6a52dc | 2757 | Set_Has_Discriminants (Priv, Has_Discriminants (Full)); |
4a214958 | 2758 | |
a5d83d61 AC |
2759 | if Has_Discriminants (Full) then |
2760 | Set_Discriminant_Constraint (Priv, | |
2761 | Discriminant_Constraint (Full)); | |
2762 | end if; | |
fbf5a39b AC |
2763 | end if; |
2764 | end Preserve_Full_Attributes; | |
996ae0b0 | 2765 | |
fbf5a39b AC |
2766 | ----------------- |
2767 | -- Type_In_Use -- | |
2768 | ----------------- | |
996ae0b0 RK |
2769 | |
2770 | function Type_In_Use (T : Entity_Id) return Boolean is | |
2771 | begin | |
2772 | return Scope (Base_Type (T)) = P | |
13bbad84 | 2773 | and then (In_Use (T) or else In_Use (Base_Type (T))); |
996ae0b0 RK |
2774 | end Type_In_Use; |
2775 | ||
2776 | -- Start of processing for Uninstall_Declarations | |
2777 | ||
2778 | begin | |
2779 | Id := First_Entity (P); | |
996ae0b0 RK |
2780 | while Present (Id) and then Id /= First_Private_Entity (P) loop |
2781 | if Debug_Flag_E then | |
2782 | Write_Str ("unlinking visible entity "); | |
2783 | Write_Int (Int (Id)); | |
2784 | Write_Eol; | |
2785 | end if; | |
2786 | ||
4ff4293f | 2787 | -- On exit from the package scope, we must preserve the visibility |
996ae0b0 RK |
2788 | -- established by use clauses in the current scope. Two cases: |
2789 | ||
2790 | -- a) If the entity is an operator, it may be a primitive operator of | |
2791 | -- a type for which there is a visible use-type clause. | |
2792 | ||
2793 | -- b) for other entities, their use-visibility is determined by a | |
2794 | -- visible use clause for the package itself. For a generic instance, | |
2795 | -- the instantiation of the formals appears in the visible part, | |
2796 | -- but the formals are private and remain so. | |
2797 | ||
2798 | if Ekind (Id) = E_Function | |
bce79204 | 2799 | and then Is_Operator_Symbol_Name (Chars (Id)) |
996ae0b0 | 2800 | and then not Is_Hidden (Id) |
fbf5a39b | 2801 | and then not Error_Posted (Id) |
996ae0b0 RK |
2802 | then |
2803 | Set_Is_Potentially_Use_Visible (Id, | |
2804 | In_Use (P) | |
2805 | or else Type_In_Use (Etype (Id)) | |
2806 | or else Type_In_Use (Etype (First_Formal (Id))) | |
2807 | or else (Present (Next_Formal (First_Formal (Id))) | |
09c954dc AC |
2808 | and then |
2809 | Type_In_Use | |
2810 | (Etype (Next_Formal (First_Formal (Id)))))); | |
996ae0b0 | 2811 | else |
31b5873d GD |
2812 | if In_Use (P) and then not Is_Hidden (Id) then |
2813 | ||
2814 | -- A child unit of a use-visible package remains use-visible | |
2815 | -- only if it is itself a visible child unit. Otherwise it | |
2816 | -- would remain visible in other contexts where P is use- | |
2817 | -- visible, because once compiled it stays in the entity list | |
2818 | -- of its parent unit. | |
2819 | ||
2820 | if Is_Child_Unit (Id) then | |
4ff4293f | 2821 | Set_Is_Potentially_Use_Visible |
8ca1ee5d | 2822 | (Id, Is_Visible_Lib_Unit (Id)); |
31b5873d GD |
2823 | else |
2824 | Set_Is_Potentially_Use_Visible (Id); | |
2825 | end if; | |
2826 | ||
2827 | else | |
2828 | Set_Is_Potentially_Use_Visible (Id, False); | |
2829 | end if; | |
996ae0b0 RK |
2830 | end if; |
2831 | ||
a5b62485 | 2832 | -- Local entities are not immediately visible outside of the package |
996ae0b0 RK |
2833 | |
2834 | Set_Is_Immediately_Visible (Id, False); | |
2835 | ||
a397db96 AC |
2836 | -- If this is a private type with a full view (for example a local |
2837 | -- subtype of a private type declared elsewhere), ensure that the | |
2838 | -- full view is also removed from visibility: it may be exposed when | |
7d4c4fde AC |
2839 | -- swapping views in an instantiation. Similarly, ensure that the |
2840 | -- use-visibility is properly set on both views. | |
a397db96 | 2841 | |
4ff4293f | 2842 | if Is_Type (Id) and then Present (Full_View (Id)) then |
7d4c4fde AC |
2843 | Set_Is_Immediately_Visible (Full_View (Id), False); |
2844 | Set_Is_Potentially_Use_Visible (Full_View (Id), | |
2845 | Is_Potentially_Use_Visible (Id)); | |
a397db96 AC |
2846 | end if; |
2847 | ||
996ae0b0 RK |
2848 | if Is_Tagged_Type (Id) and then Ekind (Id) = E_Record_Type then |
2849 | Check_Abstract_Overriding (Id); | |
3b75bcab | 2850 | Check_Conventions (Id); |
996ae0b0 RK |
2851 | end if; |
2852 | ||
09a078a1 | 2853 | if Ekind_In (Id, E_Private_Type, E_Limited_Private_Type) |
996ae0b0 RK |
2854 | and then No (Full_View (Id)) |
2855 | and then not Is_Generic_Type (Id) | |
2856 | and then not Is_Derived_Type (Id) | |
2857 | then | |
2858 | Error_Msg_N ("missing full declaration for private type&", Id); | |
2859 | ||
2860 | elsif Ekind (Id) = E_Record_Type_With_Private | |
2861 | and then not Is_Generic_Type (Id) | |
2862 | and then No (Full_View (Id)) | |
2863 | then | |
2864 | if Nkind (Parent (Id)) = N_Private_Type_Declaration then | |
2865 | Error_Msg_N ("missing full declaration for private type&", Id); | |
2866 | else | |
2867 | Error_Msg_N | |
2868 | ("missing full declaration for private extension", Id); | |
2869 | end if; | |
2870 | ||
d1f453b7 RD |
2871 | -- Case of constant, check for deferred constant declaration with |
2872 | -- no full view. Likely just a matter of a missing expression, or | |
2873 | -- accidental use of the keyword constant. | |
2874 | ||
996ae0b0 | 2875 | elsif Ekind (Id) = E_Constant |
d1f453b7 RD |
2876 | |
2877 | -- OK if constant value present | |
2878 | ||
996ae0b0 | 2879 | and then No (Constant_Value (Id)) |
d1f453b7 RD |
2880 | |
2881 | -- OK if full view present | |
2882 | ||
996ae0b0 | 2883 | and then No (Full_View (Id)) |
d1f453b7 RD |
2884 | |
2885 | -- OK if imported, since that provides the completion | |
2886 | ||
996ae0b0 | 2887 | and then not Is_Imported (Id) |
d1f453b7 RD |
2888 | |
2889 | -- OK if object declaration replaced by renaming declaration as | |
2890 | -- a result of OK_To_Rename processing (e.g. for concatenation) | |
2891 | ||
2892 | and then Nkind (Parent (Id)) /= N_Object_Renaming_Declaration | |
2893 | ||
2894 | -- OK if object declaration with the No_Initialization flag set | |
2895 | ||
2896 | and then not (Nkind (Parent (Id)) = N_Object_Declaration | |
4ff4293f | 2897 | and then No_Initialization (Parent (Id))) |
996ae0b0 | 2898 | then |
d1f453b7 RD |
2899 | -- If no private declaration is present, we assume the user did |
2900 | -- not intend a deferred constant declaration and the problem | |
2901 | -- is simply that the initializing expression is missing. | |
2902 | ||
fbf5a39b AC |
2903 | if not Has_Private_Declaration (Etype (Id)) then |
2904 | ||
c54ab0b5 AC |
2905 | -- We assume that the user did not intend a deferred constant |
2906 | -- declaration, and the expression is just missing. | |
fbf5a39b AC |
2907 | |
2908 | Error_Msg_N | |
2909 | ("constant declaration requires initialization expression", | |
2910 | Parent (Id)); | |
2911 | ||
2912 | if Is_Limited_Type (Etype (Id)) then | |
2913 | Error_Msg_N | |
3b75bcab | 2914 | ("\if variable intended, remove CONSTANT from declaration", |
fbf5a39b AC |
2915 | Parent (Id)); |
2916 | end if; | |
2917 | ||
d1f453b7 RD |
2918 | -- Otherwise if a private declaration is present, then we are |
2919 | -- missing the full declaration for the deferred constant. | |
2920 | ||
fbf5a39b AC |
2921 | else |
2922 | Error_Msg_N | |
4ff4293f AC |
2923 | ("missing full declaration for deferred constant (RM 7.4)", |
2924 | Id); | |
fbf5a39b AC |
2925 | |
2926 | if Is_Limited_Type (Etype (Id)) then | |
2927 | Error_Msg_N | |
3b75bcab | 2928 | ("\if variable intended, remove CONSTANT from declaration", |
4ff4293f | 2929 | Parent (Id)); |
fbf5a39b AC |
2930 | end if; |
2931 | end if; | |
996ae0b0 RK |
2932 | end if; |
2933 | ||
2934 | Next_Entity (Id); | |
2935 | end loop; | |
2936 | ||
2937 | -- If the specification was installed as the parent of a public child | |
2938 | -- unit, the private declarations were not installed, and there is | |
2939 | -- nothing to do. | |
2940 | ||
2941 | if not In_Private_Part (P) then | |
2942 | return; | |
2943 | else | |
2944 | Set_In_Private_Part (P, False); | |
2945 | end if; | |
2946 | ||
2947 | -- Make private entities invisible and exchange full and private | |
cec29135 ES |
2948 | -- declarations for private types. Id is now the first private entity |
2949 | -- in the package. | |
996ae0b0 RK |
2950 | |
2951 | while Present (Id) loop | |
2952 | if Debug_Flag_E then | |
2953 | Write_Str ("unlinking private entity "); | |
2954 | Write_Int (Int (Id)); | |
2955 | Write_Eol; | |
2956 | end if; | |
2957 | ||
2958 | if Is_Tagged_Type (Id) and then Ekind (Id) = E_Record_Type then | |
2959 | Check_Abstract_Overriding (Id); | |
3b75bcab | 2960 | Check_Conventions (Id); |
996ae0b0 RK |
2961 | end if; |
2962 | ||
2963 | Set_Is_Immediately_Visible (Id, False); | |
2964 | ||
4ff4293f | 2965 | if Is_Private_Base_Type (Id) and then Present (Full_View (Id)) then |
996ae0b0 RK |
2966 | Full := Full_View (Id); |
2967 | ||
cec29135 ES |
2968 | -- If the partial view is not declared in the visible part of the |
2969 | -- package (as is the case when it is a type derived from some | |
2970 | -- other private type in the private part of the current package), | |
2971 | -- no exchange takes place. | |
996ae0b0 RK |
2972 | |
2973 | if No (Parent (Id)) | |
4ff4293f AC |
2974 | or else List_Containing (Parent (Id)) /= |
2975 | Visible_Declarations (Specification (Decl)) | |
996ae0b0 RK |
2976 | then |
2977 | goto Next_Id; | |
2978 | end if; | |
2979 | ||
2980 | -- The entry in the private part points to the full declaration, | |
2981 | -- which is currently visible. Exchange them so only the private | |
cec29135 ES |
2982 | -- type declaration remains accessible, and link private and full |
2983 | -- declaration in the opposite direction. Before the actual | |
2984 | -- exchange, we copy back attributes of the full view that must | |
2985 | -- be available to the partial view too. | |
996ae0b0 RK |
2986 | |
2987 | Preserve_Full_Attributes (Id, Full); | |
2988 | ||
2989 | Set_Is_Potentially_Use_Visible (Id, In_Use (P)); | |
2990 | ||
2886a495 ES |
2991 | -- The following test may be redundant, as this is already |
2992 | -- diagnosed in sem_ch3. ??? | |
2993 | ||
83496138 AC |
2994 | if not Is_Definite_Subtype (Full) |
2995 | and then Is_Definite_Subtype (Id) | |
996ae0b0 | 2996 | then |
2886a495 ES |
2997 | Error_Msg_Sloc := Sloc (Parent (Id)); |
2998 | Error_Msg_NE | |
2999 | ("full view of& not compatible with declaration#", Full, Id); | |
996ae0b0 RK |
3000 | end if; |
3001 | ||
4ff4293f AC |
3002 | -- Swap out the subtypes and derived types of Id that |
3003 | -- were compiled in this scope, or installed previously | |
3004 | -- by Install_Private_Declarations. | |
cec29135 ES |
3005 | |
3006 | -- Before we do the swap, we verify the presence of the Full_View | |
3007 | -- field which may be empty due to a swap by a previous call to | |
3008 | -- End_Package_Scope (e.g. from the freezing mechanism). | |
996ae0b0 | 3009 | |
09a078a1 | 3010 | Priv_Elmt := First_Elmt (Private_Dependents (Id)); |
996ae0b0 RK |
3011 | while Present (Priv_Elmt) loop |
3012 | Priv_Sub := Node (Priv_Elmt); | |
3013 | ||
3014 | if Present (Full_View (Priv_Sub)) then | |
996ae0b0 RK |
3015 | if Scope (Priv_Sub) = P |
3016 | or else not In_Open_Scopes (Scope (Priv_Sub)) | |
3017 | then | |
3018 | Set_Is_Immediately_Visible (Priv_Sub, False); | |
3019 | end if; | |
3020 | ||
3021 | if Is_Visible_Dependent (Priv_Sub) then | |
3022 | Preserve_Full_Attributes | |
3023 | (Priv_Sub, Full_View (Priv_Sub)); | |
3024 | Replace_Elmt (Priv_Elmt, Full_View (Priv_Sub)); | |
3025 | Exchange_Declarations (Priv_Sub); | |
3026 | end if; | |
3027 | end if; | |
3028 | ||
3029 | Next_Elmt (Priv_Elmt); | |
3030 | end loop; | |
3031 | ||
a2cb348e | 3032 | -- Now restore the type itself to its private view |
340b490d AC |
3033 | |
3034 | Exchange_Declarations (Id); | |
3035 | ||
cec29135 ES |
3036 | -- If we have installed an underlying full view for a type derived |
3037 | -- from a private type in a child unit, restore the proper views | |
3038 | -- of private and full view. See corresponding code in | |
3039 | -- Install_Private_Declarations. | |
3040 | ||
f7d5442e ES |
3041 | -- After the exchange, Full denotes the private type in the |
3042 | -- visible part of the package. | |
3043 | ||
3044 | if Is_Private_Base_Type (Full) | |
3045 | and then Present (Full_View (Full)) | |
3046 | and then Present (Underlying_Full_View (Full)) | |
3047 | and then In_Package_Body (Current_Scope) | |
3048 | then | |
3049 | Set_Full_View (Full, Underlying_Full_View (Full)); | |
3050 | Set_Underlying_Full_View (Full, Empty); | |
3051 | end if; | |
3052 | ||
996ae0b0 | 3053 | elsif Ekind (Id) = E_Incomplete_Type |
93bcda23 | 3054 | and then Comes_From_Source (Id) |
996ae0b0 RK |
3055 | and then No (Full_View (Id)) |
3056 | then | |
cec29135 | 3057 | -- Mark Taft amendment types. Verify that there are no primitive |
5e39baa6 | 3058 | -- operations declared for the type (3.10.1(9)). |
996ae0b0 RK |
3059 | |
3060 | Set_Has_Completion_In_Body (Id); | |
3061 | ||
93bcda23 AC |
3062 | declare |
3063 | Elmt : Elmt_Id; | |
3064 | Subp : Entity_Id; | |
3065 | ||
3066 | begin | |
3067 | Elmt := First_Elmt (Private_Dependents (Id)); | |
3068 | while Present (Elmt) loop | |
3069 | Subp := Node (Elmt); | |
cec29135 | 3070 | |
4637729f AC |
3071 | -- Is_Primitive is tested because there can be cases where |
3072 | -- nonprimitive subprograms (in nested packages) are added | |
3073 | -- to the Private_Dependents list. | |
3074 | ||
3075 | if Is_Overloadable (Subp) and then Is_Primitive (Subp) then | |
93bcda23 AC |
3076 | Error_Msg_NE |
3077 | ("type& must be completed in the private part", | |
3ddfabe3 | 3078 | Parent (Subp), Id); |
cec29135 | 3079 | |
033eaf85 AC |
3080 | -- The result type of an access-to-function type cannot be a |
3081 | -- Taft-amendment type, unless the version is Ada 2012 or | |
3082 | -- later (see AI05-151). | |
cec29135 | 3083 | |
033eaf85 AC |
3084 | elsif Ada_Version < Ada_2012 |
3085 | and then Ekind (Subp) = E_Subprogram_Type | |
3086 | then | |
cec29135 ES |
3087 | if Etype (Subp) = Id |
3088 | or else | |
3089 | (Is_Class_Wide_Type (Etype (Subp)) | |
09a078a1 | 3090 | and then Etype (Etype (Subp)) = Id) |
cec29135 ES |
3091 | then |
3092 | Error_Msg_NE | |
3093 | ("type& must be completed in the private part", | |
3094 | Associated_Node_For_Itype (Subp), Id); | |
3095 | end if; | |
93bcda23 AC |
3096 | end if; |
3097 | ||
3098 | Next_Elmt (Elmt); | |
3099 | end loop; | |
3100 | end; | |
3101 | ||
996ae0b0 | 3102 | elsif not Is_Child_Unit (Id) |
09a078a1 | 3103 | and then (not Is_Private_Type (Id) or else No (Full_View (Id))) |
996ae0b0 RK |
3104 | then |
3105 | Set_Is_Hidden (Id); | |
3106 | Set_Is_Potentially_Use_Visible (Id, False); | |
3107 | end if; | |
3108 | ||
3109 | <<Next_Id>> | |
3110 | Next_Entity (Id); | |
3111 | end loop; | |
996ae0b0 RK |
3112 | end Uninstall_Declarations; |
3113 | ||
3114 | ------------------------ | |
3115 | -- Unit_Requires_Body -- | |
3116 | ------------------------ | |
3117 | ||
7569f697 | 3118 | function Unit_Requires_Body |
22a4f9d5 AC |
3119 | (Pack_Id : Entity_Id; |
3120 | Do_Abstract_States : Boolean := False) return Boolean | |
7569f697 | 3121 | is |
996ae0b0 RK |
3122 | E : Entity_Id; |
3123 | ||
08f52d9f AC |
3124 | Requires_Body : Boolean := False; |
3125 | -- Flag set when the unit has at least one construct that requries | |
3126 | -- completion in a body. | |
3127 | ||
996ae0b0 | 3128 | begin |
cec29135 ES |
3129 | -- Imported entity never requires body. Right now, only subprograms can |
3130 | -- be imported, but perhaps in the future we will allow import of | |
3131 | -- packages. | |
996ae0b0 | 3132 | |
c5cec2fe | 3133 | if Is_Imported (Pack_Id) then |
996ae0b0 RK |
3134 | return False; |
3135 | ||
3136 | -- Body required if library package with pragma Elaborate_Body | |
3137 | ||
c5cec2fe | 3138 | elsif Has_Pragma_Elaborate_Body (Pack_Id) then |
996ae0b0 RK |
3139 | return True; |
3140 | ||
3141 | -- Body required if subprogram | |
3142 | ||
c5cec2fe | 3143 | elsif Is_Subprogram_Or_Generic_Subprogram (Pack_Id) then |
996ae0b0 RK |
3144 | return True; |
3145 | ||
3146 | -- Treat a block as requiring a body | |
3147 | ||
c5cec2fe | 3148 | elsif Ekind (Pack_Id) = E_Block then |
996ae0b0 RK |
3149 | return True; |
3150 | ||
c5cec2fe AC |
3151 | elsif Ekind (Pack_Id) = E_Package |
3152 | and then Nkind (Parent (Pack_Id)) = N_Package_Specification | |
3153 | and then Present (Generic_Parent (Parent (Pack_Id))) | |
996ae0b0 RK |
3154 | then |
3155 | declare | |
c5cec2fe | 3156 | G_P : constant Entity_Id := Generic_Parent (Parent (Pack_Id)); |
996ae0b0 RK |
3157 | begin |
3158 | if Has_Pragma_Elaborate_Body (G_P) then | |
3159 | return True; | |
3160 | end if; | |
3161 | end; | |
3162 | end if; | |
3163 | ||
08f52d9f AC |
3164 | -- Traverse the entity chain of the package and look for constructs that |
3165 | -- require a completion in a body. | |
996ae0b0 | 3166 | |
c5cec2fe | 3167 | E := First_Entity (Pack_Id); |
996ae0b0 | 3168 | while Present (E) loop |
08f52d9f AC |
3169 | |
3170 | -- Skip abstract states because their completion depends on several | |
3171 | -- criteria (see below). | |
3172 | ||
3173 | if Ekind (E) = E_Abstract_State then | |
3174 | null; | |
3175 | ||
22a4f9d5 AC |
3176 | elsif Requires_Completion_In_Body |
3177 | (E, Pack_Id, Do_Abstract_States) | |
3178 | then | |
08f52d9f AC |
3179 | Requires_Body := True; |
3180 | exit; | |
996ae0b0 RK |
3181 | end if; |
3182 | ||
3183 | Next_Entity (E); | |
3184 | end loop; | |
3185 | ||
08f52d9f AC |
3186 | -- A [generic] package that defines at least one non-null abstract state |
3187 | -- requires a completion only when at least one other construct requires | |
3188 | -- a completion in a body (SPARK RM 7.1.4(4) and (6)). This check is not | |
3189 | -- performed if the caller requests this behavior. | |
3190 | ||
22a4f9d5 | 3191 | if Do_Abstract_States |
08f52d9f AC |
3192 | and then Ekind_In (Pack_Id, E_Generic_Package, E_Package) |
3193 | and then Has_Non_Null_Abstract_State (Pack_Id) | |
3194 | and then Requires_Body | |
3195 | then | |
3196 | return True; | |
3197 | end if; | |
3198 | ||
3199 | return Requires_Body; | |
996ae0b0 RK |
3200 | end Unit_Requires_Body; |
3201 | ||
98779361 RD |
3202 | ----------------------------- |
3203 | -- Unit_Requires_Body_Info -- | |
3204 | ----------------------------- | |
3205 | ||
c5cec2fe | 3206 | procedure Unit_Requires_Body_Info (Pack_Id : Entity_Id) is |
98779361 RD |
3207 | E : Entity_Id; |
3208 | ||
3209 | begin | |
c5cec2fe AC |
3210 | -- An imported entity never requires body. Right now, only subprograms |
3211 | -- can be imported, but perhaps in the future we will allow import of | |
98779361 RD |
3212 | -- packages. |
3213 | ||
c5cec2fe | 3214 | if Is_Imported (Pack_Id) then |
98779361 RD |
3215 | return; |
3216 | ||
3217 | -- Body required if library package with pragma Elaborate_Body | |
3218 | ||
c5cec2fe AC |
3219 | elsif Has_Pragma_Elaborate_Body (Pack_Id) then |
3220 | Error_Msg_N ("info: & requires body (Elaborate_Body)?Y?", Pack_Id); | |
98779361 RD |
3221 | |
3222 | -- Body required if subprogram | |
3223 | ||
c5cec2fe AC |
3224 | elsif Is_Subprogram_Or_Generic_Subprogram (Pack_Id) then |
3225 | Error_Msg_N ("info: & requires body (subprogram case)?Y?", Pack_Id); | |
98779361 RD |
3226 | |
3227 | -- Body required if generic parent has Elaborate_Body | |
3228 | ||
c5cec2fe AC |
3229 | elsif Ekind (Pack_Id) = E_Package |
3230 | and then Nkind (Parent (Pack_Id)) = N_Package_Specification | |
3231 | and then Present (Generic_Parent (Parent (Pack_Id))) | |
98779361 RD |
3232 | then |
3233 | declare | |
c5cec2fe | 3234 | G_P : constant Entity_Id := Generic_Parent (Parent (Pack_Id)); |
98779361 RD |
3235 | begin |
3236 | if Has_Pragma_Elaborate_Body (G_P) then | |
3237 | Error_Msg_N | |
2e57f88b | 3238 | ("info: & requires body (generic parent Elaborate_Body)?Y?", |
c5cec2fe | 3239 | Pack_Id); |
98779361 RD |
3240 | end if; |
3241 | end; | |
3242 | ||
3243 | -- A [generic] package that introduces at least one non-null abstract | |
3244 | -- state requires completion. However, there is a separate rule that | |
3245 | -- requires that such a package have a reason other than this for a | |
3246 | -- body being required (if necessary a pragma Elaborate_Body must be | |
3247 | -- provided). If Ignore_Abstract_State is True, we don't do this check | |
3248 | -- (so we can use Unit_Requires_Body to check for some other reason). | |
3249 | ||
c5cec2fe AC |
3250 | elsif Ekind_In (Pack_Id, E_Generic_Package, E_Package) |
3251 | and then Present (Abstract_States (Pack_Id)) | |
3252 | and then not Is_Null_State | |
3253 | (Node (First_Elmt (Abstract_States (Pack_Id)))) | |
98779361 RD |
3254 | then |
3255 | Error_Msg_N | |
c5cec2fe AC |
3256 | ("info: & requires body (non-null abstract state aspect)?Y?", |
3257 | Pack_Id); | |
98779361 RD |
3258 | end if; |
3259 | ||
3260 | -- Otherwise search entity chain for entity requiring completion | |
3261 | ||
c5cec2fe | 3262 | E := First_Entity (Pack_Id); |
98779361 | 3263 | while Present (E) loop |
c5cec2fe | 3264 | if Requires_Completion_In_Body (E, Pack_Id) then |
98779361 RD |
3265 | Error_Msg_Node_2 := E; |
3266 | Error_Msg_NE | |
c5cec2fe | 3267 | ("info: & requires body (& requires completion)?Y?", E, Pack_Id); |
98779361 RD |
3268 | end if; |
3269 | ||
3270 | Next_Entity (E); | |
3271 | end loop; | |
3272 | end Unit_Requires_Body_Info; | |
1f8766d3 | 3273 | |
996ae0b0 | 3274 | end Sem_Ch7; |