]>
Commit | Line | Data |
---|---|---|
d6f39728 | 1 | ------------------------------------------------------------------------------ |
2 | -- -- | |
3 | -- GNAT COMPILER COMPONENTS -- | |
4 | -- -- | |
5 | -- S E M _ C H 1 0 -- | |
6 | -- -- | |
7 | -- B o d y -- | |
8 | -- -- | |
79d59c5e | 9 | -- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- |
d6f39728 | 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- -- | |
80df182a | 13 | -- ware Foundation; either version 3, or (at your option) any later ver- -- |
d6f39728 | 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 -- | |
80df182a | 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. -- | |
d6f39728 | 20 | -- -- |
21 | -- GNAT was originally developed by the GNAT team at New York University. -- | |
e78e8c8e | 22 | -- Extensive contributions were provided by Ada Core Technologies Inc. -- |
d6f39728 | 23 | -- -- |
24 | ------------------------------------------------------------------------------ | |
25 | ||
26 | with Atree; use Atree; | |
27 | with Debug; use Debug; | |
28 | with Einfo; use Einfo; | |
29 | with Errout; use Errout; | |
30 | with Exp_Util; use Exp_Util; | |
3a2db8ab | 31 | with Elists; use Elists; |
d6f39728 | 32 | with Fname; use Fname; |
33 | with Fname.UF; use Fname.UF; | |
34 | with Freeze; use Freeze; | |
35 | with Impunit; use Impunit; | |
36 | with Inline; use Inline; | |
37 | with Lib; use Lib; | |
38 | with Lib.Load; use Lib.Load; | |
39 | with Lib.Xref; use Lib.Xref; | |
40 | with Namet; use Namet; | |
41 | with Nlists; use Nlists; | |
42 | with Nmake; use Nmake; | |
43 | with Opt; use Opt; | |
44 | with Output; use Output; | |
11b376d2 | 45 | with Par_SCO; use Par_SCO; |
d6f39728 | 46 | with Restrict; use Restrict; |
f49f70c6 | 47 | with Rident; use Rident; |
c54e9270 | 48 | with Rtsfind; use Rtsfind; |
d6f39728 | 49 | with Sem; use Sem; |
e17ff23f | 50 | with Sem_Ch3; use Sem_Ch3; |
d6f39728 | 51 | with Sem_Ch6; use Sem_Ch6; |
52 | with Sem_Ch7; use Sem_Ch7; | |
53 | with Sem_Ch8; use Sem_Ch8; | |
54 | with Sem_Dist; use Sem_Dist; | |
55 | with Sem_Prag; use Sem_Prag; | |
56 | with Sem_Util; use Sem_Util; | |
57 | with Sem_Warn; use Sem_Warn; | |
58 | with Stand; use Stand; | |
59 | with Sinfo; use Sinfo; | |
60 | with Sinfo.CN; use Sinfo.CN; | |
61 | with Sinput; use Sinput; | |
62 | with Snames; use Snames; | |
63 | with Style; use Style; | |
9dfe12ae | 64 | with Stylesw; use Stylesw; |
d6f39728 | 65 | with Tbuild; use Tbuild; |
d6f39728 | 66 | with Uname; use Uname; |
67 | ||
68 | package body Sem_Ch10 is | |
69 | ||
70 | ----------------------- | |
71 | -- Local Subprograms -- | |
72 | ----------------------- | |
73 | ||
74 | procedure Analyze_Context (N : Node_Id); | |
75 | -- Analyzes items in the context clause of compilation unit | |
76 | ||
9dfe12ae | 77 | procedure Build_Limited_Views (N : Node_Id); |
05e5286d | 78 | -- Build and decorate the list of shadow entities for a package mentioned |
79 | -- in a limited_with clause. If the package was not previously analyzed | |
88fcd057 | 80 | -- then it also performs a basic decoration of the real entities. This is |
81 | -- required to do not pass non-decorated entities to the back-end. | |
e2aa7314 | 82 | -- Implements Ada 2005 (AI-50217). |
9dfe12ae | 83 | |
84 | procedure Check_Body_Needed_For_SAL (Unit_Name : Entity_Id); | |
88fcd057 | 85 | -- Check whether the source for the body of a compilation unit must be |
86 | -- included in a standalone library. | |
9dfe12ae | 87 | |
d6f39728 | 88 | procedure Check_Private_Child_Unit (N : Node_Id); |
89 | -- If a with_clause mentions a private child unit, the compilation | |
899ae34b | 90 | -- unit must be a member of the same family, as described in 10.1.2. |
d6f39728 | 91 | |
92 | procedure Check_Stub_Level (N : Node_Id); | |
93 | -- Verify that a stub is declared immediately within a compilation unit, | |
94 | -- and not in an inner frame. | |
95 | ||
665e279c | 96 | procedure Expand_With_Clause (Item : Node_Id; Nam : Node_Id; N : Node_Id); |
d6f39728 | 97 | -- When a child unit appears in a context clause, the implicit withs on |
98 | -- parents are made explicit, and with clauses are inserted in the context | |
99 | -- clause before the one for the child. If a parent in the with_clause | |
100 | -- is a renaming, the implicit with_clause is on the renaming whose name | |
101 | -- is mentioned in the with_clause, and not on the package it renames. | |
102 | -- N is the compilation unit whose list of context items receives the | |
103 | -- implicit with_clauses. | |
104 | ||
f15731c4 | 105 | function Get_Parent_Entity (Unit : Node_Id) return Entity_Id; |
106 | -- Get defining entity of parent unit of a child unit. In most cases this | |
107 | -- is the defining entity of the unit, but for a child instance whose | |
108 | -- parent needs a body for inlining, the instantiation node of the parent | |
109 | -- has not yet been rewritten as a package declaration, and the entity has | |
110 | -- to be retrieved from the Instance_Spec of the unit. | |
111 | ||
6f152d7a | 112 | function Has_With_Clause |
113 | (C_Unit : Node_Id; | |
114 | Pack : Entity_Id; | |
115 | Is_Limited : Boolean := False) return Boolean; | |
45cedf2e | 116 | -- Determine whether compilation unit C_Unit contains a [limited] with |
117 | -- clause for package Pack. Use the flag Is_Limited to designate desired | |
118 | -- clause kind. | |
6f152d7a | 119 | |
d6f39728 | 120 | procedure Implicit_With_On_Parent (Child_Unit : Node_Id; N : Node_Id); |
121 | -- If the main unit is a child unit, implicit withs are also added for | |
122 | -- all its ancestors. | |
123 | ||
9c3beb70 | 124 | function In_Chain (E : Entity_Id) return Boolean; |
125 | -- Check that the shadow entity is not already in the homonym chain, for | |
126 | -- example through a limited_with clause in a parent unit. | |
127 | ||
d6f39728 | 128 | procedure Install_Context_Clauses (N : Node_Id); |
c53c8335 | 129 | -- Subsidiary to Install_Context and Install_Parents. Process only with_ |
130 | -- and use_clauses for current unit and its library unit if any. | |
d6f39728 | 131 | |
05e5286d | 132 | procedure Install_Limited_Context_Clauses (N : Node_Id); |
88fcd057 | 133 | -- Subsidiary to Install_Context. Process only limited with_clauses for |
134 | -- current unit. Implements Ada 2005 (AI-50217). | |
05e5286d | 135 | |
9dfe12ae | 136 | procedure Install_Limited_Withed_Unit (N : Node_Id); |
137 | -- Place shadow entities for a limited_with package in the visibility | |
e2aa7314 | 138 | -- structures for the current compilation. Implements Ada 2005 (AI-50217). |
9dfe12ae | 139 | |
3d875462 | 140 | procedure Install_Withed_Unit |
141 | (With_Clause : Node_Id; | |
142 | Private_With_OK : Boolean := False); | |
88fcd057 | 143 | -- If the unit is not a child unit, make unit immediately visible. The |
144 | -- caller ensures that the unit is not already currently installed. The | |
145 | -- flag Private_With_OK is set true in Install_Private_With_Clauses, which | |
146 | -- is called when compiling the private part of a package, or installing | |
147 | -- the private declarations of a parent unit. | |
d6f39728 | 148 | |
149 | procedure Install_Parents (Lib_Unit : Node_Id; Is_Private : Boolean); | |
150 | -- This procedure establishes the context for the compilation of a child | |
151 | -- unit. If Lib_Unit is a child library spec then the context of the parent | |
152 | -- is installed, and the parent itself made immediately visible, so that | |
153 | -- the child unit is processed in the declarative region of the parent. | |
154 | -- Install_Parents makes a recursive call to itself to ensure that all | |
155 | -- parents are loaded in the nested case. If Lib_Unit is a library body, | |
156 | -- the only effect of Install_Parents is to install the private decls of | |
157 | -- the parents, because the visible parent declarations will have been | |
158 | -- installed as part of the context of the corresponding spec. | |
159 | ||
160 | procedure Install_Siblings (U_Name : Entity_Id; N : Node_Id); | |
161 | -- In the compilation of a child unit, a child of any of the ancestor | |
162 | -- units is directly visible if it is visible, because the parent is in | |
163 | -- an enclosing scope. Iterate over context to find child units of U_Name | |
164 | -- or of some ancestor of it. | |
165 | ||
166 | function Is_Child_Spec (Lib_Unit : Node_Id) return Boolean; | |
167 | -- Lib_Unit is a library unit which may be a spec or a body. Is_Child_Spec | |
168 | -- returns True if Lib_Unit is a library spec which is a child spec, i.e. | |
169 | -- a library spec that has a parent. If the call to Is_Child_Spec returns | |
170 | -- True, then Parent_Spec (Lib_Unit) is non-Empty and points to the | |
171 | -- compilation unit for the parent spec. | |
172 | -- | |
88fcd057 | 173 | -- Lib_Unit can also be a subprogram body that acts as its own spec. If the |
174 | -- Parent_Spec is non-empty, this is also a child unit. | |
d6f39728 | 175 | |
d6f39728 | 176 | procedure Remove_Context_Clauses (N : Node_Id); |
2866d595 | 177 | -- Subsidiary of previous one. Remove use_ and with_clauses |
d6f39728 | 178 | |
9dfe12ae | 179 | procedure Remove_Limited_With_Clause (N : Node_Id); |
180 | -- Remove from visibility the shadow entities introduced for a package | |
e2aa7314 | 181 | -- mentioned in a limited_with clause. Implements Ada 2005 (AI-50217). |
9dfe12ae | 182 | |
d6f39728 | 183 | procedure Remove_Parents (Lib_Unit : Node_Id); |
184 | -- Remove_Parents checks if Lib_Unit is a child spec. If so then the parent | |
185 | -- contexts established by the corresponding call to Install_Parents are | |
186 | -- removed. Remove_Parents contains a recursive call to itself to ensure | |
187 | -- that all parents are removed in the nested case. | |
188 | ||
189 | procedure Remove_Unit_From_Visibility (Unit_Name : Entity_Id); | |
190 | -- Reset all visibility flags on unit after compiling it, either as a | |
191 | -- main unit or as a unit in the context. | |
192 | ||
9dfe12ae | 193 | procedure Unchain (E : Entity_Id); |
194 | -- Remove single entity from visibility list | |
195 | ||
d6f39728 | 196 | procedure Analyze_Proper_Body (N : Node_Id; Nam : Entity_Id); |
197 | -- Common processing for all stubs (subprograms, tasks, packages, and | |
198 | -- protected cases). N is the stub to be analyzed. Once the subunit | |
199 | -- name is established, load and analyze. Nam is the non-overloadable | |
200 | -- entity for which the proper body provides a completion. Subprogram | |
201 | -- stubs are handled differently because they can be declarations. | |
202 | ||
f49f70c6 | 203 | procedure sm; |
204 | -- A dummy procedure, for debugging use, called just before analyzing the | |
205 | -- main unit (after dealing with any context clauses). | |
206 | ||
9dfe12ae | 207 | -------------------------- |
208 | -- Limited_With_Clauses -- | |
209 | -------------------------- | |
210 | ||
211 | -- Limited_With clauses are the mechanism chosen for Ada05 to support | |
212 | -- mutually recursive types declared in different units. A limited_with | |
213 | -- clause that names package P in the context of unit U makes the types | |
214 | -- declared in the visible part of P available within U, but with the | |
215 | -- restriction that these types can only be used as incomplete types. | |
216 | -- The limited_with clause does not impose a semantic dependence on P, | |
217 | -- and it is possible for two packages to have limited_with_clauses on | |
218 | -- each other without creating an elaboration circularity. | |
219 | ||
220 | -- To support this feature, the analysis of a limited_with clause must | |
221 | -- create an abbreviated view of the package, without performing any | |
39a79c9e | 222 | -- semantic analysis on it. This "package abstract" contains shadow types |
223 | -- that are in one-one correspondence with the real types in the package, | |
224 | -- and that have the properties of incomplete types. | |
9dfe12ae | 225 | |
226 | -- The implementation creates two element lists: one to chain the shadow | |
227 | -- entities, and one to chain the corresponding type entities in the tree | |
228 | -- of the package. Links between corresponding entities in both chains | |
229 | -- allow the compiler to select the proper view of a given type, depending | |
230 | -- on the context. Note that in contrast with the handling of private | |
231 | -- types, the limited view and the non-limited view of a type are treated | |
232 | -- as separate entities, and no entity exchange needs to take place, which | |
233 | -- makes the implementation must simpler than could be feared. | |
234 | ||
d6f39728 | 235 | ------------------------------ |
236 | -- Analyze_Compilation_Unit -- | |
237 | ------------------------------ | |
238 | ||
239 | procedure Analyze_Compilation_Unit (N : Node_Id) is | |
240 | Unit_Node : constant Node_Id := Unit (N); | |
241 | Lib_Unit : Node_Id := Library_Unit (N); | |
7cb0fd86 | 242 | Spec_Id : Entity_Id; |
d6f39728 | 243 | Main_Cunit : constant Node_Id := Cunit (Main_Unit); |
244 | Par_Spec_Name : Unit_Name_Type; | |
245 | Unum : Unit_Number_Type; | |
246 | ||
9a504e32 | 247 | procedure Check_Redundant_Withs |
248 | (Context_Items : List_Id; | |
249 | Spec_Context_Items : List_Id := No_List); | |
250 | -- Determine whether the context list of a compilation unit contains | |
251 | -- redundant with clauses. When checking body clauses against spec | |
252 | -- clauses, set Context_Items to the context list of the body and | |
253 | -- Spec_Context_Items to that of the spec. Parent packages are not | |
254 | -- examined for documentation purposes. | |
255 | ||
d6f39728 | 256 | procedure Generate_Parent_References (N : Node_Id; P_Id : Entity_Id); |
257 | -- Generate cross-reference information for the parents of child units. | |
258 | -- N is a defining_program_unit_name, and P_Id is the immediate parent. | |
259 | ||
9a504e32 | 260 | --------------------------- |
261 | -- Check_Redundant_Withs -- | |
262 | --------------------------- | |
263 | ||
264 | procedure Check_Redundant_Withs | |
265 | (Context_Items : List_Id; | |
266 | Spec_Context_Items : List_Id := No_List) | |
267 | is | |
268 | Clause : Node_Id; | |
269 | ||
270 | procedure Process_Body_Clauses | |
271 | (Context_List : List_Id; | |
272 | Clause : Node_Id; | |
273 | Used : in out Boolean; | |
274 | Used_Type_Or_Elab : in out Boolean); | |
275 | -- Examine the context clauses of a package body, trying to match | |
276 | -- the name entity of Clause with any list element. If the match | |
277 | -- occurs on a use package clause, set Used to True, for a use | |
278 | -- type clause, pragma Elaborate or pragma Elaborate_All, set | |
279 | -- Used_Type_Or_Elab to True. | |
280 | ||
281 | procedure Process_Spec_Clauses | |
282 | (Context_List : List_Id; | |
283 | Clause : Node_Id; | |
284 | Used : in out Boolean; | |
285 | Withed : in out Boolean; | |
286 | Exit_On_Self : Boolean := False); | |
287 | -- Examine the context clauses of a package spec, trying to match | |
288 | -- the name entity of Clause with any list element. If the match | |
289 | -- occurs on a use package clause, set Used to True, for a with | |
290 | -- package clause other than Clause, set Withed to True. Limited | |
291 | -- with clauses, implicitly generated with clauses and withs | |
292 | -- having pragmas Elaborate or Elaborate_All applied to them are | |
293 | -- skipped. Exit_On_Self is used to control the search loop and | |
294 | -- force an exit whenever Clause sees itself in the search. | |
295 | ||
296 | -------------------------- | |
297 | -- Process_Body_Clauses -- | |
298 | -------------------------- | |
299 | ||
300 | procedure Process_Body_Clauses | |
301 | (Context_List : List_Id; | |
302 | Clause : Node_Id; | |
303 | Used : in out Boolean; | |
304 | Used_Type_Or_Elab : in out Boolean) | |
305 | is | |
306 | Nam_Ent : constant Entity_Id := Entity (Name (Clause)); | |
307 | Cont_Item : Node_Id; | |
308 | Prag_Unit : Node_Id; | |
309 | Subt_Mark : Node_Id; | |
310 | Use_Item : Node_Id; | |
311 | ||
58655148 | 312 | function Same_Unit (N : Node_Id; P : Entity_Id) return Boolean; |
39a79c9e | 313 | -- In an expanded name in a use clause, if the prefix is a renamed |
314 | -- package, the entity is set to the original package as a result, | |
315 | -- when checking whether the package appears in a previous with | |
316 | -- clause, the renaming has to be taken into account, to prevent | |
317 | -- spurious/incorrect warnings. A common case is use of Text_IO. | |
58655148 | 318 | |
319 | --------------- | |
320 | -- Same_Unit -- | |
321 | --------------- | |
322 | ||
323 | function Same_Unit (N : Node_Id; P : Entity_Id) return Boolean is | |
324 | begin | |
325 | return Entity (N) = P | |
326 | or else | |
327 | (Present (Renamed_Object (P)) | |
328 | and then Entity (N) = Renamed_Object (P)); | |
329 | end Same_Unit; | |
330 | ||
331 | -- Start of processing for Process_Body_Clauses | |
332 | ||
9a504e32 | 333 | begin |
334 | Used := False; | |
335 | Used_Type_Or_Elab := False; | |
336 | ||
337 | Cont_Item := First (Context_List); | |
338 | while Present (Cont_Item) loop | |
339 | ||
340 | -- Package use clause | |
341 | ||
342 | if Nkind (Cont_Item) = N_Use_Package_Clause | |
343 | and then not Used | |
344 | then | |
e17ff23f | 345 | -- Search through use clauses |
346 | ||
9a504e32 | 347 | Use_Item := First (Names (Cont_Item)); |
348 | while Present (Use_Item) and then not Used loop | |
e17ff23f | 349 | |
350 | -- Case of a direct use of the one we are looking for | |
351 | ||
9a504e32 | 352 | if Entity (Use_Item) = Nam_Ent then |
353 | Used := True; | |
e17ff23f | 354 | |
355 | -- Handle nested case, as in "with P; use P.Q.R" | |
356 | ||
357 | else | |
358 | declare | |
359 | UE : Node_Id; | |
360 | ||
361 | begin | |
362 | -- Loop through prefixes looking for match | |
363 | ||
364 | UE := Use_Item; | |
365 | while Nkind (UE) = N_Expanded_Name loop | |
58655148 | 366 | if Same_Unit (Prefix (UE), Nam_Ent) then |
e17ff23f | 367 | Used := True; |
368 | exit; | |
369 | end if; | |
370 | ||
371 | UE := Prefix (UE); | |
372 | end loop; | |
373 | end; | |
9a504e32 | 374 | end if; |
375 | ||
376 | Next (Use_Item); | |
377 | end loop; | |
378 | ||
f49f70c6 | 379 | -- USE TYPE clause |
9a504e32 | 380 | |
381 | elsif Nkind (Cont_Item) = N_Use_Type_Clause | |
382 | and then not Used_Type_Or_Elab | |
383 | then | |
384 | Subt_Mark := First (Subtype_Marks (Cont_Item)); | |
385 | while Present (Subt_Mark) | |
386 | and then not Used_Type_Or_Elab | |
387 | loop | |
58655148 | 388 | if Same_Unit (Prefix (Subt_Mark), Nam_Ent) then |
9a504e32 | 389 | Used_Type_Or_Elab := True; |
390 | end if; | |
391 | ||
392 | Next (Subt_Mark); | |
393 | end loop; | |
394 | ||
395 | -- Pragma Elaborate or Elaborate_All | |
396 | ||
397 | elsif Nkind (Cont_Item) = N_Pragma | |
398 | and then | |
f2e9c237 | 399 | (Pragma_Name (Cont_Item) = Name_Elaborate |
9a504e32 | 400 | or else |
f2e9c237 | 401 | Pragma_Name (Cont_Item) = Name_Elaborate_All) |
9a504e32 | 402 | and then not Used_Type_Or_Elab |
403 | then | |
404 | Prag_Unit := | |
405 | First (Pragma_Argument_Associations (Cont_Item)); | |
406 | while Present (Prag_Unit) | |
407 | and then not Used_Type_Or_Elab | |
408 | loop | |
409 | if Entity (Expression (Prag_Unit)) = Nam_Ent then | |
410 | Used_Type_Or_Elab := True; | |
411 | end if; | |
412 | ||
413 | Next (Prag_Unit); | |
414 | end loop; | |
415 | end if; | |
416 | ||
417 | Next (Cont_Item); | |
418 | end loop; | |
419 | end Process_Body_Clauses; | |
420 | ||
421 | -------------------------- | |
422 | -- Process_Spec_Clauses -- | |
423 | -------------------------- | |
424 | ||
425 | procedure Process_Spec_Clauses | |
426 | (Context_List : List_Id; | |
427 | Clause : Node_Id; | |
428 | Used : in out Boolean; | |
429 | Withed : in out Boolean; | |
430 | Exit_On_Self : Boolean := False) | |
431 | is | |
432 | Nam_Ent : constant Entity_Id := Entity (Name (Clause)); | |
433 | Cont_Item : Node_Id; | |
434 | Use_Item : Node_Id; | |
435 | ||
436 | begin | |
437 | Used := False; | |
438 | Withed := False; | |
439 | ||
440 | Cont_Item := First (Context_List); | |
441 | while Present (Cont_Item) loop | |
442 | ||
39a79c9e | 443 | -- Stop the search since the context items after Cont_Item have |
444 | -- already been examined in a previous iteration of the reverse | |
445 | -- loop in Check_Redundant_Withs. | |
9a504e32 | 446 | |
447 | if Exit_On_Self | |
448 | and Cont_Item = Clause | |
449 | then | |
450 | exit; | |
451 | end if; | |
452 | ||
453 | -- Package use clause | |
454 | ||
455 | if Nkind (Cont_Item) = N_Use_Package_Clause | |
456 | and then not Used | |
457 | then | |
458 | Use_Item := First (Names (Cont_Item)); | |
459 | while Present (Use_Item) and then not Used loop | |
460 | if Entity (Use_Item) = Nam_Ent then | |
461 | Used := True; | |
462 | end if; | |
463 | ||
464 | Next (Use_Item); | |
465 | end loop; | |
466 | ||
467 | -- Package with clause. Avoid processing self, implicitly | |
39a79c9e | 468 | -- generated with clauses or limited with clauses. Note that |
469 | -- we examine with clauses having pragmas Elaborate or | |
470 | -- Elaborate_All applied to them due to cases such as: | |
9a504e32 | 471 | -- |
39a79c9e | 472 | |
9a504e32 | 473 | -- with Pack; |
474 | -- with Pack; | |
475 | -- pragma Elaborate (Pack); | |
476 | -- | |
477 | -- In this case, the second with clause is redundant since | |
478 | -- the pragma applies only to the first "with Pack;". | |
479 | ||
480 | elsif Nkind (Cont_Item) = N_With_Clause | |
481 | and then not Implicit_With (Cont_Item) | |
482 | and then not Limited_Present (Cont_Item) | |
483 | and then Cont_Item /= Clause | |
484 | and then Entity (Name (Cont_Item)) = Nam_Ent | |
485 | then | |
486 | Withed := True; | |
487 | end if; | |
488 | ||
489 | Next (Cont_Item); | |
490 | end loop; | |
491 | end Process_Spec_Clauses; | |
492 | ||
493 | -- Start of processing for Check_Redundant_Withs | |
494 | ||
495 | begin | |
496 | Clause := Last (Context_Items); | |
497 | while Present (Clause) loop | |
498 | ||
39a79c9e | 499 | -- Avoid checking implicitly generated with clauses, limited with |
500 | -- clauses or withs that have pragma Elaborate or Elaborate_All. | |
9a504e32 | 501 | |
502 | if Nkind (Clause) = N_With_Clause | |
503 | and then not Implicit_With (Clause) | |
504 | and then not Limited_Present (Clause) | |
505 | and then not Elaborate_Present (Clause) | |
506 | then | |
507 | -- Package body-to-spec check | |
508 | ||
509 | if Present (Spec_Context_Items) then | |
510 | declare | |
511 | Used_In_Body : Boolean := False; | |
512 | Used_In_Spec : Boolean := False; | |
513 | Used_Type_Or_Elab : Boolean := False; | |
514 | Withed_In_Spec : Boolean := False; | |
515 | ||
516 | begin | |
517 | Process_Spec_Clauses | |
518 | (Context_List => Spec_Context_Items, | |
519 | Clause => Clause, | |
520 | Used => Used_In_Spec, | |
521 | Withed => Withed_In_Spec); | |
522 | ||
523 | Process_Body_Clauses | |
524 | (Context_List => Context_Items, | |
525 | Clause => Clause, | |
526 | Used => Used_In_Body, | |
527 | Used_Type_Or_Elab => Used_Type_Or_Elab); | |
528 | ||
529 | -- "Type Elab" refers to the presence of either a use | |
530 | -- type clause, pragmas Elaborate or Elaborate_All. | |
531 | ||
532 | -- +---------------+---------------------------+------+ | |
533 | -- | Spec | Body | Warn | | |
534 | -- +--------+------+--------+------+-----------+------+ | |
535 | -- | Withed | Used | Withed | Used | Type Elab | | | |
536 | -- | X | | X | | | X | | |
537 | -- | X | | X | X | | | | |
538 | -- | X | | X | | X | | | |
539 | -- | X | | X | X | X | | | |
540 | -- | X | X | X | | | X | | |
541 | -- | X | X | X | | X | | | |
542 | -- | X | X | X | X | | X | | |
543 | -- | X | X | X | X | X | | | |
544 | -- +--------+------+--------+------+-----------+------+ | |
545 | ||
546 | if (Withed_In_Spec | |
547 | and then not Used_Type_Or_Elab) | |
548 | and then | |
549 | ((not Used_In_Spec | |
550 | and then not Used_In_Body) | |
551 | or else | |
552 | Used_In_Spec) | |
553 | then | |
79d59c5e | 554 | Error_Msg_N -- CODEFIX |
555 | ("?redundant with clause in body", Clause); | |
9a504e32 | 556 | end if; |
557 | ||
558 | Used_In_Body := False; | |
559 | Used_In_Spec := False; | |
560 | Used_Type_Or_Elab := False; | |
561 | Withed_In_Spec := False; | |
562 | end; | |
563 | ||
564 | -- Standalone package spec or body check | |
565 | ||
566 | else | |
567 | declare | |
568 | Dont_Care : Boolean := False; | |
569 | Withed : Boolean := False; | |
570 | ||
571 | begin | |
572 | -- The mechanism for examining the context clauses of a | |
573 | -- package spec can be applied to package body clauses. | |
574 | ||
575 | Process_Spec_Clauses | |
576 | (Context_List => Context_Items, | |
577 | Clause => Clause, | |
578 | Used => Dont_Care, | |
579 | Withed => Withed, | |
580 | Exit_On_Self => True); | |
581 | ||
582 | if Withed then | |
79d59c5e | 583 | Error_Msg_N -- CODEFIX |
584 | ("?redundant with clause", Clause); | |
9a504e32 | 585 | end if; |
586 | end; | |
587 | end if; | |
588 | end if; | |
589 | ||
590 | Prev (Clause); | |
591 | end loop; | |
592 | end Check_Redundant_Withs; | |
593 | ||
d6f39728 | 594 | -------------------------------- |
595 | -- Generate_Parent_References -- | |
596 | -------------------------------- | |
597 | ||
598 | procedure Generate_Parent_References (N : Node_Id; P_Id : Entity_Id) is | |
599 | Pref : Node_Id; | |
600 | P_Name : Entity_Id := P_Id; | |
601 | ||
602 | begin | |
7cb0fd86 | 603 | Pref := Name (Parent (Defining_Entity (N))); |
d6f39728 | 604 | |
605 | if Nkind (Pref) = N_Expanded_Name then | |
606 | ||
607 | -- Done already, if the unit has been compiled indirectly as | |
608 | -- part of the closure of its context because of inlining. | |
609 | ||
610 | return; | |
611 | end if; | |
612 | ||
613 | while Nkind (Pref) = N_Selected_Component loop | |
614 | Change_Selected_Component_To_Expanded_Name (Pref); | |
615 | Set_Entity (Pref, P_Name); | |
616 | Set_Etype (Pref, Etype (P_Name)); | |
617 | Generate_Reference (P_Name, Pref, 'r'); | |
618 | Pref := Prefix (Pref); | |
619 | P_Name := Scope (P_Name); | |
620 | end loop; | |
621 | ||
622 | -- The guard here on P_Name is to handle the error condition where | |
623 | -- the parent unit is missing because the file was not found. | |
624 | ||
625 | if Present (P_Name) then | |
626 | Set_Entity (Pref, P_Name); | |
627 | Set_Etype (Pref, Etype (P_Name)); | |
628 | Generate_Reference (P_Name, Pref, 'r'); | |
629 | Style.Check_Identifier (Pref, P_Name); | |
630 | end if; | |
631 | end Generate_Parent_References; | |
632 | ||
633 | -- Start of processing for Analyze_Compilation_Unit | |
634 | ||
635 | begin | |
636 | Process_Compilation_Unit_Pragmas (N); | |
637 | ||
638 | -- If the unit is a subunit whose parent has not been analyzed (which | |
639 | -- indicates that the main unit is a subunit, either the current one or | |
640 | -- one of its descendents) then the subunit is compiled as part of the | |
641 | -- analysis of the parent, which we proceed to do. Basically this gets | |
642 | -- handled from the top down and we don't want to do anything at this | |
643 | -- level (i.e. this subunit will be handled on the way down from the | |
39a79c9e | 644 | -- parent), so at this level we immediately return. If the subunit ends |
645 | -- up not analyzed, it means that the parent did not contain a stub for | |
646 | -- it, or that there errors were detected in some ancestor. | |
d6f39728 | 647 | |
648 | if Nkind (Unit_Node) = N_Subunit | |
649 | and then not Analyzed (Lib_Unit) | |
650 | then | |
651 | Semantics (Lib_Unit); | |
652 | ||
653 | if not Analyzed (Proper_Body (Unit_Node)) then | |
f15731c4 | 654 | if Serious_Errors_Detected > 0 then |
d6f39728 | 655 | Error_Msg_N ("subunit not analyzed (errors in parent unit)", N); |
656 | else | |
657 | Error_Msg_N ("missing stub for subunit", N); | |
658 | end if; | |
659 | end if; | |
660 | ||
661 | return; | |
662 | end if; | |
663 | ||
39a79c9e | 664 | -- Analyze context (this will call Sem recursively for with'ed units) To |
665 | -- detect circularities among with-clauses that are not caught during | |
a67a63e2 | 666 | -- loading, we set the Context_Pending flag on the current unit. If the |
39a79c9e | 667 | -- flag is already set there is a potential circularity. We exclude |
668 | -- predefined units from this check because they are known to be safe. | |
669 | -- We also exclude package bodies that are present because circularities | |
670 | -- between bodies are harmless (and necessary). | |
a67a63e2 | 671 | |
672 | if Context_Pending (N) then | |
673 | declare | |
674 | Circularity : Boolean := True; | |
675 | ||
676 | begin | |
677 | if Is_Predefined_File_Name | |
678 | (Unit_File_Name (Get_Source_Unit (Unit (N)))) | |
679 | then | |
680 | Circularity := False; | |
681 | ||
682 | else | |
683 | for U in Main_Unit + 1 .. Last_Unit loop | |
684 | if Nkind (Unit (Cunit (U))) = N_Package_Body | |
685 | and then not Analyzed (Cunit (U)) | |
686 | then | |
687 | Circularity := False; | |
688 | exit; | |
689 | end if; | |
690 | end loop; | |
691 | end if; | |
692 | ||
693 | if Circularity then | |
503f7fd3 | 694 | Error_Msg_N ("circular dependency caused by with_clauses", N); |
695 | Error_Msg_N | |
a67a63e2 | 696 | ("\possibly missing limited_with clause" |
697 | & " in one of the following", N); | |
698 | ||
699 | for U in Main_Unit .. Last_Unit loop | |
700 | if Context_Pending (Cunit (U)) then | |
701 | Error_Msg_Unit_1 := Get_Unit_Name (Unit (Cunit (U))); | |
702 | Error_Msg_N ("\unit$", N); | |
703 | end if; | |
704 | end loop; | |
705 | ||
706 | raise Unrecoverable_Error; | |
707 | end if; | |
708 | end; | |
709 | else | |
710 | Set_Context_Pending (N); | |
711 | end if; | |
d6f39728 | 712 | |
713 | Analyze_Context (N); | |
714 | ||
a67a63e2 | 715 | Set_Context_Pending (N, False); |
716 | ||
88fcd057 | 717 | -- If the unit is a package body, the spec is already loaded and must be |
718 | -- analyzed first, before we analyze the body. | |
d6f39728 | 719 | |
720 | if Nkind (Unit_Node) = N_Package_Body then | |
721 | ||
88fcd057 | 722 | -- If no Lib_Unit, then there was a serious previous error, so just |
723 | -- ignore the entire analysis effort | |
d6f39728 | 724 | |
725 | if No (Lib_Unit) then | |
726 | return; | |
727 | ||
728 | else | |
729 | Semantics (Lib_Unit); | |
730 | Check_Unused_Withs (Get_Cunit_Unit_Number (Lib_Unit)); | |
731 | ||
2866d595 | 732 | -- Verify that the library unit is a package declaration |
d6f39728 | 733 | |
899ae34b | 734 | if not Nkind_In (Unit (Lib_Unit), N_Package_Declaration, |
735 | N_Generic_Package_Declaration) | |
d6f39728 | 736 | then |
737 | Error_Msg_N | |
738 | ("no legal package declaration for package body", N); | |
739 | return; | |
740 | ||
88fcd057 | 741 | -- Otherwise, the entity in the declaration is visible. Update the |
742 | -- version to reflect dependence of this body on the spec. | |
d6f39728 | 743 | |
744 | else | |
745 | Spec_Id := Defining_Entity (Unit (Lib_Unit)); | |
746 | Set_Is_Immediately_Visible (Spec_Id, True); | |
747 | Version_Update (N, Lib_Unit); | |
748 | ||
899ae34b | 749 | if Nkind (Defining_Unit_Name (Unit_Node)) = |
750 | N_Defining_Program_Unit_Name | |
d6f39728 | 751 | then |
752 | Generate_Parent_References (Unit_Node, Scope (Spec_Id)); | |
753 | end if; | |
754 | end if; | |
755 | end if; | |
756 | ||
757 | -- If the unit is a subprogram body, then we similarly need to analyze | |
758 | -- its spec. However, things are a little simpler in this case, because | |
759 | -- here, this analysis is done only for error checking and consistency | |
760 | -- purposes, so there's nothing else to be done. | |
761 | ||
762 | elsif Nkind (Unit_Node) = N_Subprogram_Body then | |
763 | if Acts_As_Spec (N) then | |
764 | ||
765 | -- If the subprogram body is a child unit, we must create a | |
766 | -- declaration for it, in order to properly load the parent(s). | |
767 | -- After this, the original unit does not acts as a spec, because | |
7cb0fd86 | 768 | -- there is an explicit one. If this unit appears in a context |
d6f39728 | 769 | -- clause, then an implicit with on the parent will be added when |
770 | -- installing the context. If this is the main unit, there is no | |
7cb0fd86 | 771 | -- Unit_Table entry for the declaration (it has the unit number |
d6f39728 | 772 | -- of the main unit) and code generation is unaffected. |
773 | ||
774 | Unum := Get_Cunit_Unit_Number (N); | |
775 | Par_Spec_Name := Get_Parent_Spec_Name (Unit_Name (Unum)); | |
776 | ||
f49f70c6 | 777 | if Par_Spec_Name /= No_Unit_Name then |
d6f39728 | 778 | Unum := |
779 | Load_Unit | |
780 | (Load_Name => Par_Spec_Name, | |
781 | Required => True, | |
782 | Subunit => False, | |
783 | Error_Node => N); | |
784 | ||
785 | if Unum /= No_Unit then | |
786 | ||
787 | -- Build subprogram declaration and attach parent unit to it | |
2d204d4b | 788 | -- This subprogram declaration does not come from source, |
789 | -- Nevertheless the backend must generate debugging info for | |
7cb0fd86 | 790 | -- it, and this must be indicated explicitly. We also mark |
791 | -- the body entity as a child unit now, to prevent a | |
792 | -- cascaded error if the spec entity cannot be entered | |
db317bdb | 793 | -- in its scope. Finally we create a Units table entry for |
794 | -- the subprogram declaration, to maintain a one-to-one | |
795 | -- correspondence with compilation unit nodes. This is | |
cf563f22 | 796 | -- critical for the tree traversals performed by CodePeer. |
d6f39728 | 797 | |
798 | declare | |
799 | Loc : constant Source_Ptr := Sloc (N); | |
800 | SCS : constant Boolean := | |
801 | Get_Comes_From_Source_Default; | |
802 | ||
803 | begin | |
804 | Set_Comes_From_Source_Default (False); | |
805 | Lib_Unit := | |
806 | Make_Compilation_Unit (Loc, | |
807 | Context_Items => New_Copy_List (Context_Items (N)), | |
808 | Unit => | |
809 | Make_Subprogram_Declaration (Sloc (N), | |
810 | Specification => | |
811 | Copy_Separate_Tree | |
812 | (Specification (Unit_Node))), | |
813 | Aux_Decls_Node => | |
814 | Make_Compilation_Unit_Aux (Loc)); | |
815 | ||
816 | Set_Library_Unit (N, Lib_Unit); | |
817 | Set_Parent_Spec (Unit (Lib_Unit), Cunit (Unum)); | |
db317bdb | 818 | Make_Child_Decl_Unit (N); |
d6f39728 | 819 | Semantics (Lib_Unit); |
7cb0fd86 | 820 | |
821 | -- Now that a separate declaration exists, the body | |
822 | -- of the child unit does not act as spec any longer. | |
823 | ||
d6f39728 | 824 | Set_Acts_As_Spec (N, False); |
7cb0fd86 | 825 | Set_Is_Child_Unit (Defining_Entity (Unit_Node)); |
f2e9c237 | 826 | Set_Debug_Info_Needed (Defining_Entity (Unit (Lib_Unit))); |
d6f39728 | 827 | Set_Comes_From_Source_Default (SCS); |
828 | end; | |
829 | end if; | |
830 | end if; | |
831 | ||
832 | -- Here for subprogram with separate declaration | |
833 | ||
834 | else | |
835 | Semantics (Lib_Unit); | |
836 | Check_Unused_Withs (Get_Cunit_Unit_Number (Lib_Unit)); | |
837 | Version_Update (N, Lib_Unit); | |
838 | end if; | |
839 | ||
442049cc | 840 | -- If this is a child unit, generate references to the parents |
1fc096b1 | 841 | |
d6f39728 | 842 | if Nkind (Defining_Unit_Name (Specification (Unit_Node))) = |
843 | N_Defining_Program_Unit_Name | |
844 | then | |
845 | Generate_Parent_References ( | |
846 | Specification (Unit_Node), | |
847 | Scope (Defining_Entity (Unit (Lib_Unit)))); | |
848 | end if; | |
849 | end if; | |
850 | ||
442049cc | 851 | -- If it is a child unit, the parent must be elaborated first and we |
852 | -- update version, since we are dependent on our parent. | |
d6f39728 | 853 | |
854 | if Is_Child_Spec (Unit_Node) then | |
855 | ||
856 | -- The analysis of the parent is done with style checks off | |
857 | ||
858 | declare | |
9dfe12ae | 859 | Save_Style_Check : constant Boolean := Style_Check; |
1e16c51c | 860 | Save_C_Restrict : constant Save_Cunit_Boolean_Restrictions := |
861 | Cunit_Boolean_Restrictions_Save; | |
d6f39728 | 862 | |
863 | begin | |
864 | if not GNAT_Mode then | |
865 | Style_Check := False; | |
866 | end if; | |
867 | ||
868 | Semantics (Parent_Spec (Unit_Node)); | |
869 | Version_Update (N, Parent_Spec (Unit_Node)); | |
870 | Style_Check := Save_Style_Check; | |
1e16c51c | 871 | Cunit_Boolean_Restrictions_Restore (Save_C_Restrict); |
d6f39728 | 872 | end; |
873 | end if; | |
874 | ||
875 | -- With the analysis done, install the context. Note that we can't | |
7cb0fd86 | 876 | -- install the context from the with clauses as we analyze them, because |
877 | -- each with clause must be analyzed in a clean visibility context, so | |
878 | -- we have to wait and install them all at once. | |
d6f39728 | 879 | |
880 | Install_Context (N); | |
881 | ||
882 | if Is_Child_Spec (Unit_Node) then | |
883 | ||
2866d595 | 884 | -- Set the entities of all parents in the program_unit_name |
d6f39728 | 885 | |
886 | Generate_Parent_References ( | |
f15731c4 | 887 | Unit_Node, Get_Parent_Entity (Unit (Parent_Spec (Unit_Node)))); |
d6f39728 | 888 | end if; |
889 | ||
890 | -- All components of the context: with-clauses, library unit, ancestors | |
f49f70c6 | 891 | -- if any, (and their context) are analyzed and installed. |
892 | ||
893 | -- Call special debug routine sm if this is the main unit | |
894 | ||
895 | if Current_Sem_Unit = Main_Unit then | |
896 | sm; | |
897 | end if; | |
898 | ||
899 | -- Now analyze the unit (package, subprogram spec, body) itself | |
d6f39728 | 900 | |
901 | Analyze (Unit_Node); | |
902 | ||
9a504e32 | 903 | if Warn_On_Redundant_Constructs then |
904 | Check_Redundant_Withs (Context_Items (N)); | |
905 | ||
906 | if Nkind (Unit_Node) = N_Package_Body then | |
907 | Check_Redundant_Withs | |
908 | (Context_Items => Context_Items (N), | |
909 | Spec_Context_Items => Context_Items (Lib_Unit)); | |
910 | end if; | |
911 | end if; | |
912 | ||
7cb0fd86 | 913 | -- The above call might have made Unit_Node an N_Subprogram_Body from |
914 | -- something else, so propagate any Acts_As_Spec flag. | |
d6f39728 | 915 | |
916 | if Nkind (Unit_Node) = N_Subprogram_Body | |
917 | and then Acts_As_Spec (Unit_Node) | |
918 | then | |
919 | Set_Acts_As_Spec (N); | |
920 | end if; | |
921 | ||
c54e9270 | 922 | -- Register predefined units in Rtsfind |
923 | ||
924 | declare | |
925 | Unum : constant Unit_Number_Type := Get_Source_Unit (Sloc (N)); | |
926 | begin | |
927 | if Is_Predefined_File_Name (Unit_File_Name (Unum)) then | |
928 | Set_RTU_Loaded (Unit_Node); | |
929 | end if; | |
930 | end; | |
931 | ||
d6f39728 | 932 | -- Treat compilation unit pragmas that appear after the library unit |
933 | ||
934 | if Present (Pragmas_After (Aux_Decls_Node (N))) then | |
935 | declare | |
936 | Prag_Node : Node_Id := First (Pragmas_After (Aux_Decls_Node (N))); | |
d6f39728 | 937 | begin |
938 | while Present (Prag_Node) loop | |
939 | Analyze (Prag_Node); | |
940 | Next (Prag_Node); | |
941 | end loop; | |
942 | end; | |
943 | end if; | |
944 | ||
e161d1a3 | 945 | -- Generate distribution stubs if requested and no error |
d6f39728 | 946 | |
947 | if N = Main_Cunit | |
948 | and then (Distribution_Stub_Mode = Generate_Receiver_Stub_Body | |
949 | or else | |
950 | Distribution_Stub_Mode = Generate_Caller_Stub_Body) | |
951 | and then not Fatal_Error (Main_Unit) | |
952 | then | |
953 | if Is_RCI_Pkg_Spec_Or_Body (N) then | |
954 | ||
955 | -- Regular RCI package | |
956 | ||
957 | Add_Stub_Constructs (N); | |
958 | ||
959 | elsif (Nkind (Unit_Node) = N_Package_Declaration | |
960 | and then Is_Shared_Passive (Defining_Entity | |
961 | (Specification (Unit_Node)))) | |
962 | or else (Nkind (Unit_Node) = N_Package_Body | |
963 | and then | |
964 | Is_Shared_Passive (Corresponding_Spec (Unit_Node))) | |
965 | then | |
966 | -- Shared passive package | |
967 | ||
968 | Add_Stub_Constructs (N); | |
969 | ||
970 | elsif Nkind (Unit_Node) = N_Package_Instantiation | |
971 | and then | |
972 | Is_Remote_Call_Interface | |
973 | (Defining_Entity (Specification (Instance_Spec (Unit_Node)))) | |
974 | then | |
975 | -- Instantiation of a RCI generic package | |
976 | ||
977 | Add_Stub_Constructs (N); | |
978 | end if; | |
d6f39728 | 979 | end if; |
980 | ||
39a79c9e | 981 | -- Remove unit from visibility, so that environment is clean for the |
982 | -- next compilation, which is either the main unit or some other unit | |
983 | -- in the context. | |
7cb0fd86 | 984 | |
899ae34b | 985 | if Nkind_In (Unit_Node, N_Package_Declaration, |
986 | N_Package_Renaming_Declaration, | |
987 | N_Subprogram_Declaration) | |
d6f39728 | 988 | or else Nkind (Unit_Node) in N_Generic_Declaration |
7cb0fd86 | 989 | or else |
990 | (Nkind (Unit_Node) = N_Subprogram_Body | |
991 | and then Acts_As_Spec (Unit_Node)) | |
d6f39728 | 992 | then |
993 | Remove_Unit_From_Visibility (Defining_Entity (Unit_Node)); | |
994 | ||
7cb0fd86 | 995 | -- If the unit is an instantiation whose body will be elaborated for |
39a79c9e | 996 | -- inlining purposes, use the proper entity of the instance. The entity |
997 | -- may be missing if the instantiation was illegal. | |
9dfe12ae | 998 | |
999 | elsif Nkind (Unit_Node) = N_Package_Instantiation | |
1000 | and then not Error_Posted (Unit_Node) | |
f49f70c6 | 1001 | and then Present (Instance_Spec (Unit_Node)) |
9dfe12ae | 1002 | then |
1003 | Remove_Unit_From_Visibility | |
1004 | (Defining_Entity (Instance_Spec (Unit_Node))); | |
1005 | ||
d6f39728 | 1006 | elsif Nkind (Unit_Node) = N_Package_Body |
1007 | or else (Nkind (Unit_Node) = N_Subprogram_Body | |
1008 | and then not Acts_As_Spec (Unit_Node)) | |
1009 | then | |
7cb0fd86 | 1010 | -- Bodies that are not the main unit are compiled if they are generic |
1011 | -- or contain generic or inlined units. Their analysis brings in the | |
1012 | -- context of the corresponding spec (unit declaration) which must be | |
1013 | -- removed as well, to return the compilation environment to its | |
1014 | -- proper state. | |
d6f39728 | 1015 | |
1016 | Remove_Context (Lib_Unit); | |
1017 | Set_Is_Immediately_Visible (Defining_Entity (Unit (Lib_Unit)), False); | |
1018 | end if; | |
1019 | ||
7cb0fd86 | 1020 | -- Last step is to deinstall the context we just installed as well as |
1021 | -- the unit just compiled. | |
d6f39728 | 1022 | |
1023 | Remove_Context (N); | |
1024 | ||
7cb0fd86 | 1025 | -- If this is the main unit and we are generating code, we must check |
1026 | -- that all generic units in the context have a body if they need it, | |
1027 | -- even if they have not been instantiated. In the absence of .ali files | |
1028 | -- for generic units, we must force the load of the body, just to | |
1029 | -- produce the proper error if the body is absent. We skip this | |
d6f39728 | 1030 | -- verification if the main unit itself is generic. |
1031 | ||
1032 | if Get_Cunit_Unit_Number (N) = Main_Unit | |
1033 | and then Operating_Mode = Generate_Code | |
1034 | and then Expander_Active | |
1035 | then | |
7cb0fd86 | 1036 | -- Check whether the source for the body of the unit must be included |
1037 | -- in a standalone library. | |
9dfe12ae | 1038 | |
1039 | Check_Body_Needed_For_SAL (Cunit_Entity (Main_Unit)); | |
1040 | ||
d6f39728 | 1041 | -- Indicate that the main unit is now analyzed, to catch possible |
7cb0fd86 | 1042 | -- circularities between it and generic bodies. Remove main unit from |
1043 | -- visibility. This might seem superfluous, but the main unit must | |
1044 | -- not be visible in the generic body expansions that follow. | |
d6f39728 | 1045 | |
1046 | Set_Analyzed (N, True); | |
1047 | Set_Is_Immediately_Visible (Cunit_Entity (Main_Unit), False); | |
1048 | ||
1049 | declare | |
1050 | Item : Node_Id; | |
1051 | Nam : Entity_Id; | |
1052 | Un : Unit_Number_Type; | |
1053 | ||
9dfe12ae | 1054 | Save_Style_Check : constant Boolean := Style_Check; |
1e16c51c | 1055 | Save_C_Restrict : constant Save_Cunit_Boolean_Restrictions := |
1056 | Cunit_Boolean_Restrictions_Save; | |
d6f39728 | 1057 | |
1058 | begin | |
1059 | Item := First (Context_Items (N)); | |
d6f39728 | 1060 | while Present (Item) loop |
a4740ca0 | 1061 | |
e17ff23f | 1062 | -- Check for explicit with clause |
a4740ca0 | 1063 | |
d6f39728 | 1064 | if Nkind (Item) = N_With_Clause |
e17ff23f | 1065 | and then not Implicit_With (Item) |
1066 | ||
1067 | -- Ada 2005 (AI-50217): Ignore limited-withed units | |
1068 | ||
1069 | and then not Limited_Present (Item) | |
d6f39728 | 1070 | then |
1071 | Nam := Entity (Name (Item)); | |
1072 | ||
f2e9c237 | 1073 | -- Compile generic subprogram, unless it is intrinsic or |
1074 | -- imported so no body is required, or generic package body | |
1075 | -- if the package spec requires a body. | |
1076 | ||
9dfe12ae | 1077 | if (Is_Generic_Subprogram (Nam) |
f2e9c237 | 1078 | and then not Is_Intrinsic_Subprogram (Nam) |
1079 | and then not Is_Imported (Nam)) | |
d6f39728 | 1080 | or else (Ekind (Nam) = E_Generic_Package |
1081 | and then Unit_Requires_Body (Nam)) | |
1082 | then | |
9dfe12ae | 1083 | Style_Check := False; |
d6f39728 | 1084 | |
1085 | if Present (Renamed_Object (Nam)) then | |
1086 | Un := | |
1087 | Load_Unit | |
1088 | (Load_Name => Get_Body_Name | |
1089 | (Get_Unit_Name | |
1090 | (Unit_Declaration_Node | |
1091 | (Renamed_Object (Nam)))), | |
1092 | Required => False, | |
1093 | Subunit => False, | |
1094 | Error_Node => N, | |
1095 | Renamings => True); | |
1096 | else | |
1097 | Un := | |
1098 | Load_Unit | |
1099 | (Load_Name => Get_Body_Name | |
1100 | (Get_Unit_Name (Item)), | |
1101 | Required => False, | |
1102 | Subunit => False, | |
1103 | Error_Node => N, | |
1104 | Renamings => True); | |
1105 | end if; | |
1106 | ||
1107 | if Un = No_Unit then | |
1108 | Error_Msg_NE | |
1109 | ("body of generic unit& not found", Item, Nam); | |
1110 | exit; | |
1111 | ||
1112 | elsif not Analyzed (Cunit (Un)) | |
1113 | and then Un /= Main_Unit | |
9dfe12ae | 1114 | and then not Fatal_Error (Un) |
d6f39728 | 1115 | then |
9dfe12ae | 1116 | Style_Check := False; |
d6f39728 | 1117 | Semantics (Cunit (Un)); |
1118 | end if; | |
1119 | end if; | |
1120 | end if; | |
1121 | ||
1122 | Next (Item); | |
1123 | end loop; | |
1124 | ||
1125 | Style_Check := Save_Style_Check; | |
1e16c51c | 1126 | Cunit_Boolean_Restrictions_Restore (Save_C_Restrict); |
d6f39728 | 1127 | end; |
1128 | end if; | |
1129 | ||
1130 | -- Deal with creating elaboration Boolean if needed. We create an | |
1131 | -- elaboration boolean only for units that come from source since | |
1132 | -- units manufactured by the compiler never need elab checks. | |
1133 | ||
1134 | if Comes_From_Source (N) | |
899ae34b | 1135 | and then Nkind_In (Unit_Node, N_Package_Declaration, |
1136 | N_Generic_Package_Declaration, | |
1137 | N_Subprogram_Declaration, | |
1138 | N_Generic_Subprogram_Declaration) | |
d6f39728 | 1139 | then |
1140 | declare | |
899ae34b | 1141 | Loc : constant Source_Ptr := Sloc (N); |
d6f39728 | 1142 | Unum : constant Unit_Number_Type := Get_Source_Unit (Loc); |
1143 | ||
1144 | begin | |
7cb0fd86 | 1145 | Spec_Id := Defining_Entity (Unit_Node); |
d6f39728 | 1146 | Generate_Definition (Spec_Id); |
1147 | ||
7cb0fd86 | 1148 | -- See if an elaboration entity is required for possible access |
1149 | -- before elaboration checking. Note that we must allow for this | |
1150 | -- even if -gnatE is not set, since a client may be compiled in | |
1151 | -- -gnatE mode and reference the entity. | |
d6f39728 | 1152 | |
f49f70c6 | 1153 | -- These entities are also used by the binder to prevent multiple |
1154 | -- attempts to execute the elaboration code for the library case | |
1155 | -- where the elaboration routine might otherwise be called more | |
1156 | -- than once. | |
1157 | ||
d6f39728 | 1158 | -- Case of units which do not require elaboration checks |
1159 | ||
1160 | if | |
88fcd057 | 1161 | -- Pure units do not need checks |
d6f39728 | 1162 | |
88fcd057 | 1163 | Is_Pure (Spec_Id) |
d6f39728 | 1164 | |
88fcd057 | 1165 | -- Preelaborated units do not need checks |
d6f39728 | 1166 | |
88fcd057 | 1167 | or else Is_Preelaborated (Spec_Id) |
d6f39728 | 1168 | |
88fcd057 | 1169 | -- No checks needed if pragma Elaborate_Body present |
d6f39728 | 1170 | |
88fcd057 | 1171 | or else Has_Pragma_Elaborate_Body (Spec_Id) |
d6f39728 | 1172 | |
88fcd057 | 1173 | -- No checks needed if unit does not require a body |
d6f39728 | 1174 | |
88fcd057 | 1175 | or else not Unit_Requires_Body (Spec_Id) |
d6f39728 | 1176 | |
88fcd057 | 1177 | -- No checks needed for predefined files |
d6f39728 | 1178 | |
88fcd057 | 1179 | or else Is_Predefined_File_Name (Unit_File_Name (Unum)) |
d6f39728 | 1180 | |
88fcd057 | 1181 | -- No checks required if no separate spec |
d6f39728 | 1182 | |
88fcd057 | 1183 | or else Acts_As_Spec (N) |
d6f39728 | 1184 | then |
1185 | -- This is a case where we only need the entity for | |
1186 | -- checking to prevent multiple elaboration checks. | |
1187 | ||
1188 | Set_Elaboration_Entity_Required (Spec_Id, False); | |
1189 | ||
1190 | -- Case of elaboration entity is required for access before | |
1191 | -- elaboration checking (so certainly we must build it!) | |
1192 | ||
1193 | else | |
1194 | Set_Elaboration_Entity_Required (Spec_Id, True); | |
1195 | end if; | |
1196 | ||
1197 | Build_Elaboration_Entity (N, Spec_Id); | |
1198 | end; | |
1199 | end if; | |
1200 | ||
e17ff23f | 1201 | -- Freeze the compilation unit entity. This for sure is needed because |
1202 | -- of some warnings that can be output (see Freeze_Subprogram), but may | |
1203 | -- in general be required. If freezing actions result, place them in the | |
1204 | -- compilation unit actions list, and analyze them. | |
d6f39728 | 1205 | |
1206 | declare | |
1207 | Loc : constant Source_Ptr := Sloc (N); | |
1208 | L : constant List_Id := | |
1209 | Freeze_Entity (Cunit_Entity (Current_Sem_Unit), Loc); | |
d6f39728 | 1210 | begin |
1211 | while Is_Non_Empty_List (L) loop | |
1212 | Insert_Library_Level_Action (Remove_Head (L)); | |
1213 | end loop; | |
1214 | end; | |
1215 | ||
1216 | Set_Analyzed (N); | |
1217 | ||
1218 | if Nkind (Unit_Node) = N_Package_Declaration | |
1219 | and then Get_Cunit_Unit_Number (N) /= Main_Unit | |
d6f39728 | 1220 | and then Expander_Active |
1221 | then | |
9dfe12ae | 1222 | declare |
1223 | Save_Style_Check : constant Boolean := Style_Check; | |
1224 | Save_Warning : constant Warning_Mode_Type := Warning_Mode; | |
35c57fc7 | 1225 | Options : Style_Check_Options; |
9dfe12ae | 1226 | |
1227 | begin | |
1228 | Save_Style_Check_Options (Options); | |
1229 | Reset_Style_Check_Options; | |
1230 | Opt.Warning_Mode := Suppress; | |
1231 | Check_Body_For_Inlining (N, Defining_Entity (Unit_Node)); | |
1232 | ||
1233 | Reset_Style_Check_Options; | |
1234 | Set_Style_Check_Options (Options); | |
1235 | Style_Check := Save_Style_Check; | |
1236 | Warning_Mode := Save_Warning; | |
1237 | end; | |
d6f39728 | 1238 | end if; |
e17ff23f | 1239 | |
1240 | -- If we are generating obsolescent warnings, then here is where we | |
1241 | -- generate them for the with'ed items. The reason for this special | |
1242 | -- processing is that the normal mechanism of generating the warnings | |
1243 | -- for referenced entities does not work for context clause references. | |
1244 | -- That's because when we first analyze the context, it is too early to | |
1245 | -- know if the with'ing unit is itself obsolescent (which suppresses | |
1246 | -- the warnings). | |
1247 | ||
1248 | if not GNAT_Mode and then Warn_On_Obsolescent_Feature then | |
1249 | ||
1250 | -- Push current compilation unit as scope, so that the test for | |
1251 | -- being within an obsolescent unit will work correctly. | |
1252 | ||
7cb0fd86 | 1253 | Push_Scope (Defining_Entity (Unit_Node)); |
e17ff23f | 1254 | |
1255 | -- Loop through context items to deal with with clauses | |
1256 | ||
1257 | declare | |
1258 | Item : Node_Id; | |
1259 | Nam : Node_Id; | |
1260 | Ent : Entity_Id; | |
1261 | ||
1262 | begin | |
1263 | Item := First (Context_Items (N)); | |
1264 | while Present (Item) loop | |
f49f70c6 | 1265 | if Nkind (Item) = N_With_Clause |
1266 | ||
1267 | -- Suppress this check in limited-withed units. Further work | |
1268 | -- needed here if we decide to incorporate this check on | |
1269 | -- limited-withed units. | |
1270 | ||
1271 | and then not Limited_Present (Item) | |
1272 | then | |
e17ff23f | 1273 | Nam := Name (Item); |
1274 | Ent := Entity (Nam); | |
1275 | ||
1276 | if Is_Obsolescent (Ent) then | |
1277 | Output_Obsolescent_Entity_Warnings (Nam, Ent); | |
1278 | end if; | |
1279 | end if; | |
1280 | ||
1281 | Next (Item); | |
1282 | end loop; | |
1283 | end; | |
1284 | ||
1285 | -- Remove temporary install of current unit as scope | |
1286 | ||
1287 | Pop_Scope; | |
1288 | end if; | |
d6f39728 | 1289 | end Analyze_Compilation_Unit; |
1290 | ||
1291 | --------------------- | |
1292 | -- Analyze_Context -- | |
1293 | --------------------- | |
1294 | ||
1295 | procedure Analyze_Context (N : Node_Id) is | |
b5be70cd | 1296 | Ukind : constant Node_Kind := Nkind (Unit (N)); |
d6f39728 | 1297 | Item : Node_Id; |
1298 | ||
1299 | begin | |
9a504e32 | 1300 | -- First process all configuration pragmas at the start of the context |
1301 | -- items. Strictly these are not part of the context clause, but that | |
1302 | -- is where the parser puts them. In any case for sure we must analyze | |
1303 | -- these before analyzing the actual context items, since they can have | |
1304 | -- an effect on that analysis (e.g. pragma Ada_2005 may allow a unit to | |
1305 | -- be with'ed as a result of changing categorizations in Ada 2005). | |
d6f39728 | 1306 | |
1307 | Item := First (Context_Items (N)); | |
9a504e32 | 1308 | while Present (Item) |
1309 | and then Nkind (Item) = N_Pragma | |
f2e9c237 | 1310 | and then Pragma_Name (Item) in Configuration_Pragma_Names |
9a504e32 | 1311 | loop |
1312 | Analyze (Item); | |
1313 | Next (Item); | |
1314 | end loop; | |
1315 | ||
3a2db8ab | 1316 | -- This is the point at which we capture the configuration settings |
1317 | -- for the unit. At the moment only the Optimize_Alignment setting | |
1318 | -- needs to be captured. Probably more later ??? | |
1319 | ||
1320 | if Optimize_Alignment_Local then | |
1321 | Set_OA_Setting (Current_Sem_Unit, 'L'); | |
1322 | else | |
1323 | Set_OA_Setting (Current_Sem_Unit, Optimize_Alignment); | |
1324 | end if; | |
1325 | ||
9a504e32 | 1326 | -- Loop through actual context items. This is done in two passes: |
1327 | ||
1328 | -- a) The first pass analyzes non-limited with-clauses and also any | |
1329 | -- configuration pragmas (we need to get the latter analyzed right | |
1330 | -- away, since they can affect processing of subsequent items. | |
1331 | ||
1332 | -- b) The second pass analyzes limited_with clauses (Ada 2005: AI-50217) | |
1333 | ||
d6f39728 | 1334 | while Present (Item) loop |
1335 | ||
88fcd057 | 1336 | -- For with clause, analyze the with clause, and then update the |
1337 | -- version, since we are dependent on a unit that we with. | |
d6f39728 | 1338 | |
05e5286d | 1339 | if Nkind (Item) = N_With_Clause |
1340 | and then not Limited_Present (Item) | |
1341 | then | |
d6f39728 | 1342 | -- Skip analyzing with clause if no unit, nothing to do (this |
88fcd057 | 1343 | -- happens for a with that references a non-existent unit). Skip |
1344 | -- as well if this is a with_clause for the main unit, which | |
234aa17e | 1345 | -- happens if a subunit has a useless with_clause on its parent. |
d6f39728 | 1346 | |
1347 | if Present (Library_Unit (Item)) then | |
234aa17e | 1348 | if Library_Unit (Item) /= Cunit (Current_Sem_Unit) then |
1349 | Analyze (Item); | |
1350 | ||
1351 | else | |
1352 | Set_Entity (Name (Item), Cunit_Entity (Current_Sem_Unit)); | |
1353 | end if; | |
d6f39728 | 1354 | end if; |
1355 | ||
1356 | if not Implicit_With (Item) then | |
1357 | Version_Update (N, Library_Unit (Item)); | |
1358 | end if; | |
1359 | ||
9a504e32 | 1360 | -- Skip pragmas. Configuration pragmas at the start were handled in |
1361 | -- the loop above, and remaining pragmas are not processed until we | |
1362 | -- actually install the context (see Install_Context). We delay the | |
1363 | -- analysis of these pragmas to make sure that we have installed all | |
1364 | -- the implicit with's on parent units. | |
1365 | ||
1366 | -- Skip use clauses at this stage, since we don't want to do any | |
d82baf7f | 1367 | -- installing of potentially use-visible entities until we |
9a504e32 | 1368 | -- actually install the complete context (in Install_Context). |
d6f39728 | 1369 | -- Otherwise things can get installed in the wrong context. |
d6f39728 | 1370 | |
1371 | else | |
1372 | null; | |
1373 | end if; | |
1374 | ||
1375 | Next (Item); | |
1376 | end loop; | |
9dfe12ae | 1377 | |
9a504e32 | 1378 | -- Second pass: examine all limited_with clauses. All other context |
1379 | -- items are ignored in this pass. | |
9dfe12ae | 1380 | |
1381 | Item := First (Context_Items (N)); | |
9dfe12ae | 1382 | while Present (Item) loop |
1383 | if Nkind (Item) = N_With_Clause | |
1384 | and then Limited_Present (Item) | |
9dfe12ae | 1385 | then |
c53c8335 | 1386 | -- No need to check errors on implicitly generated limited-with |
1387 | -- clauses. | |
9dfe12ae | 1388 | |
c53c8335 | 1389 | if not Implicit_With (Item) then |
9dfe12ae | 1390 | |
88fcd057 | 1391 | -- Verify that the illegal contexts given in 10.1.2 (18/2) are |
1392 | -- properly rejected, including renaming declarations. | |
c53c8335 | 1393 | |
899ae34b | 1394 | if not Nkind_In (Ukind, N_Package_Declaration, |
3a2db8ab | 1395 | N_Subprogram_Declaration) |
9c3beb70 | 1396 | and then Ukind not in N_Generic_Declaration |
9c3beb70 | 1397 | and then Ukind not in N_Generic_Instantiation |
c53c8335 | 1398 | then |
1399 | Error_Msg_N ("limited with_clause not allowed here", Item); | |
9dfe12ae | 1400 | |
c53c8335 | 1401 | -- Check wrong use of a limited with clause applied to the |
1402 | -- compilation unit containing the limited-with clause. | |
9dfe12ae | 1403 | |
c53c8335 | 1404 | -- limited with P.Q; |
1405 | -- package P.Q is ... | |
1406 | ||
1407 | elsif Unit (Library_Unit (Item)) = Unit (N) then | |
1408 | Error_Msg_N ("wrong use of limited-with clause", Item); | |
1409 | ||
1410 | -- Check wrong use of limited-with clause applied to some | |
1411 | -- immediate ancestor. | |
1412 | ||
1413 | elsif Is_Child_Spec (Unit (N)) then | |
1414 | declare | |
1415 | Lib_U : constant Entity_Id := Unit (Library_Unit (Item)); | |
1416 | P : Node_Id; | |
1417 | ||
1418 | begin | |
1419 | P := Parent_Spec (Unit (N)); | |
1420 | loop | |
1421 | if Unit (P) = Lib_U then | |
c6a30f24 | 1422 | Error_Msg_N ("limited with_clause cannot " |
1423 | & "name ancestor", Item); | |
c53c8335 | 1424 | exit; |
1425 | end if; | |
1426 | ||
1427 | exit when not Is_Child_Spec (Unit (P)); | |
1428 | P := Parent_Spec (Unit (P)); | |
1429 | end loop; | |
1430 | end; | |
1431 | end if; | |
1432 | ||
1433 | -- Check if the limited-withed unit is already visible through | |
1434 | -- some context clause of the current compilation unit or some | |
1435 | -- ancestor of the current compilation unit. | |
1436 | ||
1437 | declare | |
1438 | Lim_Unit_Name : constant Node_Id := Name (Item); | |
1439 | Comp_Unit : Node_Id; | |
1440 | It : Node_Id; | |
1441 | Unit_Name : Node_Id; | |
1442 | ||
1443 | begin | |
1444 | Comp_Unit := N; | |
1445 | loop | |
1446 | It := First (Context_Items (Comp_Unit)); | |
1447 | while Present (It) loop | |
1448 | if Item /= It | |
1449 | and then Nkind (It) = N_With_Clause | |
1450 | and then not Limited_Present (It) | |
1451 | and then | |
899ae34b | 1452 | Nkind_In (Unit (Library_Unit (It)), |
88fcd057 | 1453 | N_Package_Declaration, |
1454 | N_Package_Renaming_Declaration) | |
c53c8335 | 1455 | then |
899ae34b | 1456 | if Nkind (Unit (Library_Unit (It))) = |
1457 | N_Package_Declaration | |
c53c8335 | 1458 | then |
1459 | Unit_Name := Name (It); | |
1460 | else | |
1461 | Unit_Name := Name (Unit (Library_Unit (It))); | |
1462 | end if; | |
1463 | ||
1464 | -- Check if the named package (or some ancestor) | |
1465 | -- leaves visible the full-view of the unit given | |
1466 | -- in the limited-with clause | |
1467 | ||
1468 | loop | |
1469 | if Designate_Same_Unit (Lim_Unit_Name, | |
1470 | Unit_Name) | |
1471 | then | |
1472 | Error_Msg_Sloc := Sloc (It); | |
503f7fd3 | 1473 | Error_Msg_N |
7cb0fd86 | 1474 | ("simultaneous visibility of limited " |
1475 | & "and unlimited views not allowed", | |
1476 | Item); | |
503f7fd3 | 1477 | Error_Msg_NE |
7cb0fd86 | 1478 | ("\unlimited view visible through " |
1479 | & "context clause #", | |
c53c8335 | 1480 | Item, It); |
c53c8335 | 1481 | exit; |
1482 | ||
1483 | elsif Nkind (Unit_Name) = N_Identifier then | |
1484 | exit; | |
1485 | end if; | |
1486 | ||
1487 | Unit_Name := Prefix (Unit_Name); | |
1488 | end loop; | |
1489 | end if; | |
1490 | ||
1491 | Next (It); | |
1492 | end loop; | |
1493 | ||
1494 | exit when not Is_Child_Spec (Unit (Comp_Unit)); | |
1495 | ||
1496 | Comp_Unit := Parent_Spec (Unit (Comp_Unit)); | |
1497 | end loop; | |
1498 | end; | |
05e5286d | 1499 | end if; |
1500 | ||
2866d595 | 1501 | -- Skip analyzing with clause if no unit, see above |
9dfe12ae | 1502 | |
1503 | if Present (Library_Unit (Item)) then | |
1504 | Analyze (Item); | |
1505 | end if; | |
1506 | ||
1507 | -- A limited_with does not impose an elaboration order, but | |
1508 | -- there is a semantic dependency for recompilation purposes. | |
1509 | ||
1510 | if not Implicit_With (Item) then | |
1511 | Version_Update (N, Library_Unit (Item)); | |
1512 | end if; | |
9a504e32 | 1513 | |
1514 | -- Pragmas and use clauses and with clauses other than limited | |
1515 | -- with's are ignored in this pass through the context items. | |
1516 | ||
1517 | else | |
1518 | null; | |
9dfe12ae | 1519 | end if; |
1520 | ||
1521 | Next (Item); | |
1522 | end loop; | |
d6f39728 | 1523 | end Analyze_Context; |
1524 | ||
1525 | ------------------------------- | |
1526 | -- Analyze_Package_Body_Stub -- | |
1527 | ------------------------------- | |
1528 | ||
1529 | procedure Analyze_Package_Body_Stub (N : Node_Id) is | |
1530 | Id : constant Entity_Id := Defining_Identifier (N); | |
1531 | Nam : Entity_Id; | |
1532 | ||
1533 | begin | |
2866d595 | 1534 | -- The package declaration must be in the current declarative part |
d6f39728 | 1535 | |
1536 | Check_Stub_Level (N); | |
1537 | Nam := Current_Entity_In_Scope (Id); | |
1538 | ||
665e279c | 1539 | if No (Nam) or else not Is_Package_Or_Generic_Package (Nam) then |
d6f39728 | 1540 | Error_Msg_N ("missing specification for package stub", N); |
1541 | ||
1542 | elsif Has_Completion (Nam) | |
1543 | and then Present (Corresponding_Body (Unit_Declaration_Node (Nam))) | |
1544 | then | |
1545 | Error_Msg_N ("duplicate or redundant stub for package", N); | |
1546 | ||
1547 | else | |
1548 | -- Indicate that the body of the package exists. If we are doing | |
1549 | -- only semantic analysis, the stub stands for the body. If we are | |
1550 | -- generating code, the existence of the body will be confirmed | |
1551 | -- when we load the proper body. | |
1552 | ||
1553 | Set_Has_Completion (Nam); | |
1554 | Set_Scope (Defining_Entity (N), Current_Scope); | |
9dfe12ae | 1555 | Generate_Reference (Nam, Id, 'b'); |
d6f39728 | 1556 | Analyze_Proper_Body (N, Nam); |
1557 | end if; | |
1558 | end Analyze_Package_Body_Stub; | |
1559 | ||
1560 | ------------------------- | |
1561 | -- Analyze_Proper_Body -- | |
1562 | ------------------------- | |
1563 | ||
1564 | procedure Analyze_Proper_Body (N : Node_Id; Nam : Entity_Id) is | |
88fcd057 | 1565 | Subunit_Name : constant Unit_Name_Type := Get_Unit_Name (N); |
1566 | Unum : Unit_Number_Type; | |
d6f39728 | 1567 | |
1568 | procedure Optional_Subunit; | |
1569 | -- This procedure is called when the main unit is a stub, or when we | |
1570 | -- are not generating code. In such a case, we analyze the subunit if | |
1571 | -- present, which is user-friendly and in fact required for ASIS, but | |
1572 | -- we don't complain if the subunit is missing. | |
1573 | ||
1574 | ---------------------- | |
1575 | -- Optional_Subunit -- | |
1576 | ---------------------- | |
1577 | ||
1578 | procedure Optional_Subunit is | |
1579 | Comp_Unit : Node_Id; | |
1580 | ||
1581 | begin | |
39a79c9e | 1582 | -- Try to load subunit, but ignore any errors that occur during the |
1583 | -- loading of the subunit, by using the special feature in Errout to | |
1584 | -- ignore all errors. Note that Fatal_Error will still be set, so we | |
1585 | -- will be able to check for this case below. | |
d6f39728 | 1586 | |
9fb1fcd1 | 1587 | if not ASIS_Mode then |
1588 | Ignore_Errors_Enable := Ignore_Errors_Enable + 1; | |
1589 | end if; | |
1590 | ||
d6f39728 | 1591 | Unum := |
1592 | Load_Unit | |
1593 | (Load_Name => Subunit_Name, | |
1594 | Required => False, | |
1595 | Subunit => True, | |
1596 | Error_Node => N); | |
9fb1fcd1 | 1597 | |
1598 | if not ASIS_Mode then | |
1599 | Ignore_Errors_Enable := Ignore_Errors_Enable - 1; | |
1600 | end if; | |
d6f39728 | 1601 | |
1602 | -- All done if we successfully loaded the subunit | |
1603 | ||
9dfe12ae | 1604 | if Unum /= No_Unit |
1605 | and then (not Fatal_Error (Unum) or else Try_Semantics) | |
1606 | then | |
d6f39728 | 1607 | Comp_Unit := Cunit (Unum); |
1608 | ||
88fcd057 | 1609 | -- If the file was empty or seriously mangled, the unit itself may |
1610 | -- be missing. | |
d4cd0166 | 1611 | |
1612 | if No (Unit (Comp_Unit)) then | |
1613 | Error_Msg_N | |
1614 | ("subunit does not contain expected proper body", N); | |
1615 | ||
1616 | elsif Nkind (Unit (Comp_Unit)) /= N_Subunit then | |
f98319dc | 1617 | Error_Msg_N |
1618 | ("expected SEPARATE subunit, found child unit", | |
1619 | Cunit_Entity (Unum)); | |
1620 | else | |
1621 | Set_Corresponding_Stub (Unit (Comp_Unit), N); | |
1622 | Analyze_Subunit (Comp_Unit); | |
1623 | Set_Library_Unit (N, Comp_Unit); | |
1624 | end if; | |
d6f39728 | 1625 | |
1626 | elsif Unum = No_Unit | |
1627 | and then Present (Nam) | |
1628 | then | |
1629 | if Is_Protected_Type (Nam) then | |
1630 | Set_Corresponding_Body (Parent (Nam), Defining_Identifier (N)); | |
1631 | else | |
1632 | Set_Corresponding_Body ( | |
1633 | Unit_Declaration_Node (Nam), Defining_Identifier (N)); | |
1634 | end if; | |
1635 | end if; | |
1636 | end Optional_Subunit; | |
1637 | ||
1638 | -- Start of processing for Analyze_Proper_Body | |
1639 | ||
1640 | begin | |
88fcd057 | 1641 | -- If the subunit is already loaded, it means that the main unit is a |
1642 | -- subunit, and that the current unit is one of its parents which was | |
1643 | -- being analyzed to provide the needed context for the analysis of the | |
1644 | -- subunit. In this case we analyze the subunit and continue with the | |
1645 | -- parent, without looking a subsequent subunits. | |
d6f39728 | 1646 | |
1647 | if Is_Loaded (Subunit_Name) then | |
1648 | ||
88fcd057 | 1649 | -- If the proper body is already linked to the stub node, the stub is |
1650 | -- in a generic unit and just needs analyzing. | |
d6f39728 | 1651 | |
1652 | if Present (Library_Unit (N)) then | |
1653 | Set_Corresponding_Stub (Unit (Library_Unit (N)), N); | |
1654 | Analyze_Subunit (Library_Unit (N)); | |
1655 | ||
1656 | -- Otherwise we must load the subunit and link to it | |
1657 | ||
1658 | else | |
88fcd057 | 1659 | -- Load the subunit, this must work, since we originally loaded |
1660 | -- the subunit earlier on. So this will not really load it, just | |
1661 | -- give access to it. | |
d6f39728 | 1662 | |
1663 | Unum := | |
1664 | Load_Unit | |
1665 | (Load_Name => Subunit_Name, | |
1666 | Required => True, | |
1667 | Subunit => False, | |
1668 | Error_Node => N); | |
1669 | ||
1670 | -- And analyze the subunit in the parent context (note that we | |
1671 | -- do not call Semantics, since that would remove the parent | |
1672 | -- context). Because of this, we have to manually reset the | |
1673 | -- compiler state to Analyzing since it got destroyed by Load. | |
1674 | ||
1675 | if Unum /= No_Unit then | |
1676 | Compiler_State := Analyzing; | |
9dfe12ae | 1677 | |
1678 | -- Check that the proper body is a subunit and not a child | |
1679 | -- unit. If the unit was previously loaded, the error will | |
1680 | -- have been emitted when copying the generic node, so we | |
1681 | -- just return to avoid cascaded errors. | |
1682 | ||
1683 | if Nkind (Unit (Cunit (Unum))) /= N_Subunit then | |
1684 | return; | |
1685 | end if; | |
1686 | ||
d6f39728 | 1687 | Set_Corresponding_Stub (Unit (Cunit (Unum)), N); |
1688 | Analyze_Subunit (Cunit (Unum)); | |
1689 | Set_Library_Unit (N, Cunit (Unum)); | |
1690 | end if; | |
1691 | end if; | |
1692 | ||
1693 | -- If the main unit is a subunit, then we are just performing semantic | |
1694 | -- analysis on that subunit, and any other subunits of any parent unit | |
1695 | -- should be ignored, except that if we are building trees for ASIS | |
1696 | -- usage we want to annotate the stub properly. | |
1697 | ||
1698 | elsif Nkind (Unit (Cunit (Main_Unit))) = N_Subunit | |
1699 | and then Subunit_Name /= Unit_Name (Main_Unit) | |
1700 | then | |
9dfe12ae | 1701 | if ASIS_Mode then |
d6f39728 | 1702 | Optional_Subunit; |
1703 | end if; | |
1704 | ||
1705 | -- But before we return, set the flag for unloaded subunits. This | |
1706 | -- will suppress junk warnings of variables in the same declarative | |
1707 | -- part (or a higher level one) that are in danger of looking unused | |
1708 | -- when in fact there might be a declaration in the subunit that we | |
1709 | -- do not intend to load. | |
1710 | ||
1711 | Unloaded_Subunits := True; | |
1712 | return; | |
1713 | ||
1714 | -- If the subunit is not already loaded, and we are generating code, | |
39a79c9e | 1715 | -- then this is the case where compilation started from the parent, and |
1716 | -- we are generating code for an entire subunit tree. In that case we | |
1717 | -- definitely need to load the subunit. | |
d6f39728 | 1718 | |
1719 | -- In order to continue the analysis with the rest of the parent, | |
1720 | -- and other subunits, we load the unit without requiring its | |
1721 | -- presence, and emit a warning if not found, rather than terminating | |
1722 | -- the compilation abruptly, as for other missing file problems. | |
1723 | ||
9dfe12ae | 1724 | elsif Original_Operating_Mode = Generate_Code then |
d6f39728 | 1725 | |
39a79c9e | 1726 | -- If the proper body is already linked to the stub node, the stub is |
1727 | -- in a generic unit and just needs analyzing. | |
d6f39728 | 1728 | |
39a79c9e | 1729 | -- We update the version. Although we are not strictly technically |
1730 | -- semantically dependent on the subunit, given our approach of macro | |
1731 | -- substitution of subunits, it makes sense to include it in the | |
1732 | -- version identification. | |
d6f39728 | 1733 | |
1734 | if Present (Library_Unit (N)) then | |
1735 | Set_Corresponding_Stub (Unit (Library_Unit (N)), N); | |
1736 | Analyze_Subunit (Library_Unit (N)); | |
1737 | Version_Update (Cunit (Main_Unit), Library_Unit (N)); | |
1738 | ||
1739 | -- Otherwise we must load the subunit and link to it | |
1740 | ||
1741 | else | |
61e77e45 | 1742 | -- Make sure that, if the subunit is preprocessed and -gnateG is |
1743 | -- specified, the preprocessed file will be written. | |
1744 | ||
1745 | Lib.Analysing_Subunit_Of_Main := True; | |
d6f39728 | 1746 | Unum := |
1747 | Load_Unit | |
1748 | (Load_Name => Subunit_Name, | |
1749 | Required => False, | |
1750 | Subunit => True, | |
1751 | Error_Node => N); | |
61e77e45 | 1752 | Lib.Analysing_Subunit_Of_Main := False; |
d6f39728 | 1753 | |
39a79c9e | 1754 | -- Give message if we did not get the unit Emit warning even if |
1755 | -- missing subunit is not within main unit, to simplify debugging. | |
11b376d2 | 1756 | |
9dfe12ae | 1757 | if Original_Operating_Mode = Generate_Code |
d6f39728 | 1758 | and then Unum = No_Unit |
1759 | then | |
f49f70c6 | 1760 | Error_Msg_Unit_1 := Subunit_Name; |
1761 | Error_Msg_File_1 := | |
d6f39728 | 1762 | Get_File_Name (Subunit_Name, Subunit => True); |
1763 | Error_Msg_N | |
7ba19623 | 1764 | ("subunit$$ in file{ not found?!!", N); |
d6f39728 | 1765 | Subunits_Missing := True; |
d6f39728 | 1766 | end if; |
1767 | ||
1768 | -- Load_Unit may reset Compiler_State, since it may have been | |
39a79c9e | 1769 | -- necessary to parse an additional units, so we make sure that |
1770 | -- we reset it to the Analyzing state. | |
d6f39728 | 1771 | |
1772 | Compiler_State := Analyzing; | |
1773 | ||
e17ff23f | 1774 | if Unum /= No_Unit then |
d6f39728 | 1775 | if Debug_Flag_L then |
1776 | Write_Str ("*** Loaded subunit from stub. Analyze"); | |
1777 | Write_Eol; | |
1778 | end if; | |
1779 | ||
1780 | declare | |
1781 | Comp_Unit : constant Node_Id := Cunit (Unum); | |
1782 | ||
1783 | begin | |
1784 | -- Check for child unit instead of subunit | |
1785 | ||
1786 | if Nkind (Unit (Comp_Unit)) /= N_Subunit then | |
1787 | Error_Msg_N | |
1788 | ("expected SEPARATE subunit, found child unit", | |
1789 | Cunit_Entity (Unum)); | |
1790 | ||
e17ff23f | 1791 | -- OK, we have a subunit |
d6f39728 | 1792 | |
1793 | else | |
e17ff23f | 1794 | -- Set corresponding stub (even if errors) |
1795 | ||
d6f39728 | 1796 | Set_Corresponding_Stub (Unit (Comp_Unit), N); |
e17ff23f | 1797 | |
11b376d2 | 1798 | -- Collect SCO information for loaded subunit if we are |
1799 | -- in the main unit). | |
1800 | ||
1801 | if Generate_SCO | |
1802 | and then | |
1803 | In_Extended_Main_Source_Unit | |
1804 | (Cunit_Entity (Current_Sem_Unit)) | |
1805 | then | |
1806 | SCO_Record (Unum); | |
1807 | end if; | |
1808 | ||
e17ff23f | 1809 | -- Analyze the unit if semantics active |
1810 | ||
1811 | if not Fatal_Error (Unum) or else Try_Semantics then | |
1812 | Analyze_Subunit (Comp_Unit); | |
1813 | end if; | |
1814 | ||
1815 | -- Set the library unit pointer in any case | |
1816 | ||
d6f39728 | 1817 | Set_Library_Unit (N, Comp_Unit); |
1818 | ||
1819 | -- We update the version. Although we are not technically | |
1820 | -- semantically dependent on the subunit, given our | |
1821 | -- approach of macro substitution of subunits, it makes | |
1822 | -- sense to include it in the version identification. | |
1823 | ||
1824 | Version_Update (Cunit (Main_Unit), Comp_Unit); | |
1825 | end if; | |
1826 | end; | |
1827 | end if; | |
1828 | end if; | |
1829 | ||
61e77e45 | 1830 | -- The remaining case is when the subunit is not already loaded and we |
1831 | -- are not generating code. In this case we are just performing semantic | |
1832 | -- analysis on the parent, and we are not interested in the subunit. For | |
1833 | -- subprograms, analyze the stub as a body. For other entities the stub | |
1834 | -- has already been marked as completed. | |
d6f39728 | 1835 | |
1836 | else | |
1837 | Optional_Subunit; | |
1838 | end if; | |
d6f39728 | 1839 | end Analyze_Proper_Body; |
1840 | ||
1841 | ---------------------------------- | |
1842 | -- Analyze_Protected_Body_Stub -- | |
1843 | ---------------------------------- | |
1844 | ||
1845 | procedure Analyze_Protected_Body_Stub (N : Node_Id) is | |
1846 | Nam : Entity_Id := Current_Entity_In_Scope (Defining_Identifier (N)); | |
1847 | ||
1848 | begin | |
1849 | Check_Stub_Level (N); | |
1850 | ||
1a34e48c | 1851 | -- First occurrence of name may have been as an incomplete type |
d6f39728 | 1852 | |
1853 | if Present (Nam) and then Ekind (Nam) = E_Incomplete_Type then | |
1854 | Nam := Full_View (Nam); | |
1855 | end if; | |
1856 | ||
1857 | if No (Nam) | |
1858 | or else not Is_Protected_Type (Etype (Nam)) | |
1859 | then | |
503f7fd3 | 1860 | Error_Msg_N ("missing specification for Protected body", N); |
d6f39728 | 1861 | else |
1862 | Set_Scope (Defining_Entity (N), Current_Scope); | |
1863 | Set_Has_Completion (Etype (Nam)); | |
9dfe12ae | 1864 | Generate_Reference (Nam, Defining_Identifier (N), 'b'); |
d6f39728 | 1865 | Analyze_Proper_Body (N, Etype (Nam)); |
1866 | end if; | |
1867 | end Analyze_Protected_Body_Stub; | |
1868 | ||
1869 | ---------------------------------- | |
1870 | -- Analyze_Subprogram_Body_Stub -- | |
1871 | ---------------------------------- | |
1872 | ||
88fcd057 | 1873 | -- A subprogram body stub can appear with or without a previous spec. If |
1874 | -- there is one, then the analysis of the body will find it and verify | |
1875 | -- conformance. The formals appearing in the specification of the stub play | |
1876 | -- no role, except for requiring an additional conformance check. If there | |
1877 | -- is no previous subprogram declaration, the stub acts as a spec, and | |
1878 | -- provides the defining entity for the subprogram. | |
d6f39728 | 1879 | |
1880 | procedure Analyze_Subprogram_Body_Stub (N : Node_Id) is | |
1881 | Decl : Node_Id; | |
1882 | ||
1883 | begin | |
1884 | Check_Stub_Level (N); | |
1885 | ||
1886 | -- Verify that the identifier for the stub is unique within this | |
1887 | -- declarative part. | |
1888 | ||
899ae34b | 1889 | if Nkind_In (Parent (N), N_Block_Statement, |
1890 | N_Package_Body, | |
1891 | N_Subprogram_Body) | |
d6f39728 | 1892 | then |
1893 | Decl := First (Declarations (Parent (N))); | |
d6f39728 | 1894 | while Present (Decl) |
1895 | and then Decl /= N | |
1896 | loop | |
1897 | if Nkind (Decl) = N_Subprogram_Body_Stub | |
899ae34b | 1898 | and then (Chars (Defining_Unit_Name (Specification (Decl))) = |
1899 | Chars (Defining_Unit_Name (Specification (N)))) | |
d6f39728 | 1900 | then |
1901 | Error_Msg_N ("identifier for stub is not unique", N); | |
1902 | end if; | |
1903 | ||
1904 | Next (Decl); | |
1905 | end loop; | |
1906 | end if; | |
1907 | ||
1908 | -- Treat stub as a body, which checks conformance if there is a previous | |
1909 | -- declaration, or else introduces entity and its signature. | |
1910 | ||
1911 | Analyze_Subprogram_Body (N); | |
9dfe12ae | 1912 | Analyze_Proper_Body (N, Empty); |
d6f39728 | 1913 | end Analyze_Subprogram_Body_Stub; |
1914 | ||
1915 | --------------------- | |
1916 | -- Analyze_Subunit -- | |
1917 | --------------------- | |
1918 | ||
88fcd057 | 1919 | -- A subunit is compiled either by itself (for semantic checking) or as |
1920 | -- part of compiling the parent (for code generation). In either case, by | |
1921 | -- the time we actually process the subunit, the parent has already been | |
1922 | -- installed and analyzed. The node N is a compilation unit, whose context | |
1923 | -- needs to be treated here, because we come directly here from the parent | |
1924 | -- without calling Analyze_Compilation_Unit. | |
1925 | ||
1926 | -- The compilation context includes the explicit context of the subunit, | |
1927 | -- and the context of the parent, together with the parent itself. In order | |
1928 | -- to compile the current context, we remove the one inherited from the | |
1929 | -- parent, in order to have a clean visibility table. We restore the parent | |
1930 | -- context before analyzing the proper body itself. On exit, we remove only | |
1931 | -- the explicit context of the subunit. | |
d6f39728 | 1932 | |
1933 | procedure Analyze_Subunit (N : Node_Id) is | |
1934 | Lib_Unit : constant Node_Id := Library_Unit (N); | |
1935 | Par_Unit : constant Entity_Id := Current_Scope; | |
1936 | ||
1937 | Lib_Spec : Node_Id := Library_Unit (Lib_Unit); | |
1938 | Num_Scopes : Int := 0; | |
1939 | Use_Clauses : array (1 .. Scope_Stack.Last) of Node_Id; | |
1940 | Enclosing_Child : Entity_Id := Empty; | |
05e5286d | 1941 | Svg : constant Suppress_Array := Scope_Suppress; |
d6f39728 | 1942 | |
1943 | procedure Analyze_Subunit_Context; | |
88fcd057 | 1944 | -- Capture names in use clauses of the subunit. This must be done before |
1945 | -- re-installing parent declarations, because items in the context must | |
1946 | -- not be hidden by declarations local to the parent. | |
d6f39728 | 1947 | |
1948 | procedure Re_Install_Parents (L : Node_Id; Scop : Entity_Id); | |
1949 | -- Recursive procedure to restore scope of all ancestors of subunit, | |
1950 | -- from outermost in. If parent is not a subunit, the call to install | |
88fcd057 | 1951 | -- context installs context of spec and (if parent is a child unit) the |
1952 | -- context of its parents as well. It is confusing that parents should | |
1953 | -- be treated differently in both cases, but the semantics are just not | |
1954 | -- identical. | |
d6f39728 | 1955 | |
1956 | procedure Re_Install_Use_Clauses; | |
1957 | -- As part of the removal of the parent scope, the use clauses are | |
88fcd057 | 1958 | -- removed, to be reinstalled when the context of the subunit has been |
1959 | -- analyzed. Use clauses may also have been affected by the analysis of | |
1960 | -- the context of the subunit, so they have to be applied again, to | |
1961 | -- insure that the compilation environment of the rest of the parent | |
1962 | -- unit is identical. | |
d6f39728 | 1963 | |
1964 | procedure Remove_Scope; | |
88fcd057 | 1965 | -- Remove current scope from scope stack, and preserve the list of use |
1966 | -- clauses in it, to be reinstalled after context is analyzed. | |
d6f39728 | 1967 | |
5c99c290 | 1968 | ----------------------------- |
1969 | -- Analyze_Subunit_Context -- | |
1970 | ----------------------------- | |
d6f39728 | 1971 | |
1972 | procedure Analyze_Subunit_Context is | |
1973 | Item : Node_Id; | |
1974 | Nam : Node_Id; | |
1975 | Unit_Name : Entity_Id; | |
1976 | ||
1977 | begin | |
1978 | Analyze_Context (N); | |
d6f39728 | 1979 | |
9c3beb70 | 1980 | -- Make withed units immediately visible. If child unit, make the |
d6f39728 | 1981 | -- ultimate parent immediately visible. |
1982 | ||
9c3beb70 | 1983 | Item := First (Context_Items (N)); |
d6f39728 | 1984 | while Present (Item) loop |
d6f39728 | 1985 | if Nkind (Item) = N_With_Clause then |
9c3beb70 | 1986 | |
1987 | -- Protect frontend against previous errors in context clauses | |
d6f39728 | 1988 | |
b5be70cd | 1989 | if Nkind (Name (Item)) /= N_Selected_Component then |
847bc895 | 1990 | if Error_Posted (Item) then |
1991 | null; | |
d6f39728 | 1992 | |
847bc895 | 1993 | else |
1994 | Unit_Name := Entity (Name (Item)); | |
1995 | while Is_Child_Unit (Unit_Name) loop | |
1996 | Set_Is_Visible_Child_Unit (Unit_Name); | |
1997 | Unit_Name := Scope (Unit_Name); | |
1998 | end loop; | |
1999 | ||
2000 | if not Is_Immediately_Visible (Unit_Name) then | |
2001 | Set_Is_Immediately_Visible (Unit_Name); | |
2002 | Set_Context_Installed (Item); | |
2003 | end if; | |
b5be70cd | 2004 | end if; |
d6f39728 | 2005 | end if; |
2006 | ||
2007 | elsif Nkind (Item) = N_Use_Package_Clause then | |
2008 | Nam := First (Names (Item)); | |
d6f39728 | 2009 | while Present (Nam) loop |
2010 | Analyze (Nam); | |
2011 | Next (Nam); | |
2012 | end loop; | |
2013 | ||
2014 | elsif Nkind (Item) = N_Use_Type_Clause then | |
2015 | Nam := First (Subtype_Marks (Item)); | |
d6f39728 | 2016 | while Present (Nam) loop |
2017 | Analyze (Nam); | |
2018 | Next (Nam); | |
2019 | end loop; | |
2020 | end if; | |
2021 | ||
2022 | Next (Item); | |
2023 | end loop; | |
2024 | ||
88fcd057 | 2025 | -- Reset visibility of withed units. They will be made visible again |
2026 | -- when we install the subunit context. | |
d6f39728 | 2027 | |
9c3beb70 | 2028 | Item := First (Context_Items (N)); |
d6f39728 | 2029 | while Present (Item) loop |
b5be70cd | 2030 | if Nkind (Item) = N_With_Clause |
2031 | ||
9c3beb70 | 2032 | -- Protect frontend against previous errors in context clauses |
b5be70cd | 2033 | |
2034 | and then Nkind (Name (Item)) /= N_Selected_Component | |
847bc895 | 2035 | and then not Error_Posted (Item) |
b5be70cd | 2036 | then |
d6f39728 | 2037 | Unit_Name := Entity (Name (Item)); |
d6f39728 | 2038 | while Is_Child_Unit (Unit_Name) loop |
2039 | Set_Is_Visible_Child_Unit (Unit_Name, False); | |
2040 | Unit_Name := Scope (Unit_Name); | |
2041 | end loop; | |
2042 | ||
2043 | if Context_Installed (Item) then | |
2044 | Set_Is_Immediately_Visible (Unit_Name, False); | |
2045 | Set_Context_Installed (Item, False); | |
2046 | end if; | |
2047 | end if; | |
2048 | ||
2049 | Next (Item); | |
2050 | end loop; | |
d6f39728 | 2051 | end Analyze_Subunit_Context; |
2052 | ||
2053 | ------------------------ | |
2054 | -- Re_Install_Parents -- | |
2055 | ------------------------ | |
2056 | ||
2057 | procedure Re_Install_Parents (L : Node_Id; Scop : Entity_Id) is | |
2058 | E : Entity_Id; | |
2059 | ||
2060 | begin | |
2061 | if Nkind (Unit (L)) = N_Subunit then | |
2062 | Re_Install_Parents (Library_Unit (L), Scope (Scop)); | |
2063 | end if; | |
2064 | ||
2065 | Install_Context (L); | |
2066 | ||
2067 | -- If the subunit occurs within a child unit, we must restore the | |
2068 | -- immediate visibility of any siblings that may occur in context. | |
2069 | ||
2070 | if Present (Enclosing_Child) then | |
2071 | Install_Siblings (Enclosing_Child, L); | |
2072 | end if; | |
2073 | ||
f49f70c6 | 2074 | Push_Scope (Scop); |
d6f39728 | 2075 | |
2076 | if Scop /= Par_Unit then | |
2077 | Set_Is_Immediately_Visible (Scop); | |
2078 | end if; | |
2079 | ||
b5be70cd | 2080 | -- Make entities in scope visible again. For child units, restore |
2081 | -- visibility only if they are actually in context. | |
2082 | ||
9c3beb70 | 2083 | E := First_Entity (Current_Scope); |
d6f39728 | 2084 | while Present (E) loop |
b5be70cd | 2085 | if not Is_Child_Unit (E) |
2086 | or else Is_Visible_Child_Unit (E) | |
2087 | then | |
2088 | Set_Is_Immediately_Visible (E); | |
2089 | end if; | |
2090 | ||
d6f39728 | 2091 | Next_Entity (E); |
2092 | end loop; | |
2093 | ||
88fcd057 | 2094 | -- A subunit appears within a body, and for a nested subunits all the |
2095 | -- parents are bodies. Restore full visibility of their private | |
2096 | -- entities. | |
d6f39728 | 2097 | |
65149aa0 | 2098 | if Is_Package_Or_Generic_Package (Scop) then |
d6f39728 | 2099 | Set_In_Package_Body (Scop); |
2100 | Install_Private_Declarations (Scop); | |
2101 | end if; | |
2102 | end Re_Install_Parents; | |
2103 | ||
2104 | ---------------------------- | |
2105 | -- Re_Install_Use_Clauses -- | |
2106 | ---------------------------- | |
2107 | ||
2108 | procedure Re_Install_Use_Clauses is | |
2109 | U : Node_Id; | |
d6f39728 | 2110 | begin |
2111 | for J in reverse 1 .. Num_Scopes loop | |
2112 | U := Use_Clauses (J); | |
2113 | Scope_Stack.Table (Scope_Stack.Last - J + 1).First_Use_Clause := U; | |
80d4fec4 | 2114 | Install_Use_Clauses (U, Force_Installation => True); |
d6f39728 | 2115 | end loop; |
2116 | end Re_Install_Use_Clauses; | |
2117 | ||
2118 | ------------------ | |
2119 | -- Remove_Scope -- | |
2120 | ------------------ | |
2121 | ||
2122 | procedure Remove_Scope is | |
2123 | E : Entity_Id; | |
2124 | ||
2125 | begin | |
2126 | Num_Scopes := Num_Scopes + 1; | |
2127 | Use_Clauses (Num_Scopes) := | |
9c3beb70 | 2128 | Scope_Stack.Table (Scope_Stack.Last).First_Use_Clause; |
d6f39728 | 2129 | |
9c3beb70 | 2130 | E := First_Entity (Current_Scope); |
d6f39728 | 2131 | while Present (E) loop |
2132 | Set_Is_Immediately_Visible (E, False); | |
2133 | Next_Entity (E); | |
2134 | end loop; | |
2135 | ||
2136 | if Is_Child_Unit (Current_Scope) then | |
2137 | Enclosing_Child := Current_Scope; | |
2138 | end if; | |
2139 | ||
2140 | Pop_Scope; | |
2141 | end Remove_Scope; | |
2142 | ||
2143 | -- Start of processing for Analyze_Subunit | |
2144 | ||
2145 | begin | |
abb8fcb6 | 2146 | if Style_Check then |
2147 | declare | |
2148 | Nam : Node_Id := Name (Unit (N)); | |
2149 | ||
2150 | begin | |
2151 | if Nkind (Nam) = N_Selected_Component then | |
2152 | Nam := Selector_Name (Nam); | |
2153 | end if; | |
2154 | ||
2155 | Check_Identifier (Nam, Par_Unit); | |
2156 | end; | |
2157 | end if; | |
2158 | ||
d6f39728 | 2159 | if not Is_Empty_List (Context_Items (N)) then |
2160 | ||
2866d595 | 2161 | -- Save current use clauses |
d6f39728 | 2162 | |
2163 | Remove_Scope; | |
2164 | Remove_Context (Lib_Unit); | |
2165 | ||
88fcd057 | 2166 | -- Now remove parents and their context, including enclosing subunits |
2167 | -- and the outer parent body which is not a subunit. | |
d6f39728 | 2168 | |
2169 | if Present (Lib_Spec) then | |
2170 | Remove_Context (Lib_Spec); | |
2171 | ||
2172 | while Nkind (Unit (Lib_Spec)) = N_Subunit loop | |
2173 | Lib_Spec := Library_Unit (Lib_Spec); | |
2174 | Remove_Scope; | |
2175 | Remove_Context (Lib_Spec); | |
2176 | end loop; | |
2177 | ||
2178 | if Nkind (Unit (Lib_Unit)) = N_Subunit then | |
2179 | Remove_Scope; | |
2180 | end if; | |
2181 | ||
2182 | if Nkind (Unit (Lib_Spec)) = N_Package_Body then | |
2183 | Remove_Context (Library_Unit (Lib_Spec)); | |
2184 | end if; | |
2185 | end if; | |
2186 | ||
aab8de0a | 2187 | Set_Is_Immediately_Visible (Par_Unit, False); |
2188 | ||
d6f39728 | 2189 | Analyze_Subunit_Context; |
aab8de0a | 2190 | |
d6f39728 | 2191 | Re_Install_Parents (Lib_Unit, Par_Unit); |
aab8de0a | 2192 | Set_Is_Immediately_Visible (Par_Unit); |
d6f39728 | 2193 | |
88fcd057 | 2194 | -- If the context includes a child unit of the parent of the subunit, |
2195 | -- the parent will have been removed from visibility, after compiling | |
2196 | -- that cousin in the context. The visibility of the parent must be | |
2197 | -- restored now. This also applies if the context includes another | |
2198 | -- subunit of the same parent which in turn includes a child unit in | |
2199 | -- its context. | |
d6f39728 | 2200 | |
65149aa0 | 2201 | if Is_Package_Or_Generic_Package (Par_Unit) then |
d6f39728 | 2202 | if not Is_Immediately_Visible (Par_Unit) |
2203 | or else (Present (First_Entity (Par_Unit)) | |
2204 | and then not Is_Immediately_Visible | |
2205 | (First_Entity (Par_Unit))) | |
2206 | then | |
2207 | Set_Is_Immediately_Visible (Par_Unit); | |
2208 | Install_Visible_Declarations (Par_Unit); | |
2209 | Install_Private_Declarations (Par_Unit); | |
2210 | end if; | |
2211 | end if; | |
2212 | ||
2213 | Re_Install_Use_Clauses; | |
2214 | Install_Context (N); | |
2215 | ||
2866d595 | 2216 | -- Restore state of suppress flags for current body |
05e5286d | 2217 | |
2218 | Scope_Suppress := Svg; | |
2219 | ||
88fcd057 | 2220 | -- If the subunit is within a child unit, then siblings of any parent |
2221 | -- unit that appear in the context clause of the subunit must also be | |
2222 | -- made immediately visible. | |
d6f39728 | 2223 | |
2224 | if Present (Enclosing_Child) then | |
2225 | Install_Siblings (Enclosing_Child, N); | |
2226 | end if; | |
d6f39728 | 2227 | end if; |
2228 | ||
2229 | Analyze (Proper_Body (Unit (N))); | |
2230 | Remove_Context (N); | |
e17ff23f | 2231 | |
88fcd057 | 2232 | -- The subunit may contain a with_clause on a sibling of some ancestor. |
2233 | -- Removing the context will remove from visibility those ancestor child | |
2234 | -- units, which must be restored to the visibility they have in the | |
2235 | -- enclosing body. | |
e17ff23f | 2236 | |
2237 | if Present (Enclosing_Child) then | |
2238 | declare | |
2239 | C : Entity_Id; | |
2240 | begin | |
2241 | C := Current_Scope; | |
2242 | while Present (C) | |
2243 | and then Is_Child_Unit (C) | |
2244 | loop | |
2245 | Set_Is_Immediately_Visible (C); | |
2246 | Set_Is_Visible_Child_Unit (C); | |
2247 | C := Scope (C); | |
2248 | end loop; | |
2249 | end; | |
2250 | end if; | |
d6f39728 | 2251 | end Analyze_Subunit; |
2252 | ||
2253 | ---------------------------- | |
2254 | -- Analyze_Task_Body_Stub -- | |
2255 | ---------------------------- | |
2256 | ||
2257 | procedure Analyze_Task_Body_Stub (N : Node_Id) is | |
2258 | Nam : Entity_Id := Current_Entity_In_Scope (Defining_Identifier (N)); | |
2259 | Loc : constant Source_Ptr := Sloc (N); | |
2260 | ||
2261 | begin | |
2262 | Check_Stub_Level (N); | |
2263 | ||
1a34e48c | 2264 | -- First occurrence of name may have been as an incomplete type |
d6f39728 | 2265 | |
2266 | if Present (Nam) and then Ekind (Nam) = E_Incomplete_Type then | |
2267 | Nam := Full_View (Nam); | |
2268 | end if; | |
2269 | ||
88fcd057 | 2270 | if No (Nam) or else not Is_Task_Type (Etype (Nam)) then |
503f7fd3 | 2271 | Error_Msg_N ("missing specification for task body", N); |
d6f39728 | 2272 | else |
2273 | Set_Scope (Defining_Entity (N), Current_Scope); | |
9dfe12ae | 2274 | Generate_Reference (Nam, Defining_Identifier (N), 'b'); |
29ba7541 | 2275 | |
2276 | -- Check for duplicate stub, if so give message and terminate | |
2277 | ||
2278 | if Has_Completion (Etype (Nam)) then | |
2279 | Error_Msg_N ("duplicate stub for task", N); | |
2280 | return; | |
2281 | else | |
2282 | Set_Has_Completion (Etype (Nam)); | |
2283 | end if; | |
2284 | ||
d6f39728 | 2285 | Analyze_Proper_Body (N, Etype (Nam)); |
2286 | ||
88fcd057 | 2287 | -- Set elaboration flag to indicate that entity is callable. This |
2288 | -- cannot be done in the expansion of the body itself, because the | |
2289 | -- proper body is not in a declarative part. This is only done if | |
2290 | -- expansion is active, because the context may be generic and the | |
2291 | -- flag not defined yet. | |
d6f39728 | 2292 | |
2293 | if Expander_Active then | |
2294 | Insert_After (N, | |
2295 | Make_Assignment_Statement (Loc, | |
2296 | Name => | |
2297 | Make_Identifier (Loc, | |
2298 | New_External_Name (Chars (Etype (Nam)), 'E')), | |
2299 | Expression => New_Reference_To (Standard_True, Loc))); | |
2300 | end if; | |
d6f39728 | 2301 | end if; |
2302 | end Analyze_Task_Body_Stub; | |
2303 | ||
2304 | ------------------------- | |
2305 | -- Analyze_With_Clause -- | |
2306 | ------------------------- | |
2307 | ||
88fcd057 | 2308 | -- Analyze the declaration of a unit in a with clause. At end, label the |
2309 | -- with clause with the defining entity for the unit. | |
d6f39728 | 2310 | |
2311 | procedure Analyze_With_Clause (N : Node_Id) is | |
9dfe12ae | 2312 | |
88fcd057 | 2313 | -- Retrieve the original kind of the unit node, before analysis. If it |
2314 | -- is a subprogram instantiation, its analysis below will rewrite the | |
2315 | -- node as the declaration of the wrapper package. If the same | |
2316 | -- instantiation appears indirectly elsewhere in the context, it will | |
2317 | -- have been analyzed already. | |
9dfe12ae | 2318 | |
2319 | Unit_Kind : constant Node_Kind := | |
2320 | Nkind (Original_Node (Unit (Library_Unit (N)))); | |
f49f70c6 | 2321 | Nam : constant Node_Id := Name (N); |
d6f39728 | 2322 | E_Name : Entity_Id; |
2323 | Par_Name : Entity_Id; | |
2324 | Pref : Node_Id; | |
2325 | U : Node_Id; | |
2326 | ||
2327 | Intunit : Boolean; | |
2328 | -- Set True if the unit currently being compiled is an internal unit | |
2329 | ||
2330 | Save_Style_Check : constant Boolean := Opt.Style_Check; | |
571bfaf5 | 2331 | Save_C_Restrict : Save_Cunit_Boolean_Restrictions; |
d6f39728 | 2332 | |
2333 | begin | |
3a2db8ab | 2334 | U := Unit (Library_Unit (N)); |
2335 | ||
571bfaf5 | 2336 | -- If this is an internal unit which is a renaming, then this is a |
2337 | -- violation of No_Obsolescent_Features. | |
2338 | ||
2339 | -- Note: this is not quite right if the user defines one of these units | |
2340 | -- himself, but that's a marginal case, and fixing it is hard ??? | |
2341 | ||
13ba2c65 | 2342 | if Restriction_Check_Required (No_Obsolescent_Features) then |
571bfaf5 | 2343 | declare |
2344 | F : constant File_Name_Type := | |
2345 | Unit_File_Name (Get_Source_Unit (U)); | |
2346 | begin | |
2347 | if Is_Predefined_File_Name (F, Renamings_Included => True) | |
2348 | and then not | |
2349 | Is_Predefined_File_Name (F, Renamings_Included => False) | |
2350 | then | |
2351 | Check_Restriction (No_Obsolescent_Features, N); | |
2352 | end if; | |
2353 | end; | |
2354 | end if; | |
2355 | ||
2356 | -- Save current restriction set, does not apply to with'ed unit | |
2357 | ||
2358 | Save_C_Restrict := Cunit_Boolean_Restrictions_Save; | |
2359 | ||
3a2db8ab | 2360 | -- Several actions are skipped for dummy packages (those supplied for |
2361 | -- with's where no matching file could be found). Such packages are | |
2362 | -- identified by the Sloc value being set to No_Location. | |
2363 | ||
9dfe12ae | 2364 | if Limited_Present (N) then |
9c3beb70 | 2365 | |
e2aa7314 | 2366 | -- Ada 2005 (AI-50217): Build visibility structures but do not |
2fcbd967 | 2367 | -- analyze the unit. |
9dfe12ae | 2368 | |
3a2db8ab | 2369 | if Sloc (U) /= No_Location then |
2370 | Build_Limited_Views (N); | |
2371 | end if; | |
2372 | ||
9dfe12ae | 2373 | return; |
2374 | end if; | |
2375 | ||
d6f39728 | 2376 | -- We reset ordinary style checking during the analysis of a with'ed |
2377 | -- unit, but we do NOT reset GNAT special analysis mode (the latter | |
2378 | -- definitely *does* apply to with'ed units). | |
2379 | ||
2380 | if not GNAT_Mode then | |
2381 | Style_Check := False; | |
2382 | end if; | |
2383 | ||
9dfe12ae | 2384 | -- If the library unit is a predefined unit, and we are in high |
2385 | -- integrity mode, then temporarily reset Configurable_Run_Time_Mode | |
2386 | -- for the analysis of the with'ed unit. This mode does not prevent | |
2387 | -- explicit with'ing of run-time units. | |
d6f39728 | 2388 | |
9dfe12ae | 2389 | if Configurable_Run_Time_Mode |
571bfaf5 | 2390 | and then Is_Predefined_File_Name (Unit_File_Name (Get_Source_Unit (U))) |
d6f39728 | 2391 | then |
9dfe12ae | 2392 | Configurable_Run_Time_Mode := False; |
d6f39728 | 2393 | Semantics (Library_Unit (N)); |
9dfe12ae | 2394 | Configurable_Run_Time_Mode := True; |
d6f39728 | 2395 | |
2396 | else | |
2397 | Semantics (Library_Unit (N)); | |
2398 | end if; | |
2399 | ||
d6f39728 | 2400 | Intunit := Is_Internal_File_Name (Unit_File_Name (Current_Sem_Unit)); |
2401 | ||
d6f39728 | 2402 | if Sloc (U) /= No_Location then |
2403 | ||
7cb0fd86 | 2404 | -- Check restrictions, except that we skip the check if this is an |
2405 | -- internal unit unless we are compiling the internal unit as the | |
2406 | -- main unit. We also skip this for dummy packages. | |
d6f39728 | 2407 | |
f49f70c6 | 2408 | Check_Restriction_No_Dependence (Nam, N); |
2409 | ||
d6f39728 | 2410 | if not Intunit or else Current_Sem_Unit = Main_Unit then |
2411 | Check_Restricted_Unit (Unit_Name (Get_Source_Unit (U)), N); | |
2412 | end if; | |
2413 | ||
f49f70c6 | 2414 | -- Deal with special case of GNAT.Current_Exceptions which interacts |
2415 | -- with the optimization of local raise statements into gotos. | |
2416 | ||
2417 | if Nkind (Nam) = N_Selected_Component | |
2418 | and then Nkind (Prefix (Nam)) = N_Identifier | |
2419 | and then Chars (Prefix (Nam)) = Name_Gnat | |
2420 | and then (Chars (Selector_Name (Nam)) = Name_Most_Recent_Exception | |
2421 | or else | |
2422 | Chars (Selector_Name (Nam)) = Name_Exception_Traces) | |
2423 | then | |
2424 | Check_Restriction (No_Exception_Propagation, N); | |
2425 | Special_Exception_Package_Used := True; | |
2426 | end if; | |
2427 | ||
7cb0fd86 | 2428 | -- Check for inappropriate with of internal implementation unit if we |
7bc11884 | 2429 | -- are not compiling an internal unit. We do not issue this message |
2430 | -- for implicit with's generated by the compiler itself. | |
d6f39728 | 2431 | |
2432 | if Implementation_Unit_Warnings | |
d6f39728 | 2433 | and then not Intunit |
9dfe12ae | 2434 | and then not Implicit_With (N) |
d6f39728 | 2435 | then |
7189d17f | 2436 | declare |
2437 | U_Kind : constant Kind_Of_Unit := | |
2438 | Get_Kind_Of_Unit (Get_Source_Unit (U)); | |
2439 | ||
2440 | begin | |
2441 | if U_Kind = Implementation_Unit then | |
503f7fd3 | 2442 | Error_Msg_F ("& is an internal 'G'N'A'T unit?", Name (N)); |
7bc11884 | 2443 | |
2444 | -- Add alternative name if available, otherwise issue a | |
2445 | -- general warning message. | |
2446 | ||
2447 | if Error_Msg_Strlen /= 0 then | |
503f7fd3 | 2448 | Error_Msg_F ("\use ""~"" instead", Name (N)); |
7bc11884 | 2449 | else |
2450 | Error_Msg_F | |
2451 | ("\use of this unit is non-portable " & | |
2452 | "and version-dependent?", Name (N)); | |
2453 | end if; | |
7189d17f | 2454 | |
b5be70cd | 2455 | elsif U_Kind = Ada_05_Unit |
2456 | and then Ada_Version < Ada_05 | |
2457 | and then Warn_On_Ada_2005_Compatibility | |
2458 | then | |
7189d17f | 2459 | Error_Msg_N ("& is an Ada 2005 unit?", Name (N)); |
ed8e5b83 | 2460 | |
ad8b87c8 | 2461 | elsif U_Kind = Ada_2012_Unit |
2462 | and then Ada_Version < Ada_2012 | |
ed8e5b83 | 2463 | and then Warn_On_Ada_2012_Compatibility |
2464 | then | |
2465 | Error_Msg_N ("& is an Ada 2012 unit?", Name (N)); | |
7189d17f | 2466 | end if; |
2467 | end; | |
d6f39728 | 2468 | end if; |
2469 | end if; | |
2470 | ||
2471 | -- Semantic analysis of a generic unit is performed on a copy of | |
2472 | -- the original tree. Retrieve the entity on which semantic info | |
2473 | -- actually appears. | |
2474 | ||
2475 | if Unit_Kind in N_Generic_Declaration then | |
2476 | E_Name := Defining_Entity (U); | |
2477 | ||
7cb0fd86 | 2478 | -- Note: in the following test, Unit_Kind is the original Nkind, but in |
2479 | -- the case of an instantiation, semantic analysis above will have | |
2480 | -- replaced the unit by its instantiated version. If the instance body | |
2481 | -- has been generated, the instance now denotes the body entity. For | |
2482 | -- visibility purposes we need the entity of its spec. | |
e4bd5d4a | 2483 | |
2484 | elsif (Unit_Kind = N_Package_Instantiation | |
2485 | or else Nkind (Original_Node (Unit (Library_Unit (N)))) = | |
899ae34b | 2486 | N_Package_Instantiation) |
d6f39728 | 2487 | and then Nkind (U) = N_Package_Body |
2488 | then | |
d6f39728 | 2489 | E_Name := Corresponding_Spec (U); |
2490 | ||
2491 | elsif Unit_Kind = N_Package_Instantiation | |
2492 | and then Nkind (U) = N_Package_Instantiation | |
2493 | then | |
2494 | -- If the instance has not been rewritten as a package declaration, | |
2495 | -- then it appeared already in a previous with clause. Retrieve | |
2496 | -- the entity from the previous instance. | |
2497 | ||
2498 | E_Name := Defining_Entity (Specification (Instance_Spec (U))); | |
2499 | ||
665e279c | 2500 | elsif Unit_Kind in N_Subprogram_Instantiation then |
2501 | ||
7527b812 | 2502 | -- The visible subprogram is created during instantiation, and is |
2503 | -- an attribute of the wrapper package. We retrieve the wrapper | |
2504 | -- package directly from the instantiation node. If the instance | |
2505 | -- is inlined the unit is still an instantiation. Otherwise it has | |
2506 | -- been rewritten as the declaration of the wrapper itself. | |
2507 | ||
2508 | if Nkind (U) in N_Subprogram_Instantiation then | |
2509 | E_Name := | |
2510 | Related_Instance | |
2511 | (Defining_Entity (Specification (Instance_Spec (U)))); | |
2512 | else | |
2513 | E_Name := Related_Instance (Defining_Entity (U)); | |
2514 | end if; | |
d6f39728 | 2515 | |
2516 | elsif Unit_Kind = N_Package_Renaming_Declaration | |
2517 | or else Unit_Kind in N_Generic_Renaming_Declaration | |
2518 | then | |
2519 | E_Name := Defining_Entity (U); | |
2520 | ||
2521 | elsif Unit_Kind = N_Subprogram_Body | |
2522 | and then Nkind (Name (N)) = N_Selected_Component | |
2523 | and then not Acts_As_Spec (Library_Unit (N)) | |
2524 | then | |
2525 | -- For a child unit that has no spec, one has been created and | |
2526 | -- analyzed. The entity required is that of the spec. | |
2527 | ||
2528 | E_Name := Corresponding_Spec (U); | |
2529 | ||
2530 | else | |
2531 | E_Name := Defining_Entity (U); | |
2532 | end if; | |
2533 | ||
2534 | if Nkind (Name (N)) = N_Selected_Component then | |
2535 | ||
2536 | -- Child unit in a with clause | |
2537 | ||
2538 | Change_Selected_Component_To_Expanded_Name (Name (N)); | |
2539 | end if; | |
2540 | ||
2541 | -- Restore style checks and restrictions | |
2542 | ||
2543 | Style_Check := Save_Style_Check; | |
1e16c51c | 2544 | Cunit_Boolean_Restrictions_Restore (Save_C_Restrict); |
d6f39728 | 2545 | |
9c3beb70 | 2546 | -- Record the reference, but do NOT set the unit as referenced, we want |
2547 | -- to consider the unit as unreferenced if this is the only reference | |
2548 | -- that occurs. | |
d6f39728 | 2549 | |
2550 | Set_Entity_With_Style_Check (Name (N), E_Name); | |
9dfe12ae | 2551 | Generate_Reference (E_Name, Name (N), 'w', Set_Ref => False); |
d6f39728 | 2552 | |
8c7d3bad | 2553 | -- Generate references and check No_Dependence restriction for parents |
2554 | ||
d6f39728 | 2555 | if Is_Child_Unit (E_Name) then |
2556 | Pref := Prefix (Name (N)); | |
2557 | Par_Name := Scope (E_Name); | |
d6f39728 | 2558 | while Nkind (Pref) = N_Selected_Component loop |
2559 | Change_Selected_Component_To_Expanded_Name (Pref); | |
2560 | Set_Entity_With_Style_Check (Pref, Par_Name); | |
2561 | ||
2562 | Generate_Reference (Par_Name, Pref); | |
8c7d3bad | 2563 | Check_Restriction_No_Dependence (Pref, N); |
d6f39728 | 2564 | Pref := Prefix (Pref); |
e7b2d6bc | 2565 | |
9c3beb70 | 2566 | -- If E_Name is the dummy entity for a nonexistent unit, its scope |
2567 | -- is set to Standard_Standard, and no attempt should be made to | |
2568 | -- further unwind scopes. | |
e7b2d6bc | 2569 | |
2570 | if Par_Name /= Standard_Standard then | |
2571 | Par_Name := Scope (Par_Name); | |
2572 | end if; | |
d6f39728 | 2573 | end loop; |
2574 | ||
2575 | if Present (Entity (Pref)) | |
2576 | and then not Analyzed (Parent (Parent (Entity (Pref)))) | |
2577 | then | |
9c3beb70 | 2578 | -- If the entity is set without its unit being compiled, the |
2579 | -- original parent is a renaming, and Par_Name is the renamed | |
2580 | -- entity. For visibility purposes, we need the original entity, | |
2581 | -- which must be analyzed now because Load_Unit directly retrieves | |
2582 | -- the renamed unit, and the renaming declaration itself has not | |
2583 | -- been analyzed. | |
d6f39728 | 2584 | |
2585 | Analyze (Parent (Parent (Entity (Pref)))); | |
2586 | pragma Assert (Renamed_Object (Entity (Pref)) = Par_Name); | |
2587 | Par_Name := Entity (Pref); | |
2588 | end if; | |
2589 | ||
2590 | Set_Entity_With_Style_Check (Pref, Par_Name); | |
2591 | Generate_Reference (Par_Name, Pref); | |
2592 | end if; | |
2593 | ||
2594 | -- If the withed unit is System, and a system extension pragma is | |
9c3beb70 | 2595 | -- present, compile the extension now, rather than waiting for a |
2596 | -- visibility check on a specific entity. | |
d6f39728 | 2597 | |
2598 | if Chars (E_Name) = Name_System | |
2599 | and then Scope (E_Name) = Standard_Standard | |
9dfe12ae | 2600 | and then Present (System_Extend_Unit) |
d6f39728 | 2601 | and then Present_System_Aux (N) |
2602 | then | |
2866d595 | 2603 | -- If the extension is not present, an error will have been emitted |
d6f39728 | 2604 | |
2605 | null; | |
2606 | end if; | |
e27c85d0 | 2607 | |
e2aa7314 | 2608 | -- Ada 2005 (AI-262): Remove from visibility the entity corresponding |
2609 | -- to private_with units; they will be made visible later (just before | |
2610 | -- the private part is analyzed) | |
e27c85d0 | 2611 | |
2612 | if Private_Present (N) then | |
2613 | Set_Is_Immediately_Visible (E_Name, False); | |
2614 | end if; | |
d6f39728 | 2615 | end Analyze_With_Clause; |
2616 | ||
d6f39728 | 2617 | ------------------------------ |
2618 | -- Check_Private_Child_Unit -- | |
2619 | ------------------------------ | |
2620 | ||
2621 | procedure Check_Private_Child_Unit (N : Node_Id) is | |
2622 | Lib_Unit : constant Node_Id := Unit (N); | |
2623 | Item : Node_Id; | |
2624 | Curr_Unit : Entity_Id; | |
2625 | Sub_Parent : Node_Id; | |
2626 | Priv_Child : Entity_Id; | |
2627 | Par_Lib : Entity_Id; | |
2628 | Par_Spec : Node_Id; | |
2629 | ||
2630 | function Is_Private_Library_Unit (Unit : Entity_Id) return Boolean; | |
2631 | -- Returns true if and only if the library unit is declared with | |
2632 | -- an explicit designation of private. | |
2633 | ||
88fcd057 | 2634 | ----------------------------- |
2635 | -- Is_Private_Library_Unit -- | |
2636 | ----------------------------- | |
2637 | ||
d6f39728 | 2638 | function Is_Private_Library_Unit (Unit : Entity_Id) return Boolean is |
9dfe12ae | 2639 | Comp_Unit : constant Node_Id := Parent (Unit_Declaration_Node (Unit)); |
2640 | ||
d6f39728 | 2641 | begin |
9dfe12ae | 2642 | return Private_Present (Comp_Unit); |
d6f39728 | 2643 | end Is_Private_Library_Unit; |
2644 | ||
2645 | -- Start of processing for Check_Private_Child_Unit | |
2646 | ||
2647 | begin | |
899ae34b | 2648 | if Nkind_In (Lib_Unit, N_Package_Body, N_Subprogram_Body) then |
d6f39728 | 2649 | Curr_Unit := Defining_Entity (Unit (Library_Unit (N))); |
2650 | Par_Lib := Curr_Unit; | |
2651 | ||
2652 | elsif Nkind (Lib_Unit) = N_Subunit then | |
2653 | ||
7cb0fd86 | 2654 | -- The parent is itself a body. The parent entity is to be found in |
2655 | -- the corresponding spec. | |
d6f39728 | 2656 | |
2657 | Sub_Parent := Library_Unit (N); | |
2658 | Curr_Unit := Defining_Entity (Unit (Library_Unit (Sub_Parent))); | |
2659 | ||
39a79c9e | 2660 | -- If the parent itself is a subunit, Curr_Unit is the entity of the |
2661 | -- enclosing body, retrieve the spec entity which is the proper | |
2662 | -- ancestor we need for the following tests. | |
d6f39728 | 2663 | |
2664 | if Ekind (Curr_Unit) = E_Package_Body then | |
2665 | Curr_Unit := Spec_Entity (Curr_Unit); | |
2666 | end if; | |
2667 | ||
2668 | Par_Lib := Curr_Unit; | |
2669 | ||
2670 | else | |
2671 | Curr_Unit := Defining_Entity (Lib_Unit); | |
2672 | ||
2673 | Par_Lib := Curr_Unit; | |
2674 | Par_Spec := Parent_Spec (Lib_Unit); | |
2675 | ||
2676 | if No (Par_Spec) then | |
2677 | Par_Lib := Empty; | |
2678 | else | |
2679 | Par_Lib := Defining_Entity (Unit (Par_Spec)); | |
2680 | end if; | |
2681 | end if; | |
2682 | ||
2683 | -- Loop through context items | |
2684 | ||
2685 | Item := First (Context_Items (N)); | |
2686 | while Present (Item) loop | |
2687 | ||
e2aa7314 | 2688 | -- Ada 2005 (AI-262): Allow private_with of a private child package |
2689 | -- in public siblings | |
e27c85d0 | 2690 | |
d6f39728 | 2691 | if Nkind (Item) = N_With_Clause |
2692 | and then not Implicit_With (Item) | |
3a2db8ab | 2693 | and then not Limited_Present (Item) |
d6f39728 | 2694 | and then Is_Private_Descendant (Entity (Name (Item))) |
2695 | then | |
2696 | Priv_Child := Entity (Name (Item)); | |
2697 | ||
2698 | declare | |
2699 | Curr_Parent : Entity_Id := Par_Lib; | |
2700 | Child_Parent : Entity_Id := Scope (Priv_Child); | |
2701 | Prv_Ancestor : Entity_Id := Child_Parent; | |
2702 | Curr_Private : Boolean := Is_Private_Library_Unit (Curr_Unit); | |
2703 | ||
2704 | begin | |
7cb0fd86 | 2705 | -- If the child unit is a public child then locate the nearest |
2706 | -- private ancestor. Child_Parent will then be set to the | |
2707 | -- parent of that ancestor. | |
d6f39728 | 2708 | |
2709 | if not Is_Private_Library_Unit (Priv_Child) then | |
2710 | while Present (Prv_Ancestor) | |
2711 | and then not Is_Private_Library_Unit (Prv_Ancestor) | |
2712 | loop | |
2713 | Prv_Ancestor := Scope (Prv_Ancestor); | |
2714 | end loop; | |
2715 | ||
2716 | if Present (Prv_Ancestor) then | |
2717 | Child_Parent := Scope (Prv_Ancestor); | |
2718 | end if; | |
2719 | end if; | |
2720 | ||
2721 | while Present (Curr_Parent) | |
2722 | and then Curr_Parent /= Standard_Standard | |
2723 | and then Curr_Parent /= Child_Parent | |
2724 | loop | |
2725 | Curr_Private := | |
2726 | Curr_Private or else Is_Private_Library_Unit (Curr_Parent); | |
2727 | Curr_Parent := Scope (Curr_Parent); | |
2728 | end loop; | |
2729 | ||
9a504e32 | 2730 | if No (Curr_Parent) then |
d6f39728 | 2731 | Curr_Parent := Standard_Standard; |
2732 | end if; | |
2733 | ||
2734 | if Curr_Parent /= Child_Parent then | |
d6f39728 | 2735 | if Ekind (Priv_Child) = E_Generic_Package |
2736 | and then Chars (Priv_Child) in Text_IO_Package_Name | |
2737 | and then Chars (Scope (Scope (Priv_Child))) = Name_Ada | |
2738 | then | |
2739 | Error_Msg_NE | |
2740 | ("& is a nested package, not a compilation unit", | |
2741 | Name (Item), Priv_Child); | |
2742 | ||
2743 | else | |
2744 | Error_Msg_N | |
2745 | ("unit in with clause is private child unit!", Item); | |
2746 | Error_Msg_NE | |
e17ff23f | 2747 | ("\current unit must also have parent&!", |
d6f39728 | 2748 | Item, Child_Parent); |
2749 | end if; | |
2750 | ||
899ae34b | 2751 | elsif Curr_Private |
2752 | or else Private_Present (Item) | |
2753 | or else Nkind_In (Lib_Unit, N_Package_Body, N_Subunit) | |
2754 | or else (Nkind (Lib_Unit) = N_Subprogram_Body | |
2755 | and then not Acts_As_Spec (Parent (Lib_Unit))) | |
d6f39728 | 2756 | then |
899ae34b | 2757 | null; |
2758 | ||
2759 | else | |
d6f39728 | 2760 | Error_Msg_NE |
2761 | ("current unit must also be private descendant of&", | |
2762 | Item, Child_Parent); | |
2763 | end if; | |
2764 | end; | |
2765 | end if; | |
2766 | ||
2767 | Next (Item); | |
2768 | end loop; | |
2769 | ||
2770 | end Check_Private_Child_Unit; | |
2771 | ||
2772 | ---------------------- | |
2773 | -- Check_Stub_Level -- | |
2774 | ---------------------- | |
2775 | ||
2776 | procedure Check_Stub_Level (N : Node_Id) is | |
2777 | Par : constant Node_Id := Parent (N); | |
2778 | Kind : constant Node_Kind := Nkind (Par); | |
2779 | ||
2780 | begin | |
899ae34b | 2781 | if Nkind_In (Kind, N_Package_Body, |
2782 | N_Subprogram_Body, | |
2783 | N_Task_Body, | |
2784 | N_Protected_Body) | |
2785 | and then Nkind_In (Parent (Par), N_Compilation_Unit, N_Subunit) | |
d6f39728 | 2786 | then |
2787 | null; | |
2788 | ||
2789 | -- In an instance, a missing stub appears at any level. A warning | |
2790 | -- message will have been emitted already for the missing file. | |
2791 | ||
2792 | elsif not In_Instance then | |
2793 | Error_Msg_N ("stub cannot appear in an inner scope", N); | |
2794 | ||
2795 | elsif Expander_Active then | |
2796 | Error_Msg_N ("missing proper body", N); | |
2797 | end if; | |
2798 | end Check_Stub_Level; | |
2799 | ||
2800 | ------------------------ | |
2801 | -- Expand_With_Clause -- | |
2802 | ------------------------ | |
2803 | ||
665e279c | 2804 | procedure Expand_With_Clause (Item : Node_Id; Nam : Node_Id; N : Node_Id) is |
d6f39728 | 2805 | Loc : constant Source_Ptr := Sloc (Nam); |
2806 | Ent : constant Entity_Id := Entity (Nam); | |
2807 | Withn : Node_Id; | |
2808 | P : Node_Id; | |
2809 | ||
2810 | function Build_Unit_Name (Nam : Node_Id) return Node_Id; | |
c5bb9c4d | 2811 | -- Build name to be used in implicit with_clause. In most cases this |
2812 | -- is the source name, but if renamings are present we must make the | |
2813 | -- original unit visible, not the one it renames. The entity in the | |
e810d57a | 2814 | -- with clause is the renamed unit, but the identifier is the one from |
c5bb9c4d | 2815 | -- the source, which allows us to recover the unit renaming. |
d6f39728 | 2816 | |
9c3beb70 | 2817 | --------------------- |
2818 | -- Build_Unit_Name -- | |
2819 | --------------------- | |
2820 | ||
d6f39728 | 2821 | function Build_Unit_Name (Nam : Node_Id) return Node_Id is |
c5bb9c4d | 2822 | Ent : Entity_Id; |
899ae34b | 2823 | Renaming : Entity_Id; |
2824 | Result : Node_Id; | |
d6f39728 | 2825 | |
2826 | begin | |
2827 | if Nkind (Nam) = N_Identifier then | |
899ae34b | 2828 | |
39a79c9e | 2829 | -- If the parent unit P in the name of the with_clause for P.Q is |
2830 | -- a renaming of package R, then the entity of the parent is set | |
2831 | -- to R, but the identifier retains Chars (P) to be consistent | |
2832 | -- with the source (see details in lib-load). However the implicit | |
2833 | -- with_clause for the parent must make the entity for P visible, | |
2834 | -- because P.Q may be used as a prefix within the current unit. | |
2835 | -- The entity for P is the current_entity with that name, because | |
2836 | -- the package renaming declaration for it has just been analyzed. | |
2837 | -- Note that this case can only happen if P.Q has already appeared | |
2838 | -- in a previous with_clause in a related unit, such as the | |
2839 | -- library body of the current unit. | |
899ae34b | 2840 | |
2841 | if Chars (Nam) /= Chars (Entity (Nam)) then | |
2842 | Renaming := Current_Entity (Nam); | |
2843 | pragma Assert (Renamed_Entity (Renaming) = Entity (Nam)); | |
2844 | return New_Occurrence_Of (Renaming, Loc); | |
2845 | ||
2846 | else | |
2847 | return New_Occurrence_Of (Entity (Nam), Loc); | |
2848 | end if; | |
d6f39728 | 2849 | |
2850 | else | |
c5bb9c4d | 2851 | Ent := Entity (Nam); |
2852 | ||
2853 | if Present (Entity (Selector_Name (Nam))) | |
2854 | and then Chars (Entity (Selector_Name (Nam))) /= Chars (Ent) | |
2855 | and then | |
2856 | Nkind (Unit_Declaration_Node (Entity (Selector_Name (Nam)))) | |
2857 | = N_Package_Renaming_Declaration | |
2858 | then | |
39a79c9e | 2859 | -- The name in the with_clause is of the form A.B.C, and B is |
2860 | -- given by a renaming declaration. In that case we may not | |
2861 | -- have analyzed the unit for B, but replaced it directly in | |
2862 | -- lib-load with the unit it renames. We have to make A.B | |
c5bb9c4d | 2863 | -- visible, so analyze the declaration for B now, in case it |
2864 | -- has not been done yet. | |
2865 | ||
2866 | Ent := Entity (Selector_Name (Nam)); | |
2867 | Analyze | |
2868 | (Parent | |
2869 | (Unit_Declaration_Node (Entity (Selector_Name (Nam))))); | |
2870 | end if; | |
2871 | ||
d6f39728 | 2872 | Result := |
2873 | Make_Expanded_Name (Loc, | |
2874 | Chars => Chars (Entity (Nam)), | |
2875 | Prefix => Build_Unit_Name (Prefix (Nam)), | |
c5bb9c4d | 2876 | Selector_Name => New_Occurrence_Of (Ent, Loc)); |
2877 | Set_Entity (Result, Ent); | |
d6f39728 | 2878 | return Result; |
2879 | end if; | |
2880 | end Build_Unit_Name; | |
2881 | ||
9c3beb70 | 2882 | -- Start of processing for Expand_With_Clause |
2883 | ||
d6f39728 | 2884 | begin |
2885 | New_Nodes_OK := New_Nodes_OK + 1; | |
2886 | Withn := | |
f2e9c237 | 2887 | Make_With_Clause (Loc, |
2888 | Name => Build_Unit_Name (Nam)); | |
d6f39728 | 2889 | |
2890 | P := Parent (Unit_Declaration_Node (Ent)); | |
f2e9c237 | 2891 | Set_Library_Unit (Withn, P); |
2892 | Set_Corresponding_Spec (Withn, Ent); | |
2893 | Set_First_Name (Withn, True); | |
2894 | Set_Implicit_With (Withn, True); | |
d6f39728 | 2895 | |
665e279c | 2896 | -- If the unit is a package declaration, a private_with_clause on a |
88fcd057 | 2897 | -- child unit implies the implicit with on the parent is also private. |
665e279c | 2898 | |
2899 | if Nkind (Unit (N)) = N_Package_Declaration then | |
f2e9c237 | 2900 | Set_Private_Present (Withn, Private_Present (Item)); |
665e279c | 2901 | end if; |
2902 | ||
d6f39728 | 2903 | Prepend (Withn, Context_Items (N)); |
2904 | Mark_Rewrite_Insertion (Withn); | |
2905 | Install_Withed_Unit (Withn); | |
2906 | ||
2907 | if Nkind (Nam) = N_Expanded_Name then | |
665e279c | 2908 | Expand_With_Clause (Item, Prefix (Nam), N); |
d6f39728 | 2909 | end if; |
2910 | ||
2911 | New_Nodes_OK := New_Nodes_OK - 1; | |
2912 | end Expand_With_Clause; | |
2913 | ||
f15731c4 | 2914 | ----------------------- |
2915 | -- Get_Parent_Entity -- | |
2916 | ----------------------- | |
2917 | ||
2918 | function Get_Parent_Entity (Unit : Node_Id) return Entity_Id is | |
2919 | begin | |
8f71d067 | 2920 | if Nkind (Unit) = N_Package_Body |
2921 | and then Nkind (Original_Node (Unit)) = N_Package_Instantiation | |
2922 | then | |
f2e9c237 | 2923 | return Defining_Entity |
2924 | (Specification (Instance_Spec (Original_Node (Unit)))); | |
8f71d067 | 2925 | elsif Nkind (Unit) = N_Package_Instantiation then |
f15731c4 | 2926 | return Defining_Entity (Specification (Instance_Spec (Unit))); |
2927 | else | |
2928 | return Defining_Entity (Unit); | |
2929 | end if; | |
2930 | end Get_Parent_Entity; | |
2931 | ||
6f152d7a | 2932 | --------------------- |
2933 | -- Has_With_Clause -- | |
2934 | --------------------- | |
2935 | ||
2936 | function Has_With_Clause | |
2937 | (C_Unit : Node_Id; | |
2938 | Pack : Entity_Id; | |
2939 | Is_Limited : Boolean := False) return Boolean | |
2940 | is | |
2941 | Item : Node_Id; | |
45cedf2e | 2942 | |
2943 | function Named_Unit (Clause : Node_Id) return Entity_Id; | |
2944 | -- Return the entity for the unit named in a [limited] with clause | |
2945 | ||
2946 | ---------------- | |
2947 | -- Named_Unit -- | |
2948 | ---------------- | |
2949 | ||
2950 | function Named_Unit (Clause : Node_Id) return Entity_Id is | |
2951 | begin | |
2952 | if Nkind (Name (Clause)) = N_Selected_Component then | |
2953 | return Entity (Selector_Name (Name (Clause))); | |
2954 | else | |
2955 | return Entity (Name (Clause)); | |
2956 | end if; | |
2957 | end Named_Unit; | |
2958 | ||
2959 | -- Start of processing for Has_With_Clause | |
6f152d7a | 2960 | |
2961 | begin | |
2962 | if Present (Context_Items (C_Unit)) then | |
2963 | Item := First (Context_Items (C_Unit)); | |
2964 | while Present (Item) loop | |
45cedf2e | 2965 | if Nkind (Item) = N_With_Clause |
2966 | and then Limited_Present (Item) = Is_Limited | |
2967 | and then Named_Unit (Item) = Pack | |
2968 | then | |
2969 | return True; | |
6f152d7a | 2970 | end if; |
2971 | ||
2972 | Next (Item); | |
2973 | end loop; | |
2974 | end if; | |
2975 | ||
2976 | return False; | |
2977 | end Has_With_Clause; | |
2978 | ||
d6f39728 | 2979 | ----------------------------- |
2980 | -- Implicit_With_On_Parent -- | |
2981 | ----------------------------- | |
2982 | ||
2983 | procedure Implicit_With_On_Parent | |
2984 | (Child_Unit : Node_Id; | |
2985 | N : Node_Id) | |
2986 | is | |
2987 | Loc : constant Source_Ptr := Sloc (N); | |
2988 | P : constant Node_Id := Parent_Spec (Child_Unit); | |
7cb0fd86 | 2989 | P_Unit : Node_Id := Unit (P); |
9dfe12ae | 2990 | P_Name : constant Entity_Id := Get_Parent_Entity (P_Unit); |
d6f39728 | 2991 | Withn : Node_Id; |
2992 | ||
3d875462 | 2993 | function Build_Ancestor_Name (P : Node_Id) return Node_Id; |
2866d595 | 2994 | -- Build prefix of child unit name. Recurse if needed |
d6f39728 | 2995 | |
2996 | function Build_Unit_Name return Node_Id; | |
7cb0fd86 | 2997 | -- If the unit is a child unit, build qualified name with all ancestors |
d6f39728 | 2998 | |
2999 | ------------------------- | |
3000 | -- Build_Ancestor_Name -- | |
3001 | ------------------------- | |
3002 | ||
3003 | function Build_Ancestor_Name (P : Node_Id) return Node_Id is | |
f5daa077 | 3004 | P_Ref : constant Node_Id := |
9dfe12ae | 3005 | New_Reference_To (Defining_Entity (P), Loc); |
f5daa077 | 3006 | P_Spec : Node_Id := P; |
3007 | ||
d6f39728 | 3008 | begin |
f5daa077 | 3009 | -- Ancestor may have been rewritten as a package body. Retrieve |
3010 | -- the original spec to trace earlier ancestors. | |
3011 | ||
3012 | if Nkind (P) = N_Package_Body | |
3013 | and then Nkind (Original_Node (P)) = N_Package_Instantiation | |
3014 | then | |
3015 | P_Spec := Original_Node (P); | |
3016 | end if; | |
3017 | ||
3018 | if No (Parent_Spec (P_Spec)) then | |
d6f39728 | 3019 | return P_Ref; |
3020 | else | |
3021 | return | |
3022 | Make_Selected_Component (Loc, | |
f5daa077 | 3023 | Prefix => Build_Ancestor_Name (Unit (Parent_Spec (P_Spec))), |
d6f39728 | 3024 | Selector_Name => P_Ref); |
3025 | end if; | |
3026 | end Build_Ancestor_Name; | |
3027 | ||
3028 | --------------------- | |
3029 | -- Build_Unit_Name -- | |
3030 | --------------------- | |
3031 | ||
3032 | function Build_Unit_Name return Node_Id is | |
3033 | Result : Node_Id; | |
88fcd057 | 3034 | |
d6f39728 | 3035 | begin |
3036 | if No (Parent_Spec (P_Unit)) then | |
3037 | return New_Reference_To (P_Name, Loc); | |
88fcd057 | 3038 | |
d6f39728 | 3039 | else |
3040 | Result := | |
3041 | Make_Expanded_Name (Loc, | |
3042 | Chars => Chars (P_Name), | |
3043 | Prefix => Build_Ancestor_Name (Unit (Parent_Spec (P_Unit))), | |
3044 | Selector_Name => New_Reference_To (P_Name, Loc)); | |
3045 | Set_Entity (Result, P_Name); | |
3046 | return Result; | |
3047 | end if; | |
3048 | end Build_Unit_Name; | |
3049 | ||
3050 | -- Start of processing for Implicit_With_On_Parent | |
3051 | ||
3052 | begin | |
7cb0fd86 | 3053 | -- The unit of the current compilation may be a package body that |
3054 | -- replaces an instance node. In this case we need the original instance | |
3055 | -- node to construct the proper parent name. | |
8f71d067 | 3056 | |
3057 | if Nkind (P_Unit) = N_Package_Body | |
3058 | and then Nkind (Original_Node (P_Unit)) = N_Package_Instantiation | |
3059 | then | |
3060 | P_Unit := Original_Node (P_Unit); | |
3061 | end if; | |
3062 | ||
7cb0fd86 | 3063 | -- We add the implicit with if the child unit is the current unit being |
3064 | -- compiled. If the current unit is a body, we do not want to add an | |
3065 | -- implicit_with a second time to the corresponding spec. | |
665e279c | 3066 | |
3067 | if Nkind (Child_Unit) = N_Package_Declaration | |
3068 | and then Child_Unit /= Unit (Cunit (Current_Sem_Unit)) | |
3069 | then | |
3070 | return; | |
3071 | end if; | |
3072 | ||
d6f39728 | 3073 | New_Nodes_OK := New_Nodes_OK + 1; |
3074 | Withn := Make_With_Clause (Loc, Name => Build_Unit_Name); | |
3075 | ||
3076 | Set_Library_Unit (Withn, P); | |
3077 | Set_Corresponding_Spec (Withn, P_Name); | |
3078 | Set_First_Name (Withn, True); | |
3079 | Set_Implicit_With (Withn, True); | |
3080 | ||
3081 | -- Node is placed at the beginning of the context items, so that | |
3082 | -- subsequent use clauses on the parent can be validated. | |
3083 | ||
3084 | Prepend (Withn, Context_Items (N)); | |
3085 | Mark_Rewrite_Insertion (Withn); | |
3086 | Install_Withed_Unit (Withn); | |
3087 | ||
3088 | if Is_Child_Spec (P_Unit) then | |
3089 | Implicit_With_On_Parent (P_Unit, N); | |
3090 | end if; | |
3d875462 | 3091 | |
d6f39728 | 3092 | New_Nodes_OK := New_Nodes_OK - 1; |
3093 | end Implicit_With_On_Parent; | |
3094 | ||
9c3beb70 | 3095 | -------------- |
3096 | -- In_Chain -- | |
3097 | -------------- | |
3098 | ||
3099 | function In_Chain (E : Entity_Id) return Boolean is | |
3100 | H : Entity_Id; | |
3101 | ||
3102 | begin | |
3103 | H := Current_Entity (E); | |
3104 | while Present (H) loop | |
3105 | if H = E then | |
3106 | return True; | |
3107 | else | |
3108 | H := Homonym (H); | |
3109 | end if; | |
3110 | end loop; | |
3111 | ||
3112 | return False; | |
3113 | end In_Chain; | |
3114 | ||
d6f39728 | 3115 | --------------------- |
3116 | -- Install_Context -- | |
3117 | --------------------- | |
3118 | ||
3119 | procedure Install_Context (N : Node_Id) is | |
9dfe12ae | 3120 | Lib_Unit : constant Node_Id := Unit (N); |
d6f39728 | 3121 | |
3122 | begin | |
3123 | Install_Context_Clauses (N); | |
3124 | ||
3125 | if Is_Child_Spec (Lib_Unit) then | |
3126 | Install_Parents (Lib_Unit, Private_Present (Parent (Lib_Unit))); | |
3127 | end if; | |
3128 | ||
05e5286d | 3129 | Install_Limited_Context_Clauses (N); |
d6f39728 | 3130 | end Install_Context; |
3131 | ||
3132 | ----------------------------- | |
3133 | -- Install_Context_Clauses -- | |
3134 | ----------------------------- | |
3135 | ||
3136 | procedure Install_Context_Clauses (N : Node_Id) is | |
9dfe12ae | 3137 | Lib_Unit : constant Node_Id := Unit (N); |
d6f39728 | 3138 | Item : Node_Id; |
3139 | Uname_Node : Entity_Id; | |
3140 | Check_Private : Boolean := False; | |
3141 | Decl_Node : Node_Id; | |
3142 | Lib_Parent : Entity_Id; | |
3143 | ||
3144 | begin | |
9a504e32 | 3145 | -- First skip configuration pragmas at the start of the context. They |
3146 | -- are not technically part of the context clause, but that's where the | |
3147 | -- parser puts them. Note they were analyzed in Analyze_Context. | |
d6f39728 | 3148 | |
3149 | Item := First (Context_Items (N)); | |
9a504e32 | 3150 | while Present (Item) |
3151 | and then Nkind (Item) = N_Pragma | |
f2e9c237 | 3152 | and then Pragma_Name (Item) in Configuration_Pragma_Names |
9a504e32 | 3153 | loop |
3154 | Next (Item); | |
3155 | end loop; | |
3156 | ||
3157 | -- Loop through the actual context clause items. We process everything | |
3158 | -- except Limited_With clauses in this routine. Limited_With clauses | |
3159 | -- are separately installed (see Install_Limited_Context_Clauses). | |
3160 | ||
d6f39728 | 3161 | while Present (Item) loop |
3162 | ||
3163 | -- Case of explicit WITH clause | |
3164 | ||
3165 | if Nkind (Item) = N_With_Clause | |
3166 | and then not Implicit_With (Item) | |
3167 | then | |
9dfe12ae | 3168 | if Limited_Present (Item) then |
3169 | ||
2866d595 | 3170 | -- Limited withed units will be installed later |
9dfe12ae | 3171 | |
9dfe12ae | 3172 | goto Continue; |
3173 | ||
d6f39728 | 3174 | -- If Name (Item) is not an entity name, something is wrong, and |
3175 | -- this will be detected in due course, for now ignore the item | |
3176 | ||
9dfe12ae | 3177 | elsif not Is_Entity_Name (Name (Item)) then |
3178 | goto Continue; | |
3179 | ||
3180 | elsif No (Entity (Name (Item))) then | |
3181 | Set_Entity (Name (Item), Any_Id); | |
d6f39728 | 3182 | goto Continue; |
3183 | end if; | |
3184 | ||
3185 | Uname_Node := Entity (Name (Item)); | |
3186 | ||
3187 | if Is_Private_Descendant (Uname_Node) then | |
3188 | Check_Private := True; | |
3189 | end if; | |
3190 | ||
3191 | Install_Withed_Unit (Item); | |
3192 | ||
3193 | Decl_Node := Unit_Declaration_Node (Uname_Node); | |
3194 | ||
7cb0fd86 | 3195 | -- If the unit is a subprogram instance, it appears nested within |
3196 | -- a package that carries the parent information. | |
d6f39728 | 3197 | |
3198 | if Is_Generic_Instance (Uname_Node) | |
3199 | and then Ekind (Uname_Node) /= E_Package | |
3200 | then | |
3201 | Decl_Node := Parent (Parent (Decl_Node)); | |
3202 | end if; | |
3203 | ||
3204 | if Is_Child_Spec (Decl_Node) then | |
3205 | if Nkind (Name (Item)) = N_Expanded_Name then | |
665e279c | 3206 | Expand_With_Clause (Item, Prefix (Name (Item)), N); |
d6f39728 | 3207 | else |
899ae34b | 3208 | -- If not an expanded name, the child unit must be a |
d6f39728 | 3209 | -- renaming, nothing to do. |
3210 | ||
3211 | null; | |
3212 | end if; | |
3213 | ||
3214 | elsif Nkind (Decl_Node) = N_Subprogram_Body | |
3215 | and then not Acts_As_Spec (Parent (Decl_Node)) | |
3216 | and then Is_Child_Spec (Unit (Library_Unit (Parent (Decl_Node)))) | |
3217 | then | |
3218 | Implicit_With_On_Parent | |
3219 | (Unit (Library_Unit (Parent (Decl_Node))), N); | |
3220 | end if; | |
3221 | ||
3222 | -- Check license conditions unless this is a dummy unit | |
3223 | ||
3224 | if Sloc (Library_Unit (Item)) /= No_Location then | |
3225 | License_Check : declare | |
665e279c | 3226 | Withu : constant Unit_Number_Type := |
3227 | Get_Source_Unit (Library_Unit (Item)); | |
d6f39728 | 3228 | Withl : constant License_Type := |
665e279c | 3229 | License (Source_Index (Withu)); |
d6f39728 | 3230 | Unitl : constant License_Type := |
3231 | License (Source_Index (Current_Sem_Unit)); | |
3232 | ||
3233 | procedure License_Error; | |
3234 | -- Signal error of bad license | |
3235 | ||
3236 | ------------------- | |
3237 | -- License_Error -- | |
3238 | ------------------- | |
3239 | ||
3240 | procedure License_Error is | |
3241 | begin | |
3242 | Error_Msg_N | |
665e279c | 3243 | ("?license of with'ed unit & may be inconsistent", |
d6f39728 | 3244 | Name (Item)); |
3245 | end License_Error; | |
3246 | ||
3247 | -- Start of processing for License_Check | |
3248 | ||
3249 | begin | |
665e279c | 3250 | -- Exclude license check if withed unit is an internal unit. |
3251 | -- This situation arises e.g. with the GPL version of GNAT. | |
d6f39728 | 3252 | |
665e279c | 3253 | if Is_Internal_File_Name (Unit_File_Name (Withu)) then |
3254 | null; | |
d6f39728 | 3255 | |
665e279c | 3256 | -- Otherwise check various cases |
3257 | else | |
3258 | case Unitl is | |
3259 | when Unknown => | |
3260 | null; | |
d6f39728 | 3261 | |
665e279c | 3262 | when Restricted => |
3263 | if Withl = GPL then | |
3264 | License_Error; | |
3265 | end if; | |
d6f39728 | 3266 | |
665e279c | 3267 | when GPL => |
3268 | if Withl = Restricted then | |
3269 | License_Error; | |
3270 | end if; | |
3271 | ||
3272 | when Modified_GPL => | |
3273 | if Withl = Restricted or else Withl = GPL then | |
3274 | License_Error; | |
3275 | end if; | |
3276 | ||
3277 | when Unrestricted => | |
3278 | null; | |
3279 | end case; | |
3280 | end if; | |
d6f39728 | 3281 | end License_Check; |
3282 | end if; | |
3283 | ||
3284 | -- Case of USE PACKAGE clause | |
3285 | ||
3286 | elsif Nkind (Item) = N_Use_Package_Clause then | |
3287 | Analyze_Use_Package (Item); | |
3288 | ||
3289 | -- Case of USE TYPE clause | |
3290 | ||
3291 | elsif Nkind (Item) = N_Use_Type_Clause then | |
3292 | Analyze_Use_Type (Item); | |
3293 | ||
d6f39728 | 3294 | -- case of PRAGMA |
3295 | ||
3296 | elsif Nkind (Item) = N_Pragma then | |
3297 | Analyze (Item); | |
3298 | end if; | |
3299 | ||
3300 | <<Continue>> | |
3301 | Next (Item); | |
3302 | end loop; | |
3303 | ||
3304 | if Is_Child_Spec (Lib_Unit) then | |
3305 | ||
234aa17e | 3306 | -- The unit also has implicit with_clauses on its own parents |
d6f39728 | 3307 | |
3308 | if No (Context_Items (N)) then | |
3309 | Set_Context_Items (N, New_List); | |
3310 | end if; | |
3311 | ||
3312 | Implicit_With_On_Parent (Lib_Unit, N); | |
3313 | end if; | |
3314 | ||
3315 | -- If the unit is a body, the context of the specification must also | |
6ffc64fc | 3316 | -- be installed. That includes private with_clauses in that context. |
d6f39728 | 3317 | |
3318 | if Nkind (Lib_Unit) = N_Package_Body | |
3319 | or else (Nkind (Lib_Unit) = N_Subprogram_Body | |
9c3beb70 | 3320 | and then not Acts_As_Spec (N)) |
d6f39728 | 3321 | then |
3322 | Install_Context (Library_Unit (N)); | |
3323 | ||
6ffc64fc | 3324 | -- Only install private with-clauses of a spec that comes from |
3325 | -- source, excluding specs created for a subprogram body that is | |
3326 | -- a child unit. | |
3327 | ||
3328 | if Comes_From_Source (Library_Unit (N)) then | |
3329 | Install_Private_With_Clauses | |
3330 | (Defining_Entity (Unit (Library_Unit (N)))); | |
3331 | end if; | |
3332 | ||
d6f39728 | 3333 | if Is_Child_Spec (Unit (Library_Unit (N))) then |
3334 | ||
3335 | -- If the unit is the body of a public child unit, the private | |
3336 | -- declarations of the parent must be made visible. If the child | |
3337 | -- unit is private, the private declarations have been installed | |
3338 | -- already in the call to Install_Parents for the spec. Installing | |
3339 | -- private declarations must be done for all ancestors of public | |
3340 | -- child units. In addition, sibling units mentioned in the | |
3341 | -- context clause of the body are directly visible. | |
3342 | ||
3343 | declare | |
9c3beb70 | 3344 | Lib_Spec : Node_Id; |
d6f39728 | 3345 | P : Node_Id; |
3346 | P_Name : Entity_Id; | |
3347 | ||
3348 | begin | |
9c3beb70 | 3349 | Lib_Spec := Unit (Library_Unit (N)); |
d6f39728 | 3350 | while Is_Child_Spec (Lib_Spec) loop |
665e279c | 3351 | P := Unit (Parent_Spec (Lib_Spec)); |
3352 | P_Name := Defining_Entity (P); | |
d6f39728 | 3353 | |
665e279c | 3354 | if not (Private_Present (Parent (Lib_Spec))) |
3355 | and then not In_Private_Part (P_Name) | |
3356 | then | |
d6f39728 | 3357 | Install_Private_Declarations (P_Name); |
3d875462 | 3358 | Install_Private_With_Clauses (P_Name); |
d6f39728 | 3359 | Set_Use (Private_Declarations (Specification (P))); |
3360 | end if; | |
3361 | ||
3362 | Lib_Spec := P; | |
3363 | end loop; | |
3364 | end; | |
3365 | end if; | |
3366 | ||
3367 | -- For a package body, children in context are immediately visible | |
3368 | ||
3369 | Install_Siblings (Defining_Entity (Unit (Library_Unit (N))), N); | |
3370 | end if; | |
3371 | ||
899ae34b | 3372 | if Nkind_In (Lib_Unit, N_Generic_Package_Declaration, |
3373 | N_Generic_Subprogram_Declaration, | |
3374 | N_Package_Declaration, | |
3375 | N_Subprogram_Declaration) | |
d6f39728 | 3376 | then |
3377 | if Is_Child_Spec (Lib_Unit) then | |
3378 | Lib_Parent := Defining_Entity (Unit (Parent_Spec (Lib_Unit))); | |
3379 | Set_Is_Private_Descendant | |
3380 | (Defining_Entity (Lib_Unit), | |
3381 | Is_Private_Descendant (Lib_Parent) | |
3382 | or else Private_Present (Parent (Lib_Unit))); | |
3383 | ||
3384 | else | |
3385 | Set_Is_Private_Descendant | |
3386 | (Defining_Entity (Lib_Unit), | |
3387 | Private_Present (Parent (Lib_Unit))); | |
3388 | end if; | |
3389 | end if; | |
3390 | ||
3391 | if Check_Private then | |
3392 | Check_Private_Child_Unit (N); | |
3393 | end if; | |
05e5286d | 3394 | end Install_Context_Clauses; |
9dfe12ae | 3395 | |
05e5286d | 3396 | ------------------------------------- |
3397 | -- Install_Limited_Context_Clauses -- | |
3398 | ------------------------------------- | |
9dfe12ae | 3399 | |
05e5286d | 3400 | procedure Install_Limited_Context_Clauses (N : Node_Id) is |
3401 | Item : Node_Id; | |
3402 | ||
c53c8335 | 3403 | procedure Check_Renamings (P : Node_Id; W : Node_Id); |
05e5286d | 3404 | -- Check that the unlimited view of a given compilation_unit is not |
c53c8335 | 3405 | -- already visible through "use + renamings". |
05e5286d | 3406 | |
9a504e32 | 3407 | procedure Check_Private_Limited_Withed_Unit (Item : Node_Id); |
05e5286d | 3408 | -- Check that if a limited_with clause of a given compilation_unit |
88fcd057 | 3409 | -- mentions a descendant of a private child of some library unit, then |
3410 | -- the given compilation_unit shall be the declaration of a private | |
3411 | -- descendant of that library unit, or a public descendant of such. The | |
3412 | -- code is analogous to that of Check_Private_Child_Unit but we cannot | |
3413 | -- use entities on the limited with_clauses because their units have not | |
3414 | -- been analyzed, so we have to climb the tree of ancestors looking for | |
3415 | -- private keywords. | |
05e5286d | 3416 | |
c53c8335 | 3417 | procedure Expand_Limited_With_Clause |
2fcbd967 | 3418 | (Comp_Unit : Node_Id; |
3419 | Nam : Node_Id; | |
3420 | N : Node_Id); | |
c53c8335 | 3421 | -- If a child unit appears in a limited_with clause, there are implicit |
3422 | -- limited_with clauses on all parents that are not already visible | |
3423 | -- through a regular with clause. This procedure creates the implicit | |
3424 | -- limited with_clauses for the parents and loads the corresponding | |
3425 | -- units. The shadow entities are created when the inserted clause is | |
3426 | -- analyzed. Implements Ada 2005 (AI-50217). | |
05e5286d | 3427 | |
1bce61fe | 3428 | function Is_Ancestor_Unit (U1 : Node_Id; U2 : Node_Id) return Boolean; |
3429 | -- When compiling a unit Q descended from some parent unit P, a limited | |
3430 | -- with_clause in the context of P that names some other ancestor of Q | |
3431 | -- must not be installed because the ancestor is immediately visible. | |
3432 | ||
c53c8335 | 3433 | --------------------- |
3434 | -- Check_Renamings -- | |
3435 | --------------------- | |
05e5286d | 3436 | |
c53c8335 | 3437 | procedure Check_Renamings (P : Node_Id; W : Node_Id) is |
05e5286d | 3438 | Item : Node_Id; |
3439 | Spec : Node_Id; | |
3440 | WEnt : Entity_Id; | |
3441 | Nam : Node_Id; | |
3442 | E : Entity_Id; | |
3443 | E2 : Entity_Id; | |
9dfe12ae | 3444 | |
05e5286d | 3445 | begin |
3446 | pragma Assert (Nkind (W) = N_With_Clause); | |
3447 | ||
b5be70cd | 3448 | -- Protect the frontend against previous critical errors |
3449 | ||
3450 | case Nkind (Unit (Library_Unit (W))) is | |
3451 | when N_Subprogram_Declaration | | |
3452 | N_Package_Declaration | | |
3453 | N_Generic_Subprogram_Declaration | | |
3454 | N_Generic_Package_Declaration => | |
3455 | null; | |
3456 | ||
3457 | when others => | |
3458 | return; | |
3459 | end case; | |
3460 | ||
c53c8335 | 3461 | -- Check "use + renamings" |
05e5286d | 3462 | |
3463 | WEnt := Defining_Unit_Name (Specification (Unit (Library_Unit (W)))); | |
3464 | Spec := Specification (Unit (P)); | |
3465 | ||
05e5286d | 3466 | Item := First (Visible_Declarations (Spec)); |
3467 | while Present (Item) loop | |
3468 | ||
e17ff23f | 3469 | -- Look only at use package clauses |
3470 | ||
05e5286d | 3471 | if Nkind (Item) = N_Use_Package_Clause then |
3472 | ||
3473 | -- Traverse the list of packages | |
3474 | ||
3475 | Nam := First (Names (Item)); | |
05e5286d | 3476 | while Present (Nam) loop |
3477 | E := Entity (Nam); | |
3478 | ||
3479 | pragma Assert (Present (Parent (E))); | |
3480 | ||
9c3beb70 | 3481 | if Nkind (Parent (E)) = N_Package_Renaming_Declaration |
05e5286d | 3482 | and then Renamed_Entity (E) = WEnt |
3483 | then | |
e17ff23f | 3484 | -- The unlimited view is visible through use clause and |
71c11f4a | 3485 | -- renamings. There is no need to generate the error |
e17ff23f | 3486 | -- message here because Is_Visible_Through_Renamings |
3487 | -- takes care of generating the precise error message. | |
3488 | ||
05e5286d | 3489 | return; |
3490 | ||
3491 | elsif Nkind (Parent (E)) = N_Package_Specification then | |
3492 | ||
3493 | -- The use clause may refer to a local package. | |
3494 | -- Check all the enclosing scopes. | |
3495 | ||
3496 | E2 := E; | |
3497 | while E2 /= Standard_Standard | |
2fcbd967 | 3498 | and then E2 /= WEnt |
3499 | loop | |
05e5286d | 3500 | E2 := Scope (E2); |
3501 | end loop; | |
3502 | ||
3503 | if E2 = WEnt then | |
503f7fd3 | 3504 | Error_Msg_N |
9c3beb70 | 3505 | ("unlimited view visible through use clause ", W); |
05e5286d | 3506 | return; |
3507 | end if; | |
05e5286d | 3508 | end if; |
7cb0fd86 | 3509 | |
05e5286d | 3510 | Next (Nam); |
3511 | end loop; | |
05e5286d | 3512 | end if; |
3513 | ||
3514 | Next (Item); | |
3515 | end loop; | |
3516 | ||
3517 | -- Recursive call to check all the ancestors | |
3518 | ||
3519 | if Is_Child_Spec (Unit (P)) then | |
c53c8335 | 3520 | Check_Renamings (P => Parent_Spec (Unit (P)), W => W); |
05e5286d | 3521 | end if; |
c53c8335 | 3522 | end Check_Renamings; |
05e5286d | 3523 | |
3524 | --------------------------------------- | |
3525 | -- Check_Private_Limited_Withed_Unit -- | |
3526 | --------------------------------------- | |
3527 | ||
9a504e32 | 3528 | procedure Check_Private_Limited_Withed_Unit (Item : Node_Id) is |
3529 | Curr_Parent : Node_Id; | |
3530 | Child_Parent : Node_Id; | |
3a2db8ab | 3531 | Curr_Private : Boolean; |
05e5286d | 3532 | |
3533 | begin | |
9a504e32 | 3534 | -- Compilation unit of the parent of the withed library unit |
05e5286d | 3535 | |
3a2db8ab | 3536 | Child_Parent := Library_Unit (Item); |
05e5286d | 3537 | |
9a504e32 | 3538 | -- If the child unit is a public child, then locate its nearest |
88fcd057 | 3539 | -- private ancestor, if any, then Child_Parent will then be set to |
9a504e32 | 3540 | -- the parent of that ancestor. |
05e5286d | 3541 | |
9a504e32 | 3542 | if not Private_Present (Library_Unit (Item)) then |
3543 | while Present (Child_Parent) | |
3544 | and then not Private_Present (Child_Parent) | |
3545 | loop | |
3546 | Child_Parent := Parent_Spec (Unit (Child_Parent)); | |
3547 | end loop; | |
05e5286d | 3548 | |
9a504e32 | 3549 | if No (Child_Parent) then |
3550 | return; | |
3551 | end if; | |
05e5286d | 3552 | end if; |
3553 | ||
3a2db8ab | 3554 | Child_Parent := Parent_Spec (Unit (Child_Parent)); |
3555 | ||
88fcd057 | 3556 | -- Traverse all the ancestors of the current compilation unit to |
3557 | -- check if it is a descendant of named library unit. | |
9a504e32 | 3558 | |
3559 | Curr_Parent := Parent (Item); | |
3a2db8ab | 3560 | Curr_Private := Private_Present (Curr_Parent); |
3561 | ||
9a504e32 | 3562 | while Present (Parent_Spec (Unit (Curr_Parent))) |
3563 | and then Curr_Parent /= Child_Parent | |
3564 | loop | |
3565 | Curr_Parent := Parent_Spec (Unit (Curr_Parent)); | |
3a2db8ab | 3566 | Curr_Private := Curr_Private or else Private_Present (Curr_Parent); |
9a504e32 | 3567 | end loop; |
3568 | ||
3569 | if Curr_Parent /= Child_Parent then | |
3570 | Error_Msg_N | |
3571 | ("unit in with clause is private child unit!", Item); | |
3572 | Error_Msg_NE | |
e17ff23f | 3573 | ("\current unit must also have parent&!", |
9a504e32 | 3574 | Item, Defining_Unit_Name (Specification (Unit (Child_Parent)))); |
3575 | ||
3a2db8ab | 3576 | elsif Private_Present (Parent (Item)) |
3577 | or else Curr_Private | |
3578 | or else Private_Present (Item) | |
3579 | or else Nkind_In (Unit (Parent (Item)), N_Package_Body, | |
88fcd057 | 3580 | N_Subprogram_Body, |
3581 | N_Subunit) | |
9a504e32 | 3582 | then |
15175b09 | 3583 | -- Current unit is private, of descendant of a private unit |
3a2db8ab | 3584 | |
3585 | null; | |
3586 | ||
3587 | else | |
9a504e32 | 3588 | Error_Msg_NE |
3589 | ("current unit must also be private descendant of&", | |
3590 | Item, Defining_Unit_Name (Specification (Unit (Child_Parent)))); | |
05e5286d | 3591 | end if; |
3592 | end Check_Private_Limited_Withed_Unit; | |
3593 | ||
c53c8335 | 3594 | -------------------------------- |
3595 | -- Expand_Limited_With_Clause -- | |
3596 | -------------------------------- | |
05e5286d | 3597 | |
c53c8335 | 3598 | procedure Expand_Limited_With_Clause |
3599 | (Comp_Unit : Node_Id; | |
3600 | Nam : Node_Id; | |
3601 | N : Node_Id) | |
3602 | is | |
3603 | Loc : constant Source_Ptr := Sloc (Nam); | |
3604 | Unum : Unit_Number_Type; | |
3605 | Withn : Node_Id; | |
3606 | ||
3607 | function Previous_Withed_Unit (W : Node_Id) return Boolean; | |
3608 | -- Returns true if the context already includes a with_clause for | |
3609 | -- this unit. If the with_clause is non-limited, the unit is fully | |
3610 | -- visible and an implicit limited_with should not be created. If | |
3611 | -- there is already a limited_with clause for W, a second one is | |
3612 | -- simply redundant. | |
3613 | ||
3614 | -------------------------- | |
3615 | -- Previous_Withed_Unit -- | |
3616 | -------------------------- | |
3617 | ||
3618 | function Previous_Withed_Unit (W : Node_Id) return Boolean is | |
3619 | Item : Node_Id; | |
3620 | ||
3621 | begin | |
665e279c | 3622 | -- A limited with_clause cannot appear in the same context_clause |
c53c8335 | 3623 | -- as a nonlimited with_clause which mentions the same library. |
3624 | ||
3625 | Item := First (Context_Items (Comp_Unit)); | |
3626 | while Present (Item) loop | |
3627 | if Nkind (Item) = N_With_Clause | |
3628 | and then Library_Unit (Item) = Library_Unit (W) | |
3629 | then | |
3630 | return True; | |
3631 | end if; | |
3632 | ||
3633 | Next (Item); | |
3634 | end loop; | |
3635 | ||
3636 | return False; | |
3637 | end Previous_Withed_Unit; | |
3638 | ||
3639 | -- Start of processing for Expand_Limited_With_Clause | |
05e5286d | 3640 | |
3641 | begin | |
c53c8335 | 3642 | New_Nodes_OK := New_Nodes_OK + 1; |
05e5286d | 3643 | |
c53c8335 | 3644 | if Nkind (Nam) = N_Identifier then |
e17ff23f | 3645 | |
3646 | -- Create node for name of withed unit | |
3647 | ||
9c3beb70 | 3648 | Withn := |
3649 | Make_With_Clause (Loc, | |
e17ff23f | 3650 | Name => New_Copy (Nam)); |
c53c8335 | 3651 | |
3652 | else pragma Assert (Nkind (Nam) = N_Selected_Component); | |
9c3beb70 | 3653 | Withn := |
3654 | Make_With_Clause (Loc, | |
3655 | Name => Make_Selected_Component (Loc, | |
9a504e32 | 3656 | Prefix => New_Copy_Tree (Prefix (Nam)), |
58655148 | 3657 | Selector_Name => New_Copy (Selector_Name (Nam)))); |
c53c8335 | 3658 | Set_Parent (Withn, Parent (N)); |
3659 | end if; | |
3660 | ||
3661 | Set_Limited_Present (Withn); | |
3662 | Set_First_Name (Withn); | |
3663 | Set_Implicit_With (Withn); | |
3664 | ||
3665 | Unum := | |
3666 | Load_Unit | |
3667 | (Load_Name => Get_Spec_Name (Get_Unit_Name (Nam)), | |
3668 | Required => True, | |
3669 | Subunit => False, | |
3670 | Error_Node => Nam); | |
3671 | ||
39a79c9e | 3672 | -- Do not generate a limited_with_clause on the current unit. This |
3673 | -- path is taken when a unit has a limited_with clause on one of its | |
3674 | -- child units. | |
c53c8335 | 3675 | |
9c3beb70 | 3676 | if Unum = Current_Sem_Unit then |
3677 | return; | |
3678 | end if; | |
05e5286d | 3679 | |
9c3beb70 | 3680 | Set_Library_Unit (Withn, Cunit (Unum)); |
3681 | Set_Corresponding_Spec | |
3682 | (Withn, Specification (Unit (Cunit (Unum)))); | |
c53c8335 | 3683 | |
9c3beb70 | 3684 | if not Previous_Withed_Unit (Withn) then |
3685 | Prepend (Withn, Context_Items (Parent (N))); | |
3686 | Mark_Rewrite_Insertion (Withn); | |
c53c8335 | 3687 | |
9c3beb70 | 3688 | -- Add implicit limited_with_clauses for parents of child units |
3689 | -- mentioned in limited_with clauses. | |
c53c8335 | 3690 | |
9c3beb70 | 3691 | if Nkind (Nam) = N_Selected_Component then |
3692 | Expand_Limited_With_Clause (Comp_Unit, Prefix (Nam), N); | |
3693 | end if; | |
c53c8335 | 3694 | |
9c3beb70 | 3695 | Analyze (Withn); |
3696 | ||
3697 | if not Limited_View_Installed (Withn) then | |
c53c8335 | 3698 | Install_Limited_Withed_Unit (Withn); |
3699 | end if; | |
3700 | end if; | |
3701 | ||
3702 | New_Nodes_OK := New_Nodes_OK - 1; | |
3703 | end Expand_Limited_With_Clause; | |
05e5286d | 3704 | |
1bce61fe | 3705 | ---------------------- |
3706 | -- Is_Ancestor_Unit -- | |
3707 | ---------------------- | |
3708 | ||
3709 | function Is_Ancestor_Unit (U1 : Node_Id; U2 : Node_Id) return Boolean is | |
3710 | E1 : constant Entity_Id := Defining_Entity (Unit (U1)); | |
3711 | E2 : Entity_Id; | |
3712 | begin | |
3713 | if Nkind_In (Unit (U2), N_Package_Body, N_Subprogram_Body) then | |
3714 | E2 := Defining_Entity (Unit (Library_Unit (U2))); | |
3715 | return Is_Ancestor_Package (E1, E2); | |
3716 | else | |
3717 | return False; | |
3718 | end if; | |
3719 | end Is_Ancestor_Unit; | |
3720 | ||
05e5286d | 3721 | -- Start of processing for Install_Limited_Context_Clauses |
3722 | ||
3723 | begin | |
3724 | Item := First (Context_Items (N)); | |
3725 | while Present (Item) loop | |
3726 | if Nkind (Item) = N_With_Clause | |
3727 | and then Limited_Present (Item) | |
3728 | then | |
c53c8335 | 3729 | if Nkind (Name (Item)) = N_Selected_Component then |
3730 | Expand_Limited_With_Clause | |
3731 | (Comp_Unit => N, Nam => Prefix (Name (Item)), N => Item); | |
3732 | end if; | |
05e5286d | 3733 | |
9a504e32 | 3734 | Check_Private_Limited_Withed_Unit (Item); |
05e5286d | 3735 | |
c53c8335 | 3736 | if not Implicit_With (Item) |
3737 | and then Is_Child_Spec (Unit (N)) | |
3738 | then | |
3739 | Check_Renamings (Parent_Spec (Unit (N)), Item); | |
05e5286d | 3740 | end if; |
3741 | ||
7cb0fd86 | 3742 | -- A unit may have a limited with on itself if it has a limited |
3743 | -- with_clause on one of its child units. In that case it is | |
3744 | -- already being compiled and it makes no sense to install its | |
3745 | -- limited view. | |
3746 | ||
3747 | -- If the item is a limited_private_with_clause, install it if the | |
3748 | -- current unit is a body or if it is a private child. Otherwise | |
3749 | -- the private clause is installed before analyzing the private | |
3750 | -- part of the current unit. | |
c53c8335 | 3751 | |
9c3beb70 | 3752 | if Library_Unit (Item) /= Cunit (Current_Sem_Unit) |
3753 | and then not Limited_View_Installed (Item) | |
1bce61fe | 3754 | and then |
3755 | not Is_Ancestor_Unit | |
3756 | (Library_Unit (Item), Cunit (Current_Sem_Unit)) | |
9c3beb70 | 3757 | then |
7cb0fd86 | 3758 | if not Private_Present (Item) |
2fcbd967 | 3759 | or else Private_Present (N) |
899ae34b | 3760 | or else Nkind_In (Unit (N), N_Package_Body, |
3761 | N_Subprogram_Body, | |
3762 | N_Subunit) | |
7cb0fd86 | 3763 | then |
3764 | Install_Limited_Withed_Unit (Item); | |
3765 | end if; | |
c53c8335 | 3766 | end if; |
05e5286d | 3767 | end if; |
3768 | ||
3769 | Next (Item); | |
3770 | end loop; | |
e17ff23f | 3771 | |
39a79c9e | 3772 | -- Ada 2005 (AI-412): Examine visible declarations of a package spec, |
3773 | -- looking for incomplete subtype declarations of incomplete types | |
88fcd057 | 3774 | -- visible through a limited with clause. |
e17ff23f | 3775 | |
3776 | if Ada_Version >= Ada_05 | |
3777 | and then Analyzed (N) | |
3778 | and then Nkind (Unit (N)) = N_Package_Declaration | |
3779 | then | |
3780 | declare | |
3781 | Decl : Node_Id; | |
3782 | Def_Id : Entity_Id; | |
3783 | Non_Lim_View : Entity_Id; | |
3784 | ||
3785 | begin | |
3786 | Decl := First (Visible_Declarations (Specification (Unit (N)))); | |
3787 | while Present (Decl) loop | |
3788 | if Nkind (Decl) = N_Subtype_Declaration | |
3789 | and then | |
3790 | Ekind (Defining_Identifier (Decl)) = E_Incomplete_Subtype | |
3791 | and then | |
3792 | From_With_Type (Defining_Identifier (Decl)) | |
3793 | then | |
3794 | Def_Id := Defining_Identifier (Decl); | |
3795 | Non_Lim_View := Non_Limited_View (Def_Id); | |
3796 | ||
58655148 | 3797 | if not Is_Incomplete_Type (Non_Lim_View) then |
3798 | ||
3799 | -- Convert an incomplete subtype declaration into a | |
3800 | -- corresponding non-limited view subtype declaration. | |
3801 | -- This is usually the case when analyzing a body that | |
39a79c9e | 3802 | -- has regular with clauses, when the spec has limited |
58655148 | 3803 | -- ones. |
7cb0fd86 | 3804 | |
3805 | -- If the non-limited view is still incomplete, it is | |
58655148 | 3806 | -- the dummy entry already created, and the declaration |
3807 | -- cannot be reanalyzed. This is the case when installing | |
3808 | -- a parent unit that has limited with-clauses. | |
3809 | ||
3810 | Set_Subtype_Indication (Decl, | |
3811 | New_Reference_To (Non_Lim_View, Sloc (Def_Id))); | |
3812 | Set_Etype (Def_Id, Non_Lim_View); | |
3813 | Set_Ekind (Def_Id, Subtype_Kind (Ekind (Non_Lim_View))); | |
3814 | Set_Analyzed (Decl, False); | |
3815 | ||
3816 | -- Reanalyze the declaration, suppressing the call to | |
3817 | -- Enter_Name to avoid duplicate names. | |
3818 | ||
3819 | Analyze_Subtype_Declaration | |
3820 | (N => Decl, | |
3821 | Skip => True); | |
3822 | end if; | |
e17ff23f | 3823 | end if; |
3824 | ||
3825 | Next (Decl); | |
3826 | end loop; | |
3827 | end; | |
3828 | end if; | |
05e5286d | 3829 | end Install_Limited_Context_Clauses; |
d6f39728 | 3830 | |
3831 | --------------------- | |
3832 | -- Install_Parents -- | |
3833 | --------------------- | |
3834 | ||
3835 | procedure Install_Parents (Lib_Unit : Node_Id; Is_Private : Boolean) is | |
3836 | P : Node_Id; | |
3837 | E_Name : Entity_Id; | |
3838 | P_Name : Entity_Id; | |
3839 | P_Spec : Node_Id; | |
3840 | ||
3841 | begin | |
3842 | P := Unit (Parent_Spec (Lib_Unit)); | |
f15731c4 | 3843 | P_Name := Get_Parent_Entity (P); |
d6f39728 | 3844 | |
3845 | if Etype (P_Name) = Any_Type then | |
3846 | return; | |
3847 | end if; | |
3848 | ||
3849 | if Ekind (P_Name) = E_Generic_Package | |
899ae34b | 3850 | and then not Nkind_In (Lib_Unit, N_Generic_Subprogram_Declaration, |
3851 | N_Generic_Package_Declaration) | |
d6f39728 | 3852 | and then Nkind (Lib_Unit) not in N_Generic_Renaming_Declaration |
3853 | then | |
503f7fd3 | 3854 | Error_Msg_N |
d6f39728 | 3855 | ("child of a generic package must be a generic unit", Lib_Unit); |
3856 | ||
665e279c | 3857 | elsif not Is_Package_Or_Generic_Package (P_Name) then |
d6f39728 | 3858 | Error_Msg_N |
3859 | ("parent unit must be package or generic package", Lib_Unit); | |
3860 | raise Unrecoverable_Error; | |
3861 | ||
3862 | elsif Present (Renamed_Object (P_Name)) then | |
3863 | Error_Msg_N ("parent unit cannot be a renaming", Lib_Unit); | |
3864 | raise Unrecoverable_Error; | |
3865 | ||
7cb0fd86 | 3866 | -- Verify that a child of an instance is itself an instance, or the |
3867 | -- renaming of one. Given that an instance that is a unit is replaced | |
3868 | -- with a package declaration, check against the original node. The | |
3869 | -- parent may be currently being instantiated, in which case it appears | |
3870 | -- as a declaration, but the generic_parent is already established | |
3871 | -- indicating that we deal with an instance. | |
d6f39728 | 3872 | |
f5daa077 | 3873 | elsif Nkind (Original_Node (P)) = N_Package_Instantiation then |
f5daa077 | 3874 | if Nkind (Lib_Unit) in N_Renaming_Declaration |
3875 | or else Nkind (Original_Node (Lib_Unit)) in N_Generic_Instantiation | |
3876 | or else | |
3877 | (Nkind (Lib_Unit) = N_Package_Declaration | |
9c3beb70 | 3878 | and then Present (Generic_Parent (Specification (Lib_Unit)))) |
f5daa077 | 3879 | then |
3880 | null; | |
3881 | else | |
3882 | Error_Msg_N | |
3883 | ("child of an instance must be an instance or renaming", | |
3884 | Lib_Unit); | |
3885 | end if; | |
d6f39728 | 3886 | end if; |
3887 | ||
3888 | -- This is the recursive call that ensures all parents are loaded | |
3889 | ||
3890 | if Is_Child_Spec (P) then | |
3891 | Install_Parents (P, | |
3892 | Is_Private or else Private_Present (Parent (Lib_Unit))); | |
3893 | end if; | |
3894 | ||
3895 | -- Now we can install the context for this parent | |
3896 | ||
3897 | Install_Context_Clauses (Parent_Spec (Lib_Unit)); | |
9a504e32 | 3898 | Install_Limited_Context_Clauses (Parent_Spec (Lib_Unit)); |
d6f39728 | 3899 | Install_Siblings (P_Name, Parent (Lib_Unit)); |
3900 | ||
7cb0fd86 | 3901 | -- The child unit is in the declarative region of the parent. The parent |
3902 | -- must therefore appear in the scope stack and be visible, as when | |
3903 | -- compiling the corresponding body. If the child unit is private or it | |
3904 | -- is a package body, private declarations must be accessible as well. | |
3905 | -- Use declarations in the parent must also be installed. Finally, other | |
3906 | -- child units of the same parent that are in the context are | |
3907 | -- immediately visible. | |
d6f39728 | 3908 | |
3909 | -- Find entity for compilation unit, and set its private descendant | |
3dbca0d5 | 3910 | -- status as needed. Indicate that it is a compilation unit, which is |
3911 | -- redundant in general, but needed if this is a generated child spec | |
3912 | -- for a child body without previous spec. | |
d6f39728 | 3913 | |
3914 | E_Name := Defining_Entity (Lib_Unit); | |
3915 | ||
3916 | Set_Is_Child_Unit (E_Name); | |
3dbca0d5 | 3917 | Set_Is_Compilation_Unit (E_Name); |
d6f39728 | 3918 | |
3919 | Set_Is_Private_Descendant (E_Name, | |
3920 | Is_Private_Descendant (P_Name) | |
3921 | or else Private_Present (Parent (Lib_Unit))); | |
3922 | ||
3923 | P_Spec := Specification (Unit_Declaration_Node (P_Name)); | |
f49f70c6 | 3924 | Push_Scope (P_Name); |
d6f39728 | 3925 | |
3926 | -- Save current visibility of unit | |
3927 | ||
3928 | Scope_Stack.Table (Scope_Stack.Last).Previous_Visibility := | |
3929 | Is_Immediately_Visible (P_Name); | |
3930 | Set_Is_Immediately_Visible (P_Name); | |
3931 | Install_Visible_Declarations (P_Name); | |
3932 | Set_Use (Visible_Declarations (P_Spec)); | |
3933 | ||
7cb0fd86 | 3934 | -- If the parent is a generic unit, its formal part may contain formal |
3935 | -- packages and use clauses for them. | |
9dfe12ae | 3936 | |
3937 | if Ekind (P_Name) = E_Generic_Package then | |
3938 | Set_Use (Generic_Formal_Declarations (Parent (P_Spec))); | |
3939 | end if; | |
3940 | ||
d6f39728 | 3941 | if Is_Private |
3942 | or else Private_Present (Parent (Lib_Unit)) | |
3943 | then | |
3944 | Install_Private_Declarations (P_Name); | |
3d875462 | 3945 | Install_Private_With_Clauses (P_Name); |
d6f39728 | 3946 | Set_Use (Private_Declarations (P_Spec)); |
3947 | end if; | |
3948 | end Install_Parents; | |
3949 | ||
3d875462 | 3950 | ---------------------------------- |
3951 | -- Install_Private_With_Clauses -- | |
3952 | ---------------------------------- | |
3953 | ||
3954 | procedure Install_Private_With_Clauses (P : Entity_Id) is | |
3955 | Decl : constant Node_Id := Unit_Declaration_Node (P); | |
5b941af6 | 3956 | Item : Node_Id; |
3d875462 | 3957 | |
3958 | begin | |
e27c85d0 | 3959 | if Debug_Flag_I then |
3960 | Write_Str ("install private with clauses of "); | |
3961 | Write_Name (Chars (P)); | |
3962 | Write_Eol; | |
3963 | end if; | |
3964 | ||
3d875462 | 3965 | if Nkind (Parent (Decl)) = N_Compilation_Unit then |
5b941af6 | 3966 | Item := First (Context_Items (Parent (Decl))); |
5b941af6 | 3967 | while Present (Item) loop |
3968 | if Nkind (Item) = N_With_Clause | |
3969 | and then Private_Present (Item) | |
3d875462 | 3970 | then |
5b941af6 | 3971 | if Limited_Present (Item) then |
9c3beb70 | 3972 | if not Limited_View_Installed (Item) then |
3973 | Install_Limited_Withed_Unit (Item); | |
3974 | end if; | |
5b941af6 | 3975 | else |
3976 | Install_Withed_Unit (Item, Private_With_OK => True); | |
3977 | end if; | |
3d875462 | 3978 | end if; |
3979 | ||
5b941af6 | 3980 | Next (Item); |
3d875462 | 3981 | end loop; |
3982 | end if; | |
3983 | end Install_Private_With_Clauses; | |
3984 | ||
d6f39728 | 3985 | ---------------------- |
3986 | -- Install_Siblings -- | |
3987 | ---------------------- | |
3988 | ||
3989 | procedure Install_Siblings (U_Name : Entity_Id; N : Node_Id) is | |
3990 | Item : Node_Id; | |
3991 | Id : Entity_Id; | |
3992 | Prev : Entity_Id; | |
f2e9c237 | 3993 | |
d6f39728 | 3994 | begin |
7cb0fd86 | 3995 | -- Iterate over explicit with clauses, and check whether the scope of |
3996 | -- each entity is an ancestor of the current unit, in which case it is | |
3997 | -- immediately visible. | |
d6f39728 | 3998 | |
3999 | Item := First (Context_Items (N)); | |
9c3beb70 | 4000 | while Present (Item) loop |
b5be70cd | 4001 | |
88fcd057 | 4002 | -- Do not install private_with_clauses declaration, unless unit |
4003 | -- is itself a private child unit, or is a body. Note that for a | |
4004 | -- subprogram body the private_with_clause does not take effect until | |
4005 | -- after the specification. | |
b5be70cd | 4006 | |
3a2db8ab | 4007 | if Nkind (Item) /= N_With_Clause |
4008 | or else Implicit_With (Item) | |
4009 | or else Limited_Present (Item) | |
4010 | then | |
4011 | null; | |
4012 | ||
4013 | elsif not Private_Present (Item) | |
4014 | or else Private_Present (N) | |
4015 | or else Nkind (Unit (N)) = N_Package_Body | |
d6f39728 | 4016 | then |
4017 | Id := Entity (Name (Item)); | |
4018 | ||
4019 | if Is_Child_Unit (Id) | |
e27c85d0 | 4020 | and then Is_Ancestor_Package (Scope (Id), U_Name) |
d6f39728 | 4021 | then |
4022 | Set_Is_Immediately_Visible (Id); | |
e27c85d0 | 4023 | |
88fcd057 | 4024 | -- Check for the presence of another unit in the context that |
4025 | -- may be inadvertently hidden by the child. | |
d6f39728 | 4026 | |
e27c85d0 | 4027 | Prev := Current_Entity (Id); |
4028 | ||
d6f39728 | 4029 | if Present (Prev) |
4030 | and then Is_Immediately_Visible (Prev) | |
4031 | and then not Is_Child_Unit (Prev) | |
4032 | then | |
4033 | declare | |
4034 | Clause : Node_Id; | |
4035 | ||
4036 | begin | |
4037 | Clause := First (Context_Items (N)); | |
d6f39728 | 4038 | while Present (Clause) loop |
4039 | if Nkind (Clause) = N_With_Clause | |
4040 | and then Entity (Name (Clause)) = Prev | |
4041 | then | |
4042 | Error_Msg_NE | |
4043 | ("child unit& hides compilation unit " & | |
4044 | "with the same name?", | |
4045 | Name (Item), Id); | |
4046 | exit; | |
4047 | end if; | |
4048 | ||
4049 | Next (Clause); | |
4050 | end loop; | |
4051 | end; | |
4052 | end if; | |
4053 | ||
7cb0fd86 | 4054 | -- The With_Clause may be on a grand-child or one of its further |
4055 | -- descendants, which makes a child immediately visible. Examine | |
4056 | -- ancestry to determine whether such a child exists. For example, | |
4057 | -- if current unit is A.C, and with_clause is on A.X.Y.Z, then X | |
4058 | -- is immediately visible. | |
d6f39728 | 4059 | |
e17ff23f | 4060 | elsif Is_Child_Unit (Id) then |
4061 | declare | |
4062 | Par : Entity_Id; | |
4063 | ||
4064 | begin | |
4065 | Par := Scope (Id); | |
4066 | while Is_Child_Unit (Par) loop | |
4067 | if Is_Ancestor_Package (Scope (Par), U_Name) then | |
4068 | Set_Is_Immediately_Visible (Par); | |
4069 | exit; | |
4070 | end if; | |
4071 | ||
4072 | Par := Scope (Par); | |
4073 | end loop; | |
4074 | end; | |
d6f39728 | 4075 | end if; |
3a2db8ab | 4076 | |
4077 | -- If the item is a private with-clause on a child unit, the parent | |
4078 | -- may have been installed already, but the child unit must remain | |
43e39b42 | 4079 | -- invisible until installed in a private part or body, unless there |
4080 | -- is already a regular with_clause for it in the current unit. | |
3a2db8ab | 4081 | |
4082 | elsif Private_Present (Item) then | |
4083 | Id := Entity (Name (Item)); | |
4084 | ||
4085 | if Is_Child_Unit (Id) then | |
43e39b42 | 4086 | declare |
4087 | Clause : Node_Id; | |
4088 | ||
4089 | function In_Context return Boolean; | |
4090 | -- Scan context of current unit, to check whether there is | |
4091 | -- a with_clause on the same unit as a private with-clause | |
1bce61fe | 4092 | -- on a parent, in which case child unit is visible. If the |
4093 | -- unit is a grand-child, the same applies to its parent. | |
43e39b42 | 4094 | |
b6250473 | 4095 | ---------------- |
4096 | -- In_Context -- | |
4097 | ---------------- | |
4098 | ||
43e39b42 | 4099 | function In_Context return Boolean is |
4100 | begin | |
4101 | Clause := | |
4102 | First (Context_Items (Cunit (Current_Sem_Unit))); | |
4103 | while Present (Clause) loop | |
4104 | if Nkind (Clause) = N_With_Clause | |
4105 | and then Comes_From_Source (Clause) | |
4106 | and then Is_Entity_Name (Name (Clause)) | |
43e39b42 | 4107 | and then not Private_Present (Clause) |
4108 | then | |
1bce61fe | 4109 | if Entity (Name (Clause)) = Id |
4110 | or else | |
4111 | (Nkind (Name (Clause)) = N_Expanded_Name | |
4112 | and then Entity (Prefix (Name (Clause))) = Id) | |
4113 | then | |
4114 | return True; | |
4115 | end if; | |
43e39b42 | 4116 | end if; |
4117 | ||
4118 | Next (Clause); | |
4119 | end loop; | |
4120 | ||
4121 | return False; | |
4122 | end In_Context; | |
4123 | ||
4124 | begin | |
4125 | Set_Is_Visible_Child_Unit (Id, In_Context); | |
4126 | end; | |
3a2db8ab | 4127 | end if; |
d6f39728 | 4128 | end if; |
4129 | ||
4130 | Next (Item); | |
4131 | end loop; | |
4132 | end Install_Siblings; | |
4133 | ||
3a2db8ab | 4134 | --------------------------------- |
4135 | -- Install_Limited_Withed_Unit -- | |
4136 | --------------------------------- | |
9dfe12ae | 4137 | |
4138 | procedure Install_Limited_Withed_Unit (N : Node_Id) is | |
5c61a0ff | 4139 | P_Unit : constant Entity_Id := Unit (Library_Unit (N)); |
e17ff23f | 4140 | E : Entity_Id; |
cafd02b3 | 4141 | P : Entity_Id; |
9dfe12ae | 4142 | Is_Child_Package : Boolean := False; |
2fcbd967 | 4143 | Lim_Header : Entity_Id; |
4144 | Lim_Typ : Entity_Id; | |
4145 | ||
3a2db8ab | 4146 | procedure Check_Body_Required; |
4147 | -- A unit mentioned in a limited with_clause may not be mentioned in | |
4148 | -- a regular with_clause, but must still be included in the current | |
4149 | -- partition. We need to determine whether the unit needs a body, so | |
4150 | -- that the binder can determine the name of the file to be compiled. | |
4151 | -- Checking whether a unit needs a body can be done without semantic | |
4152 | -- analysis, by examining the nature of the declarations in the package. | |
4153 | ||
2fcbd967 | 4154 | function Has_Limited_With_Clause |
4155 | (C_Unit : Entity_Id; | |
4156 | Pack : Entity_Id) return Boolean; | |
4157 | -- Determine whether any package in the ancestor chain starting with | |
4158 | -- C_Unit has a limited with clause for package Pack. | |
4159 | ||
c53c8335 | 4160 | function Is_Visible_Through_Renamings (P : Entity_Id) return Boolean; |
4161 | -- Check if some package installed though normal with-clauses has a | |
4162 | -- renaming declaration of package P. AARM 10.1.2(21/2). | |
4163 | ||
3a2db8ab | 4164 | ------------------------- |
4165 | -- Check_Body_Required -- | |
4166 | ------------------------- | |
4167 | ||
3a2db8ab | 4168 | procedure Check_Body_Required is |
4169 | PA : constant List_Id := | |
4170 | Pragmas_After (Aux_Decls_Node (Parent (P_Unit))); | |
4171 | ||
4172 | procedure Check_Declarations (Spec : Node_Id); | |
4173 | -- Recursive procedure that does the work and checks nested packages | |
4174 | ||
4175 | ------------------------ | |
4176 | -- Check_Declarations -- | |
4177 | ------------------------ | |
4178 | ||
4179 | procedure Check_Declarations (Spec : Node_Id) is | |
4180 | Decl : Node_Id; | |
4181 | Incomplete_Decls : constant Elist_Id := New_Elmt_List; | |
4182 | ||
aab73971 | 4183 | Subp_List : constant Elist_Id := New_Elmt_List; |
4184 | ||
4185 | procedure Check_Pragma_Import (P : Node_Id); | |
4186 | -- If a pragma import applies to a previous subprogram, the | |
449a120b | 4187 | -- enclosing unit may not need a body. The processing is syntactic |
4188 | -- and does not require a declaration to be analyzed. The code | |
4189 | -- below also handles pragma Import when applied to a subprogram | |
4190 | -- that renames another. In this case the pragma applies to the | |
4191 | -- renamed entity. | |
4192 | -- | |
aab73971 | 4193 | -- Chains of multiple renames are not handled by the code below. |
4194 | -- It is probably impossible to handle all cases without proper | |
4195 | -- name resolution. In such cases the algorithm is conservative | |
4196 | -- and will indicate that a body is needed??? | |
4197 | ||
4198 | ------------------------- | |
4199 | -- Check_Pragma_Import -- | |
4200 | ------------------------- | |
4201 | ||
4202 | procedure Check_Pragma_Import (P : Node_Id) is | |
4203 | Arg : Node_Id; | |
4204 | Prev_Id : Elmt_Id; | |
4205 | Subp_Id : Elmt_Id; | |
4206 | Imported : Node_Id; | |
4207 | ||
4208 | procedure Remove_Homonyms (E : Node_Id); | |
449a120b | 4209 | -- Make one pass over list of subprograms. Called again if |
aab73971 | 4210 | -- subprogram is a renaming. E is known to be an identifier. |
4211 | ||
4212 | --------------------- | |
4213 | -- Remove_Homonyms -- | |
4214 | --------------------- | |
4215 | ||
449a120b | 4216 | procedure Remove_Homonyms (E : Node_Id) is |
aab73971 | 4217 | R : Entity_Id := Empty; |
449a120b | 4218 | -- Name of renamed entity, if any |
aab73971 | 4219 | |
4220 | begin | |
4221 | Subp_Id := First_Elmt (Subp_List); | |
aab73971 | 4222 | while Present (Subp_Id) loop |
4223 | if Chars (Node (Subp_Id)) = Chars (E) then | |
4224 | if Nkind (Parent (Parent (Node (Subp_Id)))) | |
4225 | /= N_Subprogram_Renaming_Declaration | |
4226 | then | |
4227 | Prev_Id := Subp_Id; | |
4228 | Next_Elmt (Subp_Id); | |
4229 | Remove_Elmt (Subp_List, Prev_Id); | |
4230 | else | |
4231 | R := Name (Parent (Parent (Node (Subp_Id)))); | |
4232 | exit; | |
4233 | end if; | |
4234 | else | |
4235 | Next_Elmt (Subp_Id); | |
4236 | end if; | |
4237 | end loop; | |
4238 | ||
4239 | if Present (R) then | |
4240 | if Nkind (R) = N_Identifier then | |
4241 | Remove_Homonyms (R); | |
4242 | ||
4243 | elsif Nkind (R) = N_Selected_Component then | |
4244 | Remove_Homonyms (Selector_Name (R)); | |
4245 | ||
449a120b | 4246 | -- Renaming of attribute |
aab73971 | 4247 | |
449a120b | 4248 | else |
aab73971 | 4249 | null; |
4250 | end if; | |
4251 | end if; | |
4252 | end Remove_Homonyms; | |
4253 | ||
449a120b | 4254 | -- Start of processing for Check_Pragma_Import |
aab73971 | 4255 | |
4256 | begin | |
aab73971 | 4257 | -- Find name of entity in Import pragma. We have not analyzed |
4258 | -- the construct, so we must guard against syntax errors. | |
4259 | ||
4260 | Arg := Next (First (Pragma_Argument_Associations (P))); | |
4261 | ||
4262 | if No (Arg) | |
4263 | or else Nkind (Expression (Arg)) /= N_Identifier | |
4264 | then | |
4265 | return; | |
4266 | else | |
4267 | Imported := Expression (Arg); | |
4268 | end if; | |
4269 | ||
4270 | Remove_Homonyms (Imported); | |
4271 | end Check_Pragma_Import; | |
4272 | ||
449a120b | 4273 | -- Start of processing for Check_Declarations |
4274 | ||
3a2db8ab | 4275 | begin |
4276 | -- Search for Elaborate Body pragma | |
4277 | ||
4278 | Decl := First (Visible_Declarations (Spec)); | |
4279 | while Present (Decl) | |
4280 | and then Nkind (Decl) = N_Pragma | |
4281 | loop | |
4282 | if Get_Pragma_Id (Decl) = Pragma_Elaborate_Body then | |
4283 | Set_Body_Required (Library_Unit (N)); | |
4284 | return; | |
4285 | end if; | |
4286 | ||
4287 | Next (Decl); | |
4288 | end loop; | |
4289 | ||
88fcd057 | 4290 | -- Look for declarations that require the presence of a body. We |
4291 | -- have already skipped pragmas at the start of the list. | |
3a2db8ab | 4292 | |
4293 | while Present (Decl) loop | |
4294 | ||
aab73971 | 4295 | -- Subprogram that comes from source means body may be needed. |
4296 | -- Save for subsequent examination of import pragmas. | |
3a2db8ab | 4297 | |
4298 | if Comes_From_Source (Decl) | |
4299 | and then (Nkind_In (Decl, N_Subprogram_Declaration, | |
aab73971 | 4300 | N_Subprogram_Renaming_Declaration, |
3a2db8ab | 4301 | N_Generic_Subprogram_Declaration)) |
4302 | then | |
aab73971 | 4303 | Append_Elmt (Defining_Entity (Decl), Subp_List); |
3a2db8ab | 4304 | |
4305 | -- Package declaration of generic package declaration. We need | |
4306 | -- to recursively examine nested declarations. | |
4307 | ||
4308 | elsif Nkind_In (Decl, N_Package_Declaration, | |
4309 | N_Generic_Package_Declaration) | |
4310 | then | |
4311 | Check_Declarations (Specification (Decl)); | |
aab73971 | 4312 | |
4313 | elsif Nkind (Decl) = N_Pragma | |
4314 | and then Pragma_Name (Decl) = Name_Import | |
4315 | then | |
4316 | Check_Pragma_Import (Decl); | |
3a2db8ab | 4317 | end if; |
4318 | ||
4319 | Next (Decl); | |
4320 | end loop; | |
4321 | ||
4322 | -- Same set of tests for private part. In addition to subprograms | |
4323 | -- detect the presence of Taft Amendment types (incomplete types | |
4324 | -- completed in the body). | |
4325 | ||
4326 | Decl := First (Private_Declarations (Spec)); | |
4327 | while Present (Decl) loop | |
4328 | if Comes_From_Source (Decl) | |
4329 | and then (Nkind_In (Decl, N_Subprogram_Declaration, | |
aab73971 | 4330 | N_Subprogram_Renaming_Declaration, |
3a2db8ab | 4331 | N_Generic_Subprogram_Declaration)) |
4332 | then | |
aab73971 | 4333 | Append_Elmt (Defining_Entity (Decl), Subp_List); |
3a2db8ab | 4334 | |
4335 | elsif Nkind_In (Decl, N_Package_Declaration, | |
4336 | N_Generic_Package_Declaration) | |
4337 | then | |
4338 | Check_Declarations (Specification (Decl)); | |
4339 | ||
4340 | -- Collect incomplete type declarations for separate pass | |
4341 | ||
4342 | elsif Nkind (Decl) = N_Incomplete_Type_Declaration then | |
4343 | Append_Elmt (Decl, Incomplete_Decls); | |
aab73971 | 4344 | |
4345 | elsif Nkind (Decl) = N_Pragma | |
4346 | and then Pragma_Name (Decl) = Name_Import | |
4347 | then | |
4348 | Check_Pragma_Import (Decl); | |
3a2db8ab | 4349 | end if; |
4350 | ||
4351 | Next (Decl); | |
4352 | end loop; | |
4353 | ||
4354 | -- Now check incomplete declarations to locate Taft amendment | |
2c145f84 | 4355 | -- types. This can be done by examining the defining identifiers |
3a2db8ab | 4356 | -- of type declarations without real semantic analysis. |
4357 | ||
4358 | declare | |
4359 | Inc : Elmt_Id; | |
4360 | ||
4361 | begin | |
4362 | Inc := First_Elmt (Incomplete_Decls); | |
4363 | while Present (Inc) loop | |
4364 | Decl := Next (Node (Inc)); | |
4365 | while Present (Decl) loop | |
4366 | if Nkind (Decl) = N_Full_Type_Declaration | |
4367 | and then Chars (Defining_Identifier (Decl)) = | |
4368 | Chars (Defining_Identifier (Node (Inc))) | |
4369 | then | |
4370 | exit; | |
4371 | end if; | |
4372 | ||
4373 | Next (Decl); | |
4374 | end loop; | |
4375 | ||
4376 | -- If no completion, this is a TAT, and a body is needed | |
4377 | ||
4378 | if No (Decl) then | |
4379 | Set_Body_Required (Library_Unit (N)); | |
4380 | return; | |
4381 | end if; | |
4382 | ||
4383 | Next_Elmt (Inc); | |
4384 | end loop; | |
4385 | end; | |
aab73971 | 4386 | |
39a79c9e | 4387 | -- Finally, check whether there are subprograms that still require |
4388 | -- a body, i.e. are not renamings or null. | |
aab73971 | 4389 | |
4390 | if not Is_Empty_Elmt_List (Subp_List) then | |
4391 | declare | |
4392 | Subp_Id : Elmt_Id; | |
d24288e3 | 4393 | Spec : Node_Id; |
aab73971 | 4394 | |
4395 | begin | |
4396 | Subp_Id := First_Elmt (Subp_List); | |
d24288e3 | 4397 | Spec := Parent (Node (Subp_Id)); |
aab73971 | 4398 | |
4399 | while Present (Subp_Id) loop | |
d24288e3 | 4400 | if Nkind (Parent (Spec)) |
4401 | = N_Subprogram_Renaming_Declaration | |
aab73971 | 4402 | then |
d24288e3 | 4403 | null; |
4404 | ||
4405 | elsif Nkind (Spec) = N_Procedure_Specification | |
4406 | and then Null_Present (Spec) | |
4407 | then | |
4408 | null; | |
4409 | ||
4410 | else | |
aab73971 | 4411 | Set_Body_Required (Library_Unit (N)); |
4412 | return; | |
4413 | end if; | |
4414 | ||
4415 | Next_Elmt (Subp_Id); | |
4416 | end loop; | |
4417 | end; | |
4418 | end if; | |
3a2db8ab | 4419 | end Check_Declarations; |
4420 | ||
4421 | -- Start of processing for Check_Body_Required | |
4422 | ||
4423 | begin | |
4424 | -- If this is an imported package (Java and CIL usage) no body is | |
4425 | -- needed. Scan list of pragmas that may follow a compilation unit | |
4426 | -- to look for a relevant pragma Import. | |
4427 | ||
4428 | if Present (PA) then | |
4429 | declare | |
4430 | Prag : Node_Id; | |
4431 | ||
4432 | begin | |
4433 | Prag := First (PA); | |
4434 | while Present (Prag) loop | |
4435 | if Nkind (Prag) = N_Pragma | |
4436 | and then Get_Pragma_Id (Prag) = Pragma_Import | |
4437 | then | |
4438 | return; | |
4439 | end if; | |
4440 | ||
4441 | Next (Prag); | |
4442 | end loop; | |
4443 | end; | |
4444 | end if; | |
4445 | ||
4446 | Check_Declarations (Specification (P_Unit)); | |
4447 | end Check_Body_Required; | |
4448 | ||
2fcbd967 | 4449 | ----------------------------- |
4450 | -- Has_Limited_With_Clause -- | |
4451 | ----------------------------- | |
4452 | ||
4453 | function Has_Limited_With_Clause | |
4454 | (C_Unit : Entity_Id; | |
4455 | Pack : Entity_Id) return Boolean | |
4456 | is | |
4457 | Par : Entity_Id; | |
4458 | Par_Unit : Node_Id; | |
4459 | ||
4460 | begin | |
4461 | Par := C_Unit; | |
4462 | while Present (Par) loop | |
4463 | if Ekind (Par) /= E_Package then | |
4464 | exit; | |
4465 | end if; | |
4466 | ||
4467 | -- Retrieve the Compilation_Unit node for Par and determine if | |
4468 | -- its context clauses contain a limited with for Pack. | |
4469 | ||
4470 | Par_Unit := Parent (Parent (Parent (Par))); | |
4471 | ||
4472 | if Nkind (Par_Unit) = N_Package_Declaration then | |
4473 | Par_Unit := Parent (Par_Unit); | |
4474 | end if; | |
4475 | ||
4476 | if Has_With_Clause (Par_Unit, Pack, True) then | |
4477 | return True; | |
4478 | end if; | |
4479 | ||
39a79c9e | 4480 | -- If there are more ancestors, climb up the tree, otherwise we |
4481 | -- are done. | |
2fcbd967 | 4482 | |
4483 | if Is_Child_Unit (Par) then | |
4484 | Par := Scope (Par); | |
4485 | else | |
4486 | exit; | |
4487 | end if; | |
4488 | end loop; | |
4489 | ||
4490 | return False; | |
4491 | end Has_Limited_With_Clause; | |
4492 | ||
c53c8335 | 4493 | ---------------------------------- |
4494 | -- Is_Visible_Through_Renamings -- | |
4495 | ---------------------------------- | |
4496 | ||
4497 | function Is_Visible_Through_Renamings (P : Entity_Id) return Boolean is | |
9c3beb70 | 4498 | Kind : constant Node_Kind := |
4499 | Nkind (Unit (Cunit (Current_Sem_Unit))); | |
c53c8335 | 4500 | Aux_Unit : Node_Id; |
4501 | Item : Node_Id; | |
4502 | Decl : Entity_Id; | |
4503 | ||
4504 | begin | |
4505 | -- Example of the error detected by this subprogram: | |
4506 | ||
4507 | -- package P is | |
4508 | -- type T is ... | |
4509 | -- end P; | |
4510 | ||
4511 | -- with P; | |
4512 | -- package Q is | |
4513 | -- package Ren_P renames P; | |
4514 | -- end Q; | |
4515 | ||
4516 | -- with Q; | |
4517 | -- package R is ... | |
4518 | ||
4519 | -- limited with P; -- ERROR | |
4520 | -- package R.C is ... | |
4521 | ||
4522 | Aux_Unit := Cunit (Current_Sem_Unit); | |
9a504e32 | 4523 | |
c53c8335 | 4524 | loop |
4525 | Item := First (Context_Items (Aux_Unit)); | |
4526 | while Present (Item) loop | |
4527 | if Nkind (Item) = N_With_Clause | |
4528 | and then not Limited_Present (Item) | |
f2e9c237 | 4529 | and then Nkind (Unit (Library_Unit (Item))) = |
4530 | N_Package_Declaration | |
c53c8335 | 4531 | then |
4532 | Decl := | |
4533 | First (Visible_Declarations | |
4534 | (Specification (Unit (Library_Unit (Item))))); | |
4535 | while Present (Decl) loop | |
4536 | if Nkind (Decl) = N_Package_Renaming_Declaration | |
4537 | and then Entity (Name (Decl)) = P | |
4538 | then | |
4539 | -- Generate the error message only if the current unit | |
4540 | -- is a package declaration; in case of subprogram | |
71c11f4a | 4541 | -- bodies and package bodies we just return True to |
c53c8335 | 4542 | -- indicate that the limited view must not be |
4543 | -- installed. | |
4544 | ||
4545 | if Kind = N_Package_Declaration then | |
503f7fd3 | 4546 | Error_Msg_N |
7cb0fd86 | 4547 | ("simultaneous visibility of the limited and " & |
4548 | "unlimited views not allowed", N); | |
c53c8335 | 4549 | Error_Msg_Sloc := Sloc (Item); |
503f7fd3 | 4550 | Error_Msg_NE |
7cb0fd86 | 4551 | ("\\ unlimited view of & visible through the " & |
4552 | "context clause #", N, P); | |
c53c8335 | 4553 | Error_Msg_Sloc := Sloc (Decl); |
7cb0fd86 | 4554 | Error_Msg_NE ("\\ and the renaming #", N, P); |
c53c8335 | 4555 | end if; |
4556 | ||
4557 | return True; | |
4558 | end if; | |
4559 | ||
4560 | Next (Decl); | |
4561 | end loop; | |
4562 | end if; | |
4563 | ||
4564 | Next (Item); | |
4565 | end loop; | |
4566 | ||
88fcd057 | 4567 | -- If it is a body not acting as spec, follow pointer to the |
71c11f4a | 4568 | -- corresponding spec, otherwise follow pointer to parent spec. |
4569 | ||
4570 | if Present (Library_Unit (Aux_Unit)) | |
4571 | and then Nkind_In (Unit (Aux_Unit), | |
4572 | N_Package_Body, N_Subprogram_Body) | |
4573 | then | |
9a504e32 | 4574 | if Aux_Unit = Library_Unit (Aux_Unit) then |
4575 | ||
4576 | -- Aux_Unit is a body that acts as a spec. Clause has | |
4577 | -- already been flagged as illegal. | |
4578 | ||
4579 | return False; | |
4580 | ||
4581 | else | |
4582 | Aux_Unit := Library_Unit (Aux_Unit); | |
4583 | end if; | |
71c11f4a | 4584 | |
c53c8335 | 4585 | else |
4586 | Aux_Unit := Parent_Spec (Unit (Aux_Unit)); | |
4587 | end if; | |
4588 | ||
9a504e32 | 4589 | exit when No (Aux_Unit); |
c53c8335 | 4590 | end loop; |
4591 | ||
4592 | return False; | |
4593 | end Is_Visible_Through_Renamings; | |
4594 | ||
9dfe12ae | 4595 | -- Start of processing for Install_Limited_Withed_Unit |
4596 | ||
4597 | begin | |
9c3beb70 | 4598 | pragma Assert (not Limited_View_Installed (N)); |
4599 | ||
cafd02b3 | 4600 | -- In case of limited with_clause on subprograms, generics, instances, |
b5be70cd | 4601 | -- or renamings, the corresponding error was previously posted and we |
3a2db8ab | 4602 | -- have nothing to do here. If the file is missing altogether, it has |
4603 | -- no source location. | |
cafd02b3 | 4604 | |
3a2db8ab | 4605 | if Nkind (P_Unit) /= N_Package_Declaration |
4606 | or else Sloc (P_Unit) = No_Location | |
4607 | then | |
b5be70cd | 4608 | return; |
4609 | end if; | |
cafd02b3 | 4610 | |
4611 | P := Defining_Unit_Name (Specification (P_Unit)); | |
4612 | ||
9c3beb70 | 4613 | -- Handle child packages |
9dfe12ae | 4614 | |
9c3beb70 | 4615 | if Nkind (P) = N_Defining_Program_Unit_Name then |
9dfe12ae | 4616 | Is_Child_Package := True; |
4617 | P := Defining_Identifier (P); | |
4618 | end if; | |
4619 | ||
6f152d7a | 4620 | -- Do not install the limited-view if the context of the unit is already |
4621 | -- available through a regular with clause. | |
4622 | ||
4623 | if Nkind (Unit (Cunit (Current_Sem_Unit))) = N_Package_Body | |
4624 | and then Has_With_Clause (Cunit (Current_Sem_Unit), P) | |
4625 | then | |
4626 | return; | |
4627 | end if; | |
4628 | ||
c53c8335 | 4629 | -- Do not install the limited-view if the full-view is already visible |
9c3beb70 | 4630 | -- through renaming declarations. |
c53c8335 | 4631 | |
4632 | if Is_Visible_Through_Renamings (P) then | |
4633 | return; | |
4634 | end if; | |
4635 | ||
f49f70c6 | 4636 | -- Do not install the limited view if this is the unit being analyzed. |
4637 | -- This unusual case will happen when a unit has a limited_with clause | |
39a79c9e | 4638 | -- on one of its children. The compilation of the child forces the load |
4639 | -- of the parent which tries to install the limited view of the child | |
4640 | -- again. Installing the limited view must also be disabled when | |
4641 | -- compiling the body of the child unit. | |
f49f70c6 | 4642 | |
7cb0fd86 | 4643 | if P = Cunit_Entity (Current_Sem_Unit) |
4644 | or else | |
4645 | (Nkind (Unit (Cunit (Current_Sem_Unit))) = N_Package_Body | |
2fcbd967 | 4646 | and then P = Main_Unit_Entity) |
4647 | then | |
4648 | return; | |
4649 | end if; | |
4650 | ||
39a79c9e | 4651 | -- This scenario is similar to the one above, the difference is that the |
4652 | -- compilation of sibling Par.Sib forces the load of parent Par which | |
4653 | -- tries to install the limited view of Lim_Pack [1]. However Par.Sib | |
4654 | -- has a with clause for Lim_Pack [2] in its body, and thus needs the | |
4655 | -- non-limited views of all entities from Lim_Pack. | |
2fcbd967 | 4656 | |
4657 | -- limited with Lim_Pack; -- [1] | |
4658 | -- package Par is ... package Lim_Pack is ... | |
4659 | ||
4660 | -- with Lim_Pack; -- [2] | |
4661 | -- package Par.Sib is ... package body Par.Sib is ... | |
4662 | ||
4663 | -- In this case Main_Unit_Entity is the spec of Par.Sib and Current_ | |
4664 | -- Sem_Unit is the body of Par.Sib. | |
4665 | ||
4666 | if Ekind (P) = E_Package | |
4667 | and then Ekind (Main_Unit_Entity) = E_Package | |
4668 | and then Is_Child_Unit (Main_Unit_Entity) | |
4669 | ||
4670 | -- The body has a regular with clause | |
4671 | ||
4672 | and then Nkind (Unit (Cunit (Current_Sem_Unit))) = N_Package_Body | |
4673 | and then Has_With_Clause (Cunit (Current_Sem_Unit), P) | |
4674 | ||
4675 | -- One of the ancestors has a limited with clause | |
4676 | ||
4677 | and then Nkind (Parent (Parent (Main_Unit_Entity))) = | |
88fcd057 | 4678 | N_Package_Specification |
2fcbd967 | 4679 | and then Has_Limited_With_Clause (Scope (Main_Unit_Entity), P) |
7cb0fd86 | 4680 | then |
f49f70c6 | 4681 | return; |
4682 | end if; | |
4683 | ||
39a79c9e | 4684 | -- A common use of the limited-with is to have a limited-with in the |
4685 | -- package spec, and a normal with in its package body. For example: | |
05e5286d | 4686 | |
4687 | -- limited with X; -- [1] | |
4688 | -- package A is ... | |
4689 | ||
4690 | -- with X; -- [2] | |
4691 | -- package body A is ... | |
4692 | ||
9c3beb70 | 4693 | -- The compilation of A's body installs the context clauses found at [2] |
4694 | -- and then the context clauses of its specification (found at [1]). As | |
4695 | -- a consequence, at [1] the specification of X has been analyzed and it | |
4696 | -- is immediately visible. According to the semantics of limited-with | |
4697 | -- context clauses we don't install the limited view because the full | |
4698 | -- view of X supersedes its limited view. | |
05e5286d | 4699 | |
9c3beb70 | 4700 | if Analyzed (P_Unit) |
3a2db8ab | 4701 | and then |
4702 | (Is_Immediately_Visible (P) | |
88fcd057 | 4703 | or else (Is_Child_Package and then Is_Visible_Child_Unit (P))) |
9dfe12ae | 4704 | then |
9dfe12ae | 4705 | return; |
4706 | end if; | |
4707 | ||
05e5286d | 4708 | if Debug_Flag_I then |
4709 | Write_Str ("install limited view of "); | |
4710 | Write_Name (Chars (P)); | |
4711 | Write_Eol; | |
4712 | end if; | |
4713 | ||
9c3beb70 | 4714 | -- If the unit has not been analyzed and the limited view has not been |
4715 | -- already installed then we install it. | |
4716 | ||
4717 | if not Analyzed (P_Unit) then | |
4718 | if not In_Chain (P) then | |
9dfe12ae | 4719 | |
9c3beb70 | 4720 | -- Minimum decoration |
4721 | ||
4722 | Set_Ekind (P, E_Package); | |
4723 | Set_Etype (P, Standard_Void_Type); | |
4724 | Set_Scope (P, Standard_Standard); | |
4725 | ||
4726 | if Is_Child_Package then | |
4727 | Set_Is_Child_Unit (P); | |
4728 | Set_Is_Visible_Child_Unit (P); | |
4729 | Set_Scope (P, Defining_Entity (Unit (Parent_Spec (P_Unit)))); | |
4730 | end if; | |
4731 | ||
4732 | -- Place entity on visibility structure | |
9dfe12ae | 4733 | |
9dfe12ae | 4734 | Set_Homonym (P, Current_Entity (P)); |
4735 | Set_Current_Entity (P); | |
05e5286d | 4736 | |
4737 | if Debug_Flag_I then | |
4738 | Write_Str (" (homonym) chain "); | |
4739 | Write_Name (Chars (P)); | |
4740 | Write_Eol; | |
4741 | end if; | |
4742 | ||
9c3beb70 | 4743 | -- Install the incomplete view. The first element of the limited |
4744 | -- view is a header (an E_Package entity) used to reference the | |
4745 | -- first shadow entity in the private part of the package. | |
9dfe12ae | 4746 | |
9c3beb70 | 4747 | Lim_Header := Limited_View (P); |
4748 | Lim_Typ := First_Entity (Lim_Header); | |
9dfe12ae | 4749 | |
9c3beb70 | 4750 | while Present (Lim_Typ) |
4751 | and then Lim_Typ /= First_Private_Entity (Lim_Header) | |
4752 | loop | |
4753 | Set_Homonym (Lim_Typ, Current_Entity (Lim_Typ)); | |
4754 | Set_Current_Entity (Lim_Typ); | |
9dfe12ae | 4755 | |
9c3beb70 | 4756 | if Debug_Flag_I then |
4757 | Write_Str (" (homonym) chain "); | |
4758 | Write_Name (Chars (Lim_Typ)); | |
4759 | Write_Eol; | |
4760 | end if; | |
9dfe12ae | 4761 | |
9c3beb70 | 4762 | Next_Entity (Lim_Typ); |
4763 | end loop; | |
9dfe12ae | 4764 | end if; |
05e5286d | 4765 | |
9c3beb70 | 4766 | -- If the unit appears in a previous regular with_clause, the regular |
4767 | -- entities of the public part of the withed package must be replaced | |
4768 | -- by the shadow ones. | |
4769 | ||
4770 | -- This code must be kept synchronized with the code that replaces the | |
7cb0fd86 | 4771 | -- shadow entities by the real entities (see body of Remove_Limited |
9c3beb70 | 4772 | -- With_Clause); otherwise the contents of the homonym chains are not |
4773 | -- consistent. | |
4774 | ||
4775 | else | |
4776 | -- Hide all the type entities of the public part of the package to | |
4777 | -- avoid its usage. This is needed to cover all the subtype decla- | |
4778 | -- rations because we do not remove them from the homonym chain. | |
9dfe12ae | 4779 | |
e17ff23f | 4780 | E := First_Entity (P); |
4781 | while Present (E) and then E /= First_Private_Entity (P) loop | |
4782 | if Is_Type (E) then | |
4783 | Set_Was_Hidden (E, Is_Hidden (E)); | |
4784 | Set_Is_Hidden (E); | |
4785 | end if; | |
9dfe12ae | 4786 | |
e17ff23f | 4787 | Next_Entity (E); |
4788 | end loop; | |
9dfe12ae | 4789 | |
9c3beb70 | 4790 | -- Replace the real entities by the shadow entities of the limited |
4791 | -- view. The first element of the limited view is a header that is | |
4792 | -- used to reference the first shadow entity in the private part | |
7cb0fd86 | 4793 | -- of the package. Successive elements are the limited views of the |
4794 | -- type (including regular incomplete types) declared in the package. | |
9dfe12ae | 4795 | |
9c3beb70 | 4796 | Lim_Header := Limited_View (P); |
9dfe12ae | 4797 | |
9c3beb70 | 4798 | Lim_Typ := First_Entity (Lim_Header); |
4799 | while Present (Lim_Typ) | |
4800 | and then Lim_Typ /= First_Private_Entity (Lim_Header) | |
4801 | loop | |
4802 | pragma Assert (not In_Chain (Lim_Typ)); | |
5b941af6 | 4803 | |
e17ff23f | 4804 | -- Do not unchain nested packages and child units |
9dfe12ae | 4805 | |
e17ff23f | 4806 | if Ekind (Lim_Typ) /= E_Package |
4807 | and then not Is_Child_Unit (Lim_Typ) | |
4808 | then | |
9c3beb70 | 4809 | declare |
4810 | Prev : Entity_Id; | |
9dfe12ae | 4811 | |
9c3beb70 | 4812 | begin |
9c3beb70 | 4813 | Prev := Current_Entity (Lim_Typ); |
7cb0fd86 | 4814 | E := Prev; |
9dfe12ae | 4815 | |
39a79c9e | 4816 | -- Replace E in the homonyms list, so that the limited view |
4817 | -- becomes available. | |
e17ff23f | 4818 | |
4819 | if E = Non_Limited_View (Lim_Typ) then | |
4820 | Set_Homonym (Lim_Typ, Homonym (Prev)); | |
9c3beb70 | 4821 | Set_Current_Entity (Lim_Typ); |
e17ff23f | 4822 | |
9c3beb70 | 4823 | else |
9c3beb70 | 4824 | loop |
e17ff23f | 4825 | E := Homonym (Prev); |
e17ff23f | 4826 | |
39a79c9e | 4827 | -- E may have been removed when installing a previous |
4828 | -- limited_with_clause. | |
e17ff23f | 4829 | |
7cb0fd86 | 4830 | exit when No (E); |
e17ff23f | 4831 | |
4832 | exit when E = Non_Limited_View (Lim_Typ); | |
4833 | ||
9c3beb70 | 4834 | Prev := Homonym (Prev); |
4835 | end loop; | |
05e5286d | 4836 | |
7cb0fd86 | 4837 | if Present (E) then |
4838 | Set_Homonym (Lim_Typ, Homonym (Homonym (Prev))); | |
4839 | Set_Homonym (Prev, Lim_Typ); | |
4840 | end if; | |
9c3beb70 | 4841 | end if; |
4842 | end; | |
4843 | ||
4844 | if Debug_Flag_I then | |
4845 | Write_Str (" (homonym) chain "); | |
4846 | Write_Name (Chars (Lim_Typ)); | |
4847 | Write_Eol; | |
4848 | end if; | |
05e5286d | 4849 | end if; |
9dfe12ae | 4850 | |
9c3beb70 | 4851 | Next_Entity (Lim_Typ); |
4852 | end loop; | |
4853 | end if; | |
9dfe12ae | 4854 | |
9c3beb70 | 4855 | -- The package must be visible while the limited-with clause is active |
4856 | -- because references to the type P.T must resolve in the usual way. | |
4857 | -- In addition, we remember that the limited-view has been installed to | |
4858 | -- uninstall it at the point of context removal. | |
9dfe12ae | 4859 | |
9c3beb70 | 4860 | Set_Is_Immediately_Visible (P); |
9dfe12ae | 4861 | Set_Limited_View_Installed (N); |
9a504e32 | 4862 | |
3a2db8ab | 4863 | -- If unit has not been analyzed in some previous context, check |
4864 | -- (imperfectly ???) whether it might need a body. | |
4865 | ||
4866 | if not Analyzed (P_Unit) then | |
4867 | Check_Body_Required; | |
4868 | end if; | |
4869 | ||
39a79c9e | 4870 | -- If the package in the limited_with clause is a child unit, the clause |
4871 | -- is unanalyzed and appears as a selected component. Recast it as an | |
4872 | -- expanded name so that the entity can be properly set. Use entity of | |
4873 | -- parent, if available, for higher ancestors in the name. | |
9a504e32 | 4874 | |
4875 | if Nkind (Name (N)) = N_Selected_Component then | |
4876 | declare | |
4877 | Nam : Node_Id; | |
4878 | Ent : Entity_Id; | |
e17ff23f | 4879 | |
9a504e32 | 4880 | begin |
4881 | Nam := Name (N); | |
4882 | Ent := P; | |
4883 | while Nkind (Nam) = N_Selected_Component | |
4884 | and then Present (Ent) | |
4885 | loop | |
4886 | Change_Selected_Component_To_Expanded_Name (Nam); | |
e17ff23f | 4887 | |
4888 | -- Set entity of parent identifiers if the unit is a child | |
4889 | -- unit. This ensures that the tree is properly formed from | |
4890 | -- semantic point of view (e.g. for ASIS queries). | |
4891 | ||
4892 | Set_Entity (Nam, Ent); | |
4893 | ||
9a504e32 | 4894 | Nam := Prefix (Nam); |
4895 | Ent := Scope (Ent); | |
e17ff23f | 4896 | |
4897 | -- Set entity of last ancestor | |
4898 | ||
4899 | if Nkind (Nam) = N_Identifier then | |
4900 | Set_Entity (Nam, Ent); | |
4901 | end if; | |
9a504e32 | 4902 | end loop; |
4903 | end; | |
4904 | end if; | |
4905 | ||
4906 | Set_Entity (Name (N), P); | |
05e5286d | 4907 | Set_From_With_Type (P); |
9dfe12ae | 4908 | end Install_Limited_Withed_Unit; |
4909 | ||
d6f39728 | 4910 | ------------------------- |
4911 | -- Install_Withed_Unit -- | |
4912 | ------------------------- | |
4913 | ||
3d875462 | 4914 | procedure Install_Withed_Unit |
4915 | (With_Clause : Node_Id; | |
4916 | Private_With_OK : Boolean := False) | |
4917 | is | |
9dfe12ae | 4918 | Uname : constant Entity_Id := Entity (Name (With_Clause)); |
d6f39728 | 4919 | P : constant Entity_Id := Scope (Uname); |
4920 | ||
4921 | begin | |
e2aa7314 | 4922 | -- Ada 2005 (AI-262): Do not install the private withed unit if we are |
e27c85d0 | 4923 | -- compiling a package declaration and the Private_With_OK flag was not |
4924 | -- set by the caller. These declarations will be installed later (before | |
4925 | -- analyzing the private part of the package). | |
4926 | ||
4927 | if Private_Present (With_Clause) | |
b5be70cd | 4928 | and then Nkind (Unit (Parent (With_Clause))) = N_Package_Declaration |
e27c85d0 | 4929 | and then not (Private_With_OK) |
4930 | then | |
4931 | return; | |
4932 | end if; | |
05e5286d | 4933 | |
4934 | if Debug_Flag_I then | |
e27c85d0 | 4935 | if Private_Present (With_Clause) then |
4936 | Write_Str ("install private withed unit "); | |
4937 | else | |
4938 | Write_Str ("install withed unit "); | |
4939 | end if; | |
4940 | ||
05e5286d | 4941 | Write_Name (Chars (Uname)); |
4942 | Write_Eol; | |
4943 | end if; | |
4944 | ||
88fcd057 | 4945 | -- We do not apply the restrictions to an internal unit unless we are |
4946 | -- compiling the internal unit as a main unit. This check is also | |
4947 | -- skipped for dummy units (for missing packages). | |
d6f39728 | 4948 | |
4949 | if Sloc (Uname) /= No_Location | |
4950 | and then (not Is_Internal_File_Name (Unit_File_Name (Current_Sem_Unit)) | |
4951 | or else Current_Sem_Unit = Main_Unit) | |
4952 | then | |
4953 | Check_Restricted_Unit | |
4954 | (Unit_Name (Get_Source_Unit (Uname)), With_Clause); | |
4955 | end if; | |
4956 | ||
4957 | if P /= Standard_Standard then | |
4958 | ||
9c3beb70 | 4959 | -- If the unit is not analyzed after analysis of the with clause and |
4960 | -- it is an instantiation then it awaits a body and is the main unit. | |
4961 | -- Its appearance in the context of some other unit indicates a | |
4962 | -- circular dependency (DEC suite perversity). | |
d6f39728 | 4963 | |
e27c85d0 | 4964 | if not Analyzed (Uname) |
d6f39728 | 4965 | and then Nkind (Parent (Uname)) = N_Package_Instantiation |
4966 | then | |
4967 | Error_Msg_N | |
4968 | ("instantiation depends on itself", Name (With_Clause)); | |
4969 | ||
4970 | elsif not Is_Visible_Child_Unit (Uname) then | |
4971 | Set_Is_Visible_Child_Unit (Uname); | |
4972 | ||
9c3beb70 | 4973 | -- If the child unit appears in the context of its parent, it is |
4974 | -- immediately visible. | |
b5be70cd | 4975 | |
4976 | if In_Open_Scopes (Scope (Uname)) then | |
4977 | Set_Is_Immediately_Visible (Uname); | |
4978 | end if; | |
4979 | ||
d6f39728 | 4980 | if Is_Generic_Instance (Uname) |
4981 | and then Ekind (Uname) in Subprogram_Kind | |
4982 | then | |
4983 | -- Set flag as well on the visible entity that denotes the | |
4984 | -- instance, which renames the current one. | |
4985 | ||
4986 | Set_Is_Visible_Child_Unit | |
4987 | (Related_Instance | |
4988 | (Defining_Entity (Unit (Library_Unit (With_Clause))))); | |
d6f39728 | 4989 | end if; |
4990 | ||
9c3beb70 | 4991 | -- The parent unit may have been installed already, and may have |
4992 | -- appeared in a use clause. | |
d6f39728 | 4993 | |
4994 | if In_Use (Scope (Uname)) then | |
4995 | Set_Is_Potentially_Use_Visible (Uname); | |
4996 | end if; | |
4997 | ||
4998 | Set_Context_Installed (With_Clause); | |
4999 | end if; | |
5000 | ||
5001 | elsif not Is_Immediately_Visible (Uname) then | |
3d875462 | 5002 | if not Private_Present (With_Clause) |
5003 | or else Private_With_OK | |
5004 | then | |
5005 | Set_Is_Immediately_Visible (Uname); | |
5006 | end if; | |
5007 | ||
d6f39728 | 5008 | Set_Context_Installed (With_Clause); |
5009 | end if; | |
5010 | ||
5011 | -- A with-clause overrides a with-type clause: there are no restric- | |
5012 | -- tions on the use of package entities. | |
5013 | ||
5014 | if Ekind (Uname) = E_Package then | |
5015 | Set_From_With_Type (Uname, False); | |
5016 | end if; | |
e0521a36 | 5017 | |
5018 | -- Ada 2005 (AI-377): it is illegal for a with_clause to name a child | |
5019 | -- unit if there is a visible homograph for it declared in the same | |
5020 | -- declarative region. This pathological case can only arise when an | |
5021 | -- instance I1 of a generic unit G1 has an explicit child unit I1.G2, | |
5022 | -- G1 has a generic child also named G2, and the context includes with_ | |
5023 | -- clauses for both I1.G2 and for G1.G2, making an implicit declaration | |
fad45a4a | 5024 | -- of I1.G2 visible as well. If the child unit is named Standard, do |
5025 | -- not apply the check to the Standard package itself. | |
e0521a36 | 5026 | |
5027 | if Is_Child_Unit (Uname) | |
5028 | and then Is_Visible_Child_Unit (Uname) | |
5029 | and then Ada_Version >= Ada_05 | |
5030 | then | |
5031 | declare | |
5032 | Decl1 : constant Node_Id := Unit_Declaration_Node (P); | |
5033 | Decl2 : Node_Id; | |
5034 | P2 : Entity_Id; | |
5035 | U2 : Entity_Id; | |
5036 | ||
5037 | begin | |
5038 | U2 := Homonym (Uname); | |
fad45a4a | 5039 | while Present (U2) |
7cb0fd86 | 5040 | and then U2 /= Standard_Standard |
fad45a4a | 5041 | loop |
e0521a36 | 5042 | P2 := Scope (U2); |
5043 | Decl2 := Unit_Declaration_Node (P2); | |
5044 | ||
5045 | if Is_Child_Unit (U2) | |
5046 | and then Is_Visible_Child_Unit (U2) | |
5047 | then | |
5048 | if Is_Generic_Instance (P) | |
5049 | and then Nkind (Decl1) = N_Package_Declaration | |
5050 | and then Generic_Parent (Specification (Decl1)) = P2 | |
5051 | then | |
5052 | Error_Msg_N ("illegal with_clause", With_Clause); | |
5053 | Error_Msg_N | |
5054 | ("\child unit has visible homograph" & | |
7cb0fd86 | 5055 | " (RM 8.3(26), 10.1.1(19))", |
e0521a36 | 5056 | With_Clause); |
5057 | exit; | |
5058 | ||
5059 | elsif Is_Generic_Instance (P2) | |
5060 | and then Nkind (Decl2) = N_Package_Declaration | |
5061 | and then Generic_Parent (Specification (Decl2)) = P | |
5062 | then | |
5063 | -- With_clause for child unit of instance appears before | |
5064 | -- in the context. We want to place the error message on | |
5065 | -- it, not on the generic child unit itself. | |
5066 | ||
5067 | declare | |
5068 | Prev_Clause : Node_Id; | |
5069 | ||
5070 | begin | |
5071 | Prev_Clause := First (List_Containing (With_Clause)); | |
5072 | while Entity (Name (Prev_Clause)) /= U2 loop | |
5073 | Next (Prev_Clause); | |
5074 | end loop; | |
5075 | ||
5076 | pragma Assert (Present (Prev_Clause)); | |
5077 | Error_Msg_N ("illegal with_clause", Prev_Clause); | |
5078 | Error_Msg_N | |
5079 | ("\child unit has visible homograph" & | |
7cb0fd86 | 5080 | " (RM 8.3(26), 10.1.1(19))", |
e0521a36 | 5081 | Prev_Clause); |
5082 | exit; | |
5083 | end; | |
5084 | end if; | |
5085 | end if; | |
5086 | ||
5087 | U2 := Homonym (U2); | |
5088 | end loop; | |
5089 | end; | |
5090 | end if; | |
d6f39728 | 5091 | end Install_Withed_Unit; |
5092 | ||
5093 | ------------------- | |
5094 | -- Is_Child_Spec -- | |
5095 | ------------------- | |
5096 | ||
5097 | function Is_Child_Spec (Lib_Unit : Node_Id) return Boolean is | |
5098 | K : constant Node_Kind := Nkind (Lib_Unit); | |
5099 | ||
5100 | begin | |
5101 | return (K in N_Generic_Declaration or else | |
5102 | K in N_Generic_Instantiation or else | |
5103 | K in N_Generic_Renaming_Declaration or else | |
5104 | K = N_Package_Declaration or else | |
5105 | K = N_Package_Renaming_Declaration or else | |
5106 | K = N_Subprogram_Declaration or else | |
5107 | K = N_Subprogram_Renaming_Declaration) | |
5108 | and then Present (Parent_Spec (Lib_Unit)); | |
5109 | end Is_Child_Spec; | |
5110 | ||
6f152d7a | 5111 | ------------------------------------ |
5112 | -- Is_Legal_Shadow_Entity_In_Body -- | |
5113 | ------------------------------------ | |
5114 | ||
5115 | function Is_Legal_Shadow_Entity_In_Body (T : Entity_Id) return Boolean is | |
5116 | C_Unit : constant Node_Id := Cunit (Current_Sem_Unit); | |
6f152d7a | 5117 | begin |
5118 | return Nkind (Unit (C_Unit)) = N_Package_Body | |
88fcd057 | 5119 | and then |
5120 | Has_With_Clause | |
5121 | (C_Unit, Cunit_Entity (Get_Source_Unit (Non_Limited_View (T)))); | |
6f152d7a | 5122 | end Is_Legal_Shadow_Entity_In_Body; |
5123 | ||
d6f39728 | 5124 | ----------------------- |
5125 | -- Load_Needed_Body -- | |
5126 | ----------------------- | |
5127 | ||
7cb0fd86 | 5128 | -- N is a generic unit named in a with clause, or else it is a unit that |
5129 | -- contains a generic unit or an inlined function. In order to perform an | |
5130 | -- instantiation, the body of the unit must be present. If the unit itself | |
5131 | -- is generic, we assume that an instantiation follows, and load & analyze | |
5132 | -- the body unconditionally. This forces analysis of the spec as well. | |
d6f39728 | 5133 | |
7cb0fd86 | 5134 | -- If the unit is not generic, but contains a generic unit, it is loaded on |
5135 | -- demand, at the point of instantiation (see ch12). | |
d6f39728 | 5136 | |
5137 | procedure Load_Needed_Body (N : Node_Id; OK : out Boolean) is | |
5138 | Body_Name : Unit_Name_Type; | |
5139 | Unum : Unit_Number_Type; | |
5140 | ||
5141 | Save_Style_Check : constant Boolean := Opt.Style_Check; | |
5142 | -- The loading and analysis is done with style checks off | |
5143 | ||
5144 | begin | |
5145 | if not GNAT_Mode then | |
5146 | Style_Check := False; | |
5147 | end if; | |
5148 | ||
5149 | Body_Name := Get_Body_Name (Get_Unit_Name (Unit (N))); | |
5150 | Unum := | |
5151 | Load_Unit | |
5152 | (Load_Name => Body_Name, | |
5153 | Required => False, | |
5154 | Subunit => False, | |
5155 | Error_Node => N, | |
5156 | Renamings => True); | |
5157 | ||
5158 | if Unum = No_Unit then | |
5159 | OK := False; | |
5160 | ||
5161 | else | |
5162 | Compiler_State := Analyzing; -- reset after load | |
5163 | ||
9dfe12ae | 5164 | if not Fatal_Error (Unum) or else Try_Semantics then |
d6f39728 | 5165 | if Debug_Flag_L then |
5166 | Write_Str ("*** Loaded generic body"); | |
5167 | Write_Eol; | |
5168 | end if; | |
5169 | ||
5170 | Semantics (Cunit (Unum)); | |
5171 | end if; | |
5172 | ||
5173 | OK := True; | |
5174 | end if; | |
5175 | ||
5176 | Style_Check := Save_Style_Check; | |
5177 | end Load_Needed_Body; | |
5178 | ||
9dfe12ae | 5179 | ------------------------- |
5180 | -- Build_Limited_Views -- | |
5181 | ------------------------- | |
5182 | ||
5183 | procedure Build_Limited_Views (N : Node_Id) is | |
5c61a0ff | 5184 | Unum : constant Unit_Number_Type := Get_Source_Unit (Library_Unit (N)); |
5185 | P : constant Entity_Id := Cunit_Entity (Unum); | |
9dfe12ae | 5186 | |
f2e9c237 | 5187 | Spec : Node_Id; -- To denote a package specification |
5188 | Lim_Typ : Entity_Id; -- To denote shadow entities | |
5189 | Comp_Typ : Entity_Id; -- To denote real entities | |
5b941af6 | 5190 | |
f2e9c237 | 5191 | Lim_Header : Entity_Id; -- Package entity |
5192 | Last_Lim_E : Entity_Id := Empty; -- Last limited entity built | |
5193 | Last_Pub_Lim_E : Entity_Id; -- To set the first private entity | |
9dfe12ae | 5194 | |
88fcd057 | 5195 | procedure Decorate_Incomplete_Type (E : Entity_Id; Scop : Entity_Id); |
9dfe12ae | 5196 | -- Add attributes of an incomplete type to a shadow entity. The same |
5197 | -- attributes are placed on the real entity, so that gigi receives | |
5198 | -- a consistent view. | |
5199 | ||
5200 | procedure Decorate_Package_Specification (P : Entity_Id); | |
5201 | -- Add attributes of a package entity to the entity in a package | |
5202 | -- declaration | |
5203 | ||
5204 | procedure Decorate_Tagged_Type | |
5205 | (Loc : Source_Ptr; | |
5206 | T : Entity_Id; | |
5207 | Scop : Entity_Id); | |
5208 | -- Set basic attributes of tagged type T, including its class_wide type. | |
5209 | -- The parameters Loc, Scope are used to decorate the class_wide type. | |
5210 | ||
88fcd057 | 5211 | procedure Build_Chain (Scope : Entity_Id; First_Decl : Node_Id); |
9dfe12ae | 5212 | -- Construct list of shadow entities and attach it to entity of |
5213 | -- package that is mentioned in a limited_with clause. | |
5214 | ||
05e5286d | 5215 | function New_Internal_Shadow_Entity |
5216 | (Kind : Entity_Kind; | |
5217 | Sloc_Value : Source_Ptr; | |
5218 | Id_Char : Character) return Entity_Id; | |
5b941af6 | 5219 | -- Build a new internal entity and append it to the list of shadow |
5220 | -- entities available through the limited-header | |
05e5286d | 5221 | |
9dfe12ae | 5222 | ----------------- |
5223 | -- Build_Chain -- | |
5224 | ----------------- | |
5225 | ||
88fcd057 | 5226 | procedure Build_Chain (Scope : Entity_Id; First_Decl : Node_Id) is |
5c61a0ff | 5227 | Analyzed_Unit : constant Boolean := Analyzed (Cunit (Unum)); |
05e5286d | 5228 | Is_Tagged : Boolean; |
5c61a0ff | 5229 | Decl : Node_Id; |
9dfe12ae | 5230 | |
5231 | begin | |
5b941af6 | 5232 | Decl := First_Decl; |
9dfe12ae | 5233 | while Present (Decl) loop |
5b941af6 | 5234 | |
5235 | -- For each library_package_declaration in the environment, there | |
5236 | -- is an implicit declaration of a *limited view* of that library | |
5237 | -- package. The limited view of a package contains: | |
7cb0fd86 | 5238 | |
5b941af6 | 5239 | -- * For each nested package_declaration, a declaration of the |
5240 | -- limited view of that package, with the same defining- | |
5241 | -- program-unit name. | |
7cb0fd86 | 5242 | |
5b941af6 | 5243 | -- * For each type_declaration in the visible part, an incomplete |
5244 | -- type-declaration with the same defining_identifier, whose | |
5245 | -- completion is the type_declaration. If the type_declaration | |
5246 | -- is tagged, then the incomplete_type_declaration is tagged | |
5247 | -- incomplete. | |
7cb0fd86 | 5248 | |
e17ff23f | 5249 | -- The partial view is tagged if the declaration has the |
5250 | -- explicit keyword, or else if it is a type extension, both | |
5251 | -- of which can be ascertained syntactically. | |
5b941af6 | 5252 | |
9dfe12ae | 5253 | if Nkind (Decl) = N_Full_Type_Declaration then |
05e5286d | 5254 | Is_Tagged := |
e17ff23f | 5255 | (Nkind (Type_Definition (Decl)) = N_Record_Definition |
5256 | and then Tagged_Present (Type_Definition (Decl))) | |
5257 | or else | |
5258 | (Nkind (Type_Definition (Decl)) = N_Derived_Type_Definition | |
5259 | and then | |
5260 | Present | |
5261 | (Record_Extension_Part (Type_Definition (Decl)))); | |
05e5286d | 5262 | |
9dfe12ae | 5263 | Comp_Typ := Defining_Identifier (Decl); |
5264 | ||
05e5286d | 5265 | if not Analyzed_Unit then |
5266 | if Is_Tagged then | |
9dfe12ae | 5267 | Decorate_Tagged_Type (Sloc (Decl), Comp_Typ, Scope); |
5268 | else | |
5269 | Decorate_Incomplete_Type (Comp_Typ, Scope); | |
5270 | end if; | |
5271 | end if; | |
5272 | ||
5273 | -- Create shadow entity for type | |
5274 | ||
88fcd057 | 5275 | Lim_Typ := |
5276 | New_Internal_Shadow_Entity | |
5277 | (Kind => Ekind (Comp_Typ), | |
5278 | Sloc_Value => Sloc (Comp_Typ), | |
5279 | Id_Char => 'Z'); | |
9dfe12ae | 5280 | |
5281 | Set_Chars (Lim_Typ, Chars (Comp_Typ)); | |
5282 | Set_Parent (Lim_Typ, Parent (Comp_Typ)); | |
5283 | Set_From_With_Type (Lim_Typ); | |
5284 | ||
05e5286d | 5285 | if Is_Tagged then |
9dfe12ae | 5286 | Decorate_Tagged_Type (Sloc (Decl), Lim_Typ, Scope); |
5287 | else | |
5288 | Decorate_Incomplete_Type (Lim_Typ, Scope); | |
5289 | end if; | |
5290 | ||
5291 | Set_Non_Limited_View (Lim_Typ, Comp_Typ); | |
9dfe12ae | 5292 | |
f2e9c237 | 5293 | elsif Nkind_In (Decl, N_Private_Type_Declaration, |
3a2db8ab | 5294 | N_Incomplete_Type_Declaration, |
5295 | N_Task_Type_Declaration, | |
5296 | N_Protected_Type_Declaration) | |
7cb0fd86 | 5297 | then |
9dfe12ae | 5298 | Comp_Typ := Defining_Identifier (Decl); |
5299 | ||
3a2db8ab | 5300 | Is_Tagged := |
5301 | Nkind_In (Decl, N_Private_Type_Declaration, | |
5302 | N_Incomplete_Type_Declaration) | |
5303 | and then Tagged_Present (Decl); | |
5304 | ||
05e5286d | 5305 | if not Analyzed_Unit then |
3a2db8ab | 5306 | if Is_Tagged then |
fad45a4a | 5307 | Decorate_Tagged_Type (Sloc (Decl), Comp_Typ, Scope); |
5308 | else | |
5309 | Decorate_Incomplete_Type (Comp_Typ, Scope); | |
5310 | end if; | |
9dfe12ae | 5311 | end if; |
5312 | ||
88fcd057 | 5313 | Lim_Typ := |
5314 | New_Internal_Shadow_Entity | |
5315 | (Kind => Ekind (Comp_Typ), | |
5316 | Sloc_Value => Sloc (Comp_Typ), | |
5317 | Id_Char => 'Z'); | |
9dfe12ae | 5318 | |
5319 | Set_Chars (Lim_Typ, Chars (Comp_Typ)); | |
5320 | Set_Parent (Lim_Typ, Parent (Comp_Typ)); | |
5321 | Set_From_With_Type (Lim_Typ); | |
5322 | ||
3a2db8ab | 5323 | if Is_Tagged then |
fad45a4a | 5324 | Decorate_Tagged_Type (Sloc (Decl), Lim_Typ, Scope); |
5325 | else | |
5326 | Decorate_Incomplete_Type (Lim_Typ, Scope); | |
5327 | end if; | |
5328 | ||
5329 | Set_Non_Limited_View (Lim_Typ, Comp_Typ); | |
5330 | ||
5331 | elsif Nkind (Decl) = N_Private_Extension_Declaration then | |
5332 | Comp_Typ := Defining_Identifier (Decl); | |
9dfe12ae | 5333 | |
fad45a4a | 5334 | if not Analyzed_Unit then |
5335 | Decorate_Tagged_Type (Sloc (Decl), Comp_Typ, Scope); | |
5336 | end if; | |
5337 | ||
5338 | -- Create shadow entity for type | |
5339 | ||
88fcd057 | 5340 | Lim_Typ := |
5341 | New_Internal_Shadow_Entity | |
5342 | (Kind => Ekind (Comp_Typ), | |
5343 | Sloc_Value => Sloc (Comp_Typ), | |
5344 | Id_Char => 'Z'); | |
fad45a4a | 5345 | |
5346 | Set_Chars (Lim_Typ, Chars (Comp_Typ)); | |
5347 | Set_Parent (Lim_Typ, Parent (Comp_Typ)); | |
5348 | Set_From_With_Type (Lim_Typ); | |
5349 | ||
5350 | Decorate_Tagged_Type (Sloc (Decl), Lim_Typ, Scope); | |
9dfe12ae | 5351 | Set_Non_Limited_View (Lim_Typ, Comp_Typ); |
9dfe12ae | 5352 | |
5353 | elsif Nkind (Decl) = N_Package_Declaration then | |
5354 | ||
5355 | -- Local package | |
5356 | ||
5357 | declare | |
5c61a0ff | 5358 | Spec : constant Node_Id := Specification (Decl); |
9dfe12ae | 5359 | |
5360 | begin | |
5361 | Comp_Typ := Defining_Unit_Name (Spec); | |
5362 | ||
5363 | if not Analyzed (Cunit (Unum)) then | |
5364 | Decorate_Package_Specification (Comp_Typ); | |
5365 | Set_Scope (Comp_Typ, Scope); | |
5366 | end if; | |
5367 | ||
88fcd057 | 5368 | Lim_Typ := |
5369 | New_Internal_Shadow_Entity | |
5370 | (Kind => Ekind (Comp_Typ), | |
5371 | Sloc_Value => Sloc (Comp_Typ), | |
5372 | Id_Char => 'Z'); | |
9dfe12ae | 5373 | |
5374 | Decorate_Package_Specification (Lim_Typ); | |
5375 | Set_Scope (Lim_Typ, Scope); | |
5376 | ||
f2e9c237 | 5377 | Set_Chars (Lim_Typ, Chars (Comp_Typ)); |
9dfe12ae | 5378 | Set_Parent (Lim_Typ, Parent (Comp_Typ)); |
5379 | Set_From_With_Type (Lim_Typ); | |
5380 | ||
5381 | -- Note: The non_limited_view attribute is not used | |
5382 | -- for local packages. | |
5383 | ||
5b941af6 | 5384 | Build_Chain |
5385 | (Scope => Lim_Typ, | |
5386 | First_Decl => First (Visible_Declarations (Spec))); | |
9dfe12ae | 5387 | end; |
5388 | end if; | |
5389 | ||
5390 | Next (Decl); | |
5391 | end loop; | |
5392 | end Build_Chain; | |
5393 | ||
88fcd057 | 5394 | ------------------------------ |
5395 | -- Decorate_Incomplete_Type -- | |
5396 | ------------------------------ | |
5397 | ||
5398 | procedure Decorate_Incomplete_Type (E : Entity_Id; Scop : Entity_Id) is | |
5399 | begin | |
5400 | Set_Ekind (E, E_Incomplete_Type); | |
5401 | Set_Scope (E, Scop); | |
5402 | Set_Etype (E, E); | |
5403 | Set_Is_First_Subtype (E, True); | |
5404 | Set_Stored_Constraint (E, No_Elist); | |
5405 | Set_Full_View (E, Empty); | |
5406 | Init_Size_Align (E); | |
5407 | end Decorate_Incomplete_Type; | |
5408 | ||
5409 | -------------------------- | |
5410 | -- Decorate_Tagged_Type -- | |
5411 | -------------------------- | |
5412 | ||
5413 | procedure Decorate_Tagged_Type | |
5414 | (Loc : Source_Ptr; | |
5415 | T : Entity_Id; | |
5416 | Scop : Entity_Id) | |
5417 | is | |
5418 | CW : Entity_Id; | |
5419 | ||
5420 | begin | |
5421 | Decorate_Incomplete_Type (T, Scop); | |
5422 | Set_Is_Tagged_Type (T); | |
5423 | ||
5424 | -- Build corresponding class_wide type, if not previously done | |
5425 | ||
5426 | -- Note: The class-wide entity is shared by the limited-view | |
5427 | -- and the full-view. | |
5428 | ||
5429 | if No (Class_Wide_Type (T)) then | |
11deeeb6 | 5430 | CW := Make_Temporary (Loc, 'S'); |
88fcd057 | 5431 | |
5432 | -- Set parent to be the same as the parent of the tagged type. | |
5433 | -- We need a parent field set, and it is supposed to point to | |
5434 | -- the declaration of the type. The tagged type declaration | |
5435 | -- essentially declares two separate types, the tagged type | |
5436 | -- itself and the corresponding class-wide type, so it is | |
5437 | -- reasonable for the parent fields to point to the declaration | |
5438 | -- in both cases. | |
5439 | ||
5440 | Set_Parent (CW, Parent (T)); | |
5441 | ||
5442 | -- Set remaining fields of classwide type | |
5443 | ||
5444 | Set_Ekind (CW, E_Class_Wide_Type); | |
5445 | Set_Etype (CW, T); | |
5446 | Set_Scope (CW, Scop); | |
5447 | Set_Is_Tagged_Type (CW); | |
5448 | Set_Is_First_Subtype (CW, True); | |
5449 | Init_Size_Align (CW); | |
5450 | Set_Has_Unknown_Discriminants (CW, True); | |
5451 | Set_Class_Wide_Type (CW, CW); | |
5452 | Set_Equivalent_Type (CW, Empty); | |
5453 | Set_From_With_Type (CW, From_With_Type (T)); | |
5454 | ||
5455 | -- Link type to its class-wide type | |
5456 | ||
5457 | Set_Class_Wide_Type (T, CW); | |
5458 | end if; | |
5459 | end Decorate_Tagged_Type; | |
5460 | ||
5461 | ------------------------------------ | |
5462 | -- Decorate_Package_Specification -- | |
5463 | ------------------------------------ | |
5464 | ||
5465 | procedure Decorate_Package_Specification (P : Entity_Id) is | |
5466 | begin | |
5467 | -- Place only the most basic attributes | |
5468 | ||
5469 | Set_Ekind (P, E_Package); | |
5470 | Set_Etype (P, Standard_Void_Type); | |
5471 | end Decorate_Package_Specification; | |
5472 | ||
5473 | -------------------------------- | |
5474 | -- New_Internal_Shadow_Entity -- | |
5475 | -------------------------------- | |
5476 | ||
5477 | function New_Internal_Shadow_Entity | |
5478 | (Kind : Entity_Kind; | |
5479 | Sloc_Value : Source_Ptr; | |
5480 | Id_Char : Character) return Entity_Id | |
5481 | is | |
11deeeb6 | 5482 | E : constant Entity_Id := Make_Temporary (Sloc_Value, Id_Char); |
88fcd057 | 5483 | |
5484 | begin | |
5485 | Set_Ekind (E, Kind); | |
5486 | Set_Is_Internal (E, True); | |
5487 | ||
5488 | if Kind in Type_Kind then | |
5489 | Init_Size_Align (E); | |
5490 | end if; | |
5491 | ||
5492 | Append_Entity (E, Lim_Header); | |
5493 | Last_Lim_E := E; | |
5494 | return E; | |
5495 | end New_Internal_Shadow_Entity; | |
5496 | ||
9dfe12ae | 5497 | -- Start of processing for Build_Limited_Views |
5498 | ||
5499 | begin | |
5500 | pragma Assert (Limited_Present (N)); | |
5501 | ||
3a2db8ab | 5502 | -- A library_item mentioned in a limited_with_clause is a package |
5503 | -- declaration, not a subprogram declaration, generic declaration, | |
5504 | -- generic instantiation, or package renaming declaration. | |
9dfe12ae | 5505 | |
05e5286d | 5506 | case Nkind (Unit (Library_Unit (N))) is |
05e5286d | 5507 | when N_Package_Declaration => |
5508 | null; | |
5509 | ||
5510 | when N_Subprogram_Declaration => | |
5511 | Error_Msg_N ("subprograms not allowed in " | |
5512 | & "limited with_clauses", N); | |
cafd02b3 | 5513 | return; |
05e5286d | 5514 | |
5515 | when N_Generic_Package_Declaration | | |
5516 | N_Generic_Subprogram_Declaration => | |
5517 | Error_Msg_N ("generics not allowed in " | |
5518 | & "limited with_clauses", N); | |
cafd02b3 | 5519 | return; |
05e5286d | 5520 | |
665e279c | 5521 | when N_Generic_Instantiation => |
05e5286d | 5522 | Error_Msg_N ("generic instantiations not allowed in " |
5523 | & "limited with_clauses", N); | |
cafd02b3 | 5524 | return; |
05e5286d | 5525 | |
665e279c | 5526 | when N_Generic_Renaming_Declaration => |
05e5286d | 5527 | Error_Msg_N ("generic renamings not allowed in " |
5528 | & "limited with_clauses", N); | |
cafd02b3 | 5529 | return; |
05e5286d | 5530 | |
b5be70cd | 5531 | when N_Subprogram_Renaming_Declaration => |
5532 | Error_Msg_N ("renamed subprograms not allowed in " | |
5533 | & "limited with_clauses", N); | |
5534 | return; | |
5535 | ||
5536 | when N_Package_Renaming_Declaration => | |
5537 | Error_Msg_N ("renamed packages not allowed in " | |
5538 | & "limited with_clauses", N); | |
5539 | return; | |
5540 | ||
05e5286d | 5541 | when others => |
e27c85d0 | 5542 | raise Program_Error; |
05e5286d | 5543 | end case; |
9dfe12ae | 5544 | |
5545 | -- Check if the chain is already built | |
5546 | ||
5547 | Spec := Specification (Unit (Library_Unit (N))); | |
5548 | ||
5549 | if Limited_View_Installed (Spec) then | |
5550 | return; | |
5551 | end if; | |
5552 | ||
5553 | Set_Ekind (P, E_Package); | |
9dfe12ae | 5554 | |
5b941af6 | 5555 | -- Build the header of the limited_view |
5556 | ||
11deeeb6 | 5557 | Lim_Header := Make_Temporary (Sloc (N), 'Z'); |
5b941af6 | 5558 | Set_Ekind (Lim_Header, E_Package); |
5559 | Set_Is_Internal (Lim_Header); | |
5560 | Set_Limited_View (P, Lim_Header); | |
5561 | ||
7cb0fd86 | 5562 | -- Create the auxiliary chain. All the shadow entities are appended to |
5563 | -- the list of entities of the limited-view header | |
5b941af6 | 5564 | |
5565 | Build_Chain | |
5566 | (Scope => P, | |
5567 | First_Decl => First (Visible_Declarations (Spec))); | |
5568 | ||
5569 | -- Save the last built shadow entity. It is needed later to set the | |
5570 | -- reference to the first shadow entity in the private part | |
5571 | ||
5572 | Last_Pub_Lim_E := Last_Lim_E; | |
5573 | ||
e2aa7314 | 5574 | -- Ada 2005 (AI-262): Add the limited view of the private declarations |
5b941af6 | 5575 | -- Required to give support to limited-private-with clauses |
5576 | ||
5577 | Build_Chain (Scope => P, | |
5578 | First_Decl => First (Private_Declarations (Spec))); | |
5579 | ||
5580 | if Last_Pub_Lim_E /= Empty then | |
88fcd057 | 5581 | Set_First_Private_Entity |
5582 | (Lim_Header, Next_Entity (Last_Pub_Lim_E)); | |
5b941af6 | 5583 | else |
88fcd057 | 5584 | Set_First_Private_Entity |
5585 | (Lim_Header, First_Entity (P)); | |
5b941af6 | 5586 | end if; |
9dfe12ae | 5587 | |
9dfe12ae | 5588 | Set_Limited_View_Installed (Spec); |
5589 | end Build_Limited_Views; | |
5590 | ||
5591 | ------------------------------- | |
5592 | -- Check_Body_Needed_For_SAL -- | |
5593 | ------------------------------- | |
5594 | ||
5595 | procedure Check_Body_Needed_For_SAL (Unit_Name : Entity_Id) is | |
5596 | ||
5597 | function Entity_Needs_Body (E : Entity_Id) return Boolean; | |
7cb0fd86 | 5598 | -- Determine whether use of entity E might require the presence of its |
5599 | -- body. For a package this requires a recursive traversal of all nested | |
5600 | -- declarations. | |
9dfe12ae | 5601 | |
5602 | --------------------------- | |
5603 | -- Entity_Needed_For_SAL -- | |
5604 | --------------------------- | |
5605 | ||
5606 | function Entity_Needs_Body (E : Entity_Id) return Boolean is | |
5607 | Ent : Entity_Id; | |
5608 | ||
5609 | begin | |
5610 | if Is_Subprogram (E) | |
5611 | and then Has_Pragma_Inline (E) | |
5612 | then | |
5613 | return True; | |
5614 | ||
d3ef794c | 5615 | elsif Ekind_In (E, E_Generic_Function, E_Generic_Procedure) then |
9dfe12ae | 5616 | return True; |
5617 | ||
5618 | elsif Ekind (E) = E_Generic_Package | |
5619 | and then | |
5620 | Nkind (Unit_Declaration_Node (E)) = N_Generic_Package_Declaration | |
5621 | and then Present (Corresponding_Body (Unit_Declaration_Node (E))) | |
5622 | then | |
5623 | return True; | |
5624 | ||
5625 | elsif Ekind (E) = E_Package | |
88fcd057 | 5626 | and then Nkind (Unit_Declaration_Node (E)) = N_Package_Declaration |
9dfe12ae | 5627 | and then Present (Corresponding_Body (Unit_Declaration_Node (E))) |
5628 | then | |
5629 | Ent := First_Entity (E); | |
9dfe12ae | 5630 | while Present (Ent) loop |
5631 | if Entity_Needs_Body (Ent) then | |
5632 | return True; | |
5633 | end if; | |
5634 | ||
5635 | Next_Entity (Ent); | |
5636 | end loop; | |
5637 | ||
5638 | return False; | |
5639 | ||
5640 | else | |
5641 | return False; | |
5642 | end if; | |
5643 | end Entity_Needs_Body; | |
5644 | ||
5645 | -- Start of processing for Check_Body_Needed_For_SAL | |
5646 | ||
5647 | begin | |
5648 | if Ekind (Unit_Name) = E_Generic_Package | |
88fcd057 | 5649 | and then Nkind (Unit_Declaration_Node (Unit_Name)) = |
9dfe12ae | 5650 | N_Generic_Package_Declaration |
5651 | and then | |
5652 | Present (Corresponding_Body (Unit_Declaration_Node (Unit_Name))) | |
5653 | then | |
5654 | Set_Body_Needed_For_SAL (Unit_Name); | |
5655 | ||
d3ef794c | 5656 | elsif Ekind_In (Unit_Name, E_Generic_Procedure, E_Generic_Function) then |
9dfe12ae | 5657 | Set_Body_Needed_For_SAL (Unit_Name); |
5658 | ||
5659 | elsif Is_Subprogram (Unit_Name) | |
5660 | and then Nkind (Unit_Declaration_Node (Unit_Name)) = | |
5661 | N_Subprogram_Declaration | |
5662 | and then Has_Pragma_Inline (Unit_Name) | |
5663 | then | |
5664 | Set_Body_Needed_For_SAL (Unit_Name); | |
5665 | ||
5666 | elsif Ekind (Unit_Name) = E_Subprogram_Body then | |
5667 | Check_Body_Needed_For_SAL | |
5668 | (Corresponding_Spec (Unit_Declaration_Node (Unit_Name))); | |
5669 | ||
5670 | elsif Ekind (Unit_Name) = E_Package | |
5671 | and then Entity_Needs_Body (Unit_Name) | |
5672 | then | |
5673 | Set_Body_Needed_For_SAL (Unit_Name); | |
5674 | ||
5675 | elsif Ekind (Unit_Name) = E_Package_Body | |
5676 | and then Nkind (Unit_Declaration_Node (Unit_Name)) = N_Package_Body | |
5677 | then | |
5678 | Check_Body_Needed_For_SAL | |
5679 | (Corresponding_Spec (Unit_Declaration_Node (Unit_Name))); | |
5680 | end if; | |
5681 | end Check_Body_Needed_For_SAL; | |
5682 | ||
d6f39728 | 5683 | -------------------- |
5684 | -- Remove_Context -- | |
5685 | -------------------- | |
5686 | ||
5687 | procedure Remove_Context (N : Node_Id) is | |
5688 | Lib_Unit : constant Node_Id := Unit (N); | |
5689 | ||
5690 | begin | |
2866d595 | 5691 | -- If this is a child unit, first remove the parent units |
d6f39728 | 5692 | |
5693 | if Is_Child_Spec (Lib_Unit) then | |
5694 | Remove_Parents (Lib_Unit); | |
5695 | end if; | |
5696 | ||
5697 | Remove_Context_Clauses (N); | |
5698 | end Remove_Context; | |
5699 | ||
5700 | ---------------------------- | |
5701 | -- Remove_Context_Clauses -- | |
5702 | ---------------------------- | |
5703 | ||
5704 | procedure Remove_Context_Clauses (N : Node_Id) is | |
5705 | Item : Node_Id; | |
5706 | Unit_Name : Entity_Id; | |
5707 | ||
5708 | begin | |
e2aa7314 | 5709 | -- Ada 2005 (AI-50217): We remove the context clauses in two phases: |
a4740ca0 | 5710 | -- limited-views first and regular-views later (to maintain the |
5711 | -- stack model). | |
d6f39728 | 5712 | |
05e5286d | 5713 | -- First Phase: Remove limited_with context clauses |
d6f39728 | 5714 | |
5715 | Item := First (Context_Items (N)); | |
05e5286d | 5716 | while Present (Item) loop |
5717 | ||
5718 | -- We are interested only in with clauses which got installed | |
5719 | -- on entry. | |
d6f39728 | 5720 | |
05e5286d | 5721 | if Nkind (Item) = N_With_Clause |
5722 | and then Limited_Present (Item) | |
5723 | and then Limited_View_Installed (Item) | |
5724 | then | |
5725 | Remove_Limited_With_Clause (Item); | |
05e5286d | 5726 | end if; |
5727 | ||
5728 | Next (Item); | |
5729 | end loop; | |
5730 | ||
5731 | -- Second Phase: Loop through context items and undo regular | |
5732 | -- with_clauses and use_clauses. | |
5733 | ||
5734 | Item := First (Context_Items (N)); | |
d6f39728 | 5735 | while Present (Item) loop |
5736 | ||
7cb0fd86 | 5737 | -- We are interested only in with clauses which got installed on |
5738 | -- entry, as indicated by their Context_Installed flag set | |
d6f39728 | 5739 | |
5740 | if Nkind (Item) = N_With_Clause | |
9dfe12ae | 5741 | and then Limited_Present (Item) |
5742 | and then Limited_View_Installed (Item) | |
5743 | then | |
05e5286d | 5744 | null; |
9dfe12ae | 5745 | |
5746 | elsif Nkind (Item) = N_With_Clause | |
d6f39728 | 5747 | and then Context_Installed (Item) |
5748 | then | |
5749 | -- Remove items from one with'ed unit | |
5750 | ||
5751 | Unit_Name := Entity (Name (Item)); | |
5752 | Remove_Unit_From_Visibility (Unit_Name); | |
5753 | Set_Context_Installed (Item, False); | |
5754 | ||
5755 | elsif Nkind (Item) = N_Use_Package_Clause then | |
5756 | End_Use_Package (Item); | |
5757 | ||
5758 | elsif Nkind (Item) = N_Use_Type_Clause then | |
5759 | End_Use_Type (Item); | |
d6f39728 | 5760 | end if; |
5761 | ||
5762 | Next (Item); | |
5763 | end loop; | |
d6f39728 | 5764 | end Remove_Context_Clauses; |
5765 | ||
9dfe12ae | 5766 | -------------------------------- |
5767 | -- Remove_Limited_With_Clause -- | |
5768 | -------------------------------- | |
5769 | ||
5770 | procedure Remove_Limited_With_Clause (N : Node_Id) is | |
5b941af6 | 5771 | P_Unit : constant Entity_Id := Unit (Library_Unit (N)); |
e17ff23f | 5772 | E : Entity_Id; |
9c3beb70 | 5773 | P : Entity_Id; |
5774 | Lim_Header : Entity_Id; | |
5b941af6 | 5775 | Lim_Typ : Entity_Id; |
9c3beb70 | 5776 | Prev : Entity_Id; |
9dfe12ae | 5777 | |
5778 | begin | |
9c3beb70 | 5779 | pragma Assert (Limited_View_Installed (N)); |
9dfe12ae | 5780 | |
9c3beb70 | 5781 | -- In case of limited with_clause on subprograms, generics, instances, |
5782 | -- or renamings, the corresponding error was previously posted and we | |
5783 | -- have nothing to do here. | |
5784 | ||
5785 | if Nkind (P_Unit) /= N_Package_Declaration then | |
5786 | return; | |
5787 | end if; | |
5788 | ||
5789 | P := Defining_Unit_Name (Specification (P_Unit)); | |
9dfe12ae | 5790 | |
9c3beb70 | 5791 | -- Handle child packages |
5792 | ||
5793 | if Nkind (P) = N_Defining_Program_Unit_Name then | |
9dfe12ae | 5794 | P := Defining_Identifier (P); |
5795 | end if; | |
5796 | ||
05e5286d | 5797 | if Debug_Flag_I then |
5798 | Write_Str ("remove limited view of "); | |
5799 | Write_Name (Chars (P)); | |
5800 | Write_Str (" from visibility"); | |
5801 | Write_Eol; | |
5802 | end if; | |
5803 | ||
39a79c9e | 5804 | -- Prepare the removal of the shadow entities from visibility. The first |
5805 | -- element of the limited view is a header (an E_Package entity) that is | |
5806 | -- used to reference the first shadow entity in the private part of the | |
5807 | -- package | |
9dfe12ae | 5808 | |
9c3beb70 | 5809 | Lim_Header := Limited_View (P); |
5810 | Lim_Typ := First_Entity (Lim_Header); | |
05e5286d | 5811 | |
9c3beb70 | 5812 | -- Remove package and shadow entities from visibility if it has not |
5813 | -- been analyzed | |
9dfe12ae | 5814 | |
5815 | if not Analyzed (P_Unit) then | |
5816 | Unchain (P); | |
9dfe12ae | 5817 | Set_Is_Immediately_Visible (P, False); |
9dfe12ae | 5818 | |
9c3beb70 | 5819 | while Present (Lim_Typ) loop |
5820 | Unchain (Lim_Typ); | |
5821 | Next_Entity (Lim_Typ); | |
5822 | end loop; | |
5823 | ||
5824 | -- Otherwise this package has already appeared in the closure and its | |
5825 | -- shadow entities must be replaced by its real entities. This code | |
5826 | -- must be kept synchronized with the complementary code in Install | |
5827 | -- Limited_Withed_Unit. | |
05e5286d | 5828 | |
9c3beb70 | 5829 | else |
5830 | -- Real entities that are type or subtype declarations were hidden | |
5831 | -- from visibility at the point of installation of the limited-view. | |
5832 | -- Now we recover the previous value of the hidden attribute. | |
05e5286d | 5833 | |
e17ff23f | 5834 | E := First_Entity (P); |
5835 | while Present (E) and then E /= First_Private_Entity (P) loop | |
5836 | if Is_Type (E) then | |
5837 | Set_Is_Hidden (E, Was_Hidden (E)); | |
5838 | end if; | |
9c3beb70 | 5839 | |
e17ff23f | 5840 | Next_Entity (E); |
5841 | end loop; | |
05e5286d | 5842 | |
9c3beb70 | 5843 | while Present (Lim_Typ) |
5844 | and then Lim_Typ /= First_Private_Entity (Lim_Header) | |
5845 | loop | |
e17ff23f | 5846 | -- Nested packages and child units were not unchained |
5847 | ||
5848 | if Ekind (Lim_Typ) /= E_Package | |
5849 | and then not Is_Child_Unit (Non_Limited_View (Lim_Typ)) | |
5850 | then | |
88fcd057 | 5851 | -- If the package has incomplete types, the limited view of the |
5852 | -- incomplete type is in fact never visible (AI05-129) but we | |
5853 | -- have created a shadow entity E1 for it, that points to E2, | |
5854 | -- a non-limited incomplete type. This in turn has a full view | |
5855 | -- E3 that is the full declaration. There is a corresponding | |
5856 | -- shadow entity E4. When reinstalling the non-limited view, | |
5857 | -- E2 must become the current entity and E3 must be ignored. | |
e17ff23f | 5858 | |
63f6eb0f | 5859 | E := Non_Limited_View (Lim_Typ); |
e17ff23f | 5860 | |
63f6eb0f | 5861 | if Present (Current_Entity (E)) |
5862 | and then Ekind (Current_Entity (E)) = E_Incomplete_Type | |
5863 | and then Full_View (Current_Entity (E)) = E | |
5864 | then | |
e17ff23f | 5865 | |
63f6eb0f | 5866 | -- Lim_Typ is the limited view of a full type declaration |
88fcd057 | 5867 | -- that has a previous incomplete declaration, i.e. E3 from |
5868 | -- the previous description. Nothing to insert. | |
e17ff23f | 5869 | |
63f6eb0f | 5870 | null; |
05e5286d | 5871 | |
63f6eb0f | 5872 | else |
5873 | pragma Assert (not In_Chain (E)); | |
05e5286d | 5874 | |
63f6eb0f | 5875 | Prev := Current_Entity (Lim_Typ); |
e17ff23f | 5876 | |
63f6eb0f | 5877 | if Prev = Lim_Typ then |
5878 | Set_Current_Entity (E); | |
e17ff23f | 5879 | |
63f6eb0f | 5880 | else |
5881 | while Present (Prev) | |
5882 | and then Homonym (Prev) /= Lim_Typ | |
5883 | loop | |
5884 | Prev := Homonym (Prev); | |
5885 | end loop; | |
5886 | ||
5887 | if Present (Prev) then | |
5888 | Set_Homonym (Prev, E); | |
5889 | end if; | |
7cb0fd86 | 5890 | end if; |
05e5286d | 5891 | |
7f2cf564 | 5892 | -- Preserve structure of homonym chain |
9c3beb70 | 5893 | |
63f6eb0f | 5894 | Set_Homonym (E, Homonym (Lim_Typ)); |
5895 | end if; | |
9c3beb70 | 5896 | end if; |
5897 | ||
5898 | Next_Entity (Lim_Typ); | |
5899 | end loop; | |
05e5286d | 5900 | end if; |
9c3beb70 | 5901 | |
5902 | -- Indicate that the limited view of the package is not installed | |
5903 | ||
5904 | Set_From_With_Type (P, False); | |
5905 | Set_Limited_View_Installed (N, False); | |
9dfe12ae | 5906 | end Remove_Limited_With_Clause; |
5907 | ||
d6f39728 | 5908 | -------------------- |
5909 | -- Remove_Parents -- | |
5910 | -------------------- | |
5911 | ||
5912 | procedure Remove_Parents (Lib_Unit : Node_Id) is | |
5913 | P : Node_Id; | |
5914 | P_Name : Entity_Id; | |
8f71d067 | 5915 | P_Spec : Node_Id := Empty; |
d6f39728 | 5916 | E : Entity_Id; |
5917 | Vis : constant Boolean := | |
5918 | Scope_Stack.Table (Scope_Stack.Last).Previous_Visibility; | |
5919 | ||
5920 | begin | |
5921 | if Is_Child_Spec (Lib_Unit) then | |
8f71d067 | 5922 | P_Spec := Parent_Spec (Lib_Unit); |
d6f39728 | 5923 | |
8f71d067 | 5924 | elsif Nkind (Lib_Unit) = N_Package_Body |
5925 | and then Nkind (Original_Node (Lib_Unit)) = N_Package_Instantiation | |
5926 | then | |
5927 | P_Spec := Parent_Spec (Original_Node (Lib_Unit)); | |
5928 | end if; | |
5929 | ||
5930 | if Present (P_Spec) then | |
8f71d067 | 5931 | P := Unit (P_Spec); |
5932 | P_Name := Get_Parent_Entity (P); | |
5933 | Remove_Context_Clauses (P_Spec); | |
d6f39728 | 5934 | End_Package_Scope (P_Name); |
5935 | Set_Is_Immediately_Visible (P_Name, Vis); | |
5936 | ||
5937 | -- Remove from visibility the siblings as well, which are directly | |
5938 | -- visible while the parent is in scope. | |
5939 | ||
5940 | E := First_Entity (P_Name); | |
d6f39728 | 5941 | while Present (E) loop |
d6f39728 | 5942 | if Is_Child_Unit (E) then |
5943 | Set_Is_Immediately_Visible (E, False); | |
5944 | end if; | |
5945 | ||
5946 | Next_Entity (E); | |
5947 | end loop; | |
5948 | ||
5949 | Set_In_Package_Body (P_Name, False); | |
5950 | ||
88fcd057 | 5951 | -- This is the recursive call to remove the context of any higher |
5952 | -- level parent. This recursion ensures that all parents are removed | |
5953 | -- in the reverse order of their installation. | |
d6f39728 | 5954 | |
5955 | Remove_Parents (P); | |
5956 | end if; | |
5957 | end Remove_Parents; | |
5958 | ||
e17ff23f | 5959 | --------------------------------- |
5960 | -- Remove_Private_With_Clauses -- | |
5961 | --------------------------------- | |
5962 | ||
5963 | procedure Remove_Private_With_Clauses (Comp_Unit : Node_Id) is | |
5964 | Item : Node_Id; | |
5965 | ||
7cb0fd86 | 5966 | function In_Regular_With_Clause (E : Entity_Id) return Boolean; |
88fcd057 | 5967 | -- Check whether a given unit appears in a regular with_clause. Used to |
5968 | -- determine whether a private_with_clause, implicit or explicit, should | |
5969 | -- be ignored. | |
7cb0fd86 | 5970 | |
5971 | ---------------------------- | |
5972 | -- In_Regular_With_Clause -- | |
5973 | ---------------------------- | |
5974 | ||
5975 | function In_Regular_With_Clause (E : Entity_Id) return Boolean | |
5976 | is | |
5977 | Item : Node_Id; | |
5978 | ||
5979 | begin | |
5980 | Item := First (Context_Items (Comp_Unit)); | |
5981 | while Present (Item) loop | |
5982 | if Nkind (Item) = N_With_Clause | |
5983 | and then Entity (Name (Item)) = E | |
5984 | and then not Private_Present (Item) | |
5985 | then | |
5986 | return True; | |
5987 | end if; | |
5988 | Next (Item); | |
5989 | end loop; | |
5990 | ||
5991 | return False; | |
5992 | end In_Regular_With_Clause; | |
5993 | ||
5994 | -- Start of processing for Remove_Private_With_Clauses | |
5995 | ||
e17ff23f | 5996 | begin |
5997 | Item := First (Context_Items (Comp_Unit)); | |
5998 | while Present (Item) loop | |
5999 | if Nkind (Item) = N_With_Clause | |
6000 | and then Private_Present (Item) | |
6001 | then | |
79d59c5e | 6002 | -- If private_with_clause is redundant, remove it from context, |
6003 | -- as a small optimization to subsequent handling of private_with | |
6004 | -- clauses in other nested packages. | |
7cb0fd86 | 6005 | |
6006 | if In_Regular_With_Clause (Entity (Name (Item))) then | |
6007 | declare | |
6008 | Nxt : constant Node_Id := Next (Item); | |
7cb0fd86 | 6009 | begin |
6010 | Remove (Item); | |
6011 | Item := Nxt; | |
6012 | end; | |
6013 | ||
6014 | elsif Limited_Present (Item) then | |
e17ff23f | 6015 | if not Limited_View_Installed (Item) then |
6016 | Remove_Limited_With_Clause (Item); | |
6017 | end if; | |
7cb0fd86 | 6018 | |
6019 | Next (Item); | |
6020 | ||
e17ff23f | 6021 | else |
6022 | Remove_Unit_From_Visibility (Entity (Name (Item))); | |
6023 | Set_Context_Installed (Item, False); | |
7cb0fd86 | 6024 | Next (Item); |
e17ff23f | 6025 | end if; |
e17ff23f | 6026 | |
7cb0fd86 | 6027 | else |
6028 | Next (Item); | |
6029 | end if; | |
e17ff23f | 6030 | end loop; |
6031 | end Remove_Private_With_Clauses; | |
6032 | ||
d6f39728 | 6033 | --------------------------------- |
6034 | -- Remove_Unit_From_Visibility -- | |
6035 | --------------------------------- | |
6036 | ||
6037 | procedure Remove_Unit_From_Visibility (Unit_Name : Entity_Id) is | |
9dfe12ae | 6038 | P : constant Entity_Id := Scope (Unit_Name); |
d6f39728 | 6039 | |
6040 | begin | |
d6f39728 | 6041 | if Debug_Flag_I then |
05e5286d | 6042 | Write_Str ("remove unit "); |
d6f39728 | 6043 | Write_Name (Chars (Unit_Name)); |
05e5286d | 6044 | Write_Str (" from visibility"); |
d6f39728 | 6045 | Write_Eol; |
6046 | end if; | |
6047 | ||
6048 | if P /= Standard_Standard then | |
6049 | Set_Is_Visible_Child_Unit (Unit_Name, False); | |
6050 | end if; | |
6051 | ||
6052 | Set_Is_Potentially_Use_Visible (Unit_Name, False); | |
6053 | Set_Is_Immediately_Visible (Unit_Name, False); | |
d6f39728 | 6054 | end Remove_Unit_From_Visibility; |
6055 | ||
f49f70c6 | 6056 | -------- |
6057 | -- sm -- | |
6058 | -------- | |
6059 | ||
6060 | procedure sm is | |
6061 | begin | |
6062 | null; | |
6063 | end sm; | |
6064 | ||
9dfe12ae | 6065 | ------------- |
6066 | -- Unchain -- | |
6067 | ------------- | |
6068 | ||
6069 | procedure Unchain (E : Entity_Id) is | |
6070 | Prev : Entity_Id; | |
6071 | ||
6072 | begin | |
6073 | Prev := Current_Entity (E); | |
6074 | ||
6075 | if No (Prev) then | |
6076 | return; | |
6077 | ||
6078 | elsif Prev = E then | |
6079 | Set_Name_Entity_Id (Chars (E), Homonym (E)); | |
6080 | ||
6081 | else | |
6082 | while Present (Prev) | |
6083 | and then Homonym (Prev) /= E | |
6084 | loop | |
6085 | Prev := Homonym (Prev); | |
6086 | end loop; | |
6087 | ||
6088 | if Present (Prev) then | |
6089 | Set_Homonym (Prev, Homonym (E)); | |
6090 | end if; | |
6091 | end if; | |
05e5286d | 6092 | |
6093 | if Debug_Flag_I then | |
6094 | Write_Str (" (homonym) unchain "); | |
6095 | Write_Name (Chars (E)); | |
6096 | Write_Eol; | |
6097 | end if; | |
9dfe12ae | 6098 | end Unchain; |
9a504e32 | 6099 | |
d6f39728 | 6100 | end Sem_Ch10; |