]>
Commit | Line | Data |
---|---|---|
996ae0b0 RK |
1 | ------------------------------------------------------------------------------ |
2 | -- -- | |
3 | -- GNAT COMPILER COMPONENTS -- | |
4 | -- -- | |
5 | -- S E M . C H 7 -- | |
6 | -- -- | |
7 | -- B o d y -- | |
8 | -- -- | |
fbf5a39b | 9 | -- Copyright (C) 1992-2003, 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- -- | |
13 | -- ware Foundation; either version 2, or (at your option) any later ver- -- | |
14 | -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- | |
15 | -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- | |
16 | -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- | |
17 | -- for more details. You should have received a copy of the GNU General -- | |
18 | -- Public License distributed with GNAT; see file COPYING. If not, write -- | |
19 | -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- | |
20 | -- MA 02111-1307, USA. -- | |
21 | -- -- | |
22 | -- GNAT was originally developed by the GNAT team at New York University. -- | |
71ff80dc | 23 | -- Extensive contributions were provided by Ada Core Technologies Inc. -- |
996ae0b0 RK |
24 | -- -- |
25 | ------------------------------------------------------------------------------ | |
26 | ||
27 | -- This package contains the routines to process package specifications and | |
28 | -- bodies. The most important semantic aspects of package processing are the | |
29 | -- handling of private and full declarations, and the construction of | |
30 | -- dispatch tables for tagged types. | |
31 | ||
32 | with Atree; use Atree; | |
33 | with Debug; use Debug; | |
34 | with Einfo; use Einfo; | |
35 | with Elists; use Elists; | |
36 | with Errout; use Errout; | |
37 | with Exp_Disp; use Exp_Disp; | |
38 | with Exp_Dbug; use Exp_Dbug; | |
39 | with Lib; use Lib; | |
40 | with Lib.Xref; use Lib.Xref; | |
41 | with Namet; use Namet; | |
42 | with Nmake; use Nmake; | |
43 | with Nlists; use Nlists; | |
44 | with Opt; use Opt; | |
45 | with Output; use Output; | |
46 | with Sem; use Sem; | |
47 | with Sem_Cat; use Sem_Cat; | |
48 | with Sem_Ch3; use Sem_Ch3; | |
49 | with Sem_Ch6; use Sem_Ch6; | |
50 | with Sem_Ch8; use Sem_Ch8; | |
51 | with Sem_Ch12; use Sem_Ch12; | |
52 | with Sem_Util; use Sem_Util; | |
53 | with Sem_Warn; use Sem_Warn; | |
54 | with Snames; use Snames; | |
55 | with Stand; use Stand; | |
56 | with Sinfo; use Sinfo; | |
57 | with Sinput; use Sinput; | |
58 | with Style; | |
59 | ||
60 | package body Sem_Ch7 is | |
61 | ||
62 | ----------------------------------- | |
63 | -- Handling private declarations -- | |
64 | ----------------------------------- | |
65 | ||
66 | -- The principle that each entity has a single defining occurrence clashes | |
67 | -- with the presence of two separate definitions for private types: the | |
68 | -- first is the private type declaration, and the second is the full type | |
69 | -- declaration. It is important that all references to the type point to | |
44d6a706 | 70 | -- the same defining occurrence, namely the first one. To enforce the two |
996ae0b0 RK |
71 | -- separate views of the entity, the corresponding information is swapped |
72 | -- between the two declarations. Outside of the package, the defining | |
44d6a706 | 73 | -- occurrence only contains the private declaration information, while in |
996ae0b0 RK |
74 | -- the private part and the body of the package the defining occurrence |
75 | -- contains the full declaration. To simplify the swap, the defining | |
76 | -- occurrence that currently holds the private declaration points to the | |
b6434700 RH |
77 | -- full declaration. During semantic processing the defining occurrence |
78 | -- also points to a list of private dependents, that is to say access types | |
79 | -- or composite types whose designated types or component types are | |
80 | -- subtypes or derived types of the private type in question. After the | |
81 | -- full declaration has been seen, the private dependents are updated to | |
82 | -- indicate that they have full definitions. | |
996ae0b0 RK |
83 | |
84 | ----------------------- | |
85 | -- Local Subprograms -- | |
86 | ----------------------- | |
87 | ||
fbf5a39b AC |
88 | procedure Install_Package_Entity (Id : Entity_Id); |
89 | -- Basic procedure for the previous two. Places one entity on its | |
90 | -- visibility chain, and recurses on the visible part if the entity | |
91 | -- is an inner package. | |
996ae0b0 RK |
92 | |
93 | function Is_Private_Base_Type (E : Entity_Id) return Boolean; | |
94 | -- True for a private type that is not a subtype. | |
95 | ||
96 | function Is_Visible_Dependent (Dep : Entity_Id) return Boolean; | |
97 | -- If the private dependent is a private type whose full view is | |
98 | -- derived from the parent type, its full properties are revealed | |
99 | -- only if we are in the immediate scope of the private dependent. | |
100 | -- Should this predicate be tightened further??? | |
101 | ||
996ae0b0 RK |
102 | procedure Declare_Inherited_Private_Subprograms (Id : Entity_Id); |
103 | -- Called upon entering the private part of a public child package | |
104 | -- and the body of a nested package, to potentially declare certain | |
105 | -- inherited subprograms that were inherited by types in the visible | |
106 | -- part, but whose declaration was deferred because the parent | |
107 | -- operation was private and not visible at that point. These | |
108 | -- subprograms are located by traversing the visible part declarations | |
fbf5a39b | 109 | -- looking for non-private type extensions and then examining each of |
996ae0b0 RK |
110 | -- the primitive operations of such types to find those that were |
111 | -- inherited but declared with a special internal name. Each such | |
112 | -- operation is now declared as an operation with a normal name (using | |
113 | -- the name of the parent operation) and replaces the previous implicit | |
114 | -- operation in the primitive operations list of the type. If the | |
115 | -- inherited private operation has been overridden, then it's | |
116 | -- replaced by the overriding operation. | |
117 | ||
118 | -------------------------- | |
119 | -- Analyze_Package_Body -- | |
120 | -------------------------- | |
121 | ||
122 | procedure Analyze_Package_Body (N : Node_Id) is | |
123 | Loc : constant Source_Ptr := Sloc (N); | |
124 | HSS : Node_Id; | |
125 | Body_Id : Entity_Id; | |
126 | Spec_Id : Entity_Id; | |
127 | Last_Spec_Entity : Entity_Id; | |
128 | New_N : Node_Id; | |
129 | Pack_Decl : Node_Id; | |
130 | ||
fbf5a39b AC |
131 | procedure Install_Composite_Operations (P : Entity_Id); |
132 | -- Composite types declared in the current scope may depend on | |
133 | -- types that were private at the point of declaration, and whose | |
134 | -- full view is now in scope. Indicate that the corresponding | |
135 | -- operations on the composite type are available. | |
136 | ||
137 | ---------------------------------- | |
138 | -- Install_Composite_Operations -- | |
139 | ---------------------------------- | |
140 | ||
141 | procedure Install_Composite_Operations (P : Entity_Id) is | |
142 | Id : Entity_Id; | |
143 | ||
144 | begin | |
145 | Id := First_Entity (P); | |
146 | ||
147 | while Present (Id) loop | |
148 | ||
149 | if Is_Type (Id) | |
150 | and then (Is_Limited_Composite (Id) | |
151 | or else Is_Private_Composite (Id)) | |
152 | and then No (Private_Component (Id)) | |
153 | then | |
154 | Set_Is_Limited_Composite (Id, False); | |
155 | Set_Is_Private_Composite (Id, False); | |
156 | end if; | |
157 | ||
158 | Next_Entity (Id); | |
159 | end loop; | |
160 | end Install_Composite_Operations; | |
161 | ||
162 | -- Start of processing for Analyze_Package_Body | |
163 | ||
996ae0b0 RK |
164 | begin |
165 | -- Find corresponding package specification, and establish the | |
166 | -- current scope. The visible defining entity for the package is the | |
167 | -- defining occurrence in the spec. On exit from the package body, all | |
168 | -- body declarations are attached to the defining entity for the body, | |
169 | -- but the later is never used for name resolution. In this fashion | |
170 | -- there is only one visible entity that denotes the package. | |
171 | ||
172 | if Debug_Flag_C then | |
173 | Write_Str ("==== Compiling package body "); | |
174 | Write_Name (Chars (Defining_Entity (N))); | |
175 | Write_Str (" from "); | |
176 | Write_Location (Loc); | |
177 | Write_Eol; | |
178 | end if; | |
179 | ||
fbf5a39b | 180 | -- Set Body_Id. Note that this Will be reset to point to the |
996ae0b0 RK |
181 | -- generic copy later on in the generic case. |
182 | ||
183 | Body_Id := Defining_Entity (N); | |
184 | ||
185 | if Present (Corresponding_Spec (N)) then | |
186 | ||
187 | -- Body is body of package instantiation. Corresponding spec | |
188 | -- has already been set. | |
189 | ||
190 | Spec_Id := Corresponding_Spec (N); | |
191 | Pack_Decl := Unit_Declaration_Node (Spec_Id); | |
192 | ||
193 | else | |
194 | Spec_Id := Current_Entity_In_Scope (Defining_Entity (N)); | |
195 | ||
196 | if Present (Spec_Id) | |
197 | and then Is_Package (Spec_Id) | |
198 | then | |
199 | Pack_Decl := Unit_Declaration_Node (Spec_Id); | |
200 | ||
201 | if Nkind (Pack_Decl) = N_Package_Renaming_Declaration then | |
202 | Error_Msg_N ("cannot supply body for package renaming", N); | |
203 | return; | |
204 | ||
205 | elsif Present (Corresponding_Body (Pack_Decl)) then | |
206 | Error_Msg_N ("redefinition of package body", N); | |
207 | return; | |
208 | end if; | |
209 | ||
210 | else | |
211 | Error_Msg_N ("missing specification for package body", N); | |
212 | return; | |
213 | end if; | |
214 | ||
215 | if Is_Package (Spec_Id) | |
216 | and then | |
217 | (Scope (Spec_Id) = Standard_Standard | |
218 | or else Is_Child_Unit (Spec_Id)) | |
219 | and then not Unit_Requires_Body (Spec_Id) | |
220 | then | |
221 | if Ada_83 then | |
222 | Error_Msg_N | |
223 | ("optional package body (not allowed in Ada 95)?", N); | |
224 | else | |
225 | Error_Msg_N | |
226 | ("spec of this package does not allow a body", N); | |
227 | end if; | |
228 | end if; | |
229 | end if; | |
230 | ||
231 | Set_Is_Compilation_Unit (Body_Id, Is_Compilation_Unit (Spec_Id)); | |
232 | Style.Check_Identifier (Body_Id, Spec_Id); | |
233 | ||
234 | if Is_Child_Unit (Spec_Id) then | |
996ae0b0 RK |
235 | if Nkind (Parent (N)) /= N_Compilation_Unit then |
236 | Error_Msg_NE | |
237 | ("body of child unit& cannot be an inner package", N, Spec_Id); | |
238 | end if; | |
239 | ||
240 | Set_Is_Child_Unit (Body_Id); | |
241 | end if; | |
242 | ||
243 | -- Generic package case | |
244 | ||
245 | if Ekind (Spec_Id) = E_Generic_Package then | |
246 | ||
247 | -- Disable expansion and perform semantic analysis on copy. | |
248 | -- The unannotated body will be used in all instantiations. | |
249 | ||
250 | Body_Id := Defining_Entity (N); | |
251 | Set_Ekind (Body_Id, E_Package_Body); | |
252 | Set_Scope (Body_Id, Scope (Spec_Id)); | |
253 | Set_Body_Entity (Spec_Id, Body_Id); | |
254 | Set_Spec_Entity (Body_Id, Spec_Id); | |
255 | ||
256 | New_N := Copy_Generic_Node (N, Empty, Instantiating => False); | |
257 | Rewrite (N, New_N); | |
258 | ||
259 | -- Update Body_Id to point to the copied node for the remainder | |
260 | -- of the processing. | |
261 | ||
262 | Body_Id := Defining_Entity (N); | |
263 | Start_Generic; | |
264 | end if; | |
265 | ||
266 | -- The Body_Id is that of the copied node in the generic case, the | |
267 | -- current node otherwise. Note that N was rewritten above, so we | |
268 | -- must be sure to get the latest Body_Id value. | |
269 | ||
270 | Set_Ekind (Body_Id, E_Package_Body); | |
271 | Set_Body_Entity (Spec_Id, Body_Id); | |
272 | Set_Spec_Entity (Body_Id, Spec_Id); | |
273 | ||
274 | -- Defining name for the package body is not a visible entity: Only | |
275 | -- the defining name for the declaration is visible. | |
276 | ||
277 | Set_Etype (Body_Id, Standard_Void_Type); | |
278 | Set_Scope (Body_Id, Scope (Spec_Id)); | |
279 | Set_Corresponding_Spec (N, Spec_Id); | |
280 | Set_Corresponding_Body (Pack_Decl, Body_Id); | |
281 | ||
282 | -- The body entity is not used for semantics or code generation, but | |
283 | -- it is attached to the entity list of the enclosing scope to simplify | |
284 | -- the listing of back-annotations for the types it main contain. | |
285 | ||
286 | if Scope (Spec_Id) /= Standard_Standard then | |
287 | Append_Entity (Body_Id, Scope (Spec_Id)); | |
288 | end if; | |
289 | ||
290 | -- Indicate that we are currently compiling the body of the package. | |
291 | ||
292 | Set_In_Package_Body (Spec_Id); | |
293 | Set_Has_Completion (Spec_Id); | |
294 | Last_Spec_Entity := Last_Entity (Spec_Id); | |
295 | ||
296 | New_Scope (Spec_Id); | |
297 | ||
298 | Set_Categorization_From_Pragmas (N); | |
299 | ||
300 | Install_Visible_Declarations (Spec_Id); | |
301 | Install_Private_Declarations (Spec_Id); | |
302 | Install_Composite_Operations (Spec_Id); | |
303 | ||
304 | if Ekind (Spec_Id) = E_Generic_Package then | |
305 | Set_Use (Generic_Formal_Declarations (Pack_Decl)); | |
306 | end if; | |
307 | ||
308 | Set_Use (Visible_Declarations (Specification (Pack_Decl))); | |
309 | Set_Use (Private_Declarations (Specification (Pack_Decl))); | |
310 | ||
311 | -- This is a nested package, so it may be necessary to declare | |
312 | -- certain inherited subprograms that are not yet visible because | |
313 | -- the parent type's subprograms are now visible. | |
314 | ||
315 | if Ekind (Scope (Spec_Id)) = E_Package | |
316 | and then Scope (Spec_Id) /= Standard_Standard | |
317 | then | |
318 | Declare_Inherited_Private_Subprograms (Spec_Id); | |
319 | end if; | |
320 | ||
321 | if Present (Declarations (N)) then | |
322 | Analyze_Declarations (Declarations (N)); | |
323 | end if; | |
324 | ||
325 | HSS := Handled_Statement_Sequence (N); | |
326 | ||
327 | if Present (HSS) then | |
07fc65c4 | 328 | Process_End_Label (HSS, 't', Spec_Id); |
996ae0b0 RK |
329 | Analyze (HSS); |
330 | ||
331 | -- Check that elaboration code in a preelaborable package body is | |
332 | -- empty other than null statements and labels (RM 10.2.1(6)). | |
333 | ||
334 | Validate_Null_Statement_Sequence (N); | |
335 | end if; | |
336 | ||
337 | Validate_Categorization_Dependency (N, Spec_Id); | |
338 | Check_Completion (Body_Id); | |
339 | ||
340 | -- Generate start of body reference. Note that we do this fairly late, | |
341 | -- because the call will use In_Extended_Main_Source_Unit as a check, | |
342 | -- and we want to make sure that Corresponding_Stub links are set | |
343 | ||
07fc65c4 | 344 | Generate_Reference (Spec_Id, Body_Id, 'b', Set_Ref => False); |
996ae0b0 RK |
345 | |
346 | -- For a generic package, collect global references and mark | |
347 | -- them on the original body so that they are not resolved | |
348 | -- again at the point of instantiation. | |
349 | ||
350 | if Ekind (Spec_Id) /= E_Package then | |
351 | Save_Global_References (Original_Node (N)); | |
352 | End_Generic; | |
353 | end if; | |
354 | ||
355 | -- The entities of the package body have so far been chained onto | |
356 | -- the declaration chain for the spec. That's been fine while we | |
357 | -- were in the body, since we wanted them to be visible, but now | |
358 | -- that we are leaving the package body, they are no longer visible, | |
359 | -- so we remove them from the entity chain of the package spec entity, | |
360 | -- and copy them to the entity chain of the package body entity, where | |
361 | -- they will never again be visible. | |
362 | ||
363 | if Present (Last_Spec_Entity) then | |
364 | Set_First_Entity (Body_Id, Next_Entity (Last_Spec_Entity)); | |
365 | Set_Next_Entity (Last_Spec_Entity, Empty); | |
366 | Set_Last_Entity (Body_Id, Last_Entity (Spec_Id)); | |
367 | Set_Last_Entity (Spec_Id, Last_Spec_Entity); | |
368 | ||
369 | else | |
370 | Set_First_Entity (Body_Id, First_Entity (Spec_Id)); | |
371 | Set_Last_Entity (Body_Id, Last_Entity (Spec_Id)); | |
372 | Set_First_Entity (Spec_Id, Empty); | |
373 | Set_Last_Entity (Spec_Id, Empty); | |
374 | end if; | |
375 | ||
376 | End_Package_Scope (Spec_Id); | |
377 | ||
378 | -- All entities declared in body are not visible. | |
379 | ||
380 | declare | |
381 | E : Entity_Id; | |
382 | ||
383 | begin | |
384 | E := First_Entity (Body_Id); | |
385 | ||
386 | while Present (E) loop | |
387 | Set_Is_Immediately_Visible (E, False); | |
388 | Set_Is_Potentially_Use_Visible (E, False); | |
389 | Set_Is_Hidden (E); | |
390 | ||
391 | -- Child units may appear on the entity list (for example if | |
392 | -- they appear in the context of a subunit) but they are not | |
393 | -- body entities. | |
394 | ||
395 | if not Is_Child_Unit (E) then | |
396 | Set_Is_Package_Body_Entity (E); | |
397 | end if; | |
398 | ||
399 | Next_Entity (E); | |
400 | end loop; | |
401 | end; | |
402 | ||
403 | Check_References (Body_Id); | |
404 | ||
fbf5a39b AC |
405 | -- For a generic unit, check that the formal parameters are referenced, |
406 | -- and that local variables are used, as for regular packages. | |
407 | ||
408 | if Ekind (Spec_Id) = E_Generic_Package then | |
409 | Check_References (Spec_Id); | |
410 | end if; | |
411 | ||
996ae0b0 RK |
412 | -- The processing so far has made all entities of the package body |
413 | -- public (i.e. externally visible to the linker). This is in general | |
414 | -- necessary, since inlined or generic bodies, for which code is | |
415 | -- generated in other units, may need to see these entities. The | |
416 | -- following loop runs backwards from the end of the entities of the | |
417 | -- package body making these entities invisible until we reach a | |
418 | -- referencer, i.e. a declaration that could reference a previous | |
419 | -- declaration, a generic body or an inlined body, or a stub (which | |
420 | -- may contain either of these). This is of course an approximation, | |
421 | -- but it is conservative and definitely correct. | |
422 | ||
423 | -- We only do this at the outer (library) level non-generic packages. | |
424 | -- The reason is simply to cut down on the number of external symbols | |
425 | -- generated, so this is simply an optimization of the efficiency | |
426 | -- of the compilation process. It has no other effect. | |
427 | ||
428 | if (Scope (Spec_Id) = Standard_Standard or else Is_Child_Unit (Spec_Id)) | |
429 | and then not Is_Generic_Unit (Spec_Id) | |
430 | and then Present (Declarations (N)) | |
431 | then | |
432 | Make_Non_Public_Where_Possible : declare | |
996ae0b0 RK |
433 | |
434 | function Has_Referencer | |
435 | (L : List_Id; | |
436 | Outer : Boolean) | |
437 | return Boolean; | |
438 | -- Traverse the given list of declarations in reverse order. | |
439 | -- Return True as soon as a referencer is reached. Return | |
440 | -- False if none is found. The Outer parameter is True for | |
441 | -- the outer level call, and False for inner level calls for | |
442 | -- nested packages. If Outer is True, then any entities up | |
443 | -- to the point of hitting a referencer get their Is_Public | |
444 | -- flag cleared, so that the entities will be treated as | |
445 | -- static entities in the C sense, and need not have fully | |
446 | -- qualified names. For inner levels, we need all names to | |
447 | -- be fully qualified to deal with the same name appearing | |
448 | -- in parallel packages (right now this is tied to their | |
449 | -- being external). | |
450 | ||
451 | -------------------- | |
452 | -- Has_Referencer -- | |
453 | -------------------- | |
454 | ||
455 | function Has_Referencer | |
456 | (L : List_Id; | |
457 | Outer : Boolean) | |
458 | return Boolean | |
459 | is | |
460 | D : Node_Id; | |
461 | E : Entity_Id; | |
462 | K : Node_Kind; | |
463 | S : Entity_Id; | |
464 | ||
465 | begin | |
466 | if No (L) then | |
467 | return False; | |
468 | end if; | |
469 | ||
470 | D := Last (L); | |
471 | ||
472 | while Present (D) loop | |
473 | K := Nkind (D); | |
474 | ||
475 | if K in N_Body_Stub then | |
476 | return True; | |
477 | ||
478 | elsif K = N_Subprogram_Body then | |
479 | if Acts_As_Spec (D) then | |
480 | E := Defining_Entity (D); | |
481 | ||
482 | -- An inlined body acts as a referencer. Note also | |
483 | -- that we never reset Is_Public for an inlined | |
484 | -- subprogram. Gigi requires Is_Public to be set. | |
485 | ||
486 | -- Note that we test Has_Pragma_Inline here rather | |
487 | -- than Is_Inlined. We are compiling this for a | |
488 | -- client, and it is the client who will decide | |
489 | -- if actual inlining should occur, so we need to | |
490 | -- assume that the procedure could be inlined for | |
491 | -- the purpose of accessing global entities. | |
492 | ||
493 | if Has_Pragma_Inline (E) then | |
494 | return True; | |
495 | else | |
496 | Set_Is_Public (E, False); | |
497 | end if; | |
498 | ||
499 | else | |
500 | E := Corresponding_Spec (D); | |
501 | ||
502 | if Present (E) | |
503 | and then (Is_Generic_Unit (E) | |
504 | or else Has_Pragma_Inline (E) | |
505 | or else Is_Inlined (E)) | |
506 | then | |
507 | return True; | |
508 | end if; | |
509 | end if; | |
510 | ||
511 | -- Processing for package bodies | |
512 | ||
513 | elsif K = N_Package_Body | |
514 | and then Present (Corresponding_Spec (D)) | |
515 | then | |
516 | E := Corresponding_Spec (D); | |
517 | ||
518 | -- Generic package body is a referencer. It would | |
519 | -- seem that we only have to consider generics that | |
520 | -- can be exported, i.e. where the corresponding spec | |
521 | -- is the spec of the current package, but because of | |
522 | -- nested instantiations, a fully private generic | |
523 | -- body may export other private body entities. | |
524 | ||
525 | if Is_Generic_Unit (E) then | |
526 | return True; | |
527 | ||
528 | -- For non-generic package body, recurse into body | |
529 | -- unless this is an instance, we ignore instances | |
530 | -- since they cannot have references that affect | |
531 | -- outer entities. | |
532 | ||
533 | elsif not Is_Generic_Instance (E) then | |
534 | if Has_Referencer | |
535 | (Declarations (D), Outer => False) | |
536 | then | |
537 | return True; | |
538 | end if; | |
539 | end if; | |
540 | ||
541 | -- Processing for package specs, recurse into declarations. | |
542 | -- Again we skip this for the case of generic instances. | |
543 | ||
544 | elsif K = N_Package_Declaration then | |
545 | S := Specification (D); | |
546 | ||
547 | if not Is_Generic_Unit (Defining_Entity (S)) then | |
548 | if Has_Referencer | |
549 | (Private_Declarations (S), Outer => False) | |
550 | then | |
551 | return True; | |
552 | elsif Has_Referencer | |
553 | (Visible_Declarations (S), Outer => False) | |
554 | then | |
555 | return True; | |
556 | end if; | |
557 | end if; | |
558 | ||
559 | -- Objects and exceptions need not be public if we have | |
560 | -- not encountered a referencer so far. We only reset | |
561 | -- the flag for outer level entities that are not | |
562 | -- imported/exported, and which have no interface name. | |
563 | ||
564 | elsif K = N_Object_Declaration | |
565 | or else K = N_Exception_Declaration | |
566 | or else K = N_Subprogram_Declaration | |
567 | then | |
568 | E := Defining_Entity (D); | |
569 | ||
570 | if Outer | |
571 | and then not Is_Imported (E) | |
572 | and then not Is_Exported (E) | |
573 | and then No (Interface_Name (E)) | |
574 | then | |
575 | Set_Is_Public (E, False); | |
576 | end if; | |
577 | end if; | |
578 | ||
579 | Prev (D); | |
580 | end loop; | |
581 | ||
582 | return False; | |
583 | end Has_Referencer; | |
584 | ||
585 | -- Start of processing for Make_Non_Public_Where_Possible | |
586 | ||
587 | begin | |
fbf5a39b AC |
588 | declare |
589 | Discard : Boolean; | |
590 | pragma Warnings (Off, Discard); | |
591 | ||
592 | begin | |
593 | Discard := Has_Referencer (Declarations (N), Outer => True); | |
594 | end; | |
996ae0b0 RK |
595 | end Make_Non_Public_Where_Possible; |
596 | end if; | |
597 | ||
598 | -- If expander is not active, then here is where we turn off the | |
599 | -- In_Package_Body flag, otherwise it is turned off at the end of | |
600 | -- the corresponding expansion routine. If this is an instance body, | |
601 | -- we need to qualify names of local entities, because the body may | |
602 | -- have been compiled as a preliminary to another instantiation. | |
603 | ||
604 | if not Expander_Active then | |
605 | Set_In_Package_Body (Spec_Id, False); | |
606 | ||
607 | if Is_Generic_Instance (Spec_Id) | |
608 | and then Operating_Mode = Generate_Code | |
609 | then | |
610 | Qualify_Entity_Names (N); | |
611 | end if; | |
612 | end if; | |
613 | end Analyze_Package_Body; | |
614 | ||
615 | --------------------------------- | |
616 | -- Analyze_Package_Declaration -- | |
617 | --------------------------------- | |
618 | ||
619 | procedure Analyze_Package_Declaration (N : Node_Id) is | |
620 | Id : constant Node_Id := Defining_Entity (N); | |
621 | PF : Boolean; | |
622 | ||
623 | begin | |
624 | Generate_Definition (Id); | |
625 | Enter_Name (Id); | |
626 | Set_Ekind (Id, E_Package); | |
627 | Set_Etype (Id, Standard_Void_Type); | |
fbf5a39b | 628 | |
996ae0b0 RK |
629 | New_Scope (Id); |
630 | ||
631 | PF := Is_Pure (Enclosing_Lib_Unit_Entity); | |
632 | Set_Is_Pure (Id, PF); | |
633 | ||
634 | Set_Categorization_From_Pragmas (N); | |
635 | ||
636 | if Debug_Flag_C then | |
637 | Write_Str ("==== Compiling package spec "); | |
638 | Write_Name (Chars (Id)); | |
639 | Write_Str (" from "); | |
640 | Write_Location (Sloc (N)); | |
641 | Write_Eol; | |
642 | end if; | |
643 | ||
644 | Analyze (Specification (N)); | |
645 | Validate_Categorization_Dependency (N, Id); | |
646 | End_Package_Scope (Id); | |
647 | ||
648 | -- For a compilation unit, indicate whether it needs a body, and | |
649 | -- whether elaboration warnings may be meaningful on it. | |
650 | ||
651 | if Nkind (Parent (N)) = N_Compilation_Unit then | |
652 | Set_Body_Required (Parent (N), Unit_Requires_Body (Id)); | |
653 | ||
654 | if not Body_Required (Parent (N)) then | |
655 | Set_Suppress_Elaboration_Warnings (Id); | |
656 | end if; | |
657 | ||
658 | Validate_RT_RAT_Component (N); | |
659 | end if; | |
996ae0b0 RK |
660 | end Analyze_Package_Declaration; |
661 | ||
662 | ----------------------------------- | |
663 | -- Analyze_Package_Specification -- | |
664 | ----------------------------------- | |
665 | ||
fbf5a39b AC |
666 | -- Note that this code is shared for the analysis of generic package |
667 | -- specs (see Sem_Ch12.Analyze_Generic_Package_Declaration for details). | |
668 | ||
996ae0b0 RK |
669 | procedure Analyze_Package_Specification (N : Node_Id) is |
670 | Id : constant Entity_Id := Defining_Entity (N); | |
671 | Orig_Decl : constant Node_Id := Original_Node (Parent (N)); | |
672 | Vis_Decls : constant List_Id := Visible_Declarations (N); | |
673 | Priv_Decls : constant List_Id := Private_Declarations (N); | |
674 | E : Entity_Id; | |
675 | L : Entity_Id; | |
fbf5a39b AC |
676 | Public_Child : Boolean; |
677 | ||
678 | procedure Clear_Constants (Id : Entity_Id; FE : Entity_Id); | |
679 | -- Clears constant indications (Never_Set_In_Source, Constant_Value, | |
680 | -- and Is_True_Constant) on all variables that are entities of Id, | |
681 | -- and on the chain whose first element is FE. A recursive call is | |
682 | -- made for all packages and generic packages. | |
683 | ||
684 | procedure Generate_Parent_References; | |
685 | -- For a child unit, generate references to parent units, for | |
686 | -- GPS navigation purposes. | |
996ae0b0 RK |
687 | |
688 | function Is_Public_Child (Child, Unit : Entity_Id) return Boolean; | |
689 | -- Child and Unit are entities of compilation units. True if Child | |
690 | -- is a public child of Parent as defined in 10.1.1 | |
691 | ||
fbf5a39b AC |
692 | --------------------- |
693 | -- Clear_Constants -- | |
694 | --------------------- | |
695 | ||
696 | procedure Clear_Constants (Id : Entity_Id; FE : Entity_Id) is | |
697 | E : Entity_Id; | |
698 | ||
699 | begin | |
700 | -- Ignore package renamings, not interesting and they can | |
701 | -- cause self referential loops in the code below. | |
702 | ||
703 | if Nkind (Parent (Id)) = N_Package_Renaming_Declaration then | |
704 | return; | |
705 | end if; | |
706 | ||
707 | -- Note: in the loop below, the check for Next_Entity pointing | |
708 | -- back to the package entity seems very odd, but it is needed, | |
709 | -- because this kind of unexpected circularity does occur ??? | |
710 | ||
711 | E := FE; | |
712 | while Present (E) and then E /= Id loop | |
713 | if Ekind (E) = E_Variable then | |
714 | Set_Never_Set_In_Source (E, False); | |
715 | Set_Is_True_Constant (E, False); | |
716 | Set_Current_Value (E, Empty); | |
717 | Set_Is_Known_Non_Null (E, False); | |
718 | ||
719 | elsif Ekind (E) = E_Package | |
720 | or else | |
721 | Ekind (E) = E_Generic_Package | |
722 | then | |
723 | Clear_Constants (E, First_Entity (E)); | |
724 | Clear_Constants (E, First_Private_Entity (E)); | |
725 | end if; | |
726 | ||
727 | Next_Entity (E); | |
728 | end loop; | |
729 | end Clear_Constants; | |
730 | ||
731 | -------------------------------- | |
732 | -- Generate_Parent_References -- | |
733 | -------------------------------- | |
734 | ||
735 | procedure Generate_Parent_References is | |
736 | Decl : Node_Id := Parent (N); | |
737 | ||
738 | begin | |
739 | if Id = Cunit_Entity (Main_Unit) | |
740 | or else Parent (Decl) = Library_Unit (Cunit (Main_Unit)) | |
741 | then | |
742 | Generate_Reference (Id, Scope (Id), 'k', False); | |
743 | ||
744 | elsif Nkind (Unit (Cunit (Main_Unit))) /= N_Subprogram_Body | |
745 | and then Nkind (Unit (Cunit (Main_Unit))) /= N_Subunit | |
746 | then | |
747 | -- If current unit is an ancestor of main unit, generate | |
748 | -- a reference to its own parent. | |
749 | ||
750 | declare | |
751 | U : Node_Id; | |
752 | Main_Spec : Node_Id := Unit (Cunit (Main_Unit)); | |
753 | ||
754 | begin | |
755 | if Nkind (Main_Spec) = N_Package_Body then | |
756 | Main_Spec := Unit (Library_Unit (Cunit (Main_Unit))); | |
757 | end if; | |
758 | ||
759 | U := Parent_Spec (Main_Spec); | |
760 | while Present (U) loop | |
761 | if U = Parent (Decl) then | |
762 | Generate_Reference (Id, Scope (Id), 'k', False); | |
763 | exit; | |
764 | ||
765 | elsif Nkind (Unit (U)) = N_Package_Body then | |
766 | exit; | |
767 | ||
768 | else | |
769 | U := Parent_Spec (Unit (U)); | |
770 | end if; | |
771 | end loop; | |
772 | end; | |
773 | end if; | |
774 | end Generate_Parent_References; | |
775 | ||
776 | --------------------- | |
777 | -- Is_Public_Child -- | |
778 | --------------------- | |
779 | ||
996ae0b0 RK |
780 | function Is_Public_Child (Child, Unit : Entity_Id) return Boolean is |
781 | begin | |
782 | if not Is_Private_Descendant (Child) then | |
783 | return True; | |
784 | else | |
785 | if Child = Unit then | |
786 | return not Private_Present ( | |
787 | Parent (Unit_Declaration_Node (Child))); | |
788 | else | |
789 | return Is_Public_Child (Scope (Child), Unit); | |
790 | end if; | |
791 | end if; | |
792 | end Is_Public_Child; | |
793 | ||
794 | -- Start of processing for Analyze_Package_Specification | |
795 | ||
796 | begin | |
797 | if Present (Vis_Decls) then | |
798 | Analyze_Declarations (Vis_Decls); | |
799 | end if; | |
800 | ||
801 | -- Verify that incomplete types have received full declarations. | |
802 | ||
803 | E := First_Entity (Id); | |
996ae0b0 RK |
804 | while Present (E) loop |
805 | if Ekind (E) = E_Incomplete_Type | |
806 | and then No (Full_View (E)) | |
807 | then | |
808 | Error_Msg_N ("no declaration in visible part for incomplete}", E); | |
809 | end if; | |
810 | ||
811 | Next_Entity (E); | |
812 | end loop; | |
813 | ||
814 | if Is_Remote_Call_Interface (Id) | |
815 | and then Nkind (Parent (Parent (N))) = N_Compilation_Unit | |
816 | then | |
817 | Validate_RCI_Declarations (Id); | |
818 | end if; | |
819 | ||
820 | -- Save global references in the visible declarations, before | |
821 | -- installing private declarations of parent unit if there is one, | |
822 | -- because the privacy status of types defined in the parent will | |
823 | -- change. This is only relevant for generic child units, but is | |
824 | -- done in all cases for uniformity. | |
825 | ||
826 | if Ekind (Id) = E_Generic_Package | |
827 | and then Nkind (Orig_Decl) = N_Generic_Package_Declaration | |
828 | then | |
829 | declare | |
830 | Orig_Spec : constant Node_Id := Specification (Orig_Decl); | |
831 | Save_Priv : constant List_Id := Private_Declarations (Orig_Spec); | |
832 | ||
833 | begin | |
834 | Set_Private_Declarations (Orig_Spec, Empty_List); | |
835 | Save_Global_References (Orig_Decl); | |
836 | Set_Private_Declarations (Orig_Spec, Save_Priv); | |
837 | end; | |
838 | end if; | |
839 | ||
840 | -- If package is a public child unit, then make the private | |
841 | -- declarations of the parent visible. | |
842 | ||
fbf5a39b AC |
843 | Public_Child := False; |
844 | ||
996ae0b0 | 845 | if Present (Parent_Spec (Parent (N))) then |
fbf5a39b AC |
846 | Generate_Parent_References; |
847 | ||
996ae0b0 RK |
848 | declare |
849 | Par : Entity_Id := Id; | |
850 | Pack_Decl : Node_Id; | |
851 | ||
852 | begin | |
853 | while Scope (Par) /= Standard_Standard | |
854 | and then Is_Public_Child (Id, Par) | |
855 | loop | |
856 | Public_Child := True; | |
857 | Par := Scope (Par); | |
858 | Install_Private_Declarations (Par); | |
859 | Pack_Decl := Unit_Declaration_Node (Par); | |
860 | Set_Use (Private_Declarations (Specification (Pack_Decl))); | |
861 | end loop; | |
862 | end; | |
863 | end if; | |
864 | ||
865 | -- Analyze private part if present. The flag In_Private_Part is | |
866 | -- reset in End_Package_Scope. | |
867 | ||
868 | L := Last_Entity (Id); | |
869 | ||
870 | if Present (Priv_Decls) then | |
996ae0b0 RK |
871 | Set_In_Private_Part (Id); |
872 | ||
873 | -- Upon entering a public child's private part, it may be | |
874 | -- necessary to declare subprograms that were derived in | |
875 | -- the package visible part but not yet made visible. | |
876 | ||
877 | if Public_Child then | |
878 | Declare_Inherited_Private_Subprograms (Id); | |
879 | end if; | |
880 | ||
881 | Analyze_Declarations (Priv_Decls); | |
882 | ||
883 | -- The first private entity is the immediate follower of the last | |
884 | -- visible entity, if there was one. | |
885 | ||
886 | if Present (L) then | |
887 | Set_First_Private_Entity (Id, Next_Entity (L)); | |
888 | else | |
889 | Set_First_Private_Entity (Id, First_Entity (Id)); | |
890 | end if; | |
891 | ||
892 | -- There may be inherited private subprograms that need to be | |
893 | -- declared, even in the absence of an explicit private part. | |
894 | -- If there are any public declarations in the package and | |
895 | -- the package is a public child unit, then an implicit private | |
896 | -- part is assumed. | |
897 | ||
898 | elsif Present (L) and then Public_Child then | |
899 | Set_In_Private_Part (Id); | |
900 | Declare_Inherited_Private_Subprograms (Id); | |
901 | Set_First_Private_Entity (Id, Next_Entity (L)); | |
902 | end if; | |
903 | ||
904 | -- Check rule of 3.6(11), which in general requires | |
905 | -- waiting till all full types have been seen. | |
906 | ||
907 | E := First_Entity (Id); | |
908 | while Present (E) loop | |
909 | if Ekind (E) = E_Record_Type or else Ekind (E) = E_Array_Type then | |
910 | Check_Aliased_Component_Types (E); | |
911 | end if; | |
912 | ||
913 | Next_Entity (E); | |
914 | end loop; | |
915 | ||
916 | if Ekind (Id) = E_Generic_Package | |
917 | and then Nkind (Orig_Decl) = N_Generic_Package_Declaration | |
918 | and then Present (Priv_Decls) | |
919 | then | |
920 | -- Save global references in private declarations, ignoring the | |
921 | -- visible declarations that were processed earlier. | |
922 | ||
923 | declare | |
924 | Orig_Spec : constant Node_Id := Specification (Orig_Decl); | |
925 | Save_Vis : constant List_Id := Visible_Declarations (Orig_Spec); | |
926 | Save_Form : constant List_Id := | |
927 | Generic_Formal_Declarations (Orig_Decl); | |
928 | ||
929 | begin | |
930 | Set_Visible_Declarations (Orig_Spec, Empty_List); | |
931 | Set_Generic_Formal_Declarations (Orig_Decl, Empty_List); | |
932 | Save_Global_References (Orig_Decl); | |
933 | Set_Generic_Formal_Declarations (Orig_Decl, Save_Form); | |
934 | Set_Visible_Declarations (Orig_Spec, Save_Vis); | |
935 | end; | |
936 | end if; | |
937 | ||
07fc65c4 | 938 | Process_End_Label (N, 'e', Id); |
fbf5a39b AC |
939 | |
940 | -- For the case of a library level package, we must go through all | |
941 | -- the entities clearing the indications that the value may be | |
942 | -- constant and not modified. Why? Because any client of this | |
943 | -- package may modify these values freely from anywhere. This | |
944 | -- also applies to any nested packages or generic packages. | |
945 | ||
946 | -- For now we unconditionally clear constants for packages that | |
947 | -- are instances of generic packages. The reason is that we do not | |
948 | -- have the body yet, and we otherwise think things are unreferenced | |
949 | -- when they are not. This should be fixed sometime (the effect is | |
950 | -- not terrible, we just lose some warnings, and also some cases | |
951 | -- of value propagation) ??? | |
952 | ||
953 | if Is_Library_Level_Entity (Id) | |
954 | or else Is_Generic_Instance (Id) | |
955 | then | |
956 | Clear_Constants (Id, First_Entity (Id)); | |
957 | Clear_Constants (Id, First_Private_Entity (Id)); | |
958 | end if; | |
996ae0b0 RK |
959 | end Analyze_Package_Specification; |
960 | ||
961 | -------------------------------------- | |
962 | -- Analyze_Private_Type_Declaration -- | |
963 | -------------------------------------- | |
964 | ||
965 | procedure Analyze_Private_Type_Declaration (N : Node_Id) is | |
fbf5a39b AC |
966 | PF : constant Boolean := Is_Pure (Enclosing_Lib_Unit_Entity); |
967 | Id : constant Entity_Id := Defining_Identifier (N); | |
996ae0b0 RK |
968 | |
969 | begin | |
970 | Generate_Definition (Id); | |
971 | Set_Is_Pure (Id, PF); | |
972 | Init_Size_Align (Id); | |
973 | ||
974 | if (Ekind (Current_Scope) /= E_Package | |
975 | and then Ekind (Current_Scope) /= E_Generic_Package) | |
976 | or else In_Private_Part (Current_Scope) | |
977 | then | |
978 | Error_Msg_N ("invalid context for private declaration", N); | |
979 | end if; | |
980 | ||
981 | New_Private_Type (N, Id, N); | |
982 | Set_Depends_On_Private (Id); | |
996ae0b0 RK |
983 | end Analyze_Private_Type_Declaration; |
984 | ||
985 | ------------------------------------------- | |
986 | -- Declare_Inherited_Private_Subprograms -- | |
987 | ------------------------------------------- | |
988 | ||
989 | procedure Declare_Inherited_Private_Subprograms (Id : Entity_Id) is | |
fbf5a39b | 990 | E : Entity_Id; |
07fc65c4 GB |
991 | Op_List : Elist_Id; |
992 | Op_Elmt : Elmt_Id; | |
993 | Op_Elmt_2 : Elmt_Id; | |
994 | Prim_Op : Entity_Id; | |
fbf5a39b | 995 | New_Op : Entity_Id := Empty; |
07fc65c4 GB |
996 | Parent_Subp : Entity_Id; |
997 | Found_Explicit : Boolean; | |
998 | Decl_Privates : Boolean; | |
999 | ||
fbf5a39b AC |
1000 | function Has_Overriding_Pragma (Subp : Entity_Id) return Boolean; |
1001 | -- Check whether a pragma Overriding has been provided for a primitive | |
1002 | -- operation that is found to be overriding in the private part. | |
1003 | ||
07fc65c4 GB |
1004 | function Is_Primitive_Of (T : Entity_Id; S : Entity_Id) return Boolean; |
1005 | -- Check whether an inherited subprogram is an operation of an | |
1006 | -- untagged derived type. | |
1007 | ||
fbf5a39b AC |
1008 | --------------------------- |
1009 | -- Has_Overriding_Pragma -- | |
1010 | --------------------------- | |
1011 | ||
1012 | function Has_Overriding_Pragma (Subp : Entity_Id) return Boolean is | |
1013 | Decl : constant Node_Id := Unit_Declaration_Node (Subp); | |
1014 | Prag : Node_Id; | |
1015 | ||
1016 | begin | |
1017 | if No (Decl) | |
1018 | or else Nkind (Decl) /= N_Subprogram_Declaration | |
1019 | or else No (Next (Decl)) | |
1020 | then | |
1021 | return False; | |
1022 | ||
1023 | else | |
1024 | Prag := Next (Decl); | |
1025 | ||
1026 | while Present (Prag) | |
1027 | and then Nkind (Prag) = N_Pragma | |
1028 | loop | |
1029 | if Chars (Prag) = Name_Overriding | |
1030 | or else Chars (Prag) = Name_Optional_Overriding | |
1031 | then | |
1032 | return True; | |
1033 | else | |
1034 | Next (Prag); | |
1035 | end if; | |
1036 | end loop; | |
1037 | end if; | |
1038 | ||
1039 | return False; | |
1040 | end Has_Overriding_Pragma; | |
1041 | ||
07fc65c4 GB |
1042 | --------------------- |
1043 | -- Is_Primitive_Of -- | |
1044 | --------------------- | |
1045 | ||
1046 | function Is_Primitive_Of (T : Entity_Id; S : Entity_Id) return Boolean is | |
1047 | Formal : Entity_Id; | |
1048 | ||
1049 | begin | |
1050 | if Etype (S) = T then | |
1051 | return True; | |
1052 | ||
1053 | else | |
1054 | Formal := First_Formal (S); | |
1055 | ||
1056 | while Present (Formal) loop | |
1057 | if Etype (Formal) = T then | |
1058 | return True; | |
1059 | end if; | |
1060 | ||
1061 | Next_Formal (Formal); | |
1062 | end loop; | |
1063 | ||
1064 | return False; | |
1065 | end if; | |
1066 | end Is_Primitive_Of; | |
1067 | ||
1068 | -- Start of processing for Declare_Inherited_Private_Subprograms | |
996ae0b0 RK |
1069 | |
1070 | begin | |
1071 | E := First_Entity (Id); | |
996ae0b0 RK |
1072 | while Present (E) loop |
1073 | ||
1074 | -- If the entity is a nonprivate type extension whose parent | |
1075 | -- type is declared in an open scope, then the type may have | |
1076 | -- inherited operations that now need to be made visible. | |
1077 | -- Ditto if the entity is a formal derived type in a child unit. | |
1078 | ||
07fc65c4 | 1079 | if ((Is_Derived_Type (E) and then not Is_Private_Type (E)) |
996ae0b0 | 1080 | or else |
fbf5a39b AC |
1081 | (Nkind (Parent (E)) = N_Private_Extension_Declaration |
1082 | and then Is_Generic_Type (E))) | |
996ae0b0 RK |
1083 | and then In_Open_Scopes (Scope (Etype (E))) |
1084 | and then E = Base_Type (E) | |
1085 | then | |
07fc65c4 GB |
1086 | if Is_Tagged_Type (E) then |
1087 | Op_List := Primitive_Operations (E); | |
07fc65c4 GB |
1088 | New_Op := Empty; |
1089 | Decl_Privates := False; | |
996ae0b0 | 1090 | |
fbf5a39b | 1091 | Op_Elmt := First_Elmt (Op_List); |
996ae0b0 RK |
1092 | while Present (Op_Elmt) loop |
1093 | Prim_Op := Node (Op_Elmt); | |
1094 | ||
1095 | -- If the primitive operation is an implicit operation | |
1096 | -- with an internal name whose parent operation has | |
1097 | -- a normal name, then we now need to either declare the | |
1098 | -- operation (i.e., make it visible), or replace it | |
1099 | -- by an overriding operation if one exists. | |
1100 | ||
1101 | if Present (Alias (Prim_Op)) | |
1102 | and then not Comes_From_Source (Prim_Op) | |
1103 | and then Is_Internal_Name (Chars (Prim_Op)) | |
1104 | and then not Is_Internal_Name (Chars (Alias (Prim_Op))) | |
1105 | then | |
1106 | Parent_Subp := Alias (Prim_Op); | |
1107 | ||
1108 | Found_Explicit := False; | |
1109 | Op_Elmt_2 := Next_Elmt (Op_Elmt); | |
1110 | while Present (Op_Elmt_2) loop | |
1111 | if Chars (Node (Op_Elmt_2)) = Chars (Parent_Subp) | |
1112 | and then Type_Conformant (Prim_Op, Node (Op_Elmt_2)) | |
1113 | then | |
1114 | -- The private inherited operation has been | |
1115 | -- overridden by an explicit subprogram, so | |
1116 | -- change the private op's list element to | |
1117 | -- designate the explicit so the explicit | |
1118 | -- one will get the right dispatching slot. | |
1119 | ||
1120 | New_Op := Node (Op_Elmt_2); | |
1121 | Replace_Elmt (Op_Elmt, New_Op); | |
1122 | Remove_Elmt (Op_List, Op_Elmt_2); | |
1123 | Found_Explicit := True; | |
1124 | Decl_Privates := True; | |
fbf5a39b AC |
1125 | |
1126 | -- If explicit_overriding is in effect, check that | |
1127 | -- the overriding operation is properly labelled. | |
1128 | ||
1129 | if Explicit_Overriding | |
1130 | and then Comes_From_Source (New_Op) | |
1131 | and then not Has_Overriding_Pragma (New_Op) | |
1132 | then | |
1133 | Error_Msg_NE | |
1134 | ("Missing overriding pragma for&", | |
1135 | New_Op, New_Op); | |
1136 | end if; | |
1137 | ||
996ae0b0 RK |
1138 | exit; |
1139 | end if; | |
1140 | ||
1141 | Next_Elmt (Op_Elmt_2); | |
1142 | end loop; | |
1143 | ||
1144 | if not Found_Explicit then | |
1145 | Derive_Subprogram | |
1146 | (New_Op, Alias (Prim_Op), E, Etype (E)); | |
1147 | ||
1148 | pragma Assert | |
1149 | (Is_Dispatching_Operation (New_Op) | |
1150 | and then Node (Last_Elmt (Op_List)) = New_Op); | |
1151 | ||
1152 | -- Substitute the new operation for the old one | |
1153 | -- in the type's primitive operations list. Since | |
1154 | -- the new operation was also just added to the end | |
1155 | -- of list, the last element must be removed. | |
1156 | ||
1157 | -- (Question: is there a simpler way of declaring | |
1158 | -- the operation, say by just replacing the name | |
1159 | -- of the earlier operation, reentering it in the | |
1160 | -- in the symbol table (how?), and marking it as | |
1161 | -- private???) | |
1162 | ||
1163 | Replace_Elmt (Op_Elmt, New_Op); | |
1164 | Remove_Last_Elmt (Op_List); | |
1165 | Decl_Privates := True; | |
1166 | end if; | |
1167 | end if; | |
1168 | ||
1169 | Next_Elmt (Op_Elmt); | |
1170 | end loop; | |
1171 | ||
1172 | -- The type's DT attributes need to be recalculated | |
1173 | -- in the case where private dispatching operations | |
1174 | -- have been added or overridden. Normally this action | |
1175 | -- occurs during type freezing, but we force it here | |
1176 | -- since the type may already have been frozen (e.g., | |
1177 | -- if the type's package has an empty private part). | |
1178 | -- This can only be done if expansion is active, otherwise | |
1179 | -- Tag may not be present. | |
1180 | ||
1181 | if Decl_Privates | |
1182 | and then Expander_Active | |
1183 | then | |
1184 | Set_All_DT_Position (E); | |
1185 | end if; | |
07fc65c4 GB |
1186 | |
1187 | else | |
1188 | -- Non-tagged type, scan forward to locate | |
1189 | -- inherited hidden operations. | |
1190 | ||
1191 | Prim_Op := Next_Entity (E); | |
1192 | ||
1193 | while Present (Prim_Op) loop | |
1194 | if Is_Subprogram (Prim_Op) | |
1195 | and then Present (Alias (Prim_Op)) | |
1196 | and then not Comes_From_Source (Prim_Op) | |
1197 | and then Is_Internal_Name (Chars (Prim_Op)) | |
1198 | and then not Is_Internal_Name (Chars (Alias (Prim_Op))) | |
1199 | and then Is_Primitive_Of (E, Prim_Op) | |
1200 | then | |
1201 | Derive_Subprogram (New_Op, Alias (Prim_Op), E, Etype (E)); | |
1202 | end if; | |
1203 | ||
1204 | Next_Entity (Prim_Op); | |
1205 | end loop; | |
1206 | end if; | |
996ae0b0 RK |
1207 | end if; |
1208 | ||
1209 | Next_Entity (E); | |
1210 | end loop; | |
1211 | end Declare_Inherited_Private_Subprograms; | |
1212 | ||
1213 | ----------------------- | |
1214 | -- End_Package_Scope -- | |
1215 | ----------------------- | |
1216 | ||
1217 | procedure End_Package_Scope (P : Entity_Id) is | |
1218 | begin | |
1219 | Uninstall_Declarations (P); | |
1220 | Pop_Scope; | |
1221 | end End_Package_Scope; | |
1222 | ||
1223 | --------------------------- | |
1224 | -- Exchange_Declarations -- | |
1225 | --------------------------- | |
1226 | ||
1227 | procedure Exchange_Declarations (Id : Entity_Id) is | |
1228 | Full_Id : constant Entity_Id := Full_View (Id); | |
1229 | H1 : constant Entity_Id := Homonym (Id); | |
1230 | Next1 : constant Entity_Id := Next_Entity (Id); | |
1231 | H2 : Entity_Id; | |
1232 | Next2 : Entity_Id; | |
1233 | ||
1234 | begin | |
1235 | -- If missing full declaration for type, nothing to exchange | |
1236 | ||
1237 | if No (Full_Id) then | |
1238 | return; | |
1239 | end if; | |
1240 | ||
1241 | -- Otherwise complete the exchange, and preserve semantic links | |
1242 | ||
1243 | Next2 := Next_Entity (Full_Id); | |
1244 | H2 := Homonym (Full_Id); | |
1245 | ||
1246 | -- Reset full declaration pointer to reflect the switched entities | |
1247 | -- and readjust the next entity chains. | |
1248 | ||
1249 | Exchange_Entities (Id, Full_Id); | |
1250 | ||
1251 | Set_Next_Entity (Id, Next1); | |
1252 | Set_Homonym (Id, H1); | |
1253 | ||
1254 | Set_Full_View (Full_Id, Id); | |
1255 | Set_Next_Entity (Full_Id, Next2); | |
1256 | Set_Homonym (Full_Id, H2); | |
1257 | end Exchange_Declarations; | |
1258 | ||
996ae0b0 RK |
1259 | ---------------------------- |
1260 | -- Install_Package_Entity -- | |
1261 | ---------------------------- | |
1262 | ||
1263 | procedure Install_Package_Entity (Id : Entity_Id) is | |
1264 | begin | |
1265 | if not Is_Internal (Id) then | |
1266 | if Debug_Flag_E then | |
1267 | Write_Str ("Install: "); | |
1268 | Write_Name (Chars (Id)); | |
1269 | Write_Eol; | |
1270 | end if; | |
1271 | ||
1272 | if not Is_Child_Unit (Id) then | |
1273 | Set_Is_Immediately_Visible (Id); | |
1274 | end if; | |
1275 | ||
1276 | end if; | |
1277 | end Install_Package_Entity; | |
1278 | ||
1279 | ---------------------------------- | |
1280 | -- Install_Private_Declarations -- | |
1281 | ---------------------------------- | |
1282 | ||
1283 | procedure Install_Private_Declarations (P : Entity_Id) is | |
1284 | Id : Entity_Id; | |
1285 | Priv_Elmt : Elmt_Id; | |
1286 | Priv : Entity_Id; | |
1287 | Full : Entity_Id; | |
1288 | ||
1289 | begin | |
1290 | -- First exchange declarations for private types, so that the | |
1291 | -- full declaration is visible. For each private type, we check | |
1292 | -- its Private_Dependents list and also exchange any subtypes of | |
1293 | -- or derived types from it. Finally, if this is a Taft amendment | |
1294 | -- type, the incomplete declaration is irrelevant, and we want to | |
1295 | -- link the eventual full declaration with the original private | |
1296 | -- one so we also skip the exchange. | |
1297 | ||
1298 | Id := First_Entity (P); | |
996ae0b0 RK |
1299 | while Present (Id) and then Id /= First_Private_Entity (P) loop |
1300 | ||
1301 | if Is_Private_Base_Type (Id) | |
1302 | and then Comes_From_Source (Full_View (Id)) | |
1303 | and then Present (Full_View (Id)) | |
1304 | and then Scope (Full_View (Id)) = Scope (Id) | |
1305 | and then Ekind (Full_View (Id)) /= E_Incomplete_Type | |
1306 | then | |
996ae0b0 RK |
1307 | -- If there is a use-type clause on the private type, set the |
1308 | -- full view accordingly. | |
1309 | ||
1310 | Set_In_Use (Full_View (Id), In_Use (Id)); | |
1311 | Full := Full_View (Id); | |
1312 | ||
1313 | if Is_Private_Base_Type (Full) | |
1314 | and then Has_Private_Declaration (Full) | |
1315 | and then Nkind (Parent (Full)) = N_Full_Type_Declaration | |
1316 | and then In_Open_Scopes (Scope (Etype (Full))) | |
1317 | and then In_Package_Body (Current_Scope) | |
1318 | and then not Is_Private_Type (Etype (Full)) | |
1319 | then | |
1320 | -- This is the completion of a private type by a derivation | |
1321 | -- from another private type which is not private anymore. This | |
1322 | -- can only happen in a package nested within a child package, | |
1323 | -- when the parent type is defined in the parent unit. At this | |
1324 | -- point the current type is not private either, and we have to | |
1325 | -- install the underlying full view, which is now visible. | |
1326 | ||
1327 | if No (Full_View (Full)) | |
1328 | and then Present (Underlying_Full_View (Full)) | |
1329 | then | |
1330 | Set_Full_View (Id, Underlying_Full_View (Full)); | |
1331 | Set_Underlying_Full_View (Full, Empty); | |
1332 | Set_Is_Frozen (Full_View (Id)); | |
1333 | end if; | |
1334 | end if; | |
1335 | ||
fbf5a39b AC |
1336 | Priv_Elmt := First_Elmt (Private_Dependents (Id)); |
1337 | ||
996ae0b0 RK |
1338 | Exchange_Declarations (Id); |
1339 | Set_Is_Immediately_Visible (Id); | |
1340 | ||
1341 | while Present (Priv_Elmt) loop | |
1342 | Priv := Node (Priv_Elmt); | |
1343 | ||
1344 | -- Before the exchange, verify that the presence of the | |
1345 | -- Full_View field. It will be empty if the entity | |
1346 | -- has already been installed due to a previous call. | |
1347 | ||
1348 | if Present (Full_View (Priv)) | |
1349 | and then Is_Visible_Dependent (Priv) | |
1350 | then | |
1351 | ||
1352 | -- For each subtype that is swapped, we also swap the | |
1353 | -- reference to it in Private_Dependents, to allow access | |
1354 | -- to it when we swap them out in End_Package_Scope. | |
1355 | ||
1356 | Replace_Elmt (Priv_Elmt, Full_View (Priv)); | |
1357 | Exchange_Declarations (Priv); | |
1358 | Set_Is_Immediately_Visible | |
1359 | (Priv, In_Open_Scopes (Scope (Priv))); | |
1360 | Set_Is_Potentially_Use_Visible | |
1361 | (Priv, Is_Potentially_Use_Visible (Node (Priv_Elmt))); | |
1362 | end if; | |
1363 | ||
1364 | Next_Elmt (Priv_Elmt); | |
1365 | end loop; | |
996ae0b0 RK |
1366 | end if; |
1367 | ||
1368 | Next_Entity (Id); | |
1369 | end loop; | |
1370 | ||
1371 | -- Next make other declarations in the private part visible as well. | |
1372 | ||
1373 | Id := First_Private_Entity (P); | |
1374 | ||
1375 | while Present (Id) loop | |
1376 | Install_Package_Entity (Id); | |
1377 | Next_Entity (Id); | |
1378 | end loop; | |
1379 | ||
1380 | -- Indicate that the private part is currently visible, so it can be | |
1381 | -- properly reset on exit. | |
1382 | ||
1383 | Set_In_Private_Part (P); | |
1384 | end Install_Private_Declarations; | |
1385 | ||
1386 | ---------------------------------- | |
1387 | -- Install_Visible_Declarations -- | |
1388 | ---------------------------------- | |
1389 | ||
1390 | procedure Install_Visible_Declarations (P : Entity_Id) is | |
1391 | Id : Entity_Id; | |
1392 | ||
1393 | begin | |
1394 | Id := First_Entity (P); | |
1395 | ||
1396 | while Present (Id) and then Id /= First_Private_Entity (P) loop | |
1397 | Install_Package_Entity (Id); | |
1398 | Next_Entity (Id); | |
1399 | end loop; | |
1400 | end Install_Visible_Declarations; | |
1401 | ||
996ae0b0 RK |
1402 | -------------------------- |
1403 | -- Is_Private_Base_Type -- | |
1404 | -------------------------- | |
1405 | ||
1406 | function Is_Private_Base_Type (E : Entity_Id) return Boolean is | |
1407 | begin | |
1408 | return Ekind (E) = E_Private_Type | |
1409 | or else Ekind (E) = E_Limited_Private_Type | |
1410 | or else Ekind (E) = E_Record_Type_With_Private; | |
1411 | end Is_Private_Base_Type; | |
1412 | ||
1413 | -------------------------- | |
1414 | -- Is_Visible_Dependent -- | |
1415 | -------------------------- | |
1416 | ||
1417 | function Is_Visible_Dependent (Dep : Entity_Id) return Boolean | |
1418 | is | |
1419 | S : constant Entity_Id := Scope (Dep); | |
1420 | ||
1421 | begin | |
1422 | -- Renamings created for actual types have the visibility of the | |
1423 | -- actual. | |
1424 | ||
1425 | if Ekind (S) = E_Package | |
1426 | and then Is_Generic_Instance (S) | |
1427 | and then (Is_Generic_Actual_Type (Dep) | |
1428 | or else Is_Generic_Actual_Type (Full_View (Dep))) | |
1429 | then | |
1430 | return True; | |
1431 | ||
1432 | elsif not (Is_Derived_Type (Dep)) | |
1433 | and then Is_Derived_Type (Full_View (Dep)) | |
1434 | then | |
fbf5a39b AC |
1435 | -- When instantiating a package body, the scope stack is empty, |
1436 | -- so check instead whether the dependent type is defined in | |
1437 | -- the same scope as the instance itself. | |
1438 | ||
1439 | return In_Open_Scopes (S) | |
1440 | or else (Is_Generic_Instance (Current_Scope) | |
1441 | and then Scope (Dep) = Scope (Current_Scope)); | |
996ae0b0 RK |
1442 | else |
1443 | return True; | |
1444 | end if; | |
1445 | end Is_Visible_Dependent; | |
1446 | ||
1447 | ---------------------------- | |
1448 | -- May_Need_Implicit_Body -- | |
1449 | ---------------------------- | |
1450 | ||
1451 | procedure May_Need_Implicit_Body (E : Entity_Id) is | |
1452 | P : constant Node_Id := Unit_Declaration_Node (E); | |
1453 | S : constant Node_Id := Parent (P); | |
1454 | B : Node_Id; | |
1455 | Decls : List_Id; | |
1456 | ||
1457 | begin | |
1458 | if not Has_Completion (E) | |
1459 | and then Nkind (P) = N_Package_Declaration | |
1460 | and then Present (Activation_Chain_Entity (P)) | |
1461 | then | |
1462 | B := | |
1463 | Make_Package_Body (Sloc (E), | |
1464 | Defining_Unit_Name => Make_Defining_Identifier (Sloc (E), | |
1465 | Chars => Chars (E)), | |
1466 | Declarations => New_List); | |
1467 | ||
1468 | if Nkind (S) = N_Package_Specification then | |
1469 | if Present (Private_Declarations (S)) then | |
1470 | Decls := Private_Declarations (S); | |
1471 | else | |
1472 | Decls := Visible_Declarations (S); | |
1473 | end if; | |
1474 | else | |
1475 | Decls := Declarations (S); | |
1476 | end if; | |
1477 | ||
1478 | Append (B, Decls); | |
1479 | Analyze (B); | |
1480 | end if; | |
1481 | end May_Need_Implicit_Body; | |
1482 | ||
1483 | ---------------------- | |
1484 | -- New_Private_Type -- | |
1485 | ---------------------- | |
1486 | ||
1487 | procedure New_Private_Type (N : Node_Id; Id : Entity_Id; Def : Node_Id) is | |
1488 | begin | |
1489 | Enter_Name (Id); | |
1490 | ||
1491 | if Limited_Present (Def) then | |
1492 | Set_Ekind (Id, E_Limited_Private_Type); | |
1493 | else | |
1494 | Set_Ekind (Id, E_Private_Type); | |
1495 | end if; | |
1496 | ||
1497 | Set_Etype (Id, Id); | |
1498 | Set_Has_Delayed_Freeze (Id); | |
1499 | Set_Is_First_Subtype (Id); | |
1500 | Init_Size_Align (Id); | |
1501 | ||
1502 | Set_Is_Constrained (Id, | |
1503 | No (Discriminant_Specifications (N)) | |
1504 | and then not Unknown_Discriminants_Present (N)); | |
1505 | ||
c0def2ad ES |
1506 | -- Set tagged flag before processing discriminants, to catch |
1507 | -- illegal usage. | |
1508 | ||
1509 | Set_Is_Tagged_Type (Id, Tagged_Present (Def)); | |
1510 | ||
996ae0b0 | 1511 | Set_Discriminant_Constraint (Id, No_Elist); |
fbf5a39b | 1512 | Set_Stored_Constraint (Id, No_Elist); |
996ae0b0 RK |
1513 | |
1514 | if Present (Discriminant_Specifications (N)) then | |
1515 | New_Scope (Id); | |
1516 | Process_Discriminants (N); | |
1517 | End_Scope; | |
1518 | ||
1519 | elsif Unknown_Discriminants_Present (N) then | |
1520 | Set_Has_Unknown_Discriminants (Id); | |
1521 | end if; | |
1522 | ||
1523 | Set_Private_Dependents (Id, New_Elmt_List); | |
1524 | ||
1525 | if Tagged_Present (Def) then | |
996ae0b0 RK |
1526 | Set_Ekind (Id, E_Record_Type_With_Private); |
1527 | Make_Class_Wide_Type (Id); | |
1528 | Set_Primitive_Operations (Id, New_Elmt_List); | |
1529 | Set_Is_Abstract (Id, Abstract_Present (Def)); | |
1530 | Set_Is_Limited_Record (Id, Limited_Present (Def)); | |
1531 | Set_Has_Delayed_Freeze (Id, True); | |
1532 | ||
1533 | elsif Abstract_Present (Def) then | |
1534 | Error_Msg_N ("only a tagged type can be abstract", N); | |
1535 | end if; | |
1536 | end New_Private_Type; | |
1537 | ||
fbf5a39b AC |
1538 | ---------------------------- |
1539 | -- Uninstall_Declarations -- | |
1540 | ---------------------------- | |
1541 | ||
1542 | procedure Uninstall_Declarations (P : Entity_Id) is | |
1543 | Decl : constant Node_Id := Unit_Declaration_Node (P); | |
1544 | Id : Entity_Id; | |
1545 | Full : Entity_Id; | |
1546 | Priv_Elmt : Elmt_Id; | |
1547 | Priv_Sub : Entity_Id; | |
996ae0b0 | 1548 | |
fbf5a39b AC |
1549 | procedure Preserve_Full_Attributes (Priv, Full : Entity_Id); |
1550 | -- Copy to the private declaration the attributes of the full view | |
1551 | -- that need to be available for the partial view also. | |
996ae0b0 | 1552 | |
fbf5a39b AC |
1553 | function Type_In_Use (T : Entity_Id) return Boolean; |
1554 | -- Check whether type or base type appear in an active use_type clause. | |
996ae0b0 | 1555 | |
fbf5a39b AC |
1556 | ------------------------------ |
1557 | -- Preserve_Full_Attributes -- | |
1558 | ------------------------------ | |
996ae0b0 | 1559 | |
fbf5a39b AC |
1560 | procedure Preserve_Full_Attributes (Priv, Full : Entity_Id) is |
1561 | Priv_Is_Base_Type : constant Boolean := Priv = Base_Type (Priv); | |
1562 | ||
1563 | begin | |
1564 | Set_Size_Info (Priv, (Full)); | |
1565 | Set_RM_Size (Priv, RM_Size (Full)); | |
1566 | Set_Size_Known_At_Compile_Time (Priv, Size_Known_At_Compile_Time | |
1567 | (Full)); | |
1568 | Set_Is_Volatile (Priv, Is_Volatile (Full)); | |
1569 | Set_Treat_As_Volatile (Priv, Treat_As_Volatile (Full)); | |
1570 | ||
1571 | if Referenced (Full) then | |
1572 | Set_Referenced (Priv); | |
1573 | end if; | |
996ae0b0 | 1574 | |
996ae0b0 | 1575 | if Priv_Is_Base_Type then |
fbf5a39b AC |
1576 | Set_Is_Controlled (Priv, Is_Controlled (Base_Type (Full))); |
1577 | Set_Finalize_Storage_Only (Priv, Finalize_Storage_Only | |
1578 | (Base_Type (Full))); | |
1579 | Set_Has_Task (Priv, Has_Task (Base_Type (Full))); | |
1580 | Set_Has_Controlled_Component (Priv, Has_Controlled_Component | |
996ae0b0 RK |
1581 | (Base_Type (Full))); |
1582 | end if; | |
1583 | ||
fbf5a39b | 1584 | Set_Freeze_Node (Priv, Freeze_Node (Full)); |
996ae0b0 | 1585 | |
fbf5a39b AC |
1586 | if Is_Tagged_Type (Priv) |
1587 | and then Is_Tagged_Type (Full) | |
1588 | and then not Error_Posted (Full) | |
1589 | then | |
1590 | if Priv_Is_Base_Type then | |
1591 | Set_Access_Disp_Table (Priv, Access_Disp_Table | |
1592 | (Base_Type (Full))); | |
1593 | end if; | |
996ae0b0 | 1594 | |
fbf5a39b AC |
1595 | Set_First_Entity (Priv, First_Entity (Full)); |
1596 | Set_Last_Entity (Priv, Last_Entity (Full)); | |
1597 | end if; | |
1598 | end Preserve_Full_Attributes; | |
996ae0b0 | 1599 | |
fbf5a39b AC |
1600 | ----------------- |
1601 | -- Type_In_Use -- | |
1602 | ----------------- | |
996ae0b0 RK |
1603 | |
1604 | function Type_In_Use (T : Entity_Id) return Boolean is | |
1605 | begin | |
1606 | return Scope (Base_Type (T)) = P | |
1607 | and then (In_Use (T) or else In_Use (Base_Type (T))); | |
1608 | end Type_In_Use; | |
1609 | ||
1610 | -- Start of processing for Uninstall_Declarations | |
1611 | ||
1612 | begin | |
1613 | Id := First_Entity (P); | |
1614 | ||
1615 | while Present (Id) and then Id /= First_Private_Entity (P) loop | |
1616 | if Debug_Flag_E then | |
1617 | Write_Str ("unlinking visible entity "); | |
1618 | Write_Int (Int (Id)); | |
1619 | Write_Eol; | |
1620 | end if; | |
1621 | ||
1622 | -- On exit from the package scope, we must preserve the visibility | |
1623 | -- established by use clauses in the current scope. Two cases: | |
1624 | ||
1625 | -- a) If the entity is an operator, it may be a primitive operator of | |
1626 | -- a type for which there is a visible use-type clause. | |
1627 | ||
1628 | -- b) for other entities, their use-visibility is determined by a | |
1629 | -- visible use clause for the package itself. For a generic instance, | |
1630 | -- the instantiation of the formals appears in the visible part, | |
1631 | -- but the formals are private and remain so. | |
1632 | ||
1633 | if Ekind (Id) = E_Function | |
1634 | and then Is_Operator_Symbol_Name (Chars (Id)) | |
1635 | and then not Is_Hidden (Id) | |
fbf5a39b | 1636 | and then not Error_Posted (Id) |
996ae0b0 RK |
1637 | then |
1638 | Set_Is_Potentially_Use_Visible (Id, | |
1639 | In_Use (P) | |
1640 | or else Type_In_Use (Etype (Id)) | |
1641 | or else Type_In_Use (Etype (First_Formal (Id))) | |
1642 | or else (Present (Next_Formal (First_Formal (Id))) | |
1643 | and then | |
1644 | Type_In_Use | |
1645 | (Etype (Next_Formal (First_Formal (Id)))))); | |
1646 | else | |
1647 | Set_Is_Potentially_Use_Visible (Id, | |
1648 | In_Use (P) and not Is_Hidden (Id)); | |
1649 | end if; | |
1650 | ||
1651 | -- Local entities are not immediately visible outside of the package. | |
1652 | ||
1653 | Set_Is_Immediately_Visible (Id, False); | |
1654 | ||
1655 | if Is_Tagged_Type (Id) and then Ekind (Id) = E_Record_Type then | |
1656 | Check_Abstract_Overriding (Id); | |
1657 | end if; | |
1658 | ||
1659 | if (Ekind (Id) = E_Private_Type | |
1660 | or else Ekind (Id) = E_Limited_Private_Type) | |
1661 | and then No (Full_View (Id)) | |
1662 | and then not Is_Generic_Type (Id) | |
1663 | and then not Is_Derived_Type (Id) | |
1664 | then | |
1665 | Error_Msg_N ("missing full declaration for private type&", Id); | |
1666 | ||
1667 | elsif Ekind (Id) = E_Record_Type_With_Private | |
1668 | and then not Is_Generic_Type (Id) | |
1669 | and then No (Full_View (Id)) | |
1670 | then | |
1671 | if Nkind (Parent (Id)) = N_Private_Type_Declaration then | |
1672 | Error_Msg_N ("missing full declaration for private type&", Id); | |
1673 | else | |
1674 | Error_Msg_N | |
1675 | ("missing full declaration for private extension", Id); | |
1676 | end if; | |
1677 | ||
1678 | elsif Ekind (Id) = E_Constant | |
1679 | and then No (Constant_Value (Id)) | |
1680 | and then No (Full_View (Id)) | |
1681 | and then not Is_Imported (Id) | |
1682 | and then (Nkind (Parent (Id)) /= N_Object_Declaration | |
1683 | or else not No_Initialization (Parent (Id))) | |
1684 | then | |
fbf5a39b AC |
1685 | if not Has_Private_Declaration (Etype (Id)) then |
1686 | ||
1687 | -- We assume that the user did not not intend a deferred | |
1688 | -- constant declaration, and the expression is just missing. | |
1689 | ||
1690 | Error_Msg_N | |
1691 | ("constant declaration requires initialization expression", | |
1692 | Parent (Id)); | |
1693 | ||
1694 | if Is_Limited_Type (Etype (Id)) then | |
1695 | Error_Msg_N | |
1696 | ("\else remove keyword CONSTANT from declaration", | |
1697 | Parent (Id)); | |
1698 | end if; | |
1699 | ||
1700 | else | |
1701 | Error_Msg_N | |
1702 | ("missing full declaration for deferred constant ('R'M 7.4)", | |
1703 | Id); | |
1704 | ||
1705 | if Is_Limited_Type (Etype (Id)) then | |
1706 | Error_Msg_N | |
1707 | ("\else remove keyword CONSTANT from declaration", | |
1708 | Parent (Id)); | |
1709 | end if; | |
1710 | end if; | |
996ae0b0 RK |
1711 | end if; |
1712 | ||
1713 | Next_Entity (Id); | |
1714 | end loop; | |
1715 | ||
1716 | -- If the specification was installed as the parent of a public child | |
1717 | -- unit, the private declarations were not installed, and there is | |
1718 | -- nothing to do. | |
1719 | ||
1720 | if not In_Private_Part (P) then | |
1721 | return; | |
1722 | else | |
1723 | Set_In_Private_Part (P, False); | |
1724 | end if; | |
1725 | ||
1726 | -- Make private entities invisible and exchange full and private | |
1727 | -- declarations for private types. | |
1728 | ||
1729 | while Present (Id) loop | |
1730 | if Debug_Flag_E then | |
1731 | Write_Str ("unlinking private entity "); | |
1732 | Write_Int (Int (Id)); | |
1733 | Write_Eol; | |
1734 | end if; | |
1735 | ||
1736 | if Is_Tagged_Type (Id) and then Ekind (Id) = E_Record_Type then | |
1737 | Check_Abstract_Overriding (Id); | |
1738 | end if; | |
1739 | ||
1740 | Set_Is_Immediately_Visible (Id, False); | |
1741 | ||
1742 | if Is_Private_Base_Type (Id) | |
1743 | and then Present (Full_View (Id)) | |
1744 | then | |
1745 | Full := Full_View (Id); | |
1746 | ||
1747 | -- If the partial view is not declared in the visible part | |
1748 | -- of the package (as is the case when it is a type derived | |
fbf5a39b | 1749 | -- from some other private type in the private part of the |
996ae0b0 RK |
1750 | -- current package), no exchange takes place. |
1751 | ||
1752 | if No (Parent (Id)) | |
1753 | or else List_Containing (Parent (Id)) | |
1754 | /= Visible_Declarations (Specification (Decl)) | |
1755 | then | |
1756 | goto Next_Id; | |
1757 | end if; | |
1758 | ||
1759 | -- The entry in the private part points to the full declaration, | |
1760 | -- which is currently visible. Exchange them so only the private | |
1761 | -- type declaration remains accessible, and link private and | |
1762 | -- full declaration in the opposite direction. Before the actual | |
1763 | -- exchange, we copy back attributes of the full view that | |
1764 | -- must be available to the partial view too. | |
1765 | ||
1766 | Preserve_Full_Attributes (Id, Full); | |
1767 | ||
1768 | Set_Is_Potentially_Use_Visible (Id, In_Use (P)); | |
1769 | ||
1770 | if Is_Indefinite_Subtype (Full) | |
1771 | and then not Is_Indefinite_Subtype (Id) | |
1772 | then | |
1773 | Error_Msg_N | |
1774 | ("full view of type must be definite subtype", Full); | |
1775 | end if; | |
1776 | ||
1777 | Priv_Elmt := First_Elmt (Private_Dependents (Id)); | |
1778 | Exchange_Declarations (Id); | |
1779 | ||
1780 | -- Swap out the subtypes and derived types of Id that were | |
1781 | -- compiled in this scope, or installed previously by | |
1782 | -- Install_Private_Declarations. | |
1783 | -- Before we do the swap, we verify the presence of the | |
1784 | -- Full_View field which may be empty due to a swap by | |
1785 | -- a previous call to End_Package_Scope (e.g. from the | |
1786 | -- freezing mechanism). | |
1787 | ||
1788 | while Present (Priv_Elmt) loop | |
1789 | Priv_Sub := Node (Priv_Elmt); | |
1790 | ||
1791 | if Present (Full_View (Priv_Sub)) then | |
1792 | ||
1793 | if Scope (Priv_Sub) = P | |
1794 | or else not In_Open_Scopes (Scope (Priv_Sub)) | |
1795 | then | |
1796 | Set_Is_Immediately_Visible (Priv_Sub, False); | |
1797 | end if; | |
1798 | ||
1799 | if Is_Visible_Dependent (Priv_Sub) then | |
1800 | Preserve_Full_Attributes | |
1801 | (Priv_Sub, Full_View (Priv_Sub)); | |
1802 | Replace_Elmt (Priv_Elmt, Full_View (Priv_Sub)); | |
1803 | Exchange_Declarations (Priv_Sub); | |
1804 | end if; | |
1805 | end if; | |
1806 | ||
1807 | Next_Elmt (Priv_Elmt); | |
1808 | end loop; | |
1809 | ||
1810 | elsif Ekind (Id) = E_Incomplete_Type | |
1811 | and then No (Full_View (Id)) | |
1812 | then | |
1813 | -- Mark Taft amendment types | |
1814 | ||
1815 | Set_Has_Completion_In_Body (Id); | |
1816 | ||
1817 | elsif not Is_Child_Unit (Id) | |
1818 | and then (not Is_Private_Type (Id) | |
1819 | or else No (Full_View (Id))) | |
1820 | then | |
1821 | Set_Is_Hidden (Id); | |
1822 | Set_Is_Potentially_Use_Visible (Id, False); | |
1823 | end if; | |
1824 | ||
1825 | <<Next_Id>> | |
1826 | Next_Entity (Id); | |
1827 | end loop; | |
996ae0b0 RK |
1828 | end Uninstall_Declarations; |
1829 | ||
1830 | ------------------------ | |
1831 | -- Unit_Requires_Body -- | |
1832 | ------------------------ | |
1833 | ||
1834 | function Unit_Requires_Body (P : Entity_Id) return Boolean is | |
1835 | E : Entity_Id; | |
1836 | ||
1837 | begin | |
1838 | -- Imported entity never requires body. Right now, only | |
1839 | -- subprograms can be imported, but perhaps in the future | |
1840 | -- we will allow import of packages. | |
1841 | ||
1842 | if Is_Imported (P) then | |
1843 | return False; | |
1844 | ||
1845 | -- Body required if library package with pragma Elaborate_Body | |
1846 | ||
1847 | elsif Has_Pragma_Elaborate_Body (P) then | |
1848 | return True; | |
1849 | ||
1850 | -- Body required if subprogram | |
1851 | ||
fbf5a39b | 1852 | elsif Is_Subprogram (P) or else Is_Generic_Subprogram (P) then |
996ae0b0 RK |
1853 | return True; |
1854 | ||
1855 | -- Treat a block as requiring a body | |
1856 | ||
1857 | elsif Ekind (P) = E_Block then | |
1858 | return True; | |
1859 | ||
1860 | elsif Ekind (P) = E_Package | |
1861 | and then Nkind (Parent (P)) = N_Package_Specification | |
1862 | and then Present (Generic_Parent (Parent (P))) | |
1863 | then | |
1864 | declare | |
fbf5a39b | 1865 | G_P : constant Entity_Id := Generic_Parent (Parent (P)); |
996ae0b0 RK |
1866 | |
1867 | begin | |
1868 | if Has_Pragma_Elaborate_Body (G_P) then | |
1869 | return True; | |
1870 | end if; | |
1871 | end; | |
1872 | end if; | |
1873 | ||
1874 | -- Otherwise search entity chain for entity requiring completion. | |
1875 | ||
1876 | E := First_Entity (P); | |
1877 | while Present (E) loop | |
1878 | ||
1879 | -- Always ignore child units. Child units get added to the entity | |
1880 | -- list of a parent unit, but are not original entities of the | |
1881 | -- parent, and so do not affect whether the parent needs a body. | |
1882 | ||
1883 | if Is_Child_Unit (E) then | |
1884 | null; | |
1885 | ||
1886 | -- Otherwise test to see if entity requires a completion | |
1887 | ||
1888 | elsif (Is_Overloadable (E) | |
1889 | and then Ekind (E) /= E_Enumeration_Literal | |
1890 | and then Ekind (E) /= E_Operator | |
1891 | and then not Is_Abstract (E) | |
1892 | and then not Has_Completion (E)) | |
1893 | ||
1894 | or else | |
1895 | (Ekind (E) = E_Package | |
1896 | and then E /= P | |
1897 | and then not Has_Completion (E) | |
1898 | and then Unit_Requires_Body (E)) | |
1899 | ||
1900 | or else | |
1901 | (Ekind (E) = E_Incomplete_Type and then No (Full_View (E))) | |
1902 | ||
1903 | or else | |
1904 | ((Ekind (E) = E_Task_Type or else | |
1905 | Ekind (E) = E_Protected_Type) | |
1906 | and then not Has_Completion (E)) | |
1907 | ||
1908 | or else | |
1909 | (Ekind (E) = E_Generic_Package and then E /= P | |
1910 | and then not Has_Completion (E) | |
1911 | and then Unit_Requires_Body (E)) | |
1912 | ||
1913 | or else | |
fbf5a39b | 1914 | (Is_Generic_Subprogram (E) |
996ae0b0 RK |
1915 | and then not Has_Completion (E)) |
1916 | ||
1917 | then | |
1918 | return True; | |
1919 | ||
1920 | -- Entity that does not require completion | |
1921 | ||
1922 | else | |
1923 | null; | |
1924 | end if; | |
1925 | ||
1926 | Next_Entity (E); | |
1927 | end loop; | |
1928 | ||
1929 | return False; | |
1930 | end Unit_Requires_Body; | |
1931 | ||
1932 | end Sem_Ch7; |