]>
Commit | Line | Data |
---|---|---|
996ae0b0 RK |
1 | ------------------------------------------------------------------------------ |
2 | -- -- | |
3 | -- GNAT COMPILER COMPONENTS -- | |
4 | -- -- | |
5 | -- S E M _ C H 1 0 -- | |
6 | -- -- | |
7 | -- B o d y -- | |
8 | -- -- | |
82c80734 | 9 | -- Copyright (C) 1992-2005 Free Software Foundation, Inc. -- |
996ae0b0 RK |
10 | -- -- |
11 | -- GNAT is free software; you can redistribute it and/or modify it under -- | |
12 | -- terms of the GNU General Public License as published by the Free Soft- -- | |
13 | -- ware Foundation; either version 2, or (at your option) any later ver- -- | |
14 | -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- | |
15 | -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- | |
16 | -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- | |
17 | -- for more details. You should have received a copy of the GNU General -- | |
18 | -- Public License distributed with GNAT; see file COPYING. If not, write -- | |
19 | -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- | |
20 | -- MA 02111-1307, USA. -- | |
21 | -- -- | |
22 | -- GNAT was originally developed by the GNAT team at New York University. -- | |
71ff80dc | 23 | -- Extensive contributions were provided by Ada Core Technologies Inc. -- |
996ae0b0 RK |
24 | -- -- |
25 | ------------------------------------------------------------------------------ | |
26 | ||
27 | with Atree; use Atree; | |
28 | with Debug; use Debug; | |
29 | with Einfo; use Einfo; | |
30 | with Errout; use Errout; | |
31 | with Exp_Util; use Exp_Util; | |
32 | with Fname; use Fname; | |
33 | with Fname.UF; use Fname.UF; | |
34 | with Freeze; use Freeze; | |
35 | with Impunit; use Impunit; | |
36 | with Inline; use Inline; | |
37 | with Lib; use Lib; | |
38 | with Lib.Load; use Lib.Load; | |
39 | with Lib.Xref; use Lib.Xref; | |
40 | with Namet; use Namet; | |
41 | with Nlists; use Nlists; | |
42 | with Nmake; use Nmake; | |
43 | with Opt; use Opt; | |
44 | with Output; use Output; | |
45 | with Restrict; use Restrict; | |
246d2ceb | 46 | with Rtsfind; use Rtsfind; |
996ae0b0 RK |
47 | with Sem; use Sem; |
48 | with Sem_Ch6; use Sem_Ch6; | |
49 | with Sem_Ch7; use Sem_Ch7; | |
50 | with Sem_Ch8; use Sem_Ch8; | |
51 | with Sem_Dist; use Sem_Dist; | |
52 | with Sem_Prag; use Sem_Prag; | |
53 | with Sem_Util; use Sem_Util; | |
54 | with Sem_Warn; use Sem_Warn; | |
55 | with Stand; use Stand; | |
56 | with Sinfo; use Sinfo; | |
57 | with Sinfo.CN; use Sinfo.CN; | |
58 | with Sinput; use Sinput; | |
59 | with Snames; use Snames; | |
60 | with Style; use Style; | |
fbf5a39b | 61 | with Stylesw; use Stylesw; |
996ae0b0 RK |
62 | with Tbuild; use Tbuild; |
63 | with Ttypes; use Ttypes; | |
64 | with Uname; use Uname; | |
65 | ||
66 | package body Sem_Ch10 is | |
67 | ||
68 | ----------------------- | |
69 | -- Local Subprograms -- | |
70 | ----------------------- | |
71 | ||
72 | procedure Analyze_Context (N : Node_Id); | |
73 | -- Analyzes items in the context clause of compilation unit | |
74 | ||
fbf5a39b | 75 | procedure Build_Limited_Views (N : Node_Id); |
657a9dd9 AC |
76 | -- Build and decorate the list of shadow entities for a package mentioned |
77 | -- in a limited_with clause. If the package was not previously analyzed | |
78 | -- then it also performs a basic decoration of the real entities; this | |
79 | -- is required to do not pass non-decorated entities to the back-end. | |
0ab80019 | 80 | -- Implements Ada 2005 (AI-50217). |
fbf5a39b AC |
81 | |
82 | procedure Check_Body_Needed_For_SAL (Unit_Name : Entity_Id); | |
83 | -- Check whether the source for the body of a compilation unit must | |
84 | -- be included in a standalone library. | |
85 | ||
996ae0b0 RK |
86 | procedure Check_With_Type_Clauses (N : Node_Id); |
87 | -- If N is a body, verify that any with_type clauses on the spec, or | |
88 | -- on the spec of any parent, have a matching with_clause. | |
89 | ||
90 | procedure Check_Private_Child_Unit (N : Node_Id); | |
91 | -- If a with_clause mentions a private child unit, the compilation | |
92 | -- unit must be a member of the same family, as described in 10.1.2 (8). | |
93 | ||
94 | procedure Check_Stub_Level (N : Node_Id); | |
95 | -- Verify that a stub is declared immediately within a compilation unit, | |
96 | -- and not in an inner frame. | |
97 | ||
fbf5a39b | 98 | procedure Expand_Limited_With_Clause (Nam : Node_Id; N : Node_Id); |
19f0526a | 99 | -- If a child unit appears in a limited_with clause, there are implicit |
fbf5a39b AC |
100 | -- limited_with clauses on all parents that are not already visible |
101 | -- through a regular with clause. This procedure creates the implicit | |
102 | -- limited with_clauses for the parents and loads the corresponding units. | |
103 | -- The shadow entities are created when the inserted clause is analyzed. | |
0ab80019 | 104 | -- Implements Ada 2005 (AI-50217). |
fbf5a39b | 105 | |
996ae0b0 RK |
106 | procedure Expand_With_Clause (Nam : Node_Id; N : Node_Id); |
107 | -- When a child unit appears in a context clause, the implicit withs on | |
108 | -- parents are made explicit, and with clauses are inserted in the context | |
109 | -- clause before the one for the child. If a parent in the with_clause | |
110 | -- is a renaming, the implicit with_clause is on the renaming whose name | |
111 | -- is mentioned in the with_clause, and not on the package it renames. | |
112 | -- N is the compilation unit whose list of context items receives the | |
113 | -- implicit with_clauses. | |
114 | ||
07fc65c4 GB |
115 | function Get_Parent_Entity (Unit : Node_Id) return Entity_Id; |
116 | -- Get defining entity of parent unit of a child unit. In most cases this | |
117 | -- is the defining entity of the unit, but for a child instance whose | |
118 | -- parent needs a body for inlining, the instantiation node of the parent | |
119 | -- has not yet been rewritten as a package declaration, and the entity has | |
120 | -- to be retrieved from the Instance_Spec of the unit. | |
121 | ||
996ae0b0 RK |
122 | procedure Implicit_With_On_Parent (Child_Unit : Node_Id; N : Node_Id); |
123 | -- If the main unit is a child unit, implicit withs are also added for | |
124 | -- all its ancestors. | |
125 | ||
126 | procedure Install_Context_Clauses (N : Node_Id); | |
127 | -- Subsidiary to previous one. Process only with_ and use_clauses for | |
128 | -- current unit and its library unit if any. | |
129 | ||
657a9dd9 AC |
130 | procedure Install_Limited_Context_Clauses (N : Node_Id); |
131 | -- Subsidiary to Install_Context. Process only limited with_clauses | |
0ab80019 | 132 | -- for current unit. Implements Ada 2005 (AI-50217). |
657a9dd9 | 133 | |
fbf5a39b AC |
134 | procedure Install_Limited_Withed_Unit (N : Node_Id); |
135 | -- Place shadow entities for a limited_with package in the visibility | |
0ab80019 | 136 | -- structures for the current compilation. Implements Ada 2005 (AI-50217). |
fbf5a39b | 137 | |
8a6a52dc AC |
138 | procedure Install_Withed_Unit |
139 | (With_Clause : Node_Id; | |
140 | Private_With_OK : Boolean := False); | |
141 | ||
996ae0b0 RK |
142 | -- If the unit is not a child unit, make unit immediately visible. |
143 | -- The caller ensures that the unit is not already currently installed. | |
8a6a52dc AC |
144 | -- The flag Private_With_OK is set true in Install_Private_With_Clauses, |
145 | -- which is called when compiling the private part of a package, or | |
146 | -- installing the private declarations of a parent unit. | |
996ae0b0 RK |
147 | |
148 | procedure Install_Parents (Lib_Unit : Node_Id; Is_Private : Boolean); | |
149 | -- This procedure establishes the context for the compilation of a child | |
150 | -- unit. If Lib_Unit is a child library spec then the context of the parent | |
151 | -- is installed, and the parent itself made immediately visible, so that | |
152 | -- the child unit is processed in the declarative region of the parent. | |
153 | -- Install_Parents makes a recursive call to itself to ensure that all | |
154 | -- parents are loaded in the nested case. If Lib_Unit is a library body, | |
155 | -- the only effect of Install_Parents is to install the private decls of | |
156 | -- the parents, because the visible parent declarations will have been | |
157 | -- installed as part of the context of the corresponding spec. | |
158 | ||
159 | procedure Install_Siblings (U_Name : Entity_Id; N : Node_Id); | |
160 | -- In the compilation of a child unit, a child of any of the ancestor | |
161 | -- units is directly visible if it is visible, because the parent is in | |
162 | -- an enclosing scope. Iterate over context to find child units of U_Name | |
163 | -- or of some ancestor of it. | |
164 | ||
165 | function Is_Child_Spec (Lib_Unit : Node_Id) return Boolean; | |
166 | -- Lib_Unit is a library unit which may be a spec or a body. Is_Child_Spec | |
167 | -- returns True if Lib_Unit is a library spec which is a child spec, i.e. | |
168 | -- a library spec that has a parent. If the call to Is_Child_Spec returns | |
169 | -- True, then Parent_Spec (Lib_Unit) is non-Empty and points to the | |
170 | -- compilation unit for the parent spec. | |
171 | -- | |
172 | -- Lib_Unit can also be a subprogram body that acts as its own spec. If | |
173 | -- the Parent_Spec is non-empty, this is also a child unit. | |
174 | ||
175 | procedure Remove_With_Type_Clause (Name : Node_Id); | |
176 | -- Remove imported type and its enclosing package from visibility, and | |
177 | -- remove attributes of imported type so they don't interfere with its | |
178 | -- analysis (should it appear otherwise in the context). | |
179 | ||
180 | procedure Remove_Context_Clauses (N : Node_Id); | |
a5b62485 | 181 | -- Subsidiary of previous one. Remove use_ and with_clauses |
996ae0b0 | 182 | |
fbf5a39b AC |
183 | procedure Remove_Limited_With_Clause (N : Node_Id); |
184 | -- Remove from visibility the shadow entities introduced for a package | |
0ab80019 | 185 | -- mentioned in a limited_with clause. Implements Ada 2005 (AI-50217). |
fbf5a39b | 186 | |
996ae0b0 RK |
187 | procedure Remove_Parents (Lib_Unit : Node_Id); |
188 | -- Remove_Parents checks if Lib_Unit is a child spec. If so then the parent | |
189 | -- contexts established by the corresponding call to Install_Parents are | |
190 | -- removed. Remove_Parents contains a recursive call to itself to ensure | |
191 | -- that all parents are removed in the nested case. | |
192 | ||
193 | procedure Remove_Unit_From_Visibility (Unit_Name : Entity_Id); | |
194 | -- Reset all visibility flags on unit after compiling it, either as a | |
195 | -- main unit or as a unit in the context. | |
196 | ||
fbf5a39b AC |
197 | procedure Unchain (E : Entity_Id); |
198 | -- Remove single entity from visibility list | |
199 | ||
996ae0b0 RK |
200 | procedure Analyze_Proper_Body (N : Node_Id; Nam : Entity_Id); |
201 | -- Common processing for all stubs (subprograms, tasks, packages, and | |
202 | -- protected cases). N is the stub to be analyzed. Once the subunit | |
203 | -- name is established, load and analyze. Nam is the non-overloadable | |
204 | -- entity for which the proper body provides a completion. Subprogram | |
205 | -- stubs are handled differently because they can be declarations. | |
206 | ||
fbf5a39b AC |
207 | -------------------------- |
208 | -- Limited_With_Clauses -- | |
209 | -------------------------- | |
210 | ||
211 | -- Limited_With clauses are the mechanism chosen for Ada05 to support | |
212 | -- mutually recursive types declared in different units. A limited_with | |
213 | -- clause that names package P in the context of unit U makes the types | |
214 | -- declared in the visible part of P available within U, but with the | |
215 | -- restriction that these types can only be used as incomplete types. | |
216 | -- The limited_with clause does not impose a semantic dependence on P, | |
217 | -- and it is possible for two packages to have limited_with_clauses on | |
218 | -- each other without creating an elaboration circularity. | |
219 | ||
220 | -- To support this feature, the analysis of a limited_with clause must | |
221 | -- create an abbreviated view of the package, without performing any | |
222 | -- semantic analysis on it. This "package abstract" contains shadow | |
223 | -- types that are in one-one correspondence with the real types in the | |
224 | -- package, and that have the properties of incomplete types. | |
225 | ||
226 | -- The implementation creates two element lists: one to chain the shadow | |
227 | -- entities, and one to chain the corresponding type entities in the tree | |
228 | -- of the package. Links between corresponding entities in both chains | |
229 | -- allow the compiler to select the proper view of a given type, depending | |
230 | -- on the context. Note that in contrast with the handling of private | |
231 | -- types, the limited view and the non-limited view of a type are treated | |
232 | -- as separate entities, and no entity exchange needs to take place, which | |
233 | -- makes the implementation must simpler than could be feared. | |
234 | ||
996ae0b0 RK |
235 | ------------------------------ |
236 | -- Analyze_Compilation_Unit -- | |
237 | ------------------------------ | |
238 | ||
239 | procedure Analyze_Compilation_Unit (N : Node_Id) is | |
240 | Unit_Node : constant Node_Id := Unit (N); | |
241 | Lib_Unit : Node_Id := Library_Unit (N); | |
242 | Spec_Id : Node_Id; | |
243 | Main_Cunit : constant Node_Id := Cunit (Main_Unit); | |
244 | Par_Spec_Name : Unit_Name_Type; | |
245 | Unum : Unit_Number_Type; | |
246 | ||
247 | procedure Generate_Parent_References (N : Node_Id; P_Id : Entity_Id); | |
248 | -- Generate cross-reference information for the parents of child units. | |
249 | -- N is a defining_program_unit_name, and P_Id is the immediate parent. | |
250 | ||
251 | -------------------------------- | |
252 | -- Generate_Parent_References -- | |
253 | -------------------------------- | |
254 | ||
255 | procedure Generate_Parent_References (N : Node_Id; P_Id : Entity_Id) is | |
256 | Pref : Node_Id; | |
257 | P_Name : Entity_Id := P_Id; | |
258 | ||
259 | begin | |
260 | Pref := Name (Parent (Defining_Entity (N))); | |
261 | ||
262 | if Nkind (Pref) = N_Expanded_Name then | |
263 | ||
264 | -- Done already, if the unit has been compiled indirectly as | |
265 | -- part of the closure of its context because of inlining. | |
266 | ||
267 | return; | |
268 | end if; | |
269 | ||
270 | while Nkind (Pref) = N_Selected_Component loop | |
271 | Change_Selected_Component_To_Expanded_Name (Pref); | |
272 | Set_Entity (Pref, P_Name); | |
273 | Set_Etype (Pref, Etype (P_Name)); | |
274 | Generate_Reference (P_Name, Pref, 'r'); | |
275 | Pref := Prefix (Pref); | |
276 | P_Name := Scope (P_Name); | |
277 | end loop; | |
278 | ||
279 | -- The guard here on P_Name is to handle the error condition where | |
280 | -- the parent unit is missing because the file was not found. | |
281 | ||
282 | if Present (P_Name) then | |
283 | Set_Entity (Pref, P_Name); | |
284 | Set_Etype (Pref, Etype (P_Name)); | |
285 | Generate_Reference (P_Name, Pref, 'r'); | |
286 | Style.Check_Identifier (Pref, P_Name); | |
287 | end if; | |
288 | end Generate_Parent_References; | |
289 | ||
290 | -- Start of processing for Analyze_Compilation_Unit | |
291 | ||
292 | begin | |
293 | Process_Compilation_Unit_Pragmas (N); | |
294 | ||
295 | -- If the unit is a subunit whose parent has not been analyzed (which | |
296 | -- indicates that the main unit is a subunit, either the current one or | |
297 | -- one of its descendents) then the subunit is compiled as part of the | |
298 | -- analysis of the parent, which we proceed to do. Basically this gets | |
299 | -- handled from the top down and we don't want to do anything at this | |
300 | -- level (i.e. this subunit will be handled on the way down from the | |
301 | -- parent), so at this level we immediately return. If the subunit | |
302 | -- ends up not analyzed, it means that the parent did not contain a | |
303 | -- stub for it, or that there errors were dectected in some ancestor. | |
304 | ||
305 | if Nkind (Unit_Node) = N_Subunit | |
306 | and then not Analyzed (Lib_Unit) | |
307 | then | |
308 | Semantics (Lib_Unit); | |
309 | ||
310 | if not Analyzed (Proper_Body (Unit_Node)) then | |
07fc65c4 | 311 | if Serious_Errors_Detected > 0 then |
996ae0b0 RK |
312 | Error_Msg_N ("subunit not analyzed (errors in parent unit)", N); |
313 | else | |
314 | Error_Msg_N ("missing stub for subunit", N); | |
315 | end if; | |
316 | end if; | |
317 | ||
318 | return; | |
319 | end if; | |
320 | ||
321 | -- Analyze context (this will call Sem recursively for with'ed units) | |
322 | ||
323 | Analyze_Context (N); | |
324 | ||
325 | -- If the unit is a package body, the spec is already loaded and must | |
326 | -- be analyzed first, before we analyze the body. | |
327 | ||
328 | if Nkind (Unit_Node) = N_Package_Body then | |
329 | ||
330 | -- If no Lib_Unit, then there was a serious previous error, so | |
331 | -- just ignore the entire analysis effort | |
332 | ||
333 | if No (Lib_Unit) then | |
334 | return; | |
335 | ||
336 | else | |
337 | Semantics (Lib_Unit); | |
338 | Check_Unused_Withs (Get_Cunit_Unit_Number (Lib_Unit)); | |
339 | ||
a5b62485 | 340 | -- Verify that the library unit is a package declaration |
996ae0b0 RK |
341 | |
342 | if Nkind (Unit (Lib_Unit)) /= N_Package_Declaration | |
343 | and then | |
344 | Nkind (Unit (Lib_Unit)) /= N_Generic_Package_Declaration | |
345 | then | |
346 | Error_Msg_N | |
347 | ("no legal package declaration for package body", N); | |
348 | return; | |
349 | ||
350 | -- Otherwise, the entity in the declaration is visible. Update | |
351 | -- the version to reflect dependence of this body on the spec. | |
352 | ||
353 | else | |
354 | Spec_Id := Defining_Entity (Unit (Lib_Unit)); | |
355 | Set_Is_Immediately_Visible (Spec_Id, True); | |
356 | Version_Update (N, Lib_Unit); | |
357 | ||
358 | if Nkind (Defining_Unit_Name (Unit_Node)) | |
359 | = N_Defining_Program_Unit_Name | |
360 | then | |
361 | Generate_Parent_References (Unit_Node, Scope (Spec_Id)); | |
362 | end if; | |
363 | end if; | |
364 | end if; | |
365 | ||
366 | -- If the unit is a subprogram body, then we similarly need to analyze | |
367 | -- its spec. However, things are a little simpler in this case, because | |
368 | -- here, this analysis is done only for error checking and consistency | |
369 | -- purposes, so there's nothing else to be done. | |
370 | ||
371 | elsif Nkind (Unit_Node) = N_Subprogram_Body then | |
372 | if Acts_As_Spec (N) then | |
373 | ||
374 | -- If the subprogram body is a child unit, we must create a | |
375 | -- declaration for it, in order to properly load the parent(s). | |
376 | -- After this, the original unit does not acts as a spec, because | |
377 | -- there is an explicit one. If this unit appears in a context | |
378 | -- clause, then an implicit with on the parent will be added when | |
379 | -- installing the context. If this is the main unit, there is no | |
380 | -- Unit_Table entry for the declaration, (It has the unit number | |
381 | -- of the main unit) and code generation is unaffected. | |
382 | ||
383 | Unum := Get_Cunit_Unit_Number (N); | |
384 | Par_Spec_Name := Get_Parent_Spec_Name (Unit_Name (Unum)); | |
385 | ||
386 | if Par_Spec_Name /= No_Name then | |
387 | Unum := | |
388 | Load_Unit | |
389 | (Load_Name => Par_Spec_Name, | |
390 | Required => True, | |
391 | Subunit => False, | |
392 | Error_Node => N); | |
393 | ||
394 | if Unum /= No_Unit then | |
395 | ||
396 | -- Build subprogram declaration and attach parent unit to it | |
24105bab AC |
397 | -- This subprogram declaration does not come from source, |
398 | -- Nevertheless the backend must generate debugging info for | |
399 | -- it, and this must be indicated explicitly. | |
996ae0b0 RK |
400 | |
401 | declare | |
402 | Loc : constant Source_Ptr := Sloc (N); | |
403 | SCS : constant Boolean := | |
404 | Get_Comes_From_Source_Default; | |
405 | ||
406 | begin | |
407 | Set_Comes_From_Source_Default (False); | |
408 | Lib_Unit := | |
409 | Make_Compilation_Unit (Loc, | |
410 | Context_Items => New_Copy_List (Context_Items (N)), | |
411 | Unit => | |
412 | Make_Subprogram_Declaration (Sloc (N), | |
413 | Specification => | |
414 | Copy_Separate_Tree | |
415 | (Specification (Unit_Node))), | |
416 | Aux_Decls_Node => | |
417 | Make_Compilation_Unit_Aux (Loc)); | |
418 | ||
419 | Set_Library_Unit (N, Lib_Unit); | |
420 | Set_Parent_Spec (Unit (Lib_Unit), Cunit (Unum)); | |
421 | Semantics (Lib_Unit); | |
422 | Set_Acts_As_Spec (N, False); | |
24105bab | 423 | Set_Needs_Debug_Info (Defining_Entity (Unit (Lib_Unit))); |
996ae0b0 RK |
424 | Set_Comes_From_Source_Default (SCS); |
425 | end; | |
426 | end if; | |
427 | end if; | |
428 | ||
429 | -- Here for subprogram with separate declaration | |
430 | ||
431 | else | |
432 | Semantics (Lib_Unit); | |
433 | Check_Unused_Withs (Get_Cunit_Unit_Number (Lib_Unit)); | |
434 | Version_Update (N, Lib_Unit); | |
435 | end if; | |
436 | ||
437 | if Nkind (Defining_Unit_Name (Specification (Unit_Node))) = | |
438 | N_Defining_Program_Unit_Name | |
439 | then | |
440 | Generate_Parent_References ( | |
441 | Specification (Unit_Node), | |
442 | Scope (Defining_Entity (Unit (Lib_Unit)))); | |
443 | end if; | |
444 | end if; | |
445 | ||
446 | -- If it is a child unit, the parent must be elaborated first | |
447 | -- and we update version, since we are dependent on our parent. | |
448 | ||
449 | if Is_Child_Spec (Unit_Node) then | |
450 | ||
451 | -- The analysis of the parent is done with style checks off | |
452 | ||
453 | declare | |
fbf5a39b | 454 | Save_Style_Check : constant Boolean := Style_Check; |
6e937c1c AC |
455 | Save_C_Restrict : constant Save_Cunit_Boolean_Restrictions := |
456 | Cunit_Boolean_Restrictions_Save; | |
996ae0b0 RK |
457 | |
458 | begin | |
459 | if not GNAT_Mode then | |
460 | Style_Check := False; | |
461 | end if; | |
462 | ||
463 | Semantics (Parent_Spec (Unit_Node)); | |
464 | Version_Update (N, Parent_Spec (Unit_Node)); | |
465 | Style_Check := Save_Style_Check; | |
6e937c1c | 466 | Cunit_Boolean_Restrictions_Restore (Save_C_Restrict); |
996ae0b0 RK |
467 | end; |
468 | end if; | |
469 | ||
470 | -- With the analysis done, install the context. Note that we can't | |
471 | -- install the context from the with clauses as we analyze them, | |
472 | -- because each with clause must be analyzed in a clean visibility | |
473 | -- context, so we have to wait and install them all at once. | |
474 | ||
475 | Install_Context (N); | |
476 | ||
477 | if Is_Child_Spec (Unit_Node) then | |
478 | ||
a5b62485 | 479 | -- Set the entities of all parents in the program_unit_name |
996ae0b0 RK |
480 | |
481 | Generate_Parent_References ( | |
07fc65c4 | 482 | Unit_Node, Get_Parent_Entity (Unit (Parent_Spec (Unit_Node)))); |
996ae0b0 RK |
483 | end if; |
484 | ||
485 | -- All components of the context: with-clauses, library unit, ancestors | |
486 | -- if any, (and their context) are analyzed and installed. Now analyze | |
487 | -- the unit itself, which is either a package, subprogram spec or body. | |
488 | ||
489 | Analyze (Unit_Node); | |
490 | ||
491 | -- The above call might have made Unit_Node an N_Subprogram_Body | |
492 | -- from something else, so propagate any Acts_As_Spec flag. | |
493 | ||
494 | if Nkind (Unit_Node) = N_Subprogram_Body | |
495 | and then Acts_As_Spec (Unit_Node) | |
496 | then | |
497 | Set_Acts_As_Spec (N); | |
498 | end if; | |
499 | ||
246d2ceb AC |
500 | -- Register predefined units in Rtsfind |
501 | ||
502 | declare | |
503 | Unum : constant Unit_Number_Type := Get_Source_Unit (Sloc (N)); | |
504 | begin | |
505 | if Is_Predefined_File_Name (Unit_File_Name (Unum)) then | |
506 | Set_RTU_Loaded (Unit_Node); | |
507 | end if; | |
508 | end; | |
509 | ||
996ae0b0 RK |
510 | -- Treat compilation unit pragmas that appear after the library unit |
511 | ||
512 | if Present (Pragmas_After (Aux_Decls_Node (N))) then | |
513 | declare | |
514 | Prag_Node : Node_Id := First (Pragmas_After (Aux_Decls_Node (N))); | |
515 | ||
516 | begin | |
517 | while Present (Prag_Node) loop | |
518 | Analyze (Prag_Node); | |
519 | Next (Prag_Node); | |
520 | end loop; | |
521 | end; | |
522 | end if; | |
523 | ||
5950a3ac | 524 | -- Generate distribution stubs if requested and no error |
996ae0b0 RK |
525 | |
526 | if N = Main_Cunit | |
527 | and then (Distribution_Stub_Mode = Generate_Receiver_Stub_Body | |
528 | or else | |
529 | Distribution_Stub_Mode = Generate_Caller_Stub_Body) | |
530 | and then not Fatal_Error (Main_Unit) | |
531 | then | |
532 | if Is_RCI_Pkg_Spec_Or_Body (N) then | |
533 | ||
534 | -- Regular RCI package | |
535 | ||
536 | Add_Stub_Constructs (N); | |
537 | ||
538 | elsif (Nkind (Unit_Node) = N_Package_Declaration | |
539 | and then Is_Shared_Passive (Defining_Entity | |
540 | (Specification (Unit_Node)))) | |
541 | or else (Nkind (Unit_Node) = N_Package_Body | |
542 | and then | |
543 | Is_Shared_Passive (Corresponding_Spec (Unit_Node))) | |
544 | then | |
545 | -- Shared passive package | |
546 | ||
547 | Add_Stub_Constructs (N); | |
548 | ||
549 | elsif Nkind (Unit_Node) = N_Package_Instantiation | |
550 | and then | |
551 | Is_Remote_Call_Interface | |
552 | (Defining_Entity (Specification (Instance_Spec (Unit_Node)))) | |
553 | then | |
554 | -- Instantiation of a RCI generic package | |
555 | ||
556 | Add_Stub_Constructs (N); | |
557 | end if; | |
558 | ||
996ae0b0 RK |
559 | end if; |
560 | ||
561 | if Nkind (Unit_Node) = N_Package_Declaration | |
562 | or else Nkind (Unit_Node) in N_Generic_Declaration | |
563 | or else Nkind (Unit_Node) = N_Package_Renaming_Declaration | |
564 | or else Nkind (Unit_Node) = N_Subprogram_Declaration | |
565 | then | |
566 | Remove_Unit_From_Visibility (Defining_Entity (Unit_Node)); | |
567 | ||
fbf5a39b AC |
568 | -- If the unit is an instantiation whose body will be elaborated |
569 | -- for inlining purposes, use the the proper entity of the instance. | |
570 | ||
571 | elsif Nkind (Unit_Node) = N_Package_Instantiation | |
572 | and then not Error_Posted (Unit_Node) | |
573 | then | |
574 | Remove_Unit_From_Visibility | |
575 | (Defining_Entity (Instance_Spec (Unit_Node))); | |
576 | ||
996ae0b0 RK |
577 | elsif Nkind (Unit_Node) = N_Package_Body |
578 | or else (Nkind (Unit_Node) = N_Subprogram_Body | |
579 | and then not Acts_As_Spec (Unit_Node)) | |
580 | then | |
581 | -- Bodies that are not the main unit are compiled if they | |
582 | -- are generic or contain generic or inlined units. Their | |
583 | -- analysis brings in the context of the corresponding spec | |
584 | -- (unit declaration) which must be removed as well, to | |
585 | -- return the compilation environment to its proper state. | |
586 | ||
587 | Remove_Context (Lib_Unit); | |
588 | Set_Is_Immediately_Visible (Defining_Entity (Unit (Lib_Unit)), False); | |
589 | end if; | |
590 | ||
591 | -- Last step is to deinstall the context we just installed | |
592 | -- as well as the unit just compiled. | |
593 | ||
594 | Remove_Context (N); | |
595 | ||
596 | -- If this is the main unit and we are generating code, we must | |
597 | -- check that all generic units in the context have a body if they | |
598 | -- need it, even if they have not been instantiated. In the absence | |
599 | -- of .ali files for generic units, we must force the load of the body, | |
600 | -- just to produce the proper error if the body is absent. We skip this | |
601 | -- verification if the main unit itself is generic. | |
602 | ||
603 | if Get_Cunit_Unit_Number (N) = Main_Unit | |
604 | and then Operating_Mode = Generate_Code | |
605 | and then Expander_Active | |
606 | then | |
fbf5a39b AC |
607 | -- Check whether the source for the body of the unit must be |
608 | -- included in a standalone library. | |
609 | ||
610 | Check_Body_Needed_For_SAL (Cunit_Entity (Main_Unit)); | |
611 | ||
996ae0b0 RK |
612 | -- Indicate that the main unit is now analyzed, to catch possible |
613 | -- circularities between it and generic bodies. Remove main unit | |
614 | -- from visibility. This might seem superfluous, but the main unit | |
615 | -- must not be visible in the generic body expansions that follow. | |
616 | ||
617 | Set_Analyzed (N, True); | |
618 | Set_Is_Immediately_Visible (Cunit_Entity (Main_Unit), False); | |
619 | ||
620 | declare | |
621 | Item : Node_Id; | |
622 | Nam : Entity_Id; | |
623 | Un : Unit_Number_Type; | |
624 | ||
fbf5a39b | 625 | Save_Style_Check : constant Boolean := Style_Check; |
6e937c1c AC |
626 | Save_C_Restrict : constant Save_Cunit_Boolean_Restrictions := |
627 | Cunit_Boolean_Restrictions_Save; | |
996ae0b0 RK |
628 | |
629 | begin | |
630 | Item := First (Context_Items (N)); | |
996ae0b0 | 631 | while Present (Item) loop |
19f0526a | 632 | |
0ab80019 | 633 | -- Ada 2005 (AI-50217): Do not consider limited-withed units |
19f0526a | 634 | |
996ae0b0 RK |
635 | if Nkind (Item) = N_With_Clause |
636 | and then not Implicit_With (Item) | |
fbf5a39b | 637 | and then not Limited_Present (Item) |
996ae0b0 RK |
638 | then |
639 | Nam := Entity (Name (Item)); | |
640 | ||
fbf5a39b | 641 | if (Is_Generic_Subprogram (Nam) |
996ae0b0 | 642 | and then not Is_Intrinsic_Subprogram (Nam)) |
996ae0b0 RK |
643 | or else (Ekind (Nam) = E_Generic_Package |
644 | and then Unit_Requires_Body (Nam)) | |
645 | then | |
fbf5a39b | 646 | Style_Check := False; |
996ae0b0 RK |
647 | |
648 | if Present (Renamed_Object (Nam)) then | |
649 | Un := | |
650 | Load_Unit | |
651 | (Load_Name => Get_Body_Name | |
652 | (Get_Unit_Name | |
653 | (Unit_Declaration_Node | |
654 | (Renamed_Object (Nam)))), | |
655 | Required => False, | |
656 | Subunit => False, | |
657 | Error_Node => N, | |
658 | Renamings => True); | |
659 | else | |
660 | Un := | |
661 | Load_Unit | |
662 | (Load_Name => Get_Body_Name | |
663 | (Get_Unit_Name (Item)), | |
664 | Required => False, | |
665 | Subunit => False, | |
666 | Error_Node => N, | |
667 | Renamings => True); | |
668 | end if; | |
669 | ||
670 | if Un = No_Unit then | |
671 | Error_Msg_NE | |
672 | ("body of generic unit& not found", Item, Nam); | |
673 | exit; | |
674 | ||
675 | elsif not Analyzed (Cunit (Un)) | |
676 | and then Un /= Main_Unit | |
fbf5a39b | 677 | and then not Fatal_Error (Un) |
996ae0b0 | 678 | then |
fbf5a39b | 679 | Style_Check := False; |
996ae0b0 RK |
680 | Semantics (Cunit (Un)); |
681 | end if; | |
682 | end if; | |
683 | end if; | |
684 | ||
685 | Next (Item); | |
686 | end loop; | |
687 | ||
688 | Style_Check := Save_Style_Check; | |
6e937c1c | 689 | Cunit_Boolean_Restrictions_Restore (Save_C_Restrict); |
996ae0b0 RK |
690 | end; |
691 | end if; | |
692 | ||
693 | -- Deal with creating elaboration Boolean if needed. We create an | |
694 | -- elaboration boolean only for units that come from source since | |
695 | -- units manufactured by the compiler never need elab checks. | |
696 | ||
697 | if Comes_From_Source (N) | |
698 | and then | |
699 | (Nkind (Unit (N)) = N_Package_Declaration or else | |
700 | Nkind (Unit (N)) = N_Generic_Package_Declaration or else | |
701 | Nkind (Unit (N)) = N_Subprogram_Declaration or else | |
702 | Nkind (Unit (N)) = N_Generic_Subprogram_Declaration) | |
703 | then | |
704 | declare | |
705 | Loc : constant Source_Ptr := Sloc (N); | |
706 | Unum : constant Unit_Number_Type := Get_Source_Unit (Loc); | |
707 | ||
708 | begin | |
709 | Spec_Id := Defining_Entity (Unit (N)); | |
710 | Generate_Definition (Spec_Id); | |
711 | ||
712 | -- See if an elaboration entity is required for possible | |
713 | -- access before elaboration checking. Note that we must | |
714 | -- allow for this even if -gnatE is not set, since a client | |
715 | -- may be compiled in -gnatE mode and reference the entity. | |
716 | ||
717 | -- Case of units which do not require elaboration checks | |
718 | ||
719 | if | |
720 | -- Pure units do not need checks | |
721 | ||
722 | Is_Pure (Spec_Id) | |
723 | ||
724 | -- Preelaborated units do not need checks | |
725 | ||
726 | or else Is_Preelaborated (Spec_Id) | |
727 | ||
728 | -- No checks needed if pagma Elaborate_Body present | |
729 | ||
730 | or else Has_Pragma_Elaborate_Body (Spec_Id) | |
731 | ||
732 | -- No checks needed if unit does not require a body | |
733 | ||
734 | or else not Unit_Requires_Body (Spec_Id) | |
735 | ||
736 | -- No checks needed for predefined files | |
737 | ||
738 | or else Is_Predefined_File_Name (Unit_File_Name (Unum)) | |
739 | ||
740 | -- No checks required if no separate spec | |
741 | ||
742 | or else Acts_As_Spec (N) | |
743 | then | |
744 | -- This is a case where we only need the entity for | |
745 | -- checking to prevent multiple elaboration checks. | |
746 | ||
747 | Set_Elaboration_Entity_Required (Spec_Id, False); | |
748 | ||
749 | -- Case of elaboration entity is required for access before | |
750 | -- elaboration checking (so certainly we must build it!) | |
751 | ||
752 | else | |
753 | Set_Elaboration_Entity_Required (Spec_Id, True); | |
754 | end if; | |
755 | ||
756 | Build_Elaboration_Entity (N, Spec_Id); | |
757 | end; | |
758 | end if; | |
759 | ||
760 | -- Finally, freeze the compilation unit entity. This for sure is needed | |
761 | -- because of some warnings that can be output (see Freeze_Subprogram), | |
762 | -- but may in general be required. If freezing actions result, place | |
763 | -- them in the compilation unit actions list, and analyze them. | |
764 | ||
765 | declare | |
766 | Loc : constant Source_Ptr := Sloc (N); | |
767 | L : constant List_Id := | |
768 | Freeze_Entity (Cunit_Entity (Current_Sem_Unit), Loc); | |
769 | ||
770 | begin | |
771 | while Is_Non_Empty_List (L) loop | |
772 | Insert_Library_Level_Action (Remove_Head (L)); | |
773 | end loop; | |
774 | end; | |
775 | ||
776 | Set_Analyzed (N); | |
777 | ||
778 | if Nkind (Unit_Node) = N_Package_Declaration | |
779 | and then Get_Cunit_Unit_Number (N) /= Main_Unit | |
996ae0b0 RK |
780 | and then Expander_Active |
781 | then | |
fbf5a39b AC |
782 | declare |
783 | Save_Style_Check : constant Boolean := Style_Check; | |
784 | Save_Warning : constant Warning_Mode_Type := Warning_Mode; | |
785 | Options : Style_Check_Options; | |
786 | ||
787 | begin | |
788 | Save_Style_Check_Options (Options); | |
789 | Reset_Style_Check_Options; | |
790 | Opt.Warning_Mode := Suppress; | |
791 | Check_Body_For_Inlining (N, Defining_Entity (Unit_Node)); | |
792 | ||
793 | Reset_Style_Check_Options; | |
794 | Set_Style_Check_Options (Options); | |
795 | Style_Check := Save_Style_Check; | |
796 | Warning_Mode := Save_Warning; | |
797 | end; | |
996ae0b0 RK |
798 | end if; |
799 | end Analyze_Compilation_Unit; | |
800 | ||
801 | --------------------- | |
802 | -- Analyze_Context -- | |
803 | --------------------- | |
804 | ||
805 | procedure Analyze_Context (N : Node_Id) is | |
806 | Item : Node_Id; | |
807 | ||
808 | begin | |
fbf5a39b AC |
809 | -- Loop through context items. This is done is three passes: |
810 | -- a) The first pass analyze non-limited with-clauses. | |
657a9dd9 | 811 | -- b) The second pass add implicit limited_with clauses for |
0ab80019 AC |
812 | -- the parents of child units (Ada 2005: AI-50217) |
813 | -- c) The third pass analyzes limited_with clauses (Ada 2005: AI-50217) | |
996ae0b0 RK |
814 | |
815 | Item := First (Context_Items (N)); | |
816 | while Present (Item) loop | |
817 | ||
818 | -- For with clause, analyze the with clause, and then update | |
819 | -- the version, since we are dependent on a unit that we with. | |
820 | ||
657a9dd9 AC |
821 | if Nkind (Item) = N_With_Clause |
822 | and then not Limited_Present (Item) | |
823 | then | |
996ae0b0 RK |
824 | |
825 | -- Skip analyzing with clause if no unit, nothing to do (this | |
fbf5a39b | 826 | -- happens for a with that references a non-existant unit) |
996ae0b0 RK |
827 | |
828 | if Present (Library_Unit (Item)) then | |
829 | Analyze (Item); | |
830 | end if; | |
831 | ||
832 | if not Implicit_With (Item) then | |
833 | Version_Update (N, Library_Unit (Item)); | |
834 | end if; | |
835 | ||
836 | -- But skip use clauses at this stage, since we don't want to do | |
837 | -- any installing of potentially use visible entities until we | |
838 | -- we actually install the complete context (in Install_Context). | |
839 | -- Otherwise things can get installed in the wrong context. | |
840 | -- Similarly, pragmas are analyzed in Install_Context, after all | |
841 | -- the implicit with's on parent units are generated. | |
842 | ||
843 | else | |
844 | null; | |
845 | end if; | |
846 | ||
847 | Next (Item); | |
848 | end loop; | |
fbf5a39b AC |
849 | |
850 | -- Second pass: add implicit limited_with_clauses for parents of | |
851 | -- child units mentioned in limited_with clauses. | |
852 | ||
853 | Item := First (Context_Items (N)); | |
854 | ||
855 | while Present (Item) loop | |
856 | if Nkind (Item) = N_With_Clause | |
857 | and then Limited_Present (Item) | |
858 | and then Nkind (Name (Item)) = N_Selected_Component | |
859 | then | |
860 | Expand_Limited_With_Clause | |
861 | (Nam => Prefix (Name (Item)), N => Item); | |
862 | end if; | |
863 | ||
864 | Next (Item); | |
865 | end loop; | |
866 | ||
a5b62485 | 867 | -- Third pass: examine all limited_with clauses |
fbf5a39b AC |
868 | |
869 | Item := First (Context_Items (N)); | |
870 | ||
871 | while Present (Item) loop | |
872 | if Nkind (Item) = N_With_Clause | |
873 | and then Limited_Present (Item) | |
874 | then | |
875 | ||
657a9dd9 AC |
876 | if Nkind (Unit (N)) /= N_Package_Declaration then |
877 | Error_Msg_N ("limited with_clause only allowed in" | |
878 | & " package specification", Item); | |
879 | end if; | |
880 | ||
a5b62485 | 881 | -- Skip analyzing with clause if no unit, see above |
fbf5a39b AC |
882 | |
883 | if Present (Library_Unit (Item)) then | |
884 | Analyze (Item); | |
885 | end if; | |
886 | ||
887 | -- A limited_with does not impose an elaboration order, but | |
888 | -- there is a semantic dependency for recompilation purposes. | |
889 | ||
890 | if not Implicit_With (Item) then | |
891 | Version_Update (N, Library_Unit (Item)); | |
892 | end if; | |
893 | end if; | |
894 | ||
895 | Next (Item); | |
896 | end loop; | |
996ae0b0 RK |
897 | end Analyze_Context; |
898 | ||
899 | ------------------------------- | |
900 | -- Analyze_Package_Body_Stub -- | |
901 | ------------------------------- | |
902 | ||
903 | procedure Analyze_Package_Body_Stub (N : Node_Id) is | |
904 | Id : constant Entity_Id := Defining_Identifier (N); | |
905 | Nam : Entity_Id; | |
906 | ||
907 | begin | |
a5b62485 | 908 | -- The package declaration must be in the current declarative part |
996ae0b0 RK |
909 | |
910 | Check_Stub_Level (N); | |
911 | Nam := Current_Entity_In_Scope (Id); | |
912 | ||
913 | if No (Nam) or else not Is_Package (Nam) then | |
914 | Error_Msg_N ("missing specification for package stub", N); | |
915 | ||
916 | elsif Has_Completion (Nam) | |
917 | and then Present (Corresponding_Body (Unit_Declaration_Node (Nam))) | |
918 | then | |
919 | Error_Msg_N ("duplicate or redundant stub for package", N); | |
920 | ||
921 | else | |
922 | -- Indicate that the body of the package exists. If we are doing | |
923 | -- only semantic analysis, the stub stands for the body. If we are | |
924 | -- generating code, the existence of the body will be confirmed | |
925 | -- when we load the proper body. | |
926 | ||
927 | Set_Has_Completion (Nam); | |
928 | Set_Scope (Defining_Entity (N), Current_Scope); | |
fbf5a39b | 929 | Generate_Reference (Nam, Id, 'b'); |
996ae0b0 RK |
930 | Analyze_Proper_Body (N, Nam); |
931 | end if; | |
932 | end Analyze_Package_Body_Stub; | |
933 | ||
934 | ------------------------- | |
935 | -- Analyze_Proper_Body -- | |
936 | ------------------------- | |
937 | ||
938 | procedure Analyze_Proper_Body (N : Node_Id; Nam : Entity_Id) is | |
939 | Subunit_Name : constant Unit_Name_Type := Get_Unit_Name (N); | |
940 | Unum : Unit_Number_Type; | |
996ae0b0 RK |
941 | |
942 | procedure Optional_Subunit; | |
943 | -- This procedure is called when the main unit is a stub, or when we | |
944 | -- are not generating code. In such a case, we analyze the subunit if | |
945 | -- present, which is user-friendly and in fact required for ASIS, but | |
946 | -- we don't complain if the subunit is missing. | |
947 | ||
948 | ---------------------- | |
949 | -- Optional_Subunit -- | |
950 | ---------------------- | |
951 | ||
952 | procedure Optional_Subunit is | |
953 | Comp_Unit : Node_Id; | |
954 | ||
955 | begin | |
956 | -- Try to load subunit, but ignore any errors that occur during | |
957 | -- the loading of the subunit, by using the special feature in | |
958 | -- Errout to ignore all errors. Note that Fatal_Error will still | |
959 | -- be set, so we will be able to check for this case below. | |
960 | ||
c37bb106 AC |
961 | if not ASIS_Mode then |
962 | Ignore_Errors_Enable := Ignore_Errors_Enable + 1; | |
963 | end if; | |
964 | ||
996ae0b0 RK |
965 | Unum := |
966 | Load_Unit | |
967 | (Load_Name => Subunit_Name, | |
968 | Required => False, | |
969 | Subunit => True, | |
970 | Error_Node => N); | |
c37bb106 AC |
971 | |
972 | if not ASIS_Mode then | |
973 | Ignore_Errors_Enable := Ignore_Errors_Enable - 1; | |
974 | end if; | |
996ae0b0 RK |
975 | |
976 | -- All done if we successfully loaded the subunit | |
977 | ||
fbf5a39b AC |
978 | if Unum /= No_Unit |
979 | and then (not Fatal_Error (Unum) or else Try_Semantics) | |
980 | then | |
996ae0b0 RK |
981 | Comp_Unit := Cunit (Unum); |
982 | ||
10b60633 ES |
983 | -- If the file was empty or seriously mangled, the unit |
984 | -- itself may be missing. | |
985 | ||
986 | if No (Unit (Comp_Unit)) then | |
987 | Error_Msg_N | |
988 | ("subunit does not contain expected proper body", N); | |
989 | ||
990 | elsif Nkind (Unit (Comp_Unit)) /= N_Subunit then | |
555360a5 AC |
991 | Error_Msg_N |
992 | ("expected SEPARATE subunit, found child unit", | |
993 | Cunit_Entity (Unum)); | |
994 | else | |
995 | Set_Corresponding_Stub (Unit (Comp_Unit), N); | |
996 | Analyze_Subunit (Comp_Unit); | |
997 | Set_Library_Unit (N, Comp_Unit); | |
998 | end if; | |
996ae0b0 RK |
999 | |
1000 | elsif Unum = No_Unit | |
1001 | and then Present (Nam) | |
1002 | then | |
1003 | if Is_Protected_Type (Nam) then | |
1004 | Set_Corresponding_Body (Parent (Nam), Defining_Identifier (N)); | |
1005 | else | |
1006 | Set_Corresponding_Body ( | |
1007 | Unit_Declaration_Node (Nam), Defining_Identifier (N)); | |
1008 | end if; | |
1009 | end if; | |
1010 | end Optional_Subunit; | |
1011 | ||
1012 | -- Start of processing for Analyze_Proper_Body | |
1013 | ||
1014 | begin | |
1015 | -- If the subunit is already loaded, it means that the main unit | |
1016 | -- is a subunit, and that the current unit is one of its parents | |
1017 | -- which was being analyzed to provide the needed context for the | |
1018 | -- analysis of the subunit. In this case we analyze the subunit and | |
1019 | -- continue with the parent, without looking a subsequent subunits. | |
1020 | ||
1021 | if Is_Loaded (Subunit_Name) then | |
1022 | ||
1023 | -- If the proper body is already linked to the stub node, | |
1024 | -- the stub is in a generic unit and just needs analyzing. | |
1025 | ||
1026 | if Present (Library_Unit (N)) then | |
1027 | Set_Corresponding_Stub (Unit (Library_Unit (N)), N); | |
1028 | Analyze_Subunit (Library_Unit (N)); | |
1029 | ||
1030 | -- Otherwise we must load the subunit and link to it | |
1031 | ||
1032 | else | |
1033 | -- Load the subunit, this must work, since we originally | |
1034 | -- loaded the subunit earlier on. So this will not really | |
1035 | -- load it, just give access to it. | |
1036 | ||
1037 | Unum := | |
1038 | Load_Unit | |
1039 | (Load_Name => Subunit_Name, | |
1040 | Required => True, | |
1041 | Subunit => False, | |
1042 | Error_Node => N); | |
1043 | ||
1044 | -- And analyze the subunit in the parent context (note that we | |
1045 | -- do not call Semantics, since that would remove the parent | |
1046 | -- context). Because of this, we have to manually reset the | |
1047 | -- compiler state to Analyzing since it got destroyed by Load. | |
1048 | ||
1049 | if Unum /= No_Unit then | |
1050 | Compiler_State := Analyzing; | |
fbf5a39b AC |
1051 | |
1052 | -- Check that the proper body is a subunit and not a child | |
1053 | -- unit. If the unit was previously loaded, the error will | |
1054 | -- have been emitted when copying the generic node, so we | |
1055 | -- just return to avoid cascaded errors. | |
1056 | ||
1057 | if Nkind (Unit (Cunit (Unum))) /= N_Subunit then | |
1058 | return; | |
1059 | end if; | |
1060 | ||
996ae0b0 RK |
1061 | Set_Corresponding_Stub (Unit (Cunit (Unum)), N); |
1062 | Analyze_Subunit (Cunit (Unum)); | |
1063 | Set_Library_Unit (N, Cunit (Unum)); | |
1064 | end if; | |
1065 | end if; | |
1066 | ||
1067 | -- If the main unit is a subunit, then we are just performing semantic | |
1068 | -- analysis on that subunit, and any other subunits of any parent unit | |
1069 | -- should be ignored, except that if we are building trees for ASIS | |
1070 | -- usage we want to annotate the stub properly. | |
1071 | ||
1072 | elsif Nkind (Unit (Cunit (Main_Unit))) = N_Subunit | |
1073 | and then Subunit_Name /= Unit_Name (Main_Unit) | |
1074 | then | |
fbf5a39b | 1075 | if ASIS_Mode then |
996ae0b0 RK |
1076 | Optional_Subunit; |
1077 | end if; | |
1078 | ||
1079 | -- But before we return, set the flag for unloaded subunits. This | |
1080 | -- will suppress junk warnings of variables in the same declarative | |
1081 | -- part (or a higher level one) that are in danger of looking unused | |
1082 | -- when in fact there might be a declaration in the subunit that we | |
1083 | -- do not intend to load. | |
1084 | ||
1085 | Unloaded_Subunits := True; | |
1086 | return; | |
1087 | ||
1088 | -- If the subunit is not already loaded, and we are generating code, | |
1089 | -- then this is the case where compilation started from the parent, | |
1090 | -- and we are generating code for an entire subunit tree. In that | |
1091 | -- case we definitely need to load the subunit. | |
1092 | ||
1093 | -- In order to continue the analysis with the rest of the parent, | |
1094 | -- and other subunits, we load the unit without requiring its | |
1095 | -- presence, and emit a warning if not found, rather than terminating | |
1096 | -- the compilation abruptly, as for other missing file problems. | |
1097 | ||
fbf5a39b | 1098 | elsif Original_Operating_Mode = Generate_Code then |
996ae0b0 RK |
1099 | |
1100 | -- If the proper body is already linked to the stub node, | |
1101 | -- the stub is in a generic unit and just needs analyzing. | |
1102 | ||
1103 | -- We update the version. Although we are not technically | |
1104 | -- semantically dependent on the subunit, given our approach | |
1105 | -- of macro substitution of subunits, it makes sense to | |
1106 | -- include it in the version identification. | |
1107 | ||
1108 | if Present (Library_Unit (N)) then | |
1109 | Set_Corresponding_Stub (Unit (Library_Unit (N)), N); | |
1110 | Analyze_Subunit (Library_Unit (N)); | |
1111 | Version_Update (Cunit (Main_Unit), Library_Unit (N)); | |
1112 | ||
1113 | -- Otherwise we must load the subunit and link to it | |
1114 | ||
1115 | else | |
1116 | Unum := | |
1117 | Load_Unit | |
1118 | (Load_Name => Subunit_Name, | |
1119 | Required => False, | |
1120 | Subunit => True, | |
1121 | Error_Node => N); | |
1122 | ||
fbf5a39b | 1123 | if Original_Operating_Mode = Generate_Code |
996ae0b0 RK |
1124 | and then Unum = No_Unit |
1125 | then | |
1126 | Error_Msg_Name_1 := Subunit_Name; | |
1127 | Error_Msg_Name_2 := | |
1128 | Get_File_Name (Subunit_Name, Subunit => True); | |
1129 | Error_Msg_N | |
1130 | ("subunit% in file{ not found!?", N); | |
1131 | Subunits_Missing := True; | |
996ae0b0 RK |
1132 | end if; |
1133 | ||
1134 | -- Load_Unit may reset Compiler_State, since it may have been | |
1135 | -- necessary to parse an additional units, so we make sure | |
1136 | -- that we reset it to the Analyzing state. | |
1137 | ||
1138 | Compiler_State := Analyzing; | |
1139 | ||
fbf5a39b AC |
1140 | if Unum /= No_Unit |
1141 | and then (not Fatal_Error (Unum) or else Try_Semantics) | |
1142 | then | |
996ae0b0 RK |
1143 | if Debug_Flag_L then |
1144 | Write_Str ("*** Loaded subunit from stub. Analyze"); | |
1145 | Write_Eol; | |
1146 | end if; | |
1147 | ||
1148 | declare | |
1149 | Comp_Unit : constant Node_Id := Cunit (Unum); | |
1150 | ||
1151 | begin | |
1152 | -- Check for child unit instead of subunit | |
1153 | ||
1154 | if Nkind (Unit (Comp_Unit)) /= N_Subunit then | |
1155 | Error_Msg_N | |
1156 | ("expected SEPARATE subunit, found child unit", | |
1157 | Cunit_Entity (Unum)); | |
1158 | ||
1159 | -- OK, we have a subunit, so go ahead and analyze it, | |
1160 | -- and set Scope of entity in stub, for ASIS use. | |
1161 | ||
1162 | else | |
1163 | Set_Corresponding_Stub (Unit (Comp_Unit), N); | |
1164 | Analyze_Subunit (Comp_Unit); | |
1165 | Set_Library_Unit (N, Comp_Unit); | |
1166 | ||
1167 | -- We update the version. Although we are not technically | |
1168 | -- semantically dependent on the subunit, given our | |
1169 | -- approach of macro substitution of subunits, it makes | |
1170 | -- sense to include it in the version identification. | |
1171 | ||
1172 | Version_Update (Cunit (Main_Unit), Comp_Unit); | |
1173 | end if; | |
1174 | end; | |
1175 | end if; | |
1176 | end if; | |
1177 | ||
1178 | -- The remaining case is when the subunit is not already loaded and | |
1179 | -- we are not generating code. In this case we are just performing | |
1180 | -- semantic analysis on the parent, and we are not interested in | |
1181 | -- the subunit. For subprograms, analyze the stub as a body. For | |
1182 | -- other entities the stub has already been marked as completed. | |
1183 | ||
1184 | else | |
1185 | Optional_Subunit; | |
1186 | end if; | |
1187 | ||
1188 | end Analyze_Proper_Body; | |
1189 | ||
1190 | ---------------------------------- | |
1191 | -- Analyze_Protected_Body_Stub -- | |
1192 | ---------------------------------- | |
1193 | ||
1194 | procedure Analyze_Protected_Body_Stub (N : Node_Id) is | |
1195 | Nam : Entity_Id := Current_Entity_In_Scope (Defining_Identifier (N)); | |
1196 | ||
1197 | begin | |
1198 | Check_Stub_Level (N); | |
1199 | ||
a5b62485 | 1200 | -- First occurence of name may have been as an incomplete type |
996ae0b0 RK |
1201 | |
1202 | if Present (Nam) and then Ekind (Nam) = E_Incomplete_Type then | |
1203 | Nam := Full_View (Nam); | |
1204 | end if; | |
1205 | ||
1206 | if No (Nam) | |
1207 | or else not Is_Protected_Type (Etype (Nam)) | |
1208 | then | |
1209 | Error_Msg_N ("missing specification for Protected body", N); | |
1210 | else | |
1211 | Set_Scope (Defining_Entity (N), Current_Scope); | |
1212 | Set_Has_Completion (Etype (Nam)); | |
fbf5a39b | 1213 | Generate_Reference (Nam, Defining_Identifier (N), 'b'); |
996ae0b0 RK |
1214 | Analyze_Proper_Body (N, Etype (Nam)); |
1215 | end if; | |
1216 | end Analyze_Protected_Body_Stub; | |
1217 | ||
1218 | ---------------------------------- | |
1219 | -- Analyze_Subprogram_Body_Stub -- | |
1220 | ---------------------------------- | |
1221 | ||
1222 | -- A subprogram body stub can appear with or without a previous | |
1223 | -- specification. If there is one, the analysis of the body will | |
1224 | -- find it and verify conformance. The formals appearing in the | |
1225 | -- specification of the stub play no role, except for requiring an | |
1226 | -- additional conformance check. If there is no previous subprogram | |
1227 | -- declaration, the stub acts as a spec, and provides the defining | |
1228 | -- entity for the subprogram. | |
1229 | ||
1230 | procedure Analyze_Subprogram_Body_Stub (N : Node_Id) is | |
1231 | Decl : Node_Id; | |
1232 | ||
1233 | begin | |
1234 | Check_Stub_Level (N); | |
1235 | ||
1236 | -- Verify that the identifier for the stub is unique within this | |
1237 | -- declarative part. | |
1238 | ||
1239 | if Nkind (Parent (N)) = N_Block_Statement | |
1240 | or else Nkind (Parent (N)) = N_Package_Body | |
1241 | or else Nkind (Parent (N)) = N_Subprogram_Body | |
1242 | then | |
1243 | Decl := First (Declarations (Parent (N))); | |
1244 | ||
1245 | while Present (Decl) | |
1246 | and then Decl /= N | |
1247 | loop | |
1248 | if Nkind (Decl) = N_Subprogram_Body_Stub | |
1249 | and then (Chars (Defining_Unit_Name (Specification (Decl))) | |
1250 | = Chars (Defining_Unit_Name (Specification (N)))) | |
1251 | then | |
1252 | Error_Msg_N ("identifier for stub is not unique", N); | |
1253 | end if; | |
1254 | ||
1255 | Next (Decl); | |
1256 | end loop; | |
1257 | end if; | |
1258 | ||
1259 | -- Treat stub as a body, which checks conformance if there is a previous | |
1260 | -- declaration, or else introduces entity and its signature. | |
1261 | ||
1262 | Analyze_Subprogram_Body (N); | |
fbf5a39b | 1263 | Analyze_Proper_Body (N, Empty); |
996ae0b0 RK |
1264 | end Analyze_Subprogram_Body_Stub; |
1265 | ||
1266 | --------------------- | |
1267 | -- Analyze_Subunit -- | |
1268 | --------------------- | |
1269 | ||
1270 | -- A subunit is compiled either by itself (for semantic checking) | |
1271 | -- or as part of compiling the parent (for code generation). In | |
1272 | -- either case, by the time we actually process the subunit, the | |
1273 | -- parent has already been installed and analyzed. The node N is | |
1274 | -- a compilation unit, whose context needs to be treated here, | |
1275 | -- because we come directly here from the parent without calling | |
1276 | -- Analyze_Compilation_Unit. | |
1277 | ||
1278 | -- The compilation context includes the explicit context of the | |
1279 | -- subunit, and the context of the parent, together with the parent | |
1280 | -- itself. In order to compile the current context, we remove the | |
1281 | -- one inherited from the parent, in order to have a clean visibility | |
1282 | -- table. We restore the parent context before analyzing the proper | |
1283 | -- body itself. On exit, we remove only the explicit context of the | |
1284 | -- subunit. | |
1285 | ||
1286 | procedure Analyze_Subunit (N : Node_Id) is | |
1287 | Lib_Unit : constant Node_Id := Library_Unit (N); | |
1288 | Par_Unit : constant Entity_Id := Current_Scope; | |
1289 | ||
1290 | Lib_Spec : Node_Id := Library_Unit (Lib_Unit); | |
1291 | Num_Scopes : Int := 0; | |
1292 | Use_Clauses : array (1 .. Scope_Stack.Last) of Node_Id; | |
1293 | Enclosing_Child : Entity_Id := Empty; | |
657a9dd9 | 1294 | Svg : constant Suppress_Array := Scope_Suppress; |
996ae0b0 RK |
1295 | |
1296 | procedure Analyze_Subunit_Context; | |
1297 | -- Capture names in use clauses of the subunit. This must be done | |
1298 | -- before re-installing parent declarations, because items in the | |
1299 | -- context must not be hidden by declarations local to the parent. | |
1300 | ||
1301 | procedure Re_Install_Parents (L : Node_Id; Scop : Entity_Id); | |
1302 | -- Recursive procedure to restore scope of all ancestors of subunit, | |
1303 | -- from outermost in. If parent is not a subunit, the call to install | |
1304 | -- context installs context of spec and (if parent is a child unit) | |
1305 | -- the context of its parents as well. It is confusing that parents | |
1306 | -- should be treated differently in both cases, but the semantics are | |
1307 | -- just not identical. | |
1308 | ||
1309 | procedure Re_Install_Use_Clauses; | |
1310 | -- As part of the removal of the parent scope, the use clauses are | |
1311 | -- removed, to be reinstalled when the context of the subunit has | |
1312 | -- been analyzed. Use clauses may also have been affected by the | |
1313 | -- analysis of the context of the subunit, so they have to be applied | |
1314 | -- again, to insure that the compilation environment of the rest of | |
1315 | -- the parent unit is identical. | |
1316 | ||
1317 | procedure Remove_Scope; | |
1318 | -- Remove current scope from scope stack, and preserve the list | |
1319 | -- of use clauses in it, to be reinstalled after context is analyzed. | |
1320 | ||
15ce9ca2 AC |
1321 | ----------------------------- |
1322 | -- Analyze_Subunit_Context -- | |
1323 | ----------------------------- | |
996ae0b0 RK |
1324 | |
1325 | procedure Analyze_Subunit_Context is | |
1326 | Item : Node_Id; | |
1327 | Nam : Node_Id; | |
1328 | Unit_Name : Entity_Id; | |
1329 | ||
1330 | begin | |
1331 | Analyze_Context (N); | |
1332 | Item := First (Context_Items (N)); | |
1333 | ||
1334 | -- make withed units immediately visible. If child unit, make the | |
1335 | -- ultimate parent immediately visible. | |
1336 | ||
1337 | while Present (Item) loop | |
1338 | ||
1339 | if Nkind (Item) = N_With_Clause then | |
1340 | Unit_Name := Entity (Name (Item)); | |
1341 | ||
1342 | while Is_Child_Unit (Unit_Name) loop | |
1343 | Set_Is_Visible_Child_Unit (Unit_Name); | |
1344 | Unit_Name := Scope (Unit_Name); | |
1345 | end loop; | |
1346 | ||
1347 | if not Is_Immediately_Visible (Unit_Name) then | |
1348 | Set_Is_Immediately_Visible (Unit_Name); | |
1349 | Set_Context_Installed (Item); | |
1350 | end if; | |
1351 | ||
1352 | elsif Nkind (Item) = N_Use_Package_Clause then | |
1353 | Nam := First (Names (Item)); | |
1354 | ||
1355 | while Present (Nam) loop | |
1356 | Analyze (Nam); | |
1357 | Next (Nam); | |
1358 | end loop; | |
1359 | ||
1360 | elsif Nkind (Item) = N_Use_Type_Clause then | |
1361 | Nam := First (Subtype_Marks (Item)); | |
1362 | ||
1363 | while Present (Nam) loop | |
1364 | Analyze (Nam); | |
1365 | Next (Nam); | |
1366 | end loop; | |
1367 | end if; | |
1368 | ||
1369 | Next (Item); | |
1370 | end loop; | |
1371 | ||
1372 | Item := First (Context_Items (N)); | |
1373 | ||
1374 | -- reset visibility of withed units. They will be made visible | |
1375 | -- again when we install the subunit context. | |
1376 | ||
1377 | while Present (Item) loop | |
1378 | ||
1379 | if Nkind (Item) = N_With_Clause then | |
1380 | Unit_Name := Entity (Name (Item)); | |
1381 | ||
1382 | while Is_Child_Unit (Unit_Name) loop | |
1383 | Set_Is_Visible_Child_Unit (Unit_Name, False); | |
1384 | Unit_Name := Scope (Unit_Name); | |
1385 | end loop; | |
1386 | ||
1387 | if Context_Installed (Item) then | |
1388 | Set_Is_Immediately_Visible (Unit_Name, False); | |
1389 | Set_Context_Installed (Item, False); | |
1390 | end if; | |
1391 | end if; | |
1392 | ||
1393 | Next (Item); | |
1394 | end loop; | |
1395 | ||
1396 | end Analyze_Subunit_Context; | |
1397 | ||
1398 | ------------------------ | |
1399 | -- Re_Install_Parents -- | |
1400 | ------------------------ | |
1401 | ||
1402 | procedure Re_Install_Parents (L : Node_Id; Scop : Entity_Id) is | |
1403 | E : Entity_Id; | |
1404 | ||
1405 | begin | |
1406 | if Nkind (Unit (L)) = N_Subunit then | |
1407 | Re_Install_Parents (Library_Unit (L), Scope (Scop)); | |
1408 | end if; | |
1409 | ||
1410 | Install_Context (L); | |
1411 | ||
1412 | -- If the subunit occurs within a child unit, we must restore the | |
1413 | -- immediate visibility of any siblings that may occur in context. | |
1414 | ||
1415 | if Present (Enclosing_Child) then | |
1416 | Install_Siblings (Enclosing_Child, L); | |
1417 | end if; | |
1418 | ||
1419 | New_Scope (Scop); | |
1420 | ||
1421 | if Scop /= Par_Unit then | |
1422 | Set_Is_Immediately_Visible (Scop); | |
1423 | end if; | |
1424 | ||
1425 | E := First_Entity (Current_Scope); | |
1426 | ||
1427 | while Present (E) loop | |
1428 | Set_Is_Immediately_Visible (E); | |
1429 | Next_Entity (E); | |
1430 | end loop; | |
1431 | ||
1432 | -- A subunit appears within a body, and for a nested subunits | |
1433 | -- all the parents are bodies. Restore full visibility of their | |
1434 | -- private entities. | |
1435 | ||
1436 | if Ekind (Scop) = E_Package then | |
1437 | Set_In_Package_Body (Scop); | |
1438 | Install_Private_Declarations (Scop); | |
1439 | end if; | |
1440 | end Re_Install_Parents; | |
1441 | ||
1442 | ---------------------------- | |
1443 | -- Re_Install_Use_Clauses -- | |
1444 | ---------------------------- | |
1445 | ||
1446 | procedure Re_Install_Use_Clauses is | |
1447 | U : Node_Id; | |
1448 | ||
1449 | begin | |
1450 | for J in reverse 1 .. Num_Scopes loop | |
1451 | U := Use_Clauses (J); | |
1452 | Scope_Stack.Table (Scope_Stack.Last - J + 1).First_Use_Clause := U; | |
0da2c8ac | 1453 | Install_Use_Clauses (U, Force_Installation => True); |
996ae0b0 RK |
1454 | end loop; |
1455 | end Re_Install_Use_Clauses; | |
1456 | ||
1457 | ------------------ | |
1458 | -- Remove_Scope -- | |
1459 | ------------------ | |
1460 | ||
1461 | procedure Remove_Scope is | |
1462 | E : Entity_Id; | |
1463 | ||
1464 | begin | |
1465 | Num_Scopes := Num_Scopes + 1; | |
1466 | Use_Clauses (Num_Scopes) := | |
1467 | Scope_Stack.Table (Scope_Stack.Last).First_Use_Clause; | |
1468 | E := First_Entity (Current_Scope); | |
1469 | ||
1470 | while Present (E) loop | |
1471 | Set_Is_Immediately_Visible (E, False); | |
1472 | Next_Entity (E); | |
1473 | end loop; | |
1474 | ||
1475 | if Is_Child_Unit (Current_Scope) then | |
1476 | Enclosing_Child := Current_Scope; | |
1477 | end if; | |
1478 | ||
1479 | Pop_Scope; | |
1480 | end Remove_Scope; | |
1481 | ||
1482 | -- Start of processing for Analyze_Subunit | |
1483 | ||
1484 | begin | |
1485 | if not Is_Empty_List (Context_Items (N)) then | |
1486 | ||
a5b62485 | 1487 | -- Save current use clauses |
996ae0b0 RK |
1488 | |
1489 | Remove_Scope; | |
1490 | Remove_Context (Lib_Unit); | |
1491 | ||
1492 | -- Now remove parents and their context, including enclosing | |
1493 | -- subunits and the outer parent body which is not a subunit. | |
1494 | ||
1495 | if Present (Lib_Spec) then | |
1496 | Remove_Context (Lib_Spec); | |
1497 | ||
1498 | while Nkind (Unit (Lib_Spec)) = N_Subunit loop | |
1499 | Lib_Spec := Library_Unit (Lib_Spec); | |
1500 | Remove_Scope; | |
1501 | Remove_Context (Lib_Spec); | |
1502 | end loop; | |
1503 | ||
1504 | if Nkind (Unit (Lib_Unit)) = N_Subunit then | |
1505 | Remove_Scope; | |
1506 | end if; | |
1507 | ||
1508 | if Nkind (Unit (Lib_Spec)) = N_Package_Body then | |
1509 | Remove_Context (Library_Unit (Lib_Spec)); | |
1510 | end if; | |
1511 | end if; | |
1512 | ||
18c0ecbe AC |
1513 | Set_Is_Immediately_Visible (Par_Unit, False); |
1514 | ||
996ae0b0 | 1515 | Analyze_Subunit_Context; |
18c0ecbe | 1516 | |
996ae0b0 | 1517 | Re_Install_Parents (Lib_Unit, Par_Unit); |
18c0ecbe | 1518 | Set_Is_Immediately_Visible (Par_Unit); |
996ae0b0 RK |
1519 | |
1520 | -- If the context includes a child unit of the parent of the | |
1521 | -- subunit, the parent will have been removed from visibility, | |
1522 | -- after compiling that cousin in the context. The visibility | |
1523 | -- of the parent must be restored now. This also applies if the | |
1524 | -- context includes another subunit of the same parent which in | |
1525 | -- turn includes a child unit in its context. | |
1526 | ||
1527 | if Ekind (Par_Unit) = E_Package then | |
1528 | if not Is_Immediately_Visible (Par_Unit) | |
1529 | or else (Present (First_Entity (Par_Unit)) | |
1530 | and then not Is_Immediately_Visible | |
1531 | (First_Entity (Par_Unit))) | |
1532 | then | |
1533 | Set_Is_Immediately_Visible (Par_Unit); | |
1534 | Install_Visible_Declarations (Par_Unit); | |
1535 | Install_Private_Declarations (Par_Unit); | |
1536 | end if; | |
1537 | end if; | |
1538 | ||
1539 | Re_Install_Use_Clauses; | |
1540 | Install_Context (N); | |
1541 | ||
a5b62485 | 1542 | -- Restore state of suppress flags for current body |
657a9dd9 AC |
1543 | |
1544 | Scope_Suppress := Svg; | |
1545 | ||
996ae0b0 RK |
1546 | -- If the subunit is within a child unit, then siblings of any |
1547 | -- parent unit that appear in the context clause of the subunit | |
1548 | -- must also be made immediately visible. | |
1549 | ||
1550 | if Present (Enclosing_Child) then | |
1551 | Install_Siblings (Enclosing_Child, N); | |
1552 | end if; | |
1553 | ||
1554 | end if; | |
1555 | ||
1556 | Analyze (Proper_Body (Unit (N))); | |
1557 | Remove_Context (N); | |
996ae0b0 RK |
1558 | end Analyze_Subunit; |
1559 | ||
1560 | ---------------------------- | |
1561 | -- Analyze_Task_Body_Stub -- | |
1562 | ---------------------------- | |
1563 | ||
1564 | procedure Analyze_Task_Body_Stub (N : Node_Id) is | |
1565 | Nam : Entity_Id := Current_Entity_In_Scope (Defining_Identifier (N)); | |
1566 | Loc : constant Source_Ptr := Sloc (N); | |
1567 | ||
1568 | begin | |
1569 | Check_Stub_Level (N); | |
1570 | ||
a5b62485 | 1571 | -- First occurence of name may have been as an incomplete type |
996ae0b0 RK |
1572 | |
1573 | if Present (Nam) and then Ekind (Nam) = E_Incomplete_Type then | |
1574 | Nam := Full_View (Nam); | |
1575 | end if; | |
1576 | ||
1577 | if No (Nam) | |
1578 | or else not Is_Task_Type (Etype (Nam)) | |
1579 | then | |
1580 | Error_Msg_N ("missing specification for task body", N); | |
1581 | else | |
1582 | Set_Scope (Defining_Entity (N), Current_Scope); | |
fbf5a39b | 1583 | Generate_Reference (Nam, Defining_Identifier (N), 'b'); |
996ae0b0 RK |
1584 | Set_Has_Completion (Etype (Nam)); |
1585 | Analyze_Proper_Body (N, Etype (Nam)); | |
1586 | ||
1587 | -- Set elaboration flag to indicate that entity is callable. | |
1588 | -- This cannot be done in the expansion of the body itself, | |
1589 | -- because the proper body is not in a declarative part. This | |
1590 | -- is only done if expansion is active, because the context | |
1591 | -- may be generic and the flag not defined yet. | |
1592 | ||
1593 | if Expander_Active then | |
1594 | Insert_After (N, | |
1595 | Make_Assignment_Statement (Loc, | |
1596 | Name => | |
1597 | Make_Identifier (Loc, | |
1598 | New_External_Name (Chars (Etype (Nam)), 'E')), | |
1599 | Expression => New_Reference_To (Standard_True, Loc))); | |
1600 | end if; | |
1601 | ||
1602 | end if; | |
1603 | end Analyze_Task_Body_Stub; | |
1604 | ||
1605 | ------------------------- | |
1606 | -- Analyze_With_Clause -- | |
1607 | ------------------------- | |
1608 | ||
1609 | -- Analyze the declaration of a unit in a with clause. At end, | |
1610 | -- label the with clause with the defining entity for the unit. | |
1611 | ||
1612 | procedure Analyze_With_Clause (N : Node_Id) is | |
fbf5a39b AC |
1613 | |
1614 | -- Retrieve the original kind of the unit node, before analysis. | |
1615 | -- If it is a subprogram instantiation, its analysis below will | |
1616 | -- rewrite as the declaration of the wrapper package. If the same | |
1617 | -- instantiation appears indirectly elsewhere in the context, it | |
1618 | -- will have been analyzed already. | |
1619 | ||
1620 | Unit_Kind : constant Node_Kind := | |
1621 | Nkind (Original_Node (Unit (Library_Unit (N)))); | |
1622 | ||
996ae0b0 RK |
1623 | E_Name : Entity_Id; |
1624 | Par_Name : Entity_Id; | |
1625 | Pref : Node_Id; | |
1626 | U : Node_Id; | |
1627 | ||
1628 | Intunit : Boolean; | |
1629 | -- Set True if the unit currently being compiled is an internal unit | |
1630 | ||
1631 | Save_Style_Check : constant Boolean := Opt.Style_Check; | |
6e937c1c AC |
1632 | Save_C_Restrict : constant Save_Cunit_Boolean_Restrictions := |
1633 | Cunit_Boolean_Restrictions_Save; | |
996ae0b0 RK |
1634 | |
1635 | begin | |
fbf5a39b | 1636 | if Limited_Present (N) then |
0ab80019 | 1637 | -- Ada 2005 (AI-50217): Build visibility structures but do not |
19f0526a | 1638 | -- analyze unit |
fbf5a39b AC |
1639 | |
1640 | Build_Limited_Views (N); | |
1641 | return; | |
1642 | end if; | |
1643 | ||
996ae0b0 RK |
1644 | -- We reset ordinary style checking during the analysis of a with'ed |
1645 | -- unit, but we do NOT reset GNAT special analysis mode (the latter | |
1646 | -- definitely *does* apply to with'ed units). | |
1647 | ||
1648 | if not GNAT_Mode then | |
1649 | Style_Check := False; | |
1650 | end if; | |
1651 | ||
fbf5a39b AC |
1652 | -- If the library unit is a predefined unit, and we are in high |
1653 | -- integrity mode, then temporarily reset Configurable_Run_Time_Mode | |
1654 | -- for the analysis of the with'ed unit. This mode does not prevent | |
1655 | -- explicit with'ing of run-time units. | |
996ae0b0 | 1656 | |
fbf5a39b | 1657 | if Configurable_Run_Time_Mode |
996ae0b0 RK |
1658 | and then |
1659 | Is_Predefined_File_Name | |
1660 | (Unit_File_Name (Get_Source_Unit (Unit (Library_Unit (N))))) | |
1661 | then | |
fbf5a39b | 1662 | Configurable_Run_Time_Mode := False; |
996ae0b0 | 1663 | Semantics (Library_Unit (N)); |
fbf5a39b | 1664 | Configurable_Run_Time_Mode := True; |
996ae0b0 RK |
1665 | |
1666 | else | |
1667 | Semantics (Library_Unit (N)); | |
1668 | end if; | |
1669 | ||
1670 | U := Unit (Library_Unit (N)); | |
5f3ab6fb | 1671 | Check_Restriction_No_Dependence (Name (N), N); |
996ae0b0 RK |
1672 | Intunit := Is_Internal_File_Name (Unit_File_Name (Current_Sem_Unit)); |
1673 | ||
1674 | -- Following checks are skipped for dummy packages (those supplied | |
1675 | -- for with's where no matching file could be found). Such packages | |
1676 | -- are identified by the Sloc value being set to No_Location | |
1677 | ||
1678 | if Sloc (U) /= No_Location then | |
1679 | ||
1680 | -- Check restrictions, except that we skip the check if this | |
1681 | -- is an internal unit unless we are compiling the internal | |
1682 | -- unit as the main unit. We also skip this for dummy packages. | |
1683 | ||
1684 | if not Intunit or else Current_Sem_Unit = Main_Unit then | |
1685 | Check_Restricted_Unit (Unit_Name (Get_Source_Unit (U)), N); | |
1686 | end if; | |
1687 | ||
1688 | -- Check for inappropriate with of internal implementation unit | |
1689 | -- if we are currently compiling the main unit and the main unit | |
fbf5a39b AC |
1690 | -- is itself not an internal unit. We do not issue this message |
1691 | -- for implicit with's generated by the compiler itself. | |
996ae0b0 RK |
1692 | |
1693 | if Implementation_Unit_Warnings | |
1694 | and then Current_Sem_Unit = Main_Unit | |
996ae0b0 | 1695 | and then not Intunit |
fbf5a39b | 1696 | and then not Implicit_With (N) |
82c80734 | 1697 | and then not GNAT_Mode |
996ae0b0 | 1698 | then |
82c80734 RD |
1699 | declare |
1700 | U_Kind : constant Kind_Of_Unit := | |
1701 | Get_Kind_Of_Unit (Get_Source_Unit (U)); | |
1702 | ||
1703 | begin | |
1704 | if U_Kind = Implementation_Unit then | |
1705 | Error_Msg_N ("& is an internal 'G'N'A'T unit?", Name (N)); | |
1706 | Error_Msg_N | |
1707 | ("\use of this unit is non-portable " & | |
1708 | "and version-dependent?", | |
1709 | Name (N)); | |
1710 | ||
1711 | elsif U_Kind = Ada_05_Unit and then Ada_Version = Ada_95 then | |
1712 | Error_Msg_N ("& is an Ada 2005 unit?", Name (N)); | |
1713 | end if; | |
1714 | end; | |
996ae0b0 RK |
1715 | end if; |
1716 | end if; | |
1717 | ||
1718 | -- Semantic analysis of a generic unit is performed on a copy of | |
1719 | -- the original tree. Retrieve the entity on which semantic info | |
1720 | -- actually appears. | |
1721 | ||
1722 | if Unit_Kind in N_Generic_Declaration then | |
1723 | E_Name := Defining_Entity (U); | |
1724 | ||
1725 | -- Note: in the following test, Unit_Kind is the original Nkind, but | |
6510f4c9 GB |
1726 | -- in the case of an instantiation, semantic analysis above will |
1727 | -- have replaced the unit by its instantiated version. If the instance | |
1728 | -- body has been generated, the instance now denotes the body entity. | |
1729 | -- For visibility purposes we need the entity of its spec. | |
1730 | ||
1731 | elsif (Unit_Kind = N_Package_Instantiation | |
1732 | or else Nkind (Original_Node (Unit (Library_Unit (N)))) = | |
1733 | N_Package_Instantiation) | |
996ae0b0 RK |
1734 | and then Nkind (U) = N_Package_Body |
1735 | then | |
996ae0b0 RK |
1736 | E_Name := Corresponding_Spec (U); |
1737 | ||
1738 | elsif Unit_Kind = N_Package_Instantiation | |
1739 | and then Nkind (U) = N_Package_Instantiation | |
1740 | then | |
1741 | -- If the instance has not been rewritten as a package declaration, | |
1742 | -- then it appeared already in a previous with clause. Retrieve | |
1743 | -- the entity from the previous instance. | |
1744 | ||
1745 | E_Name := Defining_Entity (Specification (Instance_Spec (U))); | |
1746 | ||
1747 | elsif Unit_Kind = N_Procedure_Instantiation | |
1748 | or else Unit_Kind = N_Function_Instantiation | |
1749 | then | |
1750 | -- Instantiation node is replaced with a package that contains | |
1751 | -- renaming declarations and instance itself. The subprogram | |
1752 | -- Instance is declared in the visible part of the wrapper package. | |
1753 | ||
1754 | E_Name := First_Entity (Defining_Entity (U)); | |
1755 | ||
1756 | while Present (E_Name) loop | |
1757 | exit when Is_Subprogram (E_Name) | |
1758 | and then Is_Generic_Instance (E_Name); | |
1759 | E_Name := Next_Entity (E_Name); | |
1760 | end loop; | |
1761 | ||
1762 | elsif Unit_Kind = N_Package_Renaming_Declaration | |
1763 | or else Unit_Kind in N_Generic_Renaming_Declaration | |
1764 | then | |
1765 | E_Name := Defining_Entity (U); | |
1766 | ||
1767 | elsif Unit_Kind = N_Subprogram_Body | |
1768 | and then Nkind (Name (N)) = N_Selected_Component | |
1769 | and then not Acts_As_Spec (Library_Unit (N)) | |
1770 | then | |
1771 | -- For a child unit that has no spec, one has been created and | |
1772 | -- analyzed. The entity required is that of the spec. | |
1773 | ||
1774 | E_Name := Corresponding_Spec (U); | |
1775 | ||
1776 | else | |
1777 | E_Name := Defining_Entity (U); | |
1778 | end if; | |
1779 | ||
1780 | if Nkind (Name (N)) = N_Selected_Component then | |
1781 | ||
1782 | -- Child unit in a with clause | |
1783 | ||
1784 | Change_Selected_Component_To_Expanded_Name (Name (N)); | |
1785 | end if; | |
1786 | ||
1787 | -- Restore style checks and restrictions | |
1788 | ||
1789 | Style_Check := Save_Style_Check; | |
6e937c1c | 1790 | Cunit_Boolean_Restrictions_Restore (Save_C_Restrict); |
996ae0b0 RK |
1791 | |
1792 | -- Record the reference, but do NOT set the unit as referenced, we | |
1793 | -- want to consider the unit as unreferenced if this is the only | |
1794 | -- reference that occurs. | |
1795 | ||
1796 | Set_Entity_With_Style_Check (Name (N), E_Name); | |
fbf5a39b | 1797 | Generate_Reference (E_Name, Name (N), 'w', Set_Ref => False); |
996ae0b0 RK |
1798 | |
1799 | if Is_Child_Unit (E_Name) then | |
1800 | Pref := Prefix (Name (N)); | |
1801 | Par_Name := Scope (E_Name); | |
1802 | ||
1803 | while Nkind (Pref) = N_Selected_Component loop | |
1804 | Change_Selected_Component_To_Expanded_Name (Pref); | |
1805 | Set_Entity_With_Style_Check (Pref, Par_Name); | |
1806 | ||
1807 | Generate_Reference (Par_Name, Pref); | |
1808 | Pref := Prefix (Pref); | |
9596236a AC |
1809 | |
1810 | -- If E_Name is the dummy entity for a nonexistent unit, | |
1811 | -- its scope is set to Standard_Standard, and no attempt | |
1812 | -- should be made to further unwind scopes. | |
1813 | ||
1814 | if Par_Name /= Standard_Standard then | |
1815 | Par_Name := Scope (Par_Name); | |
1816 | end if; | |
996ae0b0 RK |
1817 | end loop; |
1818 | ||
1819 | if Present (Entity (Pref)) | |
1820 | and then not Analyzed (Parent (Parent (Entity (Pref)))) | |
1821 | then | |
1822 | -- If the entity is set without its unit being compiled, | |
1823 | -- the original parent is a renaming, and Par_Name is the | |
1824 | -- renamed entity. For visibility purposes, we need the | |
1825 | -- original entity, which must be analyzed now, because | |
1826 | -- Load_Unit retrieves directly the renamed unit, and the | |
1827 | -- renaming declaration itself has not been analyzed. | |
1828 | ||
1829 | Analyze (Parent (Parent (Entity (Pref)))); | |
1830 | pragma Assert (Renamed_Object (Entity (Pref)) = Par_Name); | |
1831 | Par_Name := Entity (Pref); | |
1832 | end if; | |
1833 | ||
1834 | Set_Entity_With_Style_Check (Pref, Par_Name); | |
1835 | Generate_Reference (Par_Name, Pref); | |
1836 | end if; | |
1837 | ||
1838 | -- If the withed unit is System, and a system extension pragma is | |
1839 | -- present, compile the extension now, rather than waiting for | |
1840 | -- a visibility check on a specific entity. | |
1841 | ||
1842 | if Chars (E_Name) = Name_System | |
1843 | and then Scope (E_Name) = Standard_Standard | |
fbf5a39b | 1844 | and then Present (System_Extend_Unit) |
996ae0b0 RK |
1845 | and then Present_System_Aux (N) |
1846 | then | |
a5b62485 | 1847 | -- If the extension is not present, an error will have been emitted |
996ae0b0 RK |
1848 | |
1849 | null; | |
1850 | end if; | |
9bc856dd | 1851 | |
0ab80019 AC |
1852 | -- Ada 2005 (AI-262): Remove from visibility the entity corresponding |
1853 | -- to private_with units; they will be made visible later (just before | |
1854 | -- the private part is analyzed) | |
9bc856dd AC |
1855 | |
1856 | if Private_Present (N) then | |
1857 | Set_Is_Immediately_Visible (E_Name, False); | |
1858 | end if; | |
996ae0b0 RK |
1859 | end Analyze_With_Clause; |
1860 | ||
1861 | ------------------------------ | |
1862 | -- Analyze_With_Type_Clause -- | |
1863 | ------------------------------ | |
1864 | ||
1865 | procedure Analyze_With_Type_Clause (N : Node_Id) is | |
1866 | Loc : constant Source_Ptr := Sloc (N); | |
fbf5a39b | 1867 | Nam : constant Node_Id := Name (N); |
996ae0b0 RK |
1868 | Pack : Node_Id; |
1869 | Decl : Node_Id; | |
1870 | P : Entity_Id; | |
1871 | Unum : Unit_Number_Type; | |
1872 | Sel : Node_Id; | |
1873 | ||
07fc65c4 | 1874 | procedure Decorate_Tagged_Type (T : Entity_Id); |
a5b62485 | 1875 | -- Set basic attributes of type, including its class_wide type |
996ae0b0 RK |
1876 | |
1877 | function In_Chain (E : Entity_Id) return Boolean; | |
1878 | -- Check that the imported type is not already in the homonym chain, | |
1879 | -- for example through a with_type clause in a parent unit. | |
1880 | ||
1881 | -------------------------- | |
1882 | -- Decorate_Tagged_Type -- | |
1883 | -------------------------- | |
1884 | ||
07fc65c4 | 1885 | procedure Decorate_Tagged_Type (T : Entity_Id) is |
996ae0b0 RK |
1886 | CW : Entity_Id; |
1887 | ||
1888 | begin | |
1889 | Set_Ekind (T, E_Record_Type); | |
1890 | Set_Is_Tagged_Type (T); | |
1891 | Set_Etype (T, T); | |
1892 | Set_From_With_Type (T); | |
1893 | Set_Scope (T, P); | |
1894 | ||
1895 | if not In_Chain (T) then | |
1896 | Set_Homonym (T, Current_Entity (T)); | |
1897 | Set_Current_Entity (T); | |
1898 | end if; | |
1899 | ||
a5b62485 | 1900 | -- Build bogus class_wide type, if not previously done |
996ae0b0 RK |
1901 | |
1902 | if No (Class_Wide_Type (T)) then | |
1903 | CW := Make_Defining_Identifier (Loc, New_Internal_Name ('S')); | |
1904 | ||
1905 | Set_Ekind (CW, E_Class_Wide_Type); | |
1906 | Set_Etype (CW, T); | |
1907 | Set_Scope (CW, P); | |
1908 | Set_Is_Tagged_Type (CW); | |
1909 | Set_Is_First_Subtype (CW, True); | |
1910 | Init_Size_Align (CW); | |
1911 | Set_Has_Unknown_Discriminants | |
1912 | (CW, True); | |
1913 | Set_Class_Wide_Type (CW, CW); | |
1914 | Set_Equivalent_Type (CW, Empty); | |
1915 | Set_From_With_Type (CW); | |
1916 | ||
1917 | Set_Class_Wide_Type (T, CW); | |
1918 | end if; | |
1919 | end Decorate_Tagged_Type; | |
1920 | ||
1921 | -------------- | |
1922 | -- In_Chain -- | |
1923 | -------------- | |
1924 | ||
1925 | function In_Chain (E : Entity_Id) return Boolean is | |
1926 | H : Entity_Id := Current_Entity (E); | |
1927 | ||
1928 | begin | |
1929 | while Present (H) loop | |
1930 | ||
1931 | if H = E then | |
1932 | return True; | |
1933 | else | |
1934 | H := Homonym (H); | |
1935 | end if; | |
1936 | end loop; | |
1937 | ||
1938 | return False; | |
1939 | end In_Chain; | |
1940 | ||
1941 | -- Start of processing for Analyze_With_Type_Clause | |
1942 | ||
1943 | begin | |
1944 | if Nkind (Nam) = N_Selected_Component then | |
1945 | Pack := New_Copy_Tree (Prefix (Nam)); | |
1946 | Sel := Selector_Name (Nam); | |
1947 | ||
1948 | else | |
1949 | Error_Msg_N ("illegal name for imported type", Nam); | |
1950 | return; | |
1951 | end if; | |
1952 | ||
1953 | Decl := | |
1954 | Make_Package_Declaration (Loc, | |
1955 | Specification => | |
1956 | (Make_Package_Specification (Loc, | |
1957 | Defining_Unit_Name => Pack, | |
1958 | Visible_Declarations => New_List, | |
1959 | End_Label => Empty))); | |
1960 | ||
1961 | Unum := | |
1962 | Load_Unit | |
1963 | (Load_Name => Get_Unit_Name (Decl), | |
1964 | Required => True, | |
1965 | Subunit => False, | |
1966 | Error_Node => Nam); | |
1967 | ||
1968 | if Unum = No_Unit | |
1969 | or else Nkind (Unit (Cunit (Unum))) /= N_Package_Declaration | |
1970 | then | |
1971 | Error_Msg_N ("imported type must be declared in package", Nam); | |
1972 | return; | |
1973 | ||
1974 | elsif Unum = Current_Sem_Unit then | |
1975 | ||
1976 | -- If type is defined in unit being analyzed, then the clause | |
1977 | -- is redundant. | |
1978 | ||
1979 | return; | |
1980 | ||
1981 | else | |
1982 | P := Cunit_Entity (Unum); | |
1983 | end if; | |
1984 | ||
1985 | -- Find declaration for imported type, and set its basic attributes | |
1986 | -- if it has not been analyzed (which will be the case if there is | |
1987 | -- circular dependence). | |
1988 | ||
1989 | declare | |
1990 | Decl : Node_Id; | |
1991 | Typ : Entity_Id; | |
1992 | ||
1993 | begin | |
1994 | if not Analyzed (Cunit (Unum)) | |
1995 | and then not From_With_Type (P) | |
1996 | then | |
1997 | Set_Ekind (P, E_Package); | |
1998 | Set_Etype (P, Standard_Void_Type); | |
1999 | Set_From_With_Type (P); | |
2000 | Set_Scope (P, Standard_Standard); | |
2001 | Set_Homonym (P, Current_Entity (P)); | |
2002 | Set_Current_Entity (P); | |
2003 | ||
2004 | elsif Analyzed (Cunit (Unum)) | |
2005 | and then Is_Child_Unit (P) | |
2006 | then | |
2007 | -- If the child unit is already in scope, indicate that it is | |
2008 | -- visible, and remains so after intervening calls to rtsfind. | |
2009 | ||
2010 | Set_Is_Visible_Child_Unit (P); | |
2011 | end if; | |
2012 | ||
2013 | if Nkind (Parent (P)) = N_Defining_Program_Unit_Name then | |
2014 | ||
a5b62485 | 2015 | -- Make parent packages visible |
996ae0b0 RK |
2016 | |
2017 | declare | |
2018 | Parent_Comp : Node_Id; | |
2019 | Parent_Id : Entity_Id; | |
2020 | Child : Entity_Id; | |
2021 | ||
2022 | begin | |
2023 | Child := P; | |
2024 | Parent_Comp := Parent_Spec (Unit (Cunit (Unum))); | |
2025 | ||
2026 | loop | |
2027 | Parent_Id := Defining_Entity (Unit (Parent_Comp)); | |
2028 | Set_Scope (Child, Parent_Id); | |
2029 | ||
2030 | -- The type may be imported from a child unit, in which | |
2031 | -- case the current compilation appears in the name. Do | |
2032 | -- not change its visibility here because it will conflict | |
2033 | -- with the subsequent normal processing. | |
2034 | ||
2035 | if not Analyzed (Unit_Declaration_Node (Parent_Id)) | |
2036 | and then Parent_Id /= Cunit_Entity (Current_Sem_Unit) | |
2037 | then | |
2038 | Set_Ekind (Parent_Id, E_Package); | |
2039 | Set_Etype (Parent_Id, Standard_Void_Type); | |
2040 | ||
2041 | -- The same package may appear is several with_type | |
2042 | -- clauses. | |
2043 | ||
2044 | if not From_With_Type (Parent_Id) then | |
2045 | Set_Homonym (Parent_Id, Current_Entity (Parent_Id)); | |
2046 | Set_Current_Entity (Parent_Id); | |
2047 | Set_From_With_Type (Parent_Id); | |
2048 | end if; | |
2049 | end if; | |
2050 | ||
2051 | Set_Is_Immediately_Visible (Parent_Id); | |
2052 | ||
2053 | Child := Parent_Id; | |
2054 | Parent_Comp := Parent_Spec (Unit (Parent_Comp)); | |
2055 | exit when No (Parent_Comp); | |
2056 | end loop; | |
2057 | ||
2058 | Set_Scope (Parent_Id, Standard_Standard); | |
2059 | end; | |
2060 | end if; | |
2061 | ||
2062 | -- Even if analyzed, the package may not be currently visible. It | |
2063 | -- must be while the with_type clause is active. | |
2064 | ||
2065 | Set_Is_Immediately_Visible (P); | |
2066 | ||
2067 | Decl := | |
2068 | First (Visible_Declarations (Specification (Unit (Cunit (Unum))))); | |
2069 | ||
2070 | while Present (Decl) loop | |
2071 | ||
2072 | if Nkind (Decl) = N_Full_Type_Declaration | |
2073 | and then Chars (Defining_Identifier (Decl)) = Chars (Sel) | |
2074 | then | |
2075 | Typ := Defining_Identifier (Decl); | |
2076 | ||
2077 | if Tagged_Present (N) then | |
2078 | ||
2079 | -- The declaration must indicate that this is a tagged | |
2080 | -- type or a type extension. | |
2081 | ||
2082 | if (Nkind (Type_Definition (Decl)) = N_Record_Definition | |
2083 | and then Tagged_Present (Type_Definition (Decl))) | |
2084 | or else | |
2085 | (Nkind (Type_Definition (Decl)) | |
2086 | = N_Derived_Type_Definition | |
2087 | and then Present | |
2088 | (Record_Extension_Part (Type_Definition (Decl)))) | |
2089 | then | |
2090 | null; | |
2091 | else | |
2092 | Error_Msg_N ("imported type is not a tagged type", Nam); | |
2093 | return; | |
2094 | end if; | |
2095 | ||
2096 | if not Analyzed (Decl) then | |
2097 | ||
2098 | -- Unit is not currently visible. Add basic attributes | |
2099 | -- to type and build its class-wide type. | |
2100 | ||
2101 | Init_Size_Align (Typ); | |
07fc65c4 | 2102 | Decorate_Tagged_Type (Typ); |
996ae0b0 RK |
2103 | end if; |
2104 | ||
2105 | else | |
2106 | if Nkind (Type_Definition (Decl)) | |
2107 | /= N_Access_To_Object_Definition | |
2108 | then | |
2109 | Error_Msg_N | |
2110 | ("imported type is not an access type", Nam); | |
2111 | ||
2112 | elsif not Analyzed (Decl) then | |
2113 | Set_Ekind (Typ, E_Access_Type); | |
2114 | Set_Etype (Typ, Typ); | |
2115 | Set_Scope (Typ, P); | |
2116 | Init_Size (Typ, System_Address_Size); | |
2117 | Init_Alignment (Typ); | |
2118 | Set_Directly_Designated_Type (Typ, Standard_Integer); | |
2119 | Set_From_With_Type (Typ); | |
2120 | ||
2121 | if not In_Chain (Typ) then | |
2122 | Set_Homonym (Typ, Current_Entity (Typ)); | |
2123 | Set_Current_Entity (Typ); | |
2124 | end if; | |
2125 | end if; | |
2126 | end if; | |
2127 | ||
2128 | Set_Entity (Sel, Typ); | |
2129 | return; | |
2130 | ||
2131 | elsif ((Nkind (Decl) = N_Private_Type_Declaration | |
2132 | and then Tagged_Present (Decl)) | |
2133 | or else (Nkind (Decl) = N_Private_Extension_Declaration)) | |
2134 | and then Chars (Defining_Identifier (Decl)) = Chars (Sel) | |
2135 | then | |
2136 | Typ := Defining_Identifier (Decl); | |
2137 | ||
2138 | if not Tagged_Present (N) then | |
2139 | Error_Msg_N ("type must be declared tagged", N); | |
2140 | ||
2141 | elsif not Analyzed (Decl) then | |
07fc65c4 | 2142 | Decorate_Tagged_Type (Typ); |
996ae0b0 RK |
2143 | end if; |
2144 | ||
2145 | Set_Entity (Sel, Typ); | |
2146 | Set_From_With_Type (Typ); | |
2147 | return; | |
2148 | end if; | |
2149 | ||
2150 | Decl := Next (Decl); | |
2151 | end loop; | |
2152 | ||
2153 | Error_Msg_NE ("not a visible access or tagged type in&", Nam, P); | |
2154 | end; | |
2155 | end Analyze_With_Type_Clause; | |
2156 | ||
2157 | ----------------------------- | |
2158 | -- Check_With_Type_Clauses -- | |
2159 | ----------------------------- | |
2160 | ||
2161 | procedure Check_With_Type_Clauses (N : Node_Id) is | |
2162 | Lib_Unit : constant Node_Id := Unit (N); | |
2163 | ||
2164 | procedure Check_Parent_Context (U : Node_Id); | |
a5b62485 | 2165 | -- Examine context items of parent unit to locate with_type clauses |
996ae0b0 RK |
2166 | |
2167 | -------------------------- | |
2168 | -- Check_Parent_Context -- | |
2169 | -------------------------- | |
2170 | ||
2171 | procedure Check_Parent_Context (U : Node_Id) is | |
2172 | Item : Node_Id; | |
2173 | ||
2174 | begin | |
2175 | Item := First (Context_Items (U)); | |
2176 | while Present (Item) loop | |
2177 | if Nkind (Item) = N_With_Type_Clause | |
2178 | and then not Error_Posted (Item) | |
2179 | and then | |
2180 | From_With_Type (Scope (Entity (Selector_Name (Name (Item))))) | |
2181 | then | |
2182 | Error_Msg_Sloc := Sloc (Item); | |
2183 | Error_Msg_N ("Missing With_Clause for With_Type_Clause#", N); | |
2184 | end if; | |
2185 | ||
2186 | Next (Item); | |
2187 | end loop; | |
2188 | end Check_Parent_Context; | |
2189 | ||
2190 | -- Start of processing for Check_With_Type_Clauses | |
2191 | ||
2192 | begin | |
2193 | if Extensions_Allowed | |
2194 | and then (Nkind (Lib_Unit) = N_Package_Body | |
2195 | or else Nkind (Lib_Unit) = N_Subprogram_Body) | |
2196 | then | |
2197 | Check_Parent_Context (Library_Unit (N)); | |
0ab80019 | 2198 | |
996ae0b0 RK |
2199 | if Is_Child_Spec (Unit (Library_Unit (N))) then |
2200 | Check_Parent_Context (Parent_Spec (Unit (Library_Unit (N)))); | |
2201 | end if; | |
2202 | end if; | |
2203 | end Check_With_Type_Clauses; | |
2204 | ||
2205 | ------------------------------ | |
2206 | -- Check_Private_Child_Unit -- | |
2207 | ------------------------------ | |
2208 | ||
2209 | procedure Check_Private_Child_Unit (N : Node_Id) is | |
2210 | Lib_Unit : constant Node_Id := Unit (N); | |
2211 | Item : Node_Id; | |
2212 | Curr_Unit : Entity_Id; | |
2213 | Sub_Parent : Node_Id; | |
2214 | Priv_Child : Entity_Id; | |
2215 | Par_Lib : Entity_Id; | |
2216 | Par_Spec : Node_Id; | |
2217 | ||
2218 | function Is_Private_Library_Unit (Unit : Entity_Id) return Boolean; | |
2219 | -- Returns true if and only if the library unit is declared with | |
2220 | -- an explicit designation of private. | |
2221 | ||
2222 | function Is_Private_Library_Unit (Unit : Entity_Id) return Boolean is | |
fbf5a39b AC |
2223 | Comp_Unit : constant Node_Id := Parent (Unit_Declaration_Node (Unit)); |
2224 | ||
996ae0b0 | 2225 | begin |
fbf5a39b | 2226 | return Private_Present (Comp_Unit); |
996ae0b0 RK |
2227 | end Is_Private_Library_Unit; |
2228 | ||
2229 | -- Start of processing for Check_Private_Child_Unit | |
2230 | ||
2231 | begin | |
2232 | if Nkind (Lib_Unit) = N_Package_Body | |
2233 | or else Nkind (Lib_Unit) = N_Subprogram_Body | |
2234 | then | |
2235 | Curr_Unit := Defining_Entity (Unit (Library_Unit (N))); | |
2236 | Par_Lib := Curr_Unit; | |
2237 | ||
2238 | elsif Nkind (Lib_Unit) = N_Subunit then | |
2239 | ||
2240 | -- The parent is itself a body. The parent entity is to be found | |
2241 | -- in the corresponding spec. | |
2242 | ||
2243 | Sub_Parent := Library_Unit (N); | |
2244 | Curr_Unit := Defining_Entity (Unit (Library_Unit (Sub_Parent))); | |
2245 | ||
2246 | -- If the parent itself is a subunit, Curr_Unit is the entity | |
2247 | -- of the enclosing body, retrieve the spec entity which is | |
2248 | -- the proper ancestor we need for the following tests. | |
2249 | ||
2250 | if Ekind (Curr_Unit) = E_Package_Body then | |
2251 | Curr_Unit := Spec_Entity (Curr_Unit); | |
2252 | end if; | |
2253 | ||
2254 | Par_Lib := Curr_Unit; | |
2255 | ||
2256 | else | |
2257 | Curr_Unit := Defining_Entity (Lib_Unit); | |
2258 | ||
2259 | Par_Lib := Curr_Unit; | |
2260 | Par_Spec := Parent_Spec (Lib_Unit); | |
2261 | ||
2262 | if No (Par_Spec) then | |
2263 | Par_Lib := Empty; | |
2264 | else | |
2265 | Par_Lib := Defining_Entity (Unit (Par_Spec)); | |
2266 | end if; | |
2267 | end if; | |
2268 | ||
2269 | -- Loop through context items | |
2270 | ||
2271 | Item := First (Context_Items (N)); | |
2272 | while Present (Item) loop | |
2273 | ||
0ab80019 AC |
2274 | -- Ada 2005 (AI-262): Allow private_with of a private child package |
2275 | -- in public siblings | |
9bc856dd | 2276 | |
996ae0b0 RK |
2277 | if Nkind (Item) = N_With_Clause |
2278 | and then not Implicit_With (Item) | |
9bc856dd | 2279 | and then not Private_Present (Item) |
996ae0b0 RK |
2280 | and then Is_Private_Descendant (Entity (Name (Item))) |
2281 | then | |
2282 | Priv_Child := Entity (Name (Item)); | |
2283 | ||
2284 | declare | |
2285 | Curr_Parent : Entity_Id := Par_Lib; | |
2286 | Child_Parent : Entity_Id := Scope (Priv_Child); | |
2287 | Prv_Ancestor : Entity_Id := Child_Parent; | |
2288 | Curr_Private : Boolean := Is_Private_Library_Unit (Curr_Unit); | |
2289 | ||
2290 | begin | |
2291 | -- If the child unit is a public child then locate | |
2292 | -- the nearest private ancestor; Child_Parent will | |
2293 | -- then be set to the parent of that ancestor. | |
2294 | ||
2295 | if not Is_Private_Library_Unit (Priv_Child) then | |
2296 | while Present (Prv_Ancestor) | |
2297 | and then not Is_Private_Library_Unit (Prv_Ancestor) | |
2298 | loop | |
2299 | Prv_Ancestor := Scope (Prv_Ancestor); | |
2300 | end loop; | |
2301 | ||
2302 | if Present (Prv_Ancestor) then | |
2303 | Child_Parent := Scope (Prv_Ancestor); | |
2304 | end if; | |
2305 | end if; | |
2306 | ||
2307 | while Present (Curr_Parent) | |
2308 | and then Curr_Parent /= Standard_Standard | |
2309 | and then Curr_Parent /= Child_Parent | |
2310 | loop | |
2311 | Curr_Private := | |
2312 | Curr_Private or else Is_Private_Library_Unit (Curr_Parent); | |
2313 | Curr_Parent := Scope (Curr_Parent); | |
2314 | end loop; | |
2315 | ||
2316 | if not Present (Curr_Parent) then | |
2317 | Curr_Parent := Standard_Standard; | |
2318 | end if; | |
2319 | ||
2320 | if Curr_Parent /= Child_Parent then | |
2321 | ||
2322 | if Ekind (Priv_Child) = E_Generic_Package | |
2323 | and then Chars (Priv_Child) in Text_IO_Package_Name | |
2324 | and then Chars (Scope (Scope (Priv_Child))) = Name_Ada | |
2325 | then | |
2326 | Error_Msg_NE | |
2327 | ("& is a nested package, not a compilation unit", | |
2328 | Name (Item), Priv_Child); | |
2329 | ||
2330 | else | |
2331 | Error_Msg_N | |
2332 | ("unit in with clause is private child unit!", Item); | |
2333 | Error_Msg_NE | |
2334 | ("current unit must also have parent&!", | |
2335 | Item, Child_Parent); | |
2336 | end if; | |
2337 | ||
2338 | elsif not Curr_Private | |
2339 | and then Nkind (Lib_Unit) /= N_Package_Body | |
2340 | and then Nkind (Lib_Unit) /= N_Subprogram_Body | |
2341 | and then Nkind (Lib_Unit) /= N_Subunit | |
2342 | then | |
2343 | Error_Msg_NE | |
2344 | ("current unit must also be private descendant of&", | |
2345 | Item, Child_Parent); | |
2346 | end if; | |
2347 | end; | |
2348 | end if; | |
2349 | ||
2350 | Next (Item); | |
2351 | end loop; | |
2352 | ||
2353 | end Check_Private_Child_Unit; | |
2354 | ||
2355 | ---------------------- | |
2356 | -- Check_Stub_Level -- | |
2357 | ---------------------- | |
2358 | ||
2359 | procedure Check_Stub_Level (N : Node_Id) is | |
2360 | Par : constant Node_Id := Parent (N); | |
2361 | Kind : constant Node_Kind := Nkind (Par); | |
2362 | ||
2363 | begin | |
2364 | if (Kind = N_Package_Body | |
2365 | or else Kind = N_Subprogram_Body | |
2366 | or else Kind = N_Task_Body | |
2367 | or else Kind = N_Protected_Body) | |
2368 | ||
2369 | and then (Nkind (Parent (Par)) = N_Compilation_Unit | |
2370 | or else Nkind (Parent (Par)) = N_Subunit) | |
2371 | then | |
2372 | null; | |
2373 | ||
2374 | -- In an instance, a missing stub appears at any level. A warning | |
2375 | -- message will have been emitted already for the missing file. | |
2376 | ||
2377 | elsif not In_Instance then | |
2378 | Error_Msg_N ("stub cannot appear in an inner scope", N); | |
2379 | ||
2380 | elsif Expander_Active then | |
2381 | Error_Msg_N ("missing proper body", N); | |
2382 | end if; | |
2383 | end Check_Stub_Level; | |
2384 | ||
2385 | ------------------------ | |
2386 | -- Expand_With_Clause -- | |
2387 | ------------------------ | |
2388 | ||
2389 | procedure Expand_With_Clause (Nam : Node_Id; N : Node_Id) is | |
2390 | Loc : constant Source_Ptr := Sloc (Nam); | |
2391 | Ent : constant Entity_Id := Entity (Nam); | |
2392 | Withn : Node_Id; | |
2393 | P : Node_Id; | |
2394 | ||
2395 | function Build_Unit_Name (Nam : Node_Id) return Node_Id; | |
2396 | ||
2397 | function Build_Unit_Name (Nam : Node_Id) return Node_Id is | |
2398 | Result : Node_Id; | |
2399 | ||
2400 | begin | |
2401 | if Nkind (Nam) = N_Identifier then | |
2402 | return New_Occurrence_Of (Entity (Nam), Loc); | |
2403 | ||
2404 | else | |
2405 | Result := | |
2406 | Make_Expanded_Name (Loc, | |
2407 | Chars => Chars (Entity (Nam)), | |
2408 | Prefix => Build_Unit_Name (Prefix (Nam)), | |
2409 | Selector_Name => New_Occurrence_Of (Entity (Nam), Loc)); | |
2410 | Set_Entity (Result, Entity (Nam)); | |
2411 | return Result; | |
2412 | end if; | |
2413 | end Build_Unit_Name; | |
2414 | ||
2415 | begin | |
2416 | New_Nodes_OK := New_Nodes_OK + 1; | |
2417 | Withn := | |
2418 | Make_With_Clause (Loc, Name => Build_Unit_Name (Nam)); | |
2419 | ||
2420 | P := Parent (Unit_Declaration_Node (Ent)); | |
2421 | Set_Library_Unit (Withn, P); | |
2422 | Set_Corresponding_Spec (Withn, Ent); | |
2423 | Set_First_Name (Withn, True); | |
2424 | Set_Implicit_With (Withn, True); | |
2425 | ||
2426 | Prepend (Withn, Context_Items (N)); | |
2427 | Mark_Rewrite_Insertion (Withn); | |
2428 | Install_Withed_Unit (Withn); | |
2429 | ||
2430 | if Nkind (Nam) = N_Expanded_Name then | |
2431 | Expand_With_Clause (Prefix (Nam), N); | |
2432 | end if; | |
2433 | ||
2434 | New_Nodes_OK := New_Nodes_OK - 1; | |
2435 | end Expand_With_Clause; | |
2436 | ||
fbf5a39b AC |
2437 | -------------------------------- |
2438 | -- Expand_Limited_With_Clause -- | |
2439 | -------------------------------- | |
2440 | ||
2441 | procedure Expand_Limited_With_Clause (Nam : Node_Id; N : Node_Id) is | |
2442 | Loc : constant Source_Ptr := Sloc (Nam); | |
fbf5a39b AC |
2443 | Unum : Unit_Number_Type; |
2444 | Withn : Node_Id; | |
2445 | ||
2446 | begin | |
2447 | New_Nodes_OK := New_Nodes_OK + 1; | |
2448 | ||
2449 | if Nkind (Nam) = N_Identifier then | |
2450 | Withn := | |
2451 | Make_With_Clause (Loc, Name => Nam); | |
2452 | Set_Limited_Present (Withn); | |
2453 | Set_First_Name (Withn); | |
2454 | Set_Implicit_With (Withn); | |
2455 | ||
2456 | -- Load the corresponding parent unit | |
2457 | ||
2458 | Unum := | |
2459 | Load_Unit | |
2460 | (Load_Name => Get_Spec_Name (Get_Unit_Name (Nam)), | |
2461 | Required => True, | |
2462 | Subunit => False, | |
2463 | Error_Node => Nam); | |
2464 | ||
fbf5a39b AC |
2465 | if not Analyzed (Cunit (Unum)) then |
2466 | Set_Library_Unit (Withn, Cunit (Unum)); | |
2467 | Set_Corresponding_Spec | |
2468 | (Withn, Specification (Unit (Cunit (Unum)))); | |
2469 | ||
2470 | Prepend (Withn, Context_Items (Parent (N))); | |
2471 | Mark_Rewrite_Insertion (Withn); | |
2472 | end if; | |
2473 | ||
9bc856dd | 2474 | else pragma Assert (Nkind (Nam) = N_Selected_Component); |
fbf5a39b AC |
2475 | Withn := |
2476 | Make_With_Clause | |
2477 | (Loc, | |
2478 | Name => | |
2479 | Make_Selected_Component | |
2480 | (Loc, | |
2481 | Prefix => Prefix (Nam), | |
2482 | Selector_Name => Selector_Name (Nam))); | |
2483 | ||
2484 | Set_Parent (Withn, Parent (N)); | |
2485 | Set_Limited_Present (Withn); | |
2486 | Set_First_Name (Withn); | |
2487 | Set_Implicit_With (Withn); | |
2488 | ||
2489 | Unum := | |
2490 | Load_Unit | |
2491 | (Load_Name => Get_Spec_Name (Get_Unit_Name (Nam)), | |
2492 | Required => True, | |
2493 | Subunit => False, | |
2494 | Error_Node => Nam); | |
2495 | ||
fbf5a39b AC |
2496 | if not Analyzed (Cunit (Unum)) then |
2497 | Set_Library_Unit (Withn, Cunit (Unum)); | |
2498 | Set_Corresponding_Spec | |
2499 | (Withn, Specification (Unit (Cunit (Unum)))); | |
2500 | Prepend (Withn, Context_Items (Parent (N))); | |
2501 | Mark_Rewrite_Insertion (Withn); | |
2502 | ||
2503 | Expand_Limited_With_Clause (Prefix (Nam), N); | |
2504 | end if; | |
fbf5a39b AC |
2505 | end if; |
2506 | ||
2507 | New_Nodes_OK := New_Nodes_OK - 1; | |
2508 | end Expand_Limited_With_Clause; | |
2509 | ||
07fc65c4 GB |
2510 | ----------------------- |
2511 | -- Get_Parent_Entity -- | |
2512 | ----------------------- | |
2513 | ||
2514 | function Get_Parent_Entity (Unit : Node_Id) return Entity_Id is | |
2515 | begin | |
523456db AC |
2516 | if Nkind (Unit) = N_Package_Body |
2517 | and then Nkind (Original_Node (Unit)) = N_Package_Instantiation | |
2518 | then | |
2519 | return | |
2520 | Defining_Entity | |
2521 | (Specification (Instance_Spec (Original_Node (Unit)))); | |
2522 | ||
2523 | elsif Nkind (Unit) = N_Package_Instantiation then | |
07fc65c4 | 2524 | return Defining_Entity (Specification (Instance_Spec (Unit))); |
523456db | 2525 | |
07fc65c4 GB |
2526 | else |
2527 | return Defining_Entity (Unit); | |
2528 | end if; | |
2529 | end Get_Parent_Entity; | |
2530 | ||
996ae0b0 RK |
2531 | ----------------------------- |
2532 | -- Implicit_With_On_Parent -- | |
2533 | ----------------------------- | |
2534 | ||
2535 | procedure Implicit_With_On_Parent | |
2536 | (Child_Unit : Node_Id; | |
2537 | N : Node_Id) | |
2538 | is | |
2539 | Loc : constant Source_Ptr := Sloc (N); | |
2540 | P : constant Node_Id := Parent_Spec (Child_Unit); | |
523456db AC |
2541 | |
2542 | P_Unit : Node_Id := Unit (P); | |
2543 | ||
fbf5a39b | 2544 | P_Name : constant Entity_Id := Get_Parent_Entity (P_Unit); |
996ae0b0 RK |
2545 | Withn : Node_Id; |
2546 | ||
8a6a52dc | 2547 | function Build_Ancestor_Name (P : Node_Id) return Node_Id; |
a5b62485 | 2548 | -- Build prefix of child unit name. Recurse if needed |
996ae0b0 RK |
2549 | |
2550 | function Build_Unit_Name return Node_Id; | |
2551 | -- If the unit is a child unit, build qualified name with all | |
2552 | -- ancestors. | |
2553 | ||
2554 | ------------------------- | |
2555 | -- Build_Ancestor_Name -- | |
2556 | ------------------------- | |
2557 | ||
2558 | function Build_Ancestor_Name (P : Node_Id) return Node_Id is | |
f5905c0b | 2559 | P_Ref : constant Node_Id := |
fbf5a39b | 2560 | New_Reference_To (Defining_Entity (P), Loc); |
f5905c0b ES |
2561 | P_Spec : Node_Id := P; |
2562 | ||
996ae0b0 | 2563 | begin |
f5905c0b ES |
2564 | -- Ancestor may have been rewritten as a package body. Retrieve |
2565 | -- the original spec to trace earlier ancestors. | |
2566 | ||
2567 | if Nkind (P) = N_Package_Body | |
2568 | and then Nkind (Original_Node (P)) = N_Package_Instantiation | |
2569 | then | |
2570 | P_Spec := Original_Node (P); | |
2571 | end if; | |
2572 | ||
2573 | if No (Parent_Spec (P_Spec)) then | |
996ae0b0 RK |
2574 | return P_Ref; |
2575 | else | |
2576 | return | |
2577 | Make_Selected_Component (Loc, | |
f5905c0b | 2578 | Prefix => Build_Ancestor_Name (Unit (Parent_Spec (P_Spec))), |
996ae0b0 RK |
2579 | Selector_Name => P_Ref); |
2580 | end if; | |
2581 | end Build_Ancestor_Name; | |
2582 | ||
2583 | --------------------- | |
2584 | -- Build_Unit_Name -- | |
2585 | --------------------- | |
2586 | ||
2587 | function Build_Unit_Name return Node_Id is | |
2588 | Result : Node_Id; | |
996ae0b0 RK |
2589 | begin |
2590 | if No (Parent_Spec (P_Unit)) then | |
2591 | return New_Reference_To (P_Name, Loc); | |
2592 | else | |
2593 | Result := | |
2594 | Make_Expanded_Name (Loc, | |
2595 | Chars => Chars (P_Name), | |
2596 | Prefix => Build_Ancestor_Name (Unit (Parent_Spec (P_Unit))), | |
2597 | Selector_Name => New_Reference_To (P_Name, Loc)); | |
2598 | Set_Entity (Result, P_Name); | |
2599 | return Result; | |
2600 | end if; | |
2601 | end Build_Unit_Name; | |
2602 | ||
2603 | -- Start of processing for Implicit_With_On_Parent | |
2604 | ||
2605 | begin | |
523456db AC |
2606 | -- The unit of the current compilation may be a package body |
2607 | -- that replaces an instance node. In this case we need the | |
2608 | -- original instance node to construct the proper parent name. | |
2609 | ||
2610 | if Nkind (P_Unit) = N_Package_Body | |
2611 | and then Nkind (Original_Node (P_Unit)) = N_Package_Instantiation | |
2612 | then | |
2613 | P_Unit := Original_Node (P_Unit); | |
2614 | end if; | |
2615 | ||
996ae0b0 RK |
2616 | New_Nodes_OK := New_Nodes_OK + 1; |
2617 | Withn := Make_With_Clause (Loc, Name => Build_Unit_Name); | |
2618 | ||
2619 | Set_Library_Unit (Withn, P); | |
2620 | Set_Corresponding_Spec (Withn, P_Name); | |
2621 | Set_First_Name (Withn, True); | |
2622 | Set_Implicit_With (Withn, True); | |
2623 | ||
2624 | -- Node is placed at the beginning of the context items, so that | |
2625 | -- subsequent use clauses on the parent can be validated. | |
2626 | ||
2627 | Prepend (Withn, Context_Items (N)); | |
2628 | Mark_Rewrite_Insertion (Withn); | |
2629 | Install_Withed_Unit (Withn); | |
2630 | ||
2631 | if Is_Child_Spec (P_Unit) then | |
2632 | Implicit_With_On_Parent (P_Unit, N); | |
2633 | end if; | |
8a6a52dc | 2634 | |
996ae0b0 RK |
2635 | New_Nodes_OK := New_Nodes_OK - 1; |
2636 | end Implicit_With_On_Parent; | |
2637 | ||
2638 | --------------------- | |
2639 | -- Install_Context -- | |
2640 | --------------------- | |
2641 | ||
2642 | procedure Install_Context (N : Node_Id) is | |
fbf5a39b | 2643 | Lib_Unit : constant Node_Id := Unit (N); |
996ae0b0 RK |
2644 | |
2645 | begin | |
2646 | Install_Context_Clauses (N); | |
2647 | ||
2648 | if Is_Child_Spec (Lib_Unit) then | |
2649 | Install_Parents (Lib_Unit, Private_Present (Parent (Lib_Unit))); | |
2650 | end if; | |
2651 | ||
657a9dd9 AC |
2652 | Install_Limited_Context_Clauses (N); |
2653 | ||
996ae0b0 RK |
2654 | Check_With_Type_Clauses (N); |
2655 | end Install_Context; | |
2656 | ||
2657 | ----------------------------- | |
2658 | -- Install_Context_Clauses -- | |
2659 | ----------------------------- | |
2660 | ||
2661 | procedure Install_Context_Clauses (N : Node_Id) is | |
fbf5a39b | 2662 | Lib_Unit : constant Node_Id := Unit (N); |
996ae0b0 RK |
2663 | Item : Node_Id; |
2664 | Uname_Node : Entity_Id; | |
2665 | Check_Private : Boolean := False; | |
2666 | Decl_Node : Node_Id; | |
2667 | Lib_Parent : Entity_Id; | |
2668 | ||
2669 | begin | |
fbf5a39b AC |
2670 | -- Loop through context clauses to find the with/use clauses. |
2671 | -- This is done twice, first for everything except limited_with | |
2672 | -- clauses, and then for those, if any are present. | |
996ae0b0 RK |
2673 | |
2674 | Item := First (Context_Items (N)); | |
2675 | while Present (Item) loop | |
2676 | ||
2677 | -- Case of explicit WITH clause | |
2678 | ||
2679 | if Nkind (Item) = N_With_Clause | |
2680 | and then not Implicit_With (Item) | |
2681 | then | |
fbf5a39b AC |
2682 | if Limited_Present (Item) then |
2683 | ||
a5b62485 | 2684 | -- Limited withed units will be installed later |
fbf5a39b | 2685 | |
fbf5a39b AC |
2686 | goto Continue; |
2687 | ||
996ae0b0 RK |
2688 | -- If Name (Item) is not an entity name, something is wrong, and |
2689 | -- this will be detected in due course, for now ignore the item | |
2690 | ||
fbf5a39b AC |
2691 | elsif not Is_Entity_Name (Name (Item)) then |
2692 | goto Continue; | |
2693 | ||
2694 | elsif No (Entity (Name (Item))) then | |
2695 | Set_Entity (Name (Item), Any_Id); | |
996ae0b0 RK |
2696 | goto Continue; |
2697 | end if; | |
2698 | ||
2699 | Uname_Node := Entity (Name (Item)); | |
2700 | ||
2701 | if Is_Private_Descendant (Uname_Node) then | |
2702 | Check_Private := True; | |
2703 | end if; | |
2704 | ||
2705 | Install_Withed_Unit (Item); | |
2706 | ||
2707 | Decl_Node := Unit_Declaration_Node (Uname_Node); | |
2708 | ||
2709 | -- If the unit is a subprogram instance, it appears nested | |
2710 | -- within a package that carries the parent information. | |
2711 | ||
2712 | if Is_Generic_Instance (Uname_Node) | |
2713 | and then Ekind (Uname_Node) /= E_Package | |
2714 | then | |
2715 | Decl_Node := Parent (Parent (Decl_Node)); | |
2716 | end if; | |
2717 | ||
2718 | if Is_Child_Spec (Decl_Node) then | |
2719 | if Nkind (Name (Item)) = N_Expanded_Name then | |
2720 | Expand_With_Clause (Prefix (Name (Item)), N); | |
2721 | else | |
2722 | -- if not an expanded name, the child unit must be a | |
2723 | -- renaming, nothing to do. | |
2724 | ||
2725 | null; | |
2726 | end if; | |
2727 | ||
2728 | elsif Nkind (Decl_Node) = N_Subprogram_Body | |
2729 | and then not Acts_As_Spec (Parent (Decl_Node)) | |
2730 | and then Is_Child_Spec (Unit (Library_Unit (Parent (Decl_Node)))) | |
2731 | then | |
2732 | Implicit_With_On_Parent | |
2733 | (Unit (Library_Unit (Parent (Decl_Node))), N); | |
2734 | end if; | |
2735 | ||
2736 | -- Check license conditions unless this is a dummy unit | |
2737 | ||
2738 | if Sloc (Library_Unit (Item)) /= No_Location then | |
2739 | License_Check : declare | |
2740 | Withl : constant License_Type := | |
2741 | License (Source_Index | |
2742 | (Get_Source_Unit | |
2743 | (Library_Unit (Item)))); | |
2744 | ||
2745 | Unitl : constant License_Type := | |
2746 | License (Source_Index (Current_Sem_Unit)); | |
2747 | ||
2748 | procedure License_Error; | |
2749 | -- Signal error of bad license | |
2750 | ||
2751 | ------------------- | |
2752 | -- License_Error -- | |
2753 | ------------------- | |
2754 | ||
2755 | procedure License_Error is | |
2756 | begin | |
2757 | Error_Msg_N | |
2758 | ("?license of with'ed unit & is incompatible", | |
2759 | Name (Item)); | |
2760 | end License_Error; | |
2761 | ||
2762 | -- Start of processing for License_Check | |
2763 | ||
2764 | begin | |
2765 | case Unitl is | |
2766 | when Unknown => | |
2767 | null; | |
2768 | ||
2769 | when Restricted => | |
2770 | if Withl = GPL then | |
2771 | License_Error; | |
2772 | end if; | |
2773 | ||
2774 | when GPL => | |
2775 | if Withl = Restricted then | |
2776 | License_Error; | |
2777 | end if; | |
2778 | ||
2779 | when Modified_GPL => | |
2780 | if Withl = Restricted or else Withl = GPL then | |
2781 | License_Error; | |
2782 | end if; | |
2783 | ||
2784 | when Unrestricted => | |
2785 | null; | |
2786 | end case; | |
2787 | end License_Check; | |
2788 | end if; | |
2789 | ||
2790 | -- Case of USE PACKAGE clause | |
2791 | ||
2792 | elsif Nkind (Item) = N_Use_Package_Clause then | |
2793 | Analyze_Use_Package (Item); | |
2794 | ||
2795 | -- Case of USE TYPE clause | |
2796 | ||
2797 | elsif Nkind (Item) = N_Use_Type_Clause then | |
2798 | Analyze_Use_Type (Item); | |
2799 | ||
2800 | -- Case of WITH TYPE clause | |
2801 | ||
2802 | -- A With_Type_Clause is processed when installing the context, | |
2803 | -- because it is a visibility mechanism and does not create a | |
2804 | -- semantic dependence on other units, as a With_Clause does. | |
2805 | ||
2806 | elsif Nkind (Item) = N_With_Type_Clause then | |
2807 | Analyze_With_Type_Clause (Item); | |
2808 | ||
2809 | -- case of PRAGMA | |
2810 | ||
2811 | elsif Nkind (Item) = N_Pragma then | |
2812 | Analyze (Item); | |
2813 | end if; | |
2814 | ||
2815 | <<Continue>> | |
2816 | Next (Item); | |
2817 | end loop; | |
2818 | ||
2819 | if Is_Child_Spec (Lib_Unit) then | |
2820 | ||
657a9dd9 | 2821 | -- The unit also has implicit withs on its own parents |
996ae0b0 RK |
2822 | |
2823 | if No (Context_Items (N)) then | |
2824 | Set_Context_Items (N, New_List); | |
2825 | end if; | |
2826 | ||
2827 | Implicit_With_On_Parent (Lib_Unit, N); | |
2828 | end if; | |
2829 | ||
2830 | -- If the unit is a body, the context of the specification must also | |
2831 | -- be installed. | |
2832 | ||
2833 | if Nkind (Lib_Unit) = N_Package_Body | |
2834 | or else (Nkind (Lib_Unit) = N_Subprogram_Body | |
2835 | and then not Acts_As_Spec (N)) | |
2836 | then | |
2837 | Install_Context (Library_Unit (N)); | |
2838 | ||
2839 | if Is_Child_Spec (Unit (Library_Unit (N))) then | |
2840 | ||
2841 | -- If the unit is the body of a public child unit, the private | |
2842 | -- declarations of the parent must be made visible. If the child | |
2843 | -- unit is private, the private declarations have been installed | |
2844 | -- already in the call to Install_Parents for the spec. Installing | |
2845 | -- private declarations must be done for all ancestors of public | |
2846 | -- child units. In addition, sibling units mentioned in the | |
2847 | -- context clause of the body are directly visible. | |
2848 | ||
2849 | declare | |
2850 | Lib_Spec : Node_Id := Unit (Library_Unit (N)); | |
2851 | P : Node_Id; | |
2852 | P_Name : Entity_Id; | |
2853 | ||
2854 | begin | |
2855 | while Is_Child_Spec (Lib_Spec) loop | |
2856 | P := Unit (Parent_Spec (Lib_Spec)); | |
2857 | ||
2858 | if not (Private_Present (Parent (Lib_Spec))) then | |
2859 | P_Name := Defining_Entity (P); | |
2860 | Install_Private_Declarations (P_Name); | |
8a6a52dc | 2861 | Install_Private_With_Clauses (P_Name); |
996ae0b0 RK |
2862 | Set_Use (Private_Declarations (Specification (P))); |
2863 | end if; | |
2864 | ||
2865 | Lib_Spec := P; | |
2866 | end loop; | |
2867 | end; | |
2868 | end if; | |
2869 | ||
2870 | -- For a package body, children in context are immediately visible | |
2871 | ||
2872 | Install_Siblings (Defining_Entity (Unit (Library_Unit (N))), N); | |
2873 | end if; | |
2874 | ||
2875 | if Nkind (Lib_Unit) = N_Generic_Package_Declaration | |
2876 | or else Nkind (Lib_Unit) = N_Generic_Subprogram_Declaration | |
2877 | or else Nkind (Lib_Unit) = N_Package_Declaration | |
2878 | or else Nkind (Lib_Unit) = N_Subprogram_Declaration | |
2879 | then | |
2880 | if Is_Child_Spec (Lib_Unit) then | |
2881 | Lib_Parent := Defining_Entity (Unit (Parent_Spec (Lib_Unit))); | |
2882 | Set_Is_Private_Descendant | |
2883 | (Defining_Entity (Lib_Unit), | |
2884 | Is_Private_Descendant (Lib_Parent) | |
2885 | or else Private_Present (Parent (Lib_Unit))); | |
2886 | ||
2887 | else | |
2888 | Set_Is_Private_Descendant | |
2889 | (Defining_Entity (Lib_Unit), | |
2890 | Private_Present (Parent (Lib_Unit))); | |
2891 | end if; | |
2892 | end if; | |
2893 | ||
2894 | if Check_Private then | |
2895 | Check_Private_Child_Unit (N); | |
2896 | end if; | |
657a9dd9 | 2897 | end Install_Context_Clauses; |
fbf5a39b | 2898 | |
657a9dd9 AC |
2899 | ------------------------------------- |
2900 | -- Install_Limited_Context_Clauses -- | |
2901 | ------------------------------------- | |
fbf5a39b | 2902 | |
657a9dd9 AC |
2903 | procedure Install_Limited_Context_Clauses (N : Node_Id) is |
2904 | Item : Node_Id; | |
2905 | ||
2906 | procedure Check_Parent (P : Node_Id; W : Node_Id); | |
2907 | -- Check that the unlimited view of a given compilation_unit is not | |
2908 | -- already visible in the parents (neither immediately through the | |
2909 | -- context clauses, nor indirectly through "use + renamings"). | |
2910 | ||
2911 | procedure Check_Private_Limited_Withed_Unit (N : Node_Id); | |
2912 | -- Check that if a limited_with clause of a given compilation_unit | |
2913 | -- mentions a private child of some library unit, then the given | |
2914 | -- compilation_unit shall be the declaration of a private descendant | |
2915 | -- of that library unit. | |
2916 | ||
2917 | procedure Check_Withed_Unit (W : Node_Id); | |
2918 | -- Check that a limited with_clause does not appear in the same | |
2919 | -- context_clause as a nonlimited with_clause that mentions | |
2920 | -- the same library. | |
2921 | ||
15ce9ca2 AC |
2922 | ------------------ |
2923 | -- Check_Parent -- | |
2924 | ------------------ | |
657a9dd9 AC |
2925 | |
2926 | procedure Check_Parent (P : Node_Id; W : Node_Id) is | |
2927 | Item : Node_Id; | |
2928 | Spec : Node_Id; | |
2929 | WEnt : Entity_Id; | |
2930 | Nam : Node_Id; | |
2931 | E : Entity_Id; | |
2932 | E2 : Entity_Id; | |
fbf5a39b | 2933 | |
657a9dd9 AC |
2934 | begin |
2935 | pragma Assert (Nkind (W) = N_With_Clause); | |
2936 | ||
2937 | -- Step 1: Check if the unlimited view is installed in the parent | |
2938 | ||
2939 | Item := First (Context_Items (P)); | |
fbf5a39b AC |
2940 | while Present (Item) loop |
2941 | if Nkind (Item) = N_With_Clause | |
657a9dd9 AC |
2942 | and then not Limited_Present (Item) |
2943 | and then not Implicit_With (Item) | |
2944 | and then Library_Unit (Item) = Library_Unit (W) | |
fbf5a39b | 2945 | then |
657a9dd9 AC |
2946 | Error_Msg_N ("unlimited view visible in ancestor", W); |
2947 | return; | |
fbf5a39b AC |
2948 | end if; |
2949 | ||
2950 | Next (Item); | |
2951 | end loop; | |
657a9dd9 AC |
2952 | |
2953 | -- Step 2: Check "use + renamings" | |
2954 | ||
2955 | WEnt := Defining_Unit_Name (Specification (Unit (Library_Unit (W)))); | |
2956 | Spec := Specification (Unit (P)); | |
2957 | ||
2958 | -- We tried to traverse the list of entities corresponding to the | |
2959 | -- defining entity of the package spec. However, first_entity was | |
2960 | -- found to be 'empty'. Don't know why??? | |
2961 | ||
2962 | -- Def := Defining_Unit_Name (Spec); | |
2963 | -- Ent := First_Entity (Def); | |
2964 | ||
2965 | -- As a workaround we traverse the list of visible declarations ??? | |
2966 | ||
2967 | Item := First (Visible_Declarations (Spec)); | |
2968 | while Present (Item) loop | |
2969 | ||
2970 | if Nkind (Item) = N_Use_Package_Clause then | |
2971 | ||
2972 | -- Traverse the list of packages | |
2973 | ||
2974 | Nam := First (Names (Item)); | |
2975 | ||
2976 | while Present (Nam) loop | |
2977 | E := Entity (Nam); | |
2978 | ||
2979 | pragma Assert (Present (Parent (E))); | |
2980 | ||
2981 | if Nkind (Parent (E)) | |
2982 | = N_Package_Renaming_Declaration | |
2983 | and then Renamed_Entity (E) = WEnt | |
2984 | then | |
2985 | Error_Msg_N ("unlimited view visible through " | |
2986 | & "use_clause + renamings", W); | |
2987 | return; | |
2988 | ||
2989 | elsif Nkind (Parent (E)) = N_Package_Specification then | |
2990 | ||
2991 | -- The use clause may refer to a local package. | |
2992 | -- Check all the enclosing scopes. | |
2993 | ||
2994 | E2 := E; | |
2995 | while E2 /= Standard_Standard | |
2996 | and then E2 /= WEnt loop | |
2997 | E2 := Scope (E2); | |
2998 | end loop; | |
2999 | ||
3000 | if E2 = WEnt then | |
3001 | Error_Msg_N ("unlimited view visible through " | |
3002 | & "use_clause ", W); | |
3003 | return; | |
3004 | end if; | |
3005 | ||
3006 | end if; | |
3007 | Next (Nam); | |
3008 | end loop; | |
3009 | ||
3010 | end if; | |
3011 | ||
3012 | Next (Item); | |
3013 | end loop; | |
3014 | ||
3015 | -- Recursive call to check all the ancestors | |
3016 | ||
3017 | if Is_Child_Spec (Unit (P)) then | |
3018 | Check_Parent (P => Parent_Spec (Unit (P)), W => W); | |
3019 | end if; | |
3020 | end Check_Parent; | |
3021 | ||
3022 | --------------------------------------- | |
3023 | -- Check_Private_Limited_Withed_Unit -- | |
3024 | --------------------------------------- | |
3025 | ||
3026 | procedure Check_Private_Limited_Withed_Unit (N : Node_Id) is | |
3027 | C : Node_Id; | |
3028 | P : Node_Id; | |
3029 | Found : Boolean := False; | |
3030 | ||
3031 | begin | |
3032 | -- If the current compilation unit is not private we don't | |
3033 | -- need to check anything else. | |
3034 | ||
3035 | if not Private_Present (Parent (N)) then | |
3036 | Found := False; | |
3037 | ||
3038 | else | |
3039 | -- Compilation unit of the parent of the withed library unit | |
3040 | ||
3041 | P := Parent_Spec (Unit (Library_Unit (N))); | |
3042 | ||
3043 | -- Traverse all the ancestors of the current compilation | |
3044 | -- unit to check if it is a descendant of named library unit. | |
3045 | ||
3046 | C := Parent (N); | |
3047 | while Present (Parent_Spec (Unit (C))) loop | |
3048 | C := Parent_Spec (Unit (C)); | |
3049 | ||
3050 | if C = P then | |
3051 | Found := True; | |
3052 | exit; | |
3053 | end if; | |
3054 | end loop; | |
3055 | end if; | |
3056 | ||
3057 | if not Found then | |
3058 | Error_Msg_N ("current unit is not a private descendant" | |
3059 | & " of the withed unit ('R'M 10.1.2(8)", N); | |
3060 | end if; | |
3061 | end Check_Private_Limited_Withed_Unit; | |
3062 | ||
3063 | ----------------------- | |
3064 | -- Check_Withed_Unit -- | |
3065 | ----------------------- | |
3066 | ||
3067 | procedure Check_Withed_Unit (W : Node_Id) is | |
3068 | Item : Node_Id; | |
3069 | ||
3070 | begin | |
3071 | -- A limited with_clause can not appear in the same context_clause | |
3072 | -- as a nonlimited with_clause which mentions the same library. | |
3073 | ||
3074 | Item := First (Context_Items (N)); | |
3075 | while Present (Item) loop | |
3076 | if Nkind (Item) = N_With_Clause | |
3077 | and then not Limited_Present (Item) | |
3078 | and then not Implicit_With (Item) | |
3079 | and then Library_Unit (Item) = Library_Unit (W) | |
3080 | then | |
3081 | Error_Msg_N ("limited and unlimited view " | |
3082 | & "not allowed in the same context clauses", W); | |
3083 | return; | |
3084 | end if; | |
3085 | ||
3086 | Next (Item); | |
3087 | end loop; | |
3088 | end Check_Withed_Unit; | |
3089 | ||
3090 | -- Start of processing for Install_Limited_Context_Clauses | |
3091 | ||
3092 | begin | |
3093 | Item := First (Context_Items (N)); | |
3094 | while Present (Item) loop | |
3095 | if Nkind (Item) = N_With_Clause | |
3096 | and then Limited_Present (Item) | |
3097 | then | |
657a9dd9 AC |
3098 | Check_Withed_Unit (Item); |
3099 | ||
3100 | if Private_Present (Library_Unit (Item)) then | |
3101 | Check_Private_Limited_Withed_Unit (Item); | |
3102 | end if; | |
3103 | ||
3104 | if Is_Child_Spec (Unit (N)) then | |
3105 | Check_Parent (Parent_Spec (Unit (N)), Item); | |
3106 | end if; | |
3107 | ||
3108 | Install_Limited_Withed_Unit (Item); | |
3109 | end if; | |
3110 | ||
3111 | Next (Item); | |
3112 | end loop; | |
3113 | end Install_Limited_Context_Clauses; | |
996ae0b0 RK |
3114 | |
3115 | --------------------- | |
3116 | -- Install_Parents -- | |
3117 | --------------------- | |
3118 | ||
3119 | procedure Install_Parents (Lib_Unit : Node_Id; Is_Private : Boolean) is | |
3120 | P : Node_Id; | |
3121 | E_Name : Entity_Id; | |
3122 | P_Name : Entity_Id; | |
3123 | P_Spec : Node_Id; | |
3124 | ||
3125 | begin | |
3126 | P := Unit (Parent_Spec (Lib_Unit)); | |
07fc65c4 | 3127 | P_Name := Get_Parent_Entity (P); |
996ae0b0 RK |
3128 | |
3129 | if Etype (P_Name) = Any_Type then | |
3130 | return; | |
3131 | end if; | |
3132 | ||
3133 | if Ekind (P_Name) = E_Generic_Package | |
3134 | and then Nkind (Lib_Unit) /= N_Generic_Subprogram_Declaration | |
3135 | and then Nkind (Lib_Unit) /= N_Generic_Package_Declaration | |
3136 | and then Nkind (Lib_Unit) not in N_Generic_Renaming_Declaration | |
3137 | then | |
3138 | Error_Msg_N | |
3139 | ("child of a generic package must be a generic unit", Lib_Unit); | |
3140 | ||
3141 | elsif not Is_Package (P_Name) then | |
3142 | Error_Msg_N | |
3143 | ("parent unit must be package or generic package", Lib_Unit); | |
3144 | raise Unrecoverable_Error; | |
3145 | ||
3146 | elsif Present (Renamed_Object (P_Name)) then | |
3147 | Error_Msg_N ("parent unit cannot be a renaming", Lib_Unit); | |
3148 | raise Unrecoverable_Error; | |
3149 | ||
3150 | -- Verify that a child of an instance is itself an instance, or | |
3151 | -- the renaming of one. Given that an instance that is a unit is | |
3152 | -- replaced with a package declaration, check against the original | |
f5905c0b ES |
3153 | -- node. The parent may be currently being instantiated, in which |
3154 | -- case it appears as a declaration, but the generic_parent is | |
3155 | -- already established indicating that we deal with an instance. | |
996ae0b0 | 3156 | |
f5905c0b ES |
3157 | elsif Nkind (Original_Node (P)) = N_Package_Instantiation then |
3158 | ||
3159 | if Nkind (Lib_Unit) in N_Renaming_Declaration | |
3160 | or else Nkind (Original_Node (Lib_Unit)) in N_Generic_Instantiation | |
3161 | or else | |
3162 | (Nkind (Lib_Unit) = N_Package_Declaration | |
3163 | and then Present (Generic_Parent (Specification (Lib_Unit)))) | |
3164 | then | |
3165 | null; | |
3166 | else | |
3167 | Error_Msg_N | |
3168 | ("child of an instance must be an instance or renaming", | |
3169 | Lib_Unit); | |
3170 | end if; | |
996ae0b0 RK |
3171 | end if; |
3172 | ||
3173 | -- This is the recursive call that ensures all parents are loaded | |
3174 | ||
3175 | if Is_Child_Spec (P) then | |
3176 | Install_Parents (P, | |
3177 | Is_Private or else Private_Present (Parent (Lib_Unit))); | |
3178 | end if; | |
3179 | ||
3180 | -- Now we can install the context for this parent | |
3181 | ||
3182 | Install_Context_Clauses (Parent_Spec (Lib_Unit)); | |
3183 | Install_Siblings (P_Name, Parent (Lib_Unit)); | |
3184 | ||
3185 | -- The child unit is in the declarative region of the parent. The | |
3186 | -- parent must therefore appear in the scope stack and be visible, | |
3187 | -- as when compiling the corresponding body. If the child unit is | |
3188 | -- private or it is a package body, private declarations must be | |
3189 | -- accessible as well. Use declarations in the parent must also | |
3190 | -- be installed. Finally, other child units of the same parent that | |
3191 | -- are in the context are immediately visible. | |
3192 | ||
3193 | -- Find entity for compilation unit, and set its private descendant | |
3194 | -- status as needed. | |
3195 | ||
3196 | E_Name := Defining_Entity (Lib_Unit); | |
3197 | ||
3198 | Set_Is_Child_Unit (E_Name); | |
3199 | ||
3200 | Set_Is_Private_Descendant (E_Name, | |
3201 | Is_Private_Descendant (P_Name) | |
3202 | or else Private_Present (Parent (Lib_Unit))); | |
3203 | ||
3204 | P_Spec := Specification (Unit_Declaration_Node (P_Name)); | |
3205 | New_Scope (P_Name); | |
3206 | ||
3207 | -- Save current visibility of unit | |
3208 | ||
3209 | Scope_Stack.Table (Scope_Stack.Last).Previous_Visibility := | |
3210 | Is_Immediately_Visible (P_Name); | |
3211 | Set_Is_Immediately_Visible (P_Name); | |
3212 | Install_Visible_Declarations (P_Name); | |
3213 | Set_Use (Visible_Declarations (P_Spec)); | |
3214 | ||
fbf5a39b AC |
3215 | -- If the parent is a generic unit, its formal part may contain |
3216 | -- formal packages and use clauses for them. | |
3217 | ||
3218 | if Ekind (P_Name) = E_Generic_Package then | |
3219 | Set_Use (Generic_Formal_Declarations (Parent (P_Spec))); | |
3220 | end if; | |
3221 | ||
996ae0b0 RK |
3222 | if Is_Private |
3223 | or else Private_Present (Parent (Lib_Unit)) | |
3224 | then | |
3225 | Install_Private_Declarations (P_Name); | |
8a6a52dc | 3226 | Install_Private_With_Clauses (P_Name); |
996ae0b0 RK |
3227 | Set_Use (Private_Declarations (P_Spec)); |
3228 | end if; | |
3229 | end Install_Parents; | |
3230 | ||
8a6a52dc AC |
3231 | ---------------------------------- |
3232 | -- Install_Private_With_Clauses -- | |
3233 | ---------------------------------- | |
3234 | ||
3235 | procedure Install_Private_With_Clauses (P : Entity_Id) is | |
3236 | Decl : constant Node_Id := Unit_Declaration_Node (P); | |
0fb2ea01 | 3237 | Item : Node_Id; |
8a6a52dc AC |
3238 | |
3239 | begin | |
9bc856dd AC |
3240 | if Debug_Flag_I then |
3241 | Write_Str ("install private with clauses of "); | |
3242 | Write_Name (Chars (P)); | |
3243 | Write_Eol; | |
3244 | end if; | |
3245 | ||
8a6a52dc | 3246 | if Nkind (Parent (Decl)) = N_Compilation_Unit then |
0fb2ea01 AC |
3247 | Item := First (Context_Items (Parent (Decl))); |
3248 | ||
3249 | while Present (Item) loop | |
3250 | if Nkind (Item) = N_With_Clause | |
3251 | and then Private_Present (Item) | |
8a6a52dc | 3252 | then |
0fb2ea01 AC |
3253 | if Limited_Present (Item) then |
3254 | Install_Limited_Withed_Unit (Item); | |
3255 | else | |
3256 | Install_Withed_Unit (Item, Private_With_OK => True); | |
3257 | end if; | |
8a6a52dc AC |
3258 | end if; |
3259 | ||
0fb2ea01 | 3260 | Next (Item); |
8a6a52dc AC |
3261 | end loop; |
3262 | end if; | |
3263 | end Install_Private_With_Clauses; | |
3264 | ||
996ae0b0 RK |
3265 | ---------------------- |
3266 | -- Install_Siblings -- | |
3267 | ---------------------- | |
3268 | ||
3269 | procedure Install_Siblings (U_Name : Entity_Id; N : Node_Id) is | |
3270 | Item : Node_Id; | |
3271 | Id : Entity_Id; | |
3272 | Prev : Entity_Id; | |
996ae0b0 RK |
3273 | begin |
3274 | -- Iterate over explicit with clauses, and check whether the | |
3275 | -- scope of each entity is an ancestor of the current unit. | |
3276 | ||
3277 | Item := First (Context_Items (N)); | |
996ae0b0 | 3278 | while Present (Item) loop |
996ae0b0 RK |
3279 | if Nkind (Item) = N_With_Clause |
3280 | and then not Implicit_With (Item) | |
fbf5a39b | 3281 | and then not Limited_Present (Item) |
996ae0b0 RK |
3282 | then |
3283 | Id := Entity (Name (Item)); | |
3284 | ||
3285 | if Is_Child_Unit (Id) | |
9bc856dd | 3286 | and then Is_Ancestor_Package (Scope (Id), U_Name) |
996ae0b0 RK |
3287 | then |
3288 | Set_Is_Immediately_Visible (Id); | |
9bc856dd | 3289 | |
996ae0b0 RK |
3290 | -- Check for the presence of another unit in the context, |
3291 | -- that may be inadvertently hidden by the child. | |
3292 | ||
9bc856dd AC |
3293 | Prev := Current_Entity (Id); |
3294 | ||
996ae0b0 RK |
3295 | if Present (Prev) |
3296 | and then Is_Immediately_Visible (Prev) | |
3297 | and then not Is_Child_Unit (Prev) | |
3298 | then | |
3299 | declare | |
3300 | Clause : Node_Id; | |
3301 | ||
3302 | begin | |
3303 | Clause := First (Context_Items (N)); | |
3304 | ||
3305 | while Present (Clause) loop | |
3306 | if Nkind (Clause) = N_With_Clause | |
3307 | and then Entity (Name (Clause)) = Prev | |
3308 | then | |
3309 | Error_Msg_NE | |
3310 | ("child unit& hides compilation unit " & | |
3311 | "with the same name?", | |
3312 | Name (Item), Id); | |
3313 | exit; | |
3314 | end if; | |
3315 | ||
3316 | Next (Clause); | |
3317 | end loop; | |
3318 | end; | |
3319 | end if; | |
3320 | ||
3321 | -- the With_Clause may be on a grand-child, which makes | |
3322 | -- the child immediately visible. | |
3323 | ||
3324 | elsif Is_Child_Unit (Scope (Id)) | |
9bc856dd | 3325 | and then Is_Ancestor_Package (Scope (Scope (Id)), U_Name) |
996ae0b0 RK |
3326 | then |
3327 | Set_Is_Immediately_Visible (Scope (Id)); | |
3328 | end if; | |
3329 | end if; | |
3330 | ||
3331 | Next (Item); | |
3332 | end loop; | |
3333 | end Install_Siblings; | |
3334 | ||
fbf5a39b AC |
3335 | ------------------------------- |
3336 | -- Install_Limited_With_Unit -- | |
3337 | ------------------------------- | |
3338 | ||
3339 | procedure Install_Limited_Withed_Unit (N : Node_Id) is | |
91b1417d | 3340 | Unum : constant Unit_Number_Type := |
fbf5a39b | 3341 | Get_Source_Unit (Library_Unit (N)); |
91b1417d | 3342 | P_Unit : constant Entity_Id := Unit (Library_Unit (N)); |
12e0c41c | 3343 | P : Entity_Id; |
fbf5a39b AC |
3344 | Is_Child_Package : Boolean := False; |
3345 | ||
0fb2ea01 AC |
3346 | Lim_Header : Entity_Id; |
3347 | Lim_Typ : Entity_Id; | |
3348 | ||
fbf5a39b AC |
3349 | function In_Chain (E : Entity_Id) return Boolean; |
3350 | -- Check that the shadow entity is not already in the homonym | |
3351 | -- chain, for example through a limited_with clause in a parent unit. | |
3352 | ||
8a6a52dc AC |
3353 | -------------- |
3354 | -- In_Chain -- | |
3355 | -------------- | |
3356 | ||
fbf5a39b AC |
3357 | function In_Chain (E : Entity_Id) return Boolean is |
3358 | H : Entity_Id := Current_Entity (E); | |
3359 | ||
3360 | begin | |
3361 | while Present (H) loop | |
3362 | if H = E then | |
3363 | return True; | |
3364 | else | |
3365 | H := Homonym (H); | |
3366 | end if; | |
3367 | end loop; | |
3368 | ||
3369 | return False; | |
3370 | end In_Chain; | |
3371 | ||
3372 | -- Start of processing for Install_Limited_Withed_Unit | |
3373 | ||
3374 | begin | |
12e0c41c AC |
3375 | -- In case of limited with_clause on subprograms, generics, instances, |
3376 | -- or generic renamings, the corresponding error was previously posted | |
3377 | -- and we have nothing to do here. | |
3378 | ||
3379 | case Nkind (P_Unit) is | |
3380 | ||
3381 | when N_Package_Declaration => | |
3382 | null; | |
3383 | ||
3384 | when N_Subprogram_Declaration | | |
3385 | N_Generic_Package_Declaration | | |
3386 | N_Generic_Subprogram_Declaration | | |
3387 | N_Package_Instantiation | | |
3388 | N_Function_Instantiation | | |
3389 | N_Procedure_Instantiation | | |
3390 | N_Generic_Package_Renaming_Declaration | | |
3391 | N_Generic_Procedure_Renaming_Declaration | | |
3392 | N_Generic_Function_Renaming_Declaration => | |
3393 | return; | |
3394 | ||
3395 | when others => | |
9bc856dd | 3396 | raise Program_Error; |
12e0c41c AC |
3397 | end case; |
3398 | ||
3399 | P := Defining_Unit_Name (Specification (P_Unit)); | |
3400 | ||
fbf5a39b AC |
3401 | if Nkind (P) = N_Defining_Program_Unit_Name then |
3402 | ||
3403 | -- Retrieve entity of child package | |
3404 | ||
3405 | Is_Child_Package := True; | |
3406 | P := Defining_Identifier (P); | |
3407 | end if; | |
3408 | ||
657a9dd9 AC |
3409 | -- A common usage of the limited-with is to have a limited-with |
3410 | -- in the package spec, and a normal with in its package body. | |
3411 | -- For example: | |
3412 | ||
3413 | -- limited with X; -- [1] | |
3414 | -- package A is ... | |
3415 | ||
3416 | -- with X; -- [2] | |
3417 | -- package body A is ... | |
3418 | ||
3419 | -- The compilation of A's body installs the entities of its | |
3420 | -- withed packages (the context clauses found at [2]) and | |
3421 | -- then the context clauses of its specification (found at [1]). | |
3422 | ||
3423 | -- As a consequence, at point [1] the specification of X has been | |
3424 | -- analyzed and it is immediately visible. According to the semantics | |
3425 | -- of the limited-with context clauses we don't install the limited | |
3426 | -- view because the full view of X supersedes its limited view. | |
3427 | ||
fbf5a39b | 3428 | if Analyzed (Cunit (Unum)) |
b5e792e2 AC |
3429 | and then (Is_Immediately_Visible (P) |
3430 | or else (Is_Child_Package | |
3431 | and then Is_Visible_Child_Unit (P))) | |
fbf5a39b | 3432 | then |
0ab80019 | 3433 | -- Ada 2005 (AI-262): Install the private declarations of P |
0fb2ea01 AC |
3434 | |
3435 | if Private_Present (N) | |
3436 | and then not In_Private_Part (P) | |
3437 | then | |
3438 | declare | |
3439 | Id : Entity_Id; | |
3440 | begin | |
3441 | Id := First_Private_Entity (P); | |
3442 | ||
3443 | while Present (Id) loop | |
3444 | if not Is_Internal (Id) | |
3445 | and then not Is_Child_Unit (Id) | |
3446 | then | |
3447 | if not In_Chain (Id) then | |
3448 | Set_Homonym (Id, Current_Entity (Id)); | |
3449 | Set_Current_Entity (Id); | |
3450 | end if; | |
3451 | ||
3452 | Set_Is_Immediately_Visible (Id); | |
3453 | end if; | |
3454 | ||
3455 | Next_Entity (Id); | |
3456 | end loop; | |
3457 | ||
3458 | Set_In_Private_Part (P); | |
3459 | end; | |
3460 | end if; | |
3461 | ||
fbf5a39b AC |
3462 | return; |
3463 | end if; | |
3464 | ||
657a9dd9 AC |
3465 | if Debug_Flag_I then |
3466 | Write_Str ("install limited view of "); | |
3467 | Write_Name (Chars (P)); | |
3468 | Write_Eol; | |
3469 | end if; | |
3470 | ||
fbf5a39b AC |
3471 | if not Analyzed (Cunit (Unum)) then |
3472 | Set_Ekind (P, E_Package); | |
3473 | Set_Etype (P, Standard_Void_Type); | |
3474 | Set_Scope (P, Standard_Standard); | |
3475 | ||
3476 | -- Place entity on visibility structure | |
3477 | ||
3478 | if Current_Entity (P) /= P then | |
3479 | Set_Homonym (P, Current_Entity (P)); | |
3480 | Set_Current_Entity (P); | |
657a9dd9 AC |
3481 | |
3482 | if Debug_Flag_I then | |
3483 | Write_Str (" (homonym) chain "); | |
3484 | Write_Name (Chars (P)); | |
3485 | Write_Eol; | |
3486 | end if; | |
3487 | ||
fbf5a39b AC |
3488 | end if; |
3489 | ||
3490 | if Is_Child_Package then | |
3491 | Set_Is_Child_Unit (P); | |
3492 | Set_Is_Visible_Child_Unit (P); | |
3493 | ||
3494 | declare | |
3495 | Parent_Comp : Node_Id; | |
3496 | Parent_Id : Entity_Id; | |
3497 | ||
3498 | begin | |
3499 | Parent_Comp := Parent_Spec (Unit (Cunit (Unum))); | |
3500 | Parent_Id := Defining_Entity (Unit (Parent_Comp)); | |
3501 | ||
3502 | Set_Scope (P, Parent_Id); | |
3503 | end; | |
3504 | end if; | |
657a9dd9 | 3505 | |
fbf5a39b | 3506 | else |
657a9dd9 | 3507 | |
fbf5a39b AC |
3508 | -- If the unit appears in a previous regular with_clause, the |
3509 | -- regular entities must be unchained before the shadow ones | |
3510 | -- are made accessible. | |
3511 | ||
3512 | declare | |
3513 | Ent : Entity_Id; | |
3514 | begin | |
3515 | Ent := First_Entity (P); | |
3516 | ||
3517 | while Present (Ent) loop | |
3518 | Unchain (Ent); | |
3519 | Next_Entity (Ent); | |
3520 | end loop; | |
3521 | end; | |
657a9dd9 | 3522 | |
fbf5a39b AC |
3523 | end if; |
3524 | ||
3525 | -- The package must be visible while the with_type clause is active, | |
3526 | -- because references to the type P.T must resolve in the usual way. | |
3527 | ||
3528 | Set_Is_Immediately_Visible (P); | |
3529 | ||
0fb2ea01 AC |
3530 | -- Install each incomplete view. The first element of the limited view |
3531 | -- is a header (an E_Package entity) that is used to reference the first | |
3532 | -- shadow entity in the private part of the package | |
3533 | ||
3534 | Lim_Header := Limited_View (P); | |
3535 | Lim_Typ := First_Entity (Lim_Header); | |
fbf5a39b | 3536 | |
0fb2ea01 | 3537 | while Present (Lim_Typ) loop |
fbf5a39b | 3538 | |
0fb2ea01 AC |
3539 | exit when not Private_Present (N) |
3540 | and then Lim_Typ = First_Private_Entity (Lim_Header); | |
fbf5a39b AC |
3541 | |
3542 | if not In_Chain (Lim_Typ) then | |
3543 | Set_Homonym (Lim_Typ, Current_Entity (Lim_Typ)); | |
3544 | Set_Current_Entity (Lim_Typ); | |
657a9dd9 AC |
3545 | |
3546 | if Debug_Flag_I then | |
3547 | Write_Str (" (homonym) chain "); | |
3548 | Write_Name (Chars (Lim_Typ)); | |
3549 | Write_Eol; | |
3550 | end if; | |
fbf5a39b AC |
3551 | end if; |
3552 | ||
0fb2ea01 | 3553 | Next_Entity (Lim_Typ); |
fbf5a39b AC |
3554 | end loop; |
3555 | ||
3556 | -- The context clause has installed a limited-view, mark it | |
3557 | -- accordingly, to uninstall it when the context is removed. | |
3558 | ||
3559 | Set_Limited_View_Installed (N); | |
657a9dd9 | 3560 | Set_From_With_Type (P); |
fbf5a39b AC |
3561 | end Install_Limited_Withed_Unit; |
3562 | ||
996ae0b0 RK |
3563 | ------------------------- |
3564 | -- Install_Withed_Unit -- | |
3565 | ------------------------- | |
3566 | ||
8a6a52dc AC |
3567 | procedure Install_Withed_Unit |
3568 | (With_Clause : Node_Id; | |
3569 | Private_With_OK : Boolean := False) | |
3570 | is | |
fbf5a39b | 3571 | Uname : constant Entity_Id := Entity (Name (With_Clause)); |
996ae0b0 RK |
3572 | P : constant Entity_Id := Scope (Uname); |
3573 | ||
3574 | begin | |
0ab80019 | 3575 | -- Ada 2005 (AI-262): Do not install the private withed unit if we are |
9bc856dd AC |
3576 | -- compiling a package declaration and the Private_With_OK flag was not |
3577 | -- set by the caller. These declarations will be installed later (before | |
3578 | -- analyzing the private part of the package). | |
3579 | ||
3580 | if Private_Present (With_Clause) | |
3581 | and then Nkind (Cunit (Current_Sem_Unit)) = N_Package_Declaration | |
3582 | and then not (Private_With_OK) | |
3583 | then | |
3584 | return; | |
3585 | end if; | |
657a9dd9 AC |
3586 | |
3587 | if Debug_Flag_I then | |
9bc856dd AC |
3588 | if Private_Present (With_Clause) then |
3589 | Write_Str ("install private withed unit "); | |
3590 | else | |
3591 | Write_Str ("install withed unit "); | |
3592 | end if; | |
3593 | ||
657a9dd9 AC |
3594 | Write_Name (Chars (Uname)); |
3595 | Write_Eol; | |
3596 | end if; | |
3597 | ||
996ae0b0 RK |
3598 | -- We do not apply the restrictions to an internal unit unless |
3599 | -- we are compiling the internal unit as a main unit. This check | |
3600 | -- is also skipped for dummy units (for missing packages). | |
3601 | ||
3602 | if Sloc (Uname) /= No_Location | |
3603 | and then (not Is_Internal_File_Name (Unit_File_Name (Current_Sem_Unit)) | |
3604 | or else Current_Sem_Unit = Main_Unit) | |
3605 | then | |
3606 | Check_Restricted_Unit | |
3607 | (Unit_Name (Get_Source_Unit (Uname)), With_Clause); | |
3608 | end if; | |
3609 | ||
3610 | if P /= Standard_Standard then | |
3611 | ||
3612 | -- If the unit is not analyzed after analysis of the with clause, | |
3613 | -- and it is an instantiation, then it awaits a body and is the main | |
3614 | -- unit. Its appearance in the context of some other unit indicates | |
3615 | -- a circular dependency (DEC suite perversity). | |
3616 | ||
9bc856dd | 3617 | if not Analyzed (Uname) |
996ae0b0 RK |
3618 | and then Nkind (Parent (Uname)) = N_Package_Instantiation |
3619 | then | |
3620 | Error_Msg_N | |
3621 | ("instantiation depends on itself", Name (With_Clause)); | |
3622 | ||
3623 | elsif not Is_Visible_Child_Unit (Uname) then | |
3624 | Set_Is_Visible_Child_Unit (Uname); | |
3625 | ||
3626 | if Is_Generic_Instance (Uname) | |
3627 | and then Ekind (Uname) in Subprogram_Kind | |
3628 | then | |
3629 | -- Set flag as well on the visible entity that denotes the | |
3630 | -- instance, which renames the current one. | |
3631 | ||
3632 | Set_Is_Visible_Child_Unit | |
3633 | (Related_Instance | |
3634 | (Defining_Entity (Unit (Library_Unit (With_Clause))))); | |
996ae0b0 RK |
3635 | end if; |
3636 | ||
3637 | -- The parent unit may have been installed already, and | |
3638 | -- may have appeared in a use clause. | |
3639 | ||
3640 | if In_Use (Scope (Uname)) then | |
3641 | Set_Is_Potentially_Use_Visible (Uname); | |
3642 | end if; | |
3643 | ||
3644 | Set_Context_Installed (With_Clause); | |
3645 | end if; | |
3646 | ||
3647 | elsif not Is_Immediately_Visible (Uname) then | |
8a6a52dc AC |
3648 | if not Private_Present (With_Clause) |
3649 | or else Private_With_OK | |
3650 | then | |
3651 | Set_Is_Immediately_Visible (Uname); | |
3652 | end if; | |
3653 | ||
996ae0b0 RK |
3654 | Set_Context_Installed (With_Clause); |
3655 | end if; | |
3656 | ||
3657 | -- A with-clause overrides a with-type clause: there are no restric- | |
3658 | -- tions on the use of package entities. | |
3659 | ||
3660 | if Ekind (Uname) = E_Package then | |
3661 | Set_From_With_Type (Uname, False); | |
3662 | end if; | |
5f3ab6fb AC |
3663 | |
3664 | -- Ada 2005 (AI-377): it is illegal for a with_clause to name a child | |
3665 | -- unit if there is a visible homograph for it declared in the same | |
3666 | -- declarative region. This pathological case can only arise when an | |
3667 | -- instance I1 of a generic unit G1 has an explicit child unit I1.G2, | |
3668 | -- G1 has a generic child also named G2, and the context includes with_ | |
3669 | -- clauses for both I1.G2 and for G1.G2, making an implicit declaration | |
3670 | -- of I1.G2 visible as well. | |
3671 | ||
3672 | if Is_Child_Unit (Uname) | |
3673 | and then Is_Visible_Child_Unit (Uname) | |
3674 | and then Ada_Version >= Ada_05 | |
3675 | then | |
3676 | declare | |
3677 | Decl1 : constant Node_Id := Unit_Declaration_Node (P); | |
3678 | Decl2 : Node_Id; | |
3679 | P2 : Entity_Id; | |
3680 | U2 : Entity_Id; | |
3681 | ||
3682 | begin | |
3683 | U2 := Homonym (Uname); | |
3684 | while Present (U2) loop | |
3685 | P2 := Scope (U2); | |
3686 | Decl2 := Unit_Declaration_Node (P2); | |
3687 | ||
3688 | if Is_Child_Unit (U2) | |
3689 | and then Is_Visible_Child_Unit (U2) | |
3690 | then | |
3691 | if Is_Generic_Instance (P) | |
3692 | and then Nkind (Decl1) = N_Package_Declaration | |
3693 | and then Generic_Parent (Specification (Decl1)) = P2 | |
3694 | then | |
3695 | Error_Msg_N ("illegal with_clause", With_Clause); | |
3696 | Error_Msg_N | |
3697 | ("\child unit has visible homograph" & | |
3698 | " ('R'M 8.3(26), 10.1.1(19))", | |
3699 | With_Clause); | |
3700 | exit; | |
3701 | ||
3702 | elsif Is_Generic_Instance (P2) | |
3703 | and then Nkind (Decl2) = N_Package_Declaration | |
3704 | and then Generic_Parent (Specification (Decl2)) = P | |
3705 | then | |
3706 | -- With_clause for child unit of instance appears before | |
3707 | -- in the context. We want to place the error message on | |
3708 | -- it, not on the generic child unit itself. | |
3709 | ||
3710 | declare | |
3711 | Prev_Clause : Node_Id; | |
3712 | ||
3713 | begin | |
3714 | Prev_Clause := First (List_Containing (With_Clause)); | |
3715 | while Entity (Name (Prev_Clause)) /= U2 loop | |
3716 | Next (Prev_Clause); | |
3717 | end loop; | |
3718 | ||
3719 | pragma Assert (Present (Prev_Clause)); | |
3720 | Error_Msg_N ("illegal with_clause", Prev_Clause); | |
3721 | Error_Msg_N | |
3722 | ("\child unit has visible homograph" & | |
3723 | " ('R'M 8.3(26), 10.1.1(19))", | |
3724 | Prev_Clause); | |
3725 | exit; | |
3726 | end; | |
3727 | end if; | |
3728 | end if; | |
3729 | ||
3730 | U2 := Homonym (U2); | |
3731 | end loop; | |
3732 | end; | |
3733 | end if; | |
996ae0b0 RK |
3734 | end Install_Withed_Unit; |
3735 | ||
3736 | ------------------- | |
3737 | -- Is_Child_Spec -- | |
3738 | ------------------- | |
3739 | ||
3740 | function Is_Child_Spec (Lib_Unit : Node_Id) return Boolean is | |
3741 | K : constant Node_Kind := Nkind (Lib_Unit); | |
3742 | ||
3743 | begin | |
3744 | return (K in N_Generic_Declaration or else | |
3745 | K in N_Generic_Instantiation or else | |
3746 | K in N_Generic_Renaming_Declaration or else | |
3747 | K = N_Package_Declaration or else | |
3748 | K = N_Package_Renaming_Declaration or else | |
3749 | K = N_Subprogram_Declaration or else | |
3750 | K = N_Subprogram_Renaming_Declaration) | |
3751 | and then Present (Parent_Spec (Lib_Unit)); | |
3752 | end Is_Child_Spec; | |
3753 | ||
3754 | ----------------------- | |
3755 | -- Load_Needed_Body -- | |
3756 | ----------------------- | |
3757 | ||
3758 | -- N is a generic unit named in a with clause, or else it is | |
3759 | -- a unit that contains a generic unit or an inlined function. | |
3760 | -- In order to perform an instantiation, the body of the unit | |
3761 | -- must be present. If the unit itself is generic, we assume | |
3762 | -- that an instantiation follows, and load and analyze the body | |
3763 | -- unconditionally. This forces analysis of the spec as well. | |
3764 | ||
3765 | -- If the unit is not generic, but contains a generic unit, it | |
3766 | -- is loaded on demand, at the point of instantiation (see ch12). | |
3767 | ||
3768 | procedure Load_Needed_Body (N : Node_Id; OK : out Boolean) is | |
3769 | Body_Name : Unit_Name_Type; | |
3770 | Unum : Unit_Number_Type; | |
3771 | ||
3772 | Save_Style_Check : constant Boolean := Opt.Style_Check; | |
3773 | -- The loading and analysis is done with style checks off | |
3774 | ||
3775 | begin | |
3776 | if not GNAT_Mode then | |
3777 | Style_Check := False; | |
3778 | end if; | |
3779 | ||
3780 | Body_Name := Get_Body_Name (Get_Unit_Name (Unit (N))); | |
3781 | Unum := | |
3782 | Load_Unit | |
3783 | (Load_Name => Body_Name, | |
3784 | Required => False, | |
3785 | Subunit => False, | |
3786 | Error_Node => N, | |
3787 | Renamings => True); | |
3788 | ||
3789 | if Unum = No_Unit then | |
3790 | OK := False; | |
3791 | ||
3792 | else | |
3793 | Compiler_State := Analyzing; -- reset after load | |
3794 | ||
fbf5a39b | 3795 | if not Fatal_Error (Unum) or else Try_Semantics then |
996ae0b0 RK |
3796 | if Debug_Flag_L then |
3797 | Write_Str ("*** Loaded generic body"); | |
3798 | Write_Eol; | |
3799 | end if; | |
3800 | ||
3801 | Semantics (Cunit (Unum)); | |
3802 | end if; | |
3803 | ||
3804 | OK := True; | |
3805 | end if; | |
3806 | ||
3807 | Style_Check := Save_Style_Check; | |
3808 | end Load_Needed_Body; | |
3809 | ||
fbf5a39b AC |
3810 | ------------------------- |
3811 | -- Build_Limited_Views -- | |
3812 | ------------------------- | |
3813 | ||
3814 | procedure Build_Limited_Views (N : Node_Id) is | |
91b1417d AC |
3815 | Unum : constant Unit_Number_Type := Get_Source_Unit (Library_Unit (N)); |
3816 | P : constant Entity_Id := Cunit_Entity (Unum); | |
fbf5a39b | 3817 | |
0fb2ea01 AC |
3818 | Spec : Node_Id; -- To denote a package specification |
3819 | Lim_Typ : Entity_Id; -- To denote shadow entities | |
3820 | Comp_Typ : Entity_Id; -- To denote real entities | |
3821 | ||
3822 | Lim_Header : Entity_Id; -- Package entity | |
3823 | Last_Lim_E : Entity_Id := Empty; -- Last limited entity built | |
3824 | Last_Pub_Lim_E : Entity_Id; -- To set the first private entity | |
fbf5a39b AC |
3825 | |
3826 | procedure Decorate_Incomplete_Type | |
3827 | (E : Entity_Id; | |
3828 | Scop : Entity_Id); | |
3829 | -- Add attributes of an incomplete type to a shadow entity. The same | |
3830 | -- attributes are placed on the real entity, so that gigi receives | |
3831 | -- a consistent view. | |
3832 | ||
3833 | procedure Decorate_Package_Specification (P : Entity_Id); | |
3834 | -- Add attributes of a package entity to the entity in a package | |
3835 | -- declaration | |
3836 | ||
3837 | procedure Decorate_Tagged_Type | |
3838 | (Loc : Source_Ptr; | |
3839 | T : Entity_Id; | |
3840 | Scop : Entity_Id); | |
3841 | -- Set basic attributes of tagged type T, including its class_wide type. | |
3842 | -- The parameters Loc, Scope are used to decorate the class_wide type. | |
3843 | ||
0fb2ea01 AC |
3844 | procedure Build_Chain |
3845 | (Scope : Entity_Id; | |
3846 | First_Decl : Node_Id); | |
fbf5a39b AC |
3847 | -- Construct list of shadow entities and attach it to entity of |
3848 | -- package that is mentioned in a limited_with clause. | |
3849 | ||
657a9dd9 AC |
3850 | function New_Internal_Shadow_Entity |
3851 | (Kind : Entity_Kind; | |
3852 | Sloc_Value : Source_Ptr; | |
3853 | Id_Char : Character) return Entity_Id; | |
0fb2ea01 AC |
3854 | -- Build a new internal entity and append it to the list of shadow |
3855 | -- entities available through the limited-header | |
657a9dd9 | 3856 | |
fbf5a39b AC |
3857 | ------------------------------ |
3858 | -- Decorate_Incomplete_Type -- | |
3859 | ------------------------------ | |
3860 | ||
3861 | procedure Decorate_Incomplete_Type | |
3862 | (E : Entity_Id; | |
3863 | Scop : Entity_Id) | |
3864 | is | |
3865 | begin | |
0fb2ea01 AC |
3866 | Set_Ekind (E, E_Incomplete_Type); |
3867 | Set_Scope (E, Scop); | |
3868 | Set_Etype (E, E); | |
3869 | Set_Is_First_Subtype (E, True); | |
3870 | Set_Stored_Constraint (E, No_Elist); | |
3871 | Set_Full_View (E, Empty); | |
3872 | Init_Size_Align (E); | |
fbf5a39b AC |
3873 | end Decorate_Incomplete_Type; |
3874 | ||
3875 | -------------------------- | |
3876 | -- Decorate_Tagged_Type -- | |
3877 | -------------------------- | |
3878 | ||
3879 | procedure Decorate_Tagged_Type | |
3880 | (Loc : Source_Ptr; | |
3881 | T : Entity_Id; | |
3882 | Scop : Entity_Id) | |
3883 | is | |
3884 | CW : Entity_Id; | |
3885 | ||
3886 | begin | |
3887 | Decorate_Incomplete_Type (T, Scop); | |
3888 | Set_Is_Tagged_Type (T); | |
3889 | ||
3890 | -- Build corresponding class_wide type, if not previously done | |
3891 | ||
3892 | if No (Class_Wide_Type (T)) then | |
3893 | CW := Make_Defining_Identifier (Loc, New_Internal_Name ('S')); | |
3894 | ||
3895 | Set_Ekind (CW, E_Class_Wide_Type); | |
3896 | Set_Etype (CW, T); | |
3897 | Set_Scope (CW, Scop); | |
3898 | Set_Is_Tagged_Type (CW); | |
3899 | Set_Is_First_Subtype (CW, True); | |
3900 | Init_Size_Align (CW); | |
3901 | Set_Has_Unknown_Discriminants (CW, True); | |
3902 | Set_Class_Wide_Type (CW, CW); | |
3903 | Set_Equivalent_Type (CW, Empty); | |
3904 | Set_From_With_Type (CW, From_With_Type (T)); | |
3905 | ||
0fb2ea01 | 3906 | Set_Class_Wide_Type (T, CW); |
fbf5a39b AC |
3907 | end if; |
3908 | end Decorate_Tagged_Type; | |
3909 | ||
3910 | ------------------------------------ | |
3911 | -- Decorate_Package_Specification -- | |
3912 | ------------------------------------ | |
3913 | ||
3914 | procedure Decorate_Package_Specification (P : Entity_Id) is | |
3915 | begin | |
3916 | -- Place only the most basic attributes | |
3917 | ||
3918 | Set_Ekind (P, E_Package); | |
3919 | Set_Etype (P, Standard_Void_Type); | |
3920 | end Decorate_Package_Specification; | |
3921 | ||
657a9dd9 AC |
3922 | ------------------------- |
3923 | -- New_Internal_Entity -- | |
3924 | ------------------------- | |
3925 | ||
3926 | function New_Internal_Shadow_Entity | |
3927 | (Kind : Entity_Kind; | |
3928 | Sloc_Value : Source_Ptr; | |
3929 | Id_Char : Character) return Entity_Id | |
3930 | is | |
0fb2ea01 | 3931 | E : constant Entity_Id := |
657a9dd9 AC |
3932 | Make_Defining_Identifier (Sloc_Value, |
3933 | Chars => New_Internal_Name (Id_Char)); | |
3934 | ||
3935 | begin | |
0fb2ea01 AC |
3936 | Set_Ekind (E, Kind); |
3937 | Set_Is_Internal (E, True); | |
657a9dd9 AC |
3938 | |
3939 | if Kind in Type_Kind then | |
0fb2ea01 | 3940 | Init_Size_Align (E); |
657a9dd9 AC |
3941 | end if; |
3942 | ||
0fb2ea01 AC |
3943 | Append_Entity (E, Lim_Header); |
3944 | Last_Lim_E := E; | |
3945 | return E; | |
657a9dd9 AC |
3946 | end New_Internal_Shadow_Entity; |
3947 | ||
fbf5a39b AC |
3948 | ----------------- |
3949 | -- Build_Chain -- | |
3950 | ----------------- | |
3951 | ||
0fb2ea01 AC |
3952 | procedure Build_Chain |
3953 | (Scope : Entity_Id; | |
3954 | First_Decl : Node_Id) | |
3955 | is | |
91b1417d | 3956 | Analyzed_Unit : constant Boolean := Analyzed (Cunit (Unum)); |
657a9dd9 | 3957 | Is_Tagged : Boolean; |
91b1417d | 3958 | Decl : Node_Id; |
fbf5a39b AC |
3959 | |
3960 | begin | |
0fb2ea01 | 3961 | Decl := First_Decl; |
fbf5a39b AC |
3962 | |
3963 | while Present (Decl) loop | |
0fb2ea01 AC |
3964 | |
3965 | -- For each library_package_declaration in the environment, there | |
3966 | -- is an implicit declaration of a *limited view* of that library | |
3967 | -- package. The limited view of a package contains: | |
3968 | -- | |
3969 | -- * For each nested package_declaration, a declaration of the | |
3970 | -- limited view of that package, with the same defining- | |
3971 | -- program-unit name. | |
3972 | -- | |
3973 | -- * For each type_declaration in the visible part, an incomplete | |
3974 | -- type-declaration with the same defining_identifier, whose | |
3975 | -- completion is the type_declaration. If the type_declaration | |
3976 | -- is tagged, then the incomplete_type_declaration is tagged | |
3977 | -- incomplete. | |
3978 | ||
fbf5a39b | 3979 | if Nkind (Decl) = N_Full_Type_Declaration then |
657a9dd9 AC |
3980 | Is_Tagged := |
3981 | Nkind (Type_Definition (Decl)) = N_Record_Definition | |
3982 | and then Tagged_Present (Type_Definition (Decl)); | |
3983 | ||
fbf5a39b AC |
3984 | Comp_Typ := Defining_Identifier (Decl); |
3985 | ||
657a9dd9 AC |
3986 | if not Analyzed_Unit then |
3987 | if Is_Tagged then | |
fbf5a39b AC |
3988 | Decorate_Tagged_Type (Sloc (Decl), Comp_Typ, Scope); |
3989 | else | |
3990 | Decorate_Incomplete_Type (Comp_Typ, Scope); | |
3991 | end if; | |
3992 | end if; | |
3993 | ||
3994 | -- Create shadow entity for type | |
3995 | ||
0fb2ea01 | 3996 | Lim_Typ := New_Internal_Shadow_Entity |
fbf5a39b | 3997 | (Kind => Ekind (Comp_Typ), |
fbf5a39b AC |
3998 | Sloc_Value => Sloc (Comp_Typ), |
3999 | Id_Char => 'Z'); | |
4000 | ||
4001 | Set_Chars (Lim_Typ, Chars (Comp_Typ)); | |
4002 | Set_Parent (Lim_Typ, Parent (Comp_Typ)); | |
4003 | Set_From_With_Type (Lim_Typ); | |
4004 | ||
657a9dd9 | 4005 | if Is_Tagged then |
fbf5a39b AC |
4006 | Decorate_Tagged_Type (Sloc (Decl), Lim_Typ, Scope); |
4007 | else | |
4008 | Decorate_Incomplete_Type (Lim_Typ, Scope); | |
4009 | end if; | |
4010 | ||
4011 | Set_Non_Limited_View (Lim_Typ, Comp_Typ); | |
fbf5a39b AC |
4012 | |
4013 | elsif Nkind (Decl) = N_Private_Type_Declaration | |
4014 | and then Tagged_Present (Decl) | |
4015 | then | |
4016 | Comp_Typ := Defining_Identifier (Decl); | |
4017 | ||
657a9dd9 | 4018 | if not Analyzed_Unit then |
fbf5a39b AC |
4019 | Decorate_Tagged_Type (Sloc (Decl), Comp_Typ, Scope); |
4020 | end if; | |
4021 | ||
657a9dd9 | 4022 | Lim_Typ := New_Internal_Shadow_Entity |
fbf5a39b | 4023 | (Kind => Ekind (Comp_Typ), |
fbf5a39b AC |
4024 | Sloc_Value => Sloc (Comp_Typ), |
4025 | Id_Char => 'Z'); | |
4026 | ||
4027 | Set_Chars (Lim_Typ, Chars (Comp_Typ)); | |
4028 | Set_Parent (Lim_Typ, Parent (Comp_Typ)); | |
4029 | Set_From_With_Type (Lim_Typ); | |
4030 | ||
4031 | Decorate_Tagged_Type (Sloc (Decl), Lim_Typ, Scope); | |
4032 | ||
4033 | Set_Non_Limited_View (Lim_Typ, Comp_Typ); | |
fbf5a39b AC |
4034 | |
4035 | elsif Nkind (Decl) = N_Package_Declaration then | |
4036 | ||
4037 | -- Local package | |
4038 | ||
4039 | declare | |
91b1417d | 4040 | Spec : constant Node_Id := Specification (Decl); |
fbf5a39b AC |
4041 | |
4042 | begin | |
4043 | Comp_Typ := Defining_Unit_Name (Spec); | |
4044 | ||
4045 | if not Analyzed (Cunit (Unum)) then | |
4046 | Decorate_Package_Specification (Comp_Typ); | |
4047 | Set_Scope (Comp_Typ, Scope); | |
4048 | end if; | |
4049 | ||
657a9dd9 | 4050 | Lim_Typ := New_Internal_Shadow_Entity |
fbf5a39b | 4051 | (Kind => Ekind (Comp_Typ), |
fbf5a39b AC |
4052 | Sloc_Value => Sloc (Comp_Typ), |
4053 | Id_Char => 'Z'); | |
4054 | ||
4055 | Decorate_Package_Specification (Lim_Typ); | |
4056 | Set_Scope (Lim_Typ, Scope); | |
4057 | ||
4058 | Set_Chars (Lim_Typ, Chars (Comp_Typ)); | |
4059 | Set_Parent (Lim_Typ, Parent (Comp_Typ)); | |
4060 | Set_From_With_Type (Lim_Typ); | |
4061 | ||
4062 | -- Note: The non_limited_view attribute is not used | |
4063 | -- for local packages. | |
4064 | ||
0fb2ea01 AC |
4065 | Build_Chain |
4066 | (Scope => Lim_Typ, | |
4067 | First_Decl => First (Visible_Declarations (Spec))); | |
fbf5a39b AC |
4068 | end; |
4069 | end if; | |
4070 | ||
4071 | Next (Decl); | |
4072 | end loop; | |
4073 | end Build_Chain; | |
4074 | ||
4075 | -- Start of processing for Build_Limited_Views | |
4076 | ||
4077 | begin | |
4078 | pragma Assert (Limited_Present (N)); | |
4079 | ||
657a9dd9 AC |
4080 | -- A library_item mentioned in a limited_with_clause shall be |
4081 | -- a package_declaration, not a subprogram_declaration, | |
4082 | -- generic_declaration, generic_instantiation, or | |
4083 | -- package_renaming_declaration | |
fbf5a39b | 4084 | |
657a9dd9 AC |
4085 | case Nkind (Unit (Library_Unit (N))) is |
4086 | ||
4087 | when N_Package_Declaration => | |
4088 | null; | |
4089 | ||
4090 | when N_Subprogram_Declaration => | |
4091 | Error_Msg_N ("subprograms not allowed in " | |
4092 | & "limited with_clauses", N); | |
12e0c41c | 4093 | return; |
657a9dd9 AC |
4094 | |
4095 | when N_Generic_Package_Declaration | | |
4096 | N_Generic_Subprogram_Declaration => | |
4097 | Error_Msg_N ("generics not allowed in " | |
4098 | & "limited with_clauses", N); | |
12e0c41c | 4099 | return; |
657a9dd9 AC |
4100 | |
4101 | when N_Package_Instantiation | | |
4102 | N_Function_Instantiation | | |
4103 | N_Procedure_Instantiation => | |
4104 | Error_Msg_N ("generic instantiations not allowed in " | |
4105 | & "limited with_clauses", N); | |
12e0c41c | 4106 | return; |
657a9dd9 AC |
4107 | |
4108 | when N_Generic_Package_Renaming_Declaration | | |
4109 | N_Generic_Procedure_Renaming_Declaration | | |
4110 | N_Generic_Function_Renaming_Declaration => | |
4111 | Error_Msg_N ("generic renamings not allowed in " | |
4112 | & "limited with_clauses", N); | |
12e0c41c | 4113 | return; |
657a9dd9 AC |
4114 | |
4115 | when others => | |
9bc856dd | 4116 | raise Program_Error; |
657a9dd9 | 4117 | end case; |
fbf5a39b AC |
4118 | |
4119 | -- Check if the chain is already built | |
4120 | ||
4121 | Spec := Specification (Unit (Library_Unit (N))); | |
4122 | ||
4123 | if Limited_View_Installed (Spec) then | |
4124 | return; | |
4125 | end if; | |
4126 | ||
4127 | Set_Ekind (P, E_Package); | |
fbf5a39b | 4128 | |
0fb2ea01 AC |
4129 | -- Build the header of the limited_view |
4130 | ||
4131 | Lim_Header := Make_Defining_Identifier (Sloc (N), | |
4132 | Chars => New_Internal_Name (Id_Char => 'Z')); | |
4133 | Set_Ekind (Lim_Header, E_Package); | |
4134 | Set_Is_Internal (Lim_Header); | |
4135 | Set_Limited_View (P, Lim_Header); | |
4136 | ||
4137 | -- Create the auxiliary chain. All the shadow entities are appended | |
4138 | -- to the list of entities of the limited-view header | |
4139 | ||
4140 | Build_Chain | |
4141 | (Scope => P, | |
4142 | First_Decl => First (Visible_Declarations (Spec))); | |
4143 | ||
4144 | -- Save the last built shadow entity. It is needed later to set the | |
4145 | -- reference to the first shadow entity in the private part | |
4146 | ||
4147 | Last_Pub_Lim_E := Last_Lim_E; | |
4148 | ||
0ab80019 | 4149 | -- Ada 2005 (AI-262): Add the limited view of the private declarations |
0fb2ea01 AC |
4150 | -- Required to give support to limited-private-with clauses |
4151 | ||
4152 | Build_Chain (Scope => P, | |
4153 | First_Decl => First (Private_Declarations (Spec))); | |
4154 | ||
4155 | if Last_Pub_Lim_E /= Empty then | |
4156 | Set_First_Private_Entity (Lim_Header, | |
4157 | Next_Entity (Last_Pub_Lim_E)); | |
4158 | else | |
4159 | Set_First_Private_Entity (Lim_Header, | |
4160 | First_Entity (P)); | |
4161 | end if; | |
fbf5a39b | 4162 | |
fbf5a39b AC |
4163 | Set_Limited_View_Installed (Spec); |
4164 | end Build_Limited_Views; | |
4165 | ||
4166 | ------------------------------- | |
4167 | -- Check_Body_Needed_For_SAL -- | |
4168 | ------------------------------- | |
4169 | ||
4170 | procedure Check_Body_Needed_For_SAL (Unit_Name : Entity_Id) is | |
4171 | ||
4172 | function Entity_Needs_Body (E : Entity_Id) return Boolean; | |
4173 | -- Determine whether use of entity E might require the presence | |
4174 | -- of its body. For a package this requires a recursive traversal | |
4175 | -- of all nested declarations. | |
4176 | ||
4177 | --------------------------- | |
4178 | -- Entity_Needed_For_SAL -- | |
4179 | --------------------------- | |
4180 | ||
4181 | function Entity_Needs_Body (E : Entity_Id) return Boolean is | |
4182 | Ent : Entity_Id; | |
4183 | ||
4184 | begin | |
4185 | if Is_Subprogram (E) | |
4186 | and then Has_Pragma_Inline (E) | |
4187 | then | |
4188 | return True; | |
4189 | ||
4190 | elsif Ekind (E) = E_Generic_Function | |
4191 | or else Ekind (E) = E_Generic_Procedure | |
4192 | then | |
4193 | return True; | |
4194 | ||
4195 | elsif Ekind (E) = E_Generic_Package | |
4196 | and then | |
4197 | Nkind (Unit_Declaration_Node (E)) = N_Generic_Package_Declaration | |
4198 | and then Present (Corresponding_Body (Unit_Declaration_Node (E))) | |
4199 | then | |
4200 | return True; | |
4201 | ||
4202 | elsif Ekind (E) = E_Package | |
4203 | and then | |
4204 | Nkind (Unit_Declaration_Node (E)) = N_Package_Declaration | |
4205 | and then Present (Corresponding_Body (Unit_Declaration_Node (E))) | |
4206 | then | |
4207 | Ent := First_Entity (E); | |
4208 | ||
4209 | while Present (Ent) loop | |
4210 | if Entity_Needs_Body (Ent) then | |
4211 | return True; | |
4212 | end if; | |
4213 | ||
4214 | Next_Entity (Ent); | |
4215 | end loop; | |
4216 | ||
4217 | return False; | |
4218 | ||
4219 | else | |
4220 | return False; | |
4221 | end if; | |
4222 | end Entity_Needs_Body; | |
4223 | ||
4224 | -- Start of processing for Check_Body_Needed_For_SAL | |
4225 | ||
4226 | begin | |
4227 | if Ekind (Unit_Name) = E_Generic_Package | |
4228 | and then | |
4229 | Nkind (Unit_Declaration_Node (Unit_Name)) = | |
4230 | N_Generic_Package_Declaration | |
4231 | and then | |
4232 | Present (Corresponding_Body (Unit_Declaration_Node (Unit_Name))) | |
4233 | then | |
4234 | Set_Body_Needed_For_SAL (Unit_Name); | |
4235 | ||
4236 | elsif Ekind (Unit_Name) = E_Generic_Procedure | |
4237 | or else Ekind (Unit_Name) = E_Generic_Function | |
4238 | then | |
4239 | Set_Body_Needed_For_SAL (Unit_Name); | |
4240 | ||
4241 | elsif Is_Subprogram (Unit_Name) | |
4242 | and then Nkind (Unit_Declaration_Node (Unit_Name)) = | |
4243 | N_Subprogram_Declaration | |
4244 | and then Has_Pragma_Inline (Unit_Name) | |
4245 | then | |
4246 | Set_Body_Needed_For_SAL (Unit_Name); | |
4247 | ||
4248 | elsif Ekind (Unit_Name) = E_Subprogram_Body then | |
4249 | Check_Body_Needed_For_SAL | |
4250 | (Corresponding_Spec (Unit_Declaration_Node (Unit_Name))); | |
4251 | ||
4252 | elsif Ekind (Unit_Name) = E_Package | |
4253 | and then Entity_Needs_Body (Unit_Name) | |
4254 | then | |
4255 | Set_Body_Needed_For_SAL (Unit_Name); | |
4256 | ||
4257 | elsif Ekind (Unit_Name) = E_Package_Body | |
4258 | and then Nkind (Unit_Declaration_Node (Unit_Name)) = N_Package_Body | |
4259 | then | |
4260 | Check_Body_Needed_For_SAL | |
4261 | (Corresponding_Spec (Unit_Declaration_Node (Unit_Name))); | |
4262 | end if; | |
4263 | end Check_Body_Needed_For_SAL; | |
4264 | ||
996ae0b0 RK |
4265 | -------------------- |
4266 | -- Remove_Context -- | |
4267 | -------------------- | |
4268 | ||
4269 | procedure Remove_Context (N : Node_Id) is | |
4270 | Lib_Unit : constant Node_Id := Unit (N); | |
4271 | ||
4272 | begin | |
a5b62485 | 4273 | -- If this is a child unit, first remove the parent units |
996ae0b0 RK |
4274 | |
4275 | if Is_Child_Spec (Lib_Unit) then | |
4276 | Remove_Parents (Lib_Unit); | |
4277 | end if; | |
4278 | ||
4279 | Remove_Context_Clauses (N); | |
4280 | end Remove_Context; | |
4281 | ||
4282 | ---------------------------- | |
4283 | -- Remove_Context_Clauses -- | |
4284 | ---------------------------- | |
4285 | ||
4286 | procedure Remove_Context_Clauses (N : Node_Id) is | |
4287 | Item : Node_Id; | |
4288 | Unit_Name : Entity_Id; | |
4289 | ||
4290 | begin | |
0ab80019 | 4291 | -- Ada 2005 (AI-50217): We remove the context clauses in two phases: |
19f0526a AC |
4292 | -- limited-views first and regular-views later (to maintain the |
4293 | -- stack model). | |
996ae0b0 | 4294 | |
657a9dd9 | 4295 | -- First Phase: Remove limited_with context clauses |
996ae0b0 RK |
4296 | |
4297 | Item := First (Context_Items (N)); | |
657a9dd9 AC |
4298 | while Present (Item) loop |
4299 | ||
4300 | -- We are interested only in with clauses which got installed | |
4301 | -- on entry. | |
996ae0b0 | 4302 | |
657a9dd9 AC |
4303 | if Nkind (Item) = N_With_Clause |
4304 | and then Limited_Present (Item) | |
4305 | and then Limited_View_Installed (Item) | |
4306 | then | |
4307 | Remove_Limited_With_Clause (Item); | |
657a9dd9 AC |
4308 | end if; |
4309 | ||
4310 | Next (Item); | |
4311 | end loop; | |
4312 | ||
4313 | -- Second Phase: Loop through context items and undo regular | |
4314 | -- with_clauses and use_clauses. | |
4315 | ||
4316 | Item := First (Context_Items (N)); | |
996ae0b0 RK |
4317 | while Present (Item) loop |
4318 | ||
4319 | -- We are interested only in with clauses which got installed | |
4320 | -- on entry, as indicated by their Context_Installed flag set | |
4321 | ||
4322 | if Nkind (Item) = N_With_Clause | |
fbf5a39b AC |
4323 | and then Limited_Present (Item) |
4324 | and then Limited_View_Installed (Item) | |
4325 | then | |
657a9dd9 | 4326 | null; |
fbf5a39b AC |
4327 | |
4328 | elsif Nkind (Item) = N_With_Clause | |
996ae0b0 RK |
4329 | and then Context_Installed (Item) |
4330 | then | |
4331 | -- Remove items from one with'ed unit | |
4332 | ||
4333 | Unit_Name := Entity (Name (Item)); | |
4334 | Remove_Unit_From_Visibility (Unit_Name); | |
4335 | Set_Context_Installed (Item, False); | |
4336 | ||
4337 | elsif Nkind (Item) = N_Use_Package_Clause then | |
4338 | End_Use_Package (Item); | |
4339 | ||
4340 | elsif Nkind (Item) = N_Use_Type_Clause then | |
4341 | End_Use_Type (Item); | |
4342 | ||
4343 | elsif Nkind (Item) = N_With_Type_Clause then | |
4344 | Remove_With_Type_Clause (Name (Item)); | |
4345 | end if; | |
4346 | ||
4347 | Next (Item); | |
4348 | end loop; | |
996ae0b0 RK |
4349 | end Remove_Context_Clauses; |
4350 | ||
fbf5a39b AC |
4351 | -------------------------------- |
4352 | -- Remove_Limited_With_Clause -- | |
4353 | -------------------------------- | |
4354 | ||
4355 | procedure Remove_Limited_With_Clause (N : Node_Id) is | |
0fb2ea01 AC |
4356 | P_Unit : constant Entity_Id := Unit (Library_Unit (N)); |
4357 | P : Entity_Id := Defining_Unit_Name (Specification (P_Unit)); | |
4358 | Lim_Typ : Entity_Id; | |
fbf5a39b AC |
4359 | |
4360 | begin | |
4361 | if Nkind (P) = N_Defining_Program_Unit_Name then | |
4362 | ||
4363 | -- Retrieve entity of Child package | |
4364 | ||
4365 | P := Defining_Identifier (P); | |
4366 | end if; | |
4367 | ||
657a9dd9 AC |
4368 | if Debug_Flag_I then |
4369 | Write_Str ("remove limited view of "); | |
4370 | Write_Name (Chars (P)); | |
4371 | Write_Str (" from visibility"); | |
4372 | Write_Eol; | |
4373 | end if; | |
4374 | ||
0fb2ea01 AC |
4375 | -- Remove all shadow entities from visibility. The first element of the |
4376 | -- limited view is a header (an E_Package entity) that is used to | |
4377 | -- reference the first shadow entity in the private part of the package | |
fbf5a39b | 4378 | |
0fb2ea01 | 4379 | Lim_Typ := First_Entity (Limited_View (P)); |
fbf5a39b | 4380 | |
0fb2ea01 | 4381 | while Present (Lim_Typ) loop |
fbf5a39b | 4382 | Unchain (Lim_Typ); |
0fb2ea01 | 4383 | Next_Entity (Lim_Typ); |
fbf5a39b AC |
4384 | end loop; |
4385 | ||
657a9dd9 AC |
4386 | -- Indicate that the limited view of the package is not installed |
4387 | ||
4388 | Set_From_With_Type (P, False); | |
4389 | Set_Limited_View_Installed (N, False); | |
4390 | ||
fbf5a39b AC |
4391 | -- If the exporting package has previously been analyzed, it |
4392 | -- has appeared in the closure already and should be left alone. | |
4393 | -- Otherwise, remove package itself from visibility. | |
4394 | ||
4395 | if not Analyzed (P_Unit) then | |
4396 | Unchain (P); | |
4397 | Set_First_Entity (P, Empty); | |
4398 | Set_Last_Entity (P, Empty); | |
4399 | Set_Ekind (P, E_Void); | |
4400 | Set_Scope (P, Empty); | |
4401 | Set_Is_Immediately_Visible (P, False); | |
fbf5a39b | 4402 | |
657a9dd9 AC |
4403 | else |
4404 | ||
4405 | -- Reinstall visible entities (entities removed from visibility in | |
4406 | -- Install_Limited_Withed to install the shadow entities). | |
4407 | ||
4408 | declare | |
4409 | Ent : Entity_Id; | |
4410 | ||
4411 | begin | |
4412 | Ent := First_Entity (P); | |
4413 | while Present (Ent) and then Ent /= First_Private_Entity (P) loop | |
4414 | ||
4415 | -- Shadow entities have not been added to the list of | |
4416 | -- entities associated to the package spec. Therefore we | |
4417 | -- just have to re-chain all its visible entities. | |
4418 | ||
4419 | if not Is_Class_Wide_Type (Ent) then | |
4420 | ||
4421 | Set_Homonym (Ent, Current_Entity (Ent)); | |
4422 | Set_Current_Entity (Ent); | |
4423 | ||
4424 | if Debug_Flag_I then | |
4425 | Write_Str (" (homonym) chain "); | |
4426 | Write_Name (Chars (Ent)); | |
4427 | Write_Eol; | |
4428 | end if; | |
657a9dd9 AC |
4429 | end if; |
4430 | ||
4431 | Next_Entity (Ent); | |
4432 | end loop; | |
4433 | end; | |
4434 | end if; | |
fbf5a39b AC |
4435 | end Remove_Limited_With_Clause; |
4436 | ||
996ae0b0 RK |
4437 | -------------------- |
4438 | -- Remove_Parents -- | |
4439 | -------------------- | |
4440 | ||
4441 | procedure Remove_Parents (Lib_Unit : Node_Id) is | |
4442 | P : Node_Id; | |
4443 | P_Name : Entity_Id; | |
523456db | 4444 | P_Spec : Node_Id := Empty; |
996ae0b0 RK |
4445 | E : Entity_Id; |
4446 | Vis : constant Boolean := | |
4447 | Scope_Stack.Table (Scope_Stack.Last).Previous_Visibility; | |
4448 | ||
4449 | begin | |
4450 | if Is_Child_Spec (Lib_Unit) then | |
523456db | 4451 | P_Spec := Parent_Spec (Lib_Unit); |
996ae0b0 | 4452 | |
523456db AC |
4453 | elsif Nkind (Lib_Unit) = N_Package_Body |
4454 | and then Nkind (Original_Node (Lib_Unit)) = N_Package_Instantiation | |
4455 | then | |
4456 | P_Spec := Parent_Spec (Original_Node (Lib_Unit)); | |
4457 | end if; | |
4458 | ||
4459 | if Present (P_Spec) then | |
4460 | ||
4461 | P := Unit (P_Spec); | |
4462 | P_Name := Get_Parent_Entity (P); | |
4463 | Remove_Context_Clauses (P_Spec); | |
996ae0b0 RK |
4464 | End_Package_Scope (P_Name); |
4465 | Set_Is_Immediately_Visible (P_Name, Vis); | |
4466 | ||
4467 | -- Remove from visibility the siblings as well, which are directly | |
4468 | -- visible while the parent is in scope. | |
4469 | ||
4470 | E := First_Entity (P_Name); | |
4471 | ||
4472 | while Present (E) loop | |
4473 | ||
4474 | if Is_Child_Unit (E) then | |
4475 | Set_Is_Immediately_Visible (E, False); | |
4476 | end if; | |
4477 | ||
4478 | Next_Entity (E); | |
4479 | end loop; | |
4480 | ||
4481 | Set_In_Package_Body (P_Name, False); | |
4482 | ||
4483 | -- This is the recursive call to remove the context of any | |
4484 | -- higher level parent. This recursion ensures that all parents | |
4485 | -- are removed in the reverse order of their installation. | |
4486 | ||
4487 | Remove_Parents (P); | |
4488 | end if; | |
4489 | end Remove_Parents; | |
4490 | ||
4491 | ----------------------------- | |
4492 | -- Remove_With_Type_Clause -- | |
4493 | ----------------------------- | |
4494 | ||
4495 | procedure Remove_With_Type_Clause (Name : Node_Id) is | |
4496 | Typ : Entity_Id; | |
4497 | P : Entity_Id; | |
4498 | ||
4499 | procedure Unchain (E : Entity_Id); | |
a5b62485 AC |
4500 | -- Remove entity from visibility list |
4501 | ||
4502 | ------------- | |
4503 | -- Unchain -- | |
4504 | ------------- | |
996ae0b0 RK |
4505 | |
4506 | procedure Unchain (E : Entity_Id) is | |
4507 | Prev : Entity_Id; | |
4508 | ||
4509 | begin | |
4510 | Prev := Current_Entity (E); | |
4511 | ||
4512 | -- Package entity may appear is several with_type_clauses, and | |
4513 | -- may have been removed already. | |
4514 | ||
4515 | if No (Prev) then | |
4516 | return; | |
4517 | ||
4518 | elsif Prev = E then | |
4519 | Set_Name_Entity_Id (Chars (E), Homonym (E)); | |
4520 | ||
4521 | else | |
4522 | while Present (Prev) | |
4523 | and then Homonym (Prev) /= E | |
4524 | loop | |
4525 | Prev := Homonym (Prev); | |
4526 | end loop; | |
4527 | ||
fbf5a39b | 4528 | if Present (Prev) then |
996ae0b0 RK |
4529 | Set_Homonym (Prev, Homonym (E)); |
4530 | end if; | |
4531 | end if; | |
4532 | end Unchain; | |
4533 | ||
a5b62485 | 4534 | -- Start of processing for Remove_With_Type_Clause |
657a9dd9 | 4535 | |
996ae0b0 RK |
4536 | begin |
4537 | if Nkind (Name) = N_Selected_Component then | |
4538 | Typ := Entity (Selector_Name (Name)); | |
4539 | ||
a5b62485 AC |
4540 | -- If no Typ, then error in declaration, ignore |
4541 | ||
4542 | if No (Typ) then | |
996ae0b0 RK |
4543 | return; |
4544 | end if; | |
4545 | else | |
4546 | return; | |
4547 | end if; | |
4548 | ||
4549 | P := Scope (Typ); | |
4550 | ||
4551 | -- If the exporting package has been analyzed, it has appeared in the | |
4552 | -- context already and should be left alone. Otherwise, remove from | |
4553 | -- visibility. | |
4554 | ||
4555 | if not Analyzed (Unit_Declaration_Node (P)) then | |
4556 | Unchain (P); | |
4557 | Unchain (Typ); | |
4558 | Set_Is_Frozen (Typ, False); | |
4559 | end if; | |
4560 | ||
4561 | if Ekind (Typ) = E_Record_Type then | |
4562 | Set_From_With_Type (Class_Wide_Type (Typ), False); | |
4563 | Set_From_With_Type (Typ, False); | |
4564 | end if; | |
4565 | ||
4566 | Set_From_With_Type (P, False); | |
4567 | ||
a5b62485 | 4568 | -- If P is a child unit, remove parents as well |
996ae0b0 RK |
4569 | |
4570 | P := Scope (P); | |
4571 | ||
4572 | while Present (P) | |
4573 | and then P /= Standard_Standard | |
4574 | loop | |
4575 | Set_From_With_Type (P, False); | |
4576 | ||
4577 | if not Analyzed (Unit_Declaration_Node (P)) then | |
4578 | Unchain (P); | |
4579 | end if; | |
4580 | ||
4581 | P := Scope (P); | |
4582 | end loop; | |
4583 | ||
4584 | -- The back-end needs to know that an access type is imported, so it | |
4585 | -- does not need elaboration and can appear in a mutually recursive | |
4586 | -- record definition, so the imported flag on an access type is | |
4587 | -- preserved. | |
4588 | ||
4589 | end Remove_With_Type_Clause; | |
4590 | ||
4591 | --------------------------------- | |
4592 | -- Remove_Unit_From_Visibility -- | |
4593 | --------------------------------- | |
4594 | ||
4595 | procedure Remove_Unit_From_Visibility (Unit_Name : Entity_Id) is | |
fbf5a39b | 4596 | P : constant Entity_Id := Scope (Unit_Name); |
996ae0b0 RK |
4597 | |
4598 | begin | |
4599 | ||
4600 | if Debug_Flag_I then | |
657a9dd9 | 4601 | Write_Str ("remove unit "); |
996ae0b0 | 4602 | Write_Name (Chars (Unit_Name)); |
657a9dd9 | 4603 | Write_Str (" from visibility"); |
996ae0b0 RK |
4604 | Write_Eol; |
4605 | end if; | |
4606 | ||
4607 | if P /= Standard_Standard then | |
4608 | Set_Is_Visible_Child_Unit (Unit_Name, False); | |
4609 | end if; | |
4610 | ||
4611 | Set_Is_Potentially_Use_Visible (Unit_Name, False); | |
4612 | Set_Is_Immediately_Visible (Unit_Name, False); | |
4613 | ||
4614 | end Remove_Unit_From_Visibility; | |
4615 | ||
fbf5a39b AC |
4616 | ------------- |
4617 | -- Unchain -- | |
4618 | ------------- | |
4619 | ||
4620 | procedure Unchain (E : Entity_Id) is | |
4621 | Prev : Entity_Id; | |
4622 | ||
4623 | begin | |
4624 | Prev := Current_Entity (E); | |
4625 | ||
4626 | if No (Prev) then | |
4627 | return; | |
4628 | ||
4629 | elsif Prev = E then | |
4630 | Set_Name_Entity_Id (Chars (E), Homonym (E)); | |
4631 | ||
4632 | else | |
4633 | while Present (Prev) | |
4634 | and then Homonym (Prev) /= E | |
4635 | loop | |
4636 | Prev := Homonym (Prev); | |
4637 | end loop; | |
4638 | ||
4639 | if Present (Prev) then | |
4640 | Set_Homonym (Prev, Homonym (E)); | |
4641 | end if; | |
4642 | end if; | |
657a9dd9 AC |
4643 | |
4644 | if Debug_Flag_I then | |
4645 | Write_Str (" (homonym) unchain "); | |
4646 | Write_Name (Chars (E)); | |
4647 | Write_Eol; | |
4648 | end if; | |
4649 | ||
fbf5a39b | 4650 | end Unchain; |
996ae0b0 | 4651 | end Sem_Ch10; |