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