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