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