* config/mips/mips.c (function_arg): Where one part of a
[official-gcc.git] / gcc / ada / sem_ch10.adb
blob210a23c53116f8eb558f71957ea55a7471ccf96f
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- S E M _ C H 1 0 --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
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, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
21 -- --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 -- --
25 ------------------------------------------------------------------------------
27 with Atree; use Atree;
28 with Debug; use Debug;
29 with Einfo; use Einfo;
30 with Errout; use Errout;
31 with Exp_Util; use Exp_Util;
32 with Fname; use Fname;
33 with Fname.UF; use Fname.UF;
34 with Freeze; use Freeze;
35 with Impunit; use Impunit;
36 with Inline; use Inline;
37 with Lib; use Lib;
38 with Lib.Load; use Lib.Load;
39 with Lib.Xref; use Lib.Xref;
40 with Namet; use Namet;
41 with Nlists; use Nlists;
42 with Nmake; use Nmake;
43 with Opt; use Opt;
44 with Output; use Output;
45 with Restrict; use Restrict;
46 with Rtsfind; use Rtsfind;
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;
61 with Stylesw; use Stylesw;
62 with Tbuild; use Tbuild;
63 with Ttypes; use Ttypes;
64 with Uname; use Uname;
66 package body Sem_Ch10 is
68 -----------------------
69 -- Local Subprograms --
70 -----------------------
72 procedure Analyze_Context (N : Node_Id);
73 -- Analyzes items in the context clause of compilation unit
75 procedure Build_Limited_Views (N : Node_Id);
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.
80 -- Implements Ada 2005 (AI-50217).
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.
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.
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).
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.
98 procedure Expand_With_Clause (Item : Node_Id; Nam : Node_Id; N : Node_Id);
99 -- When a child unit appears in a context clause, the implicit withs on
100 -- parents are made explicit, and with clauses are inserted in the context
101 -- clause before the one for the child. If a parent in the with_clause
102 -- is a renaming, the implicit with_clause is on the renaming whose name
103 -- is mentioned in the with_clause, and not on the package it renames.
104 -- N is the compilation unit whose list of context items receives the
105 -- implicit with_clauses.
107 function Get_Parent_Entity (Unit : Node_Id) return Entity_Id;
108 -- Get defining entity of parent unit of a child unit. In most cases this
109 -- is the defining entity of the unit, but for a child instance whose
110 -- parent needs a body for inlining, the instantiation node of the parent
111 -- has not yet been rewritten as a package declaration, and the entity has
112 -- to be retrieved from the Instance_Spec of the unit.
114 procedure Implicit_With_On_Parent (Child_Unit : Node_Id; N : Node_Id);
115 -- If the main unit is a child unit, implicit withs are also added for
116 -- all its ancestors.
118 function In_Chain (E : Entity_Id) return Boolean;
119 -- Check that the shadow entity is not already in the homonym chain, for
120 -- example through a limited_with clause in a parent unit.
122 procedure Install_Context_Clauses (N : Node_Id);
123 -- Subsidiary to Install_Context and Install_Parents. Process only with_
124 -- and use_clauses for current unit and its library unit if any.
126 procedure Install_Limited_Context_Clauses (N : Node_Id);
127 -- Subsidiary to Install_Context. Process only limited with_clauses
128 -- for current unit. Implements Ada 2005 (AI-50217).
130 procedure Install_Limited_Withed_Unit (N : Node_Id);
131 -- Place shadow entities for a limited_with package in the visibility
132 -- structures for the current compilation. Implements Ada 2005 (AI-50217).
134 procedure Install_Withed_Unit
135 (With_Clause : Node_Id;
136 Private_With_OK : Boolean := False);
137 -- If the unit is not a child unit, make unit immediately visible.
138 -- The caller ensures that the unit is not already currently installed.
139 -- The flag Private_With_OK is set true in Install_Private_With_Clauses,
140 -- which is called when compiling the private part of a package, or
141 -- installing the private declarations of a parent unit.
143 procedure Install_Parents (Lib_Unit : Node_Id; Is_Private : Boolean);
144 -- This procedure establishes the context for the compilation of a child
145 -- unit. If Lib_Unit is a child library spec then the context of the parent
146 -- is installed, and the parent itself made immediately visible, so that
147 -- the child unit is processed in the declarative region of the parent.
148 -- Install_Parents makes a recursive call to itself to ensure that all
149 -- parents are loaded in the nested case. If Lib_Unit is a library body,
150 -- the only effect of Install_Parents is to install the private decls of
151 -- the parents, because the visible parent declarations will have been
152 -- installed as part of the context of the corresponding spec.
154 procedure Install_Siblings (U_Name : Entity_Id; N : Node_Id);
155 -- In the compilation of a child unit, a child of any of the ancestor
156 -- units is directly visible if it is visible, because the parent is in
157 -- an enclosing scope. Iterate over context to find child units of U_Name
158 -- or of some ancestor of it.
160 function Is_Child_Spec (Lib_Unit : Node_Id) return Boolean;
161 -- Lib_Unit is a library unit which may be a spec or a body. Is_Child_Spec
162 -- returns True if Lib_Unit is a library spec which is a child spec, i.e.
163 -- a library spec that has a parent. If the call to Is_Child_Spec returns
164 -- True, then Parent_Spec (Lib_Unit) is non-Empty and points to the
165 -- compilation unit for the parent spec.
167 -- Lib_Unit can also be a subprogram body that acts as its own spec. If
168 -- the Parent_Spec is non-empty, this is also a child unit.
170 procedure Remove_With_Type_Clause (Name : Node_Id);
171 -- Remove imported type and its enclosing package from visibility, and
172 -- remove attributes of imported type so they don't interfere with its
173 -- analysis (should it appear otherwise in the context).
175 procedure Remove_Context_Clauses (N : Node_Id);
176 -- Subsidiary of previous one. Remove use_ and with_clauses
178 procedure Remove_Limited_With_Clause (N : Node_Id);
179 -- Remove from visibility the shadow entities introduced for a package
180 -- mentioned in a limited_with clause. Implements Ada 2005 (AI-50217).
182 procedure Remove_Parents (Lib_Unit : Node_Id);
183 -- Remove_Parents checks if Lib_Unit is a child spec. If so then the parent
184 -- contexts established by the corresponding call to Install_Parents are
185 -- removed. Remove_Parents contains a recursive call to itself to ensure
186 -- that all parents are removed in the nested case.
188 procedure Remove_Unit_From_Visibility (Unit_Name : Entity_Id);
189 -- Reset all visibility flags on unit after compiling it, either as a
190 -- main unit or as a unit in the context.
192 procedure Unchain (E : Entity_Id);
193 -- Remove single entity from visibility list
195 procedure Analyze_Proper_Body (N : Node_Id; Nam : Entity_Id);
196 -- Common processing for all stubs (subprograms, tasks, packages, and
197 -- protected cases). N is the stub to be analyzed. Once the subunit
198 -- name is established, load and analyze. Nam is the non-overloadable
199 -- entity for which the proper body provides a completion. Subprogram
200 -- stubs are handled differently because they can be declarations.
202 --------------------------
203 -- Limited_With_Clauses --
204 --------------------------
206 -- Limited_With clauses are the mechanism chosen for Ada05 to support
207 -- mutually recursive types declared in different units. A limited_with
208 -- clause that names package P in the context of unit U makes the types
209 -- declared in the visible part of P available within U, but with the
210 -- restriction that these types can only be used as incomplete types.
211 -- The limited_with clause does not impose a semantic dependence on P,
212 -- and it is possible for two packages to have limited_with_clauses on
213 -- each other without creating an elaboration circularity.
215 -- To support this feature, the analysis of a limited_with clause must
216 -- create an abbreviated view of the package, without performing any
217 -- semantic analysis on it. This "package abstract" contains shadow
218 -- types that are in one-one correspondence with the real types in the
219 -- package, and that have the properties of incomplete types.
221 -- The implementation creates two element lists: one to chain the shadow
222 -- entities, and one to chain the corresponding type entities in the tree
223 -- of the package. Links between corresponding entities in both chains
224 -- allow the compiler to select the proper view of a given type, depending
225 -- on the context. Note that in contrast with the handling of private
226 -- types, the limited view and the non-limited view of a type are treated
227 -- as separate entities, and no entity exchange needs to take place, which
228 -- makes the implementation must simpler than could be feared.
230 ------------------------------
231 -- Analyze_Compilation_Unit --
232 ------------------------------
234 procedure Analyze_Compilation_Unit (N : Node_Id) is
235 Unit_Node : constant Node_Id := Unit (N);
236 Lib_Unit : Node_Id := Library_Unit (N);
237 Spec_Id : Node_Id;
238 Main_Cunit : constant Node_Id := Cunit (Main_Unit);
239 Par_Spec_Name : Unit_Name_Type;
240 Unum : Unit_Number_Type;
242 procedure Check_Redundant_Withs
243 (Context_Items : List_Id;
244 Spec_Context_Items : List_Id := No_List);
245 -- Determine whether the context list of a compilation unit contains
246 -- redundant with clauses. When checking body clauses against spec
247 -- clauses, set Context_Items to the context list of the body and
248 -- Spec_Context_Items to that of the spec. Parent packages are not
249 -- examined for documentation purposes.
251 procedure Generate_Parent_References (N : Node_Id; P_Id : Entity_Id);
252 -- Generate cross-reference information for the parents of child units.
253 -- N is a defining_program_unit_name, and P_Id is the immediate parent.
255 ---------------------------
256 -- Check_Redundant_Withs --
257 ---------------------------
259 procedure Check_Redundant_Withs
260 (Context_Items : List_Id;
261 Spec_Context_Items : List_Id := No_List)
263 Clause : Node_Id;
265 procedure Process_Body_Clauses
266 (Context_List : List_Id;
267 Clause : Node_Id;
268 Used : in out Boolean;
269 Used_Type_Or_Elab : in out Boolean);
270 -- Examine the context clauses of a package body, trying to match
271 -- the name entity of Clause with any list element. If the match
272 -- occurs on a use package clause, set Used to True, for a use
273 -- type clause, pragma Elaborate or pragma Elaborate_All, set
274 -- Used_Type_Or_Elab to True.
276 procedure Process_Spec_Clauses
277 (Context_List : List_Id;
278 Clause : Node_Id;
279 Used : in out Boolean;
280 Withed : in out Boolean;
281 Exit_On_Self : Boolean := False);
282 -- Examine the context clauses of a package spec, trying to match
283 -- the name entity of Clause with any list element. If the match
284 -- occurs on a use package clause, set Used to True, for a with
285 -- package clause other than Clause, set Withed to True. Limited
286 -- with clauses, implicitly generated with clauses and withs
287 -- having pragmas Elaborate or Elaborate_All applied to them are
288 -- skipped. Exit_On_Self is used to control the search loop and
289 -- force an exit whenever Clause sees itself in the search.
291 --------------------------
292 -- Process_Body_Clauses --
293 --------------------------
295 procedure Process_Body_Clauses
296 (Context_List : List_Id;
297 Clause : Node_Id;
298 Used : in out Boolean;
299 Used_Type_Or_Elab : in out Boolean)
301 Nam_Ent : constant Entity_Id := Entity (Name (Clause));
302 Cont_Item : Node_Id;
303 Prag_Unit : Node_Id;
304 Subt_Mark : Node_Id;
305 Use_Item : Node_Id;
307 begin
308 Used := False;
309 Used_Type_Or_Elab := False;
311 Cont_Item := First (Context_List);
312 while Present (Cont_Item) loop
314 -- Package use clause
316 if Nkind (Cont_Item) = N_Use_Package_Clause
317 and then not Used
318 then
319 Use_Item := First (Names (Cont_Item));
320 while Present (Use_Item) and then not Used loop
321 if Entity (Use_Item) = Nam_Ent then
322 Used := True;
323 end if;
325 Next (Use_Item);
326 end loop;
328 -- Type use clause
330 elsif Nkind (Cont_Item) = N_Use_Type_Clause
331 and then not Used_Type_Or_Elab
332 then
333 Subt_Mark := First (Subtype_Marks (Cont_Item));
334 while Present (Subt_Mark)
335 and then not Used_Type_Or_Elab
336 loop
337 if Entity (Prefix (Subt_Mark)) = Nam_Ent then
338 Used_Type_Or_Elab := True;
339 end if;
341 Next (Subt_Mark);
342 end loop;
344 -- Pragma Elaborate or Elaborate_All
346 elsif Nkind (Cont_Item) = N_Pragma
347 and then
348 (Chars (Cont_Item) = Name_Elaborate
349 or else
350 Chars (Cont_Item) = Name_Elaborate_All)
351 and then not Used_Type_Or_Elab
352 then
353 Prag_Unit :=
354 First (Pragma_Argument_Associations (Cont_Item));
355 while Present (Prag_Unit)
356 and then not Used_Type_Or_Elab
357 loop
358 if Entity (Expression (Prag_Unit)) = Nam_Ent then
359 Used_Type_Or_Elab := True;
360 end if;
362 Next (Prag_Unit);
363 end loop;
364 end if;
366 Next (Cont_Item);
367 end loop;
368 end Process_Body_Clauses;
370 --------------------------
371 -- Process_Spec_Clauses --
372 --------------------------
374 procedure Process_Spec_Clauses
375 (Context_List : List_Id;
376 Clause : Node_Id;
377 Used : in out Boolean;
378 Withed : in out Boolean;
379 Exit_On_Self : Boolean := False)
381 Nam_Ent : constant Entity_Id := Entity (Name (Clause));
382 Cont_Item : Node_Id;
383 Use_Item : Node_Id;
385 begin
386 Used := False;
387 Withed := False;
389 Cont_Item := First (Context_List);
390 while Present (Cont_Item) loop
392 -- Stop the search since the context items after Cont_Item
393 -- have already been examined in a previous iteration of
394 -- the reverse loop in Check_Redundant_Withs.
396 if Exit_On_Self
397 and Cont_Item = Clause
398 then
399 exit;
400 end if;
402 -- Package use clause
404 if Nkind (Cont_Item) = N_Use_Package_Clause
405 and then not Used
406 then
407 Use_Item := First (Names (Cont_Item));
408 while Present (Use_Item) and then not Used loop
409 if Entity (Use_Item) = Nam_Ent then
410 Used := True;
411 end if;
413 Next (Use_Item);
414 end loop;
416 -- Package with clause. Avoid processing self, implicitly
417 -- generated with clauses or limited with clauses. Note
418 -- that we examine with clauses having pragmas Elaborate
419 -- or Elaborate_All applied to them due to cases such as:
421 -- with Pack;
422 -- with Pack;
423 -- pragma Elaborate (Pack);
425 -- In this case, the second with clause is redundant since
426 -- the pragma applies only to the first "with Pack;".
428 elsif Nkind (Cont_Item) = N_With_Clause
429 and then not Implicit_With (Cont_Item)
430 and then not Limited_Present (Cont_Item)
431 and then Cont_Item /= Clause
432 and then Entity (Name (Cont_Item)) = Nam_Ent
433 then
434 Withed := True;
435 end if;
437 Next (Cont_Item);
438 end loop;
439 end Process_Spec_Clauses;
441 -- Start of processing for Check_Redundant_Withs
443 begin
444 Clause := Last (Context_Items);
445 while Present (Clause) loop
447 -- Avoid checking implicitly generated with clauses, limited
448 -- with clauses or withs that have pragma Elaborate or
449 -- Elaborate_All apllied.
451 if Nkind (Clause) = N_With_Clause
452 and then not Implicit_With (Clause)
453 and then not Limited_Present (Clause)
454 and then not Elaborate_Present (Clause)
455 then
456 -- Package body-to-spec check
458 if Present (Spec_Context_Items) then
459 declare
460 Used_In_Body : Boolean := False;
461 Used_In_Spec : Boolean := False;
462 Used_Type_Or_Elab : Boolean := False;
463 Withed_In_Spec : Boolean := False;
465 begin
466 Process_Spec_Clauses
467 (Context_List => Spec_Context_Items,
468 Clause => Clause,
469 Used => Used_In_Spec,
470 Withed => Withed_In_Spec);
472 Process_Body_Clauses
473 (Context_List => Context_Items,
474 Clause => Clause,
475 Used => Used_In_Body,
476 Used_Type_Or_Elab => Used_Type_Or_Elab);
478 -- "Type Elab" refers to the presence of either a use
479 -- type clause, pragmas Elaborate or Elaborate_All.
481 -- +---------------+---------------------------+------+
482 -- | Spec | Body | Warn |
483 -- +--------+------+--------+------+-----------+------+
484 -- | Withed | Used | Withed | Used | Type Elab | |
485 -- | X | | X | | | X |
486 -- | X | | X | X | | |
487 -- | X | | X | | X | |
488 -- | X | | X | X | X | |
489 -- | X | X | X | | | X |
490 -- | X | X | X | | X | |
491 -- | X | X | X | X | | X |
492 -- | X | X | X | X | X | |
493 -- +--------+------+--------+------+-----------+------+
495 if (Withed_In_Spec
496 and then not Used_Type_Or_Elab)
497 and then
498 ((not Used_In_Spec
499 and then not Used_In_Body)
500 or else
501 Used_In_Spec)
502 then
503 Error_Msg_N ("?redundant with clause in body", Clause);
504 end if;
506 Used_In_Body := False;
507 Used_In_Spec := False;
508 Used_Type_Or_Elab := False;
509 Withed_In_Spec := False;
510 end;
512 -- Standalone package spec or body check
514 else
515 declare
516 Dont_Care : Boolean := False;
517 Withed : Boolean := False;
519 begin
520 -- The mechanism for examining the context clauses of a
521 -- package spec can be applied to package body clauses.
523 Process_Spec_Clauses
524 (Context_List => Context_Items,
525 Clause => Clause,
526 Used => Dont_Care,
527 Withed => Withed,
528 Exit_On_Self => True);
530 if Withed then
531 Error_Msg_N ("?redundant with clause", Clause);
532 end if;
533 end;
534 end if;
535 end if;
537 Prev (Clause);
538 end loop;
539 end Check_Redundant_Withs;
541 --------------------------------
542 -- Generate_Parent_References --
543 --------------------------------
545 procedure Generate_Parent_References (N : Node_Id; P_Id : Entity_Id) is
546 Pref : Node_Id;
547 P_Name : Entity_Id := P_Id;
549 begin
550 Pref := Name (Parent (Defining_Entity (N)));
552 if Nkind (Pref) = N_Expanded_Name then
554 -- Done already, if the unit has been compiled indirectly as
555 -- part of the closure of its context because of inlining.
557 return;
558 end if;
560 while Nkind (Pref) = N_Selected_Component loop
561 Change_Selected_Component_To_Expanded_Name (Pref);
562 Set_Entity (Pref, P_Name);
563 Set_Etype (Pref, Etype (P_Name));
564 Generate_Reference (P_Name, Pref, 'r');
565 Pref := Prefix (Pref);
566 P_Name := Scope (P_Name);
567 end loop;
569 -- The guard here on P_Name is to handle the error condition where
570 -- the parent unit is missing because the file was not found.
572 if Present (P_Name) then
573 Set_Entity (Pref, P_Name);
574 Set_Etype (Pref, Etype (P_Name));
575 Generate_Reference (P_Name, Pref, 'r');
576 Style.Check_Identifier (Pref, P_Name);
577 end if;
578 end Generate_Parent_References;
580 -- Start of processing for Analyze_Compilation_Unit
582 begin
583 Process_Compilation_Unit_Pragmas (N);
585 -- If the unit is a subunit whose parent has not been analyzed (which
586 -- indicates that the main unit is a subunit, either the current one or
587 -- one of its descendents) then the subunit is compiled as part of the
588 -- analysis of the parent, which we proceed to do. Basically this gets
589 -- handled from the top down and we don't want to do anything at this
590 -- level (i.e. this subunit will be handled on the way down from the
591 -- parent), so at this level we immediately return. If the subunit
592 -- ends up not analyzed, it means that the parent did not contain a
593 -- stub for it, or that there errors were dectected in some ancestor.
595 if Nkind (Unit_Node) = N_Subunit
596 and then not Analyzed (Lib_Unit)
597 then
598 Semantics (Lib_Unit);
600 if not Analyzed (Proper_Body (Unit_Node)) then
601 if Serious_Errors_Detected > 0 then
602 Error_Msg_N ("subunit not analyzed (errors in parent unit)", N);
603 else
604 Error_Msg_N ("missing stub for subunit", N);
605 end if;
606 end if;
608 return;
609 end if;
611 -- Analyze context (this will call Sem recursively for with'ed units)
613 Analyze_Context (N);
615 -- If the unit is a package body, the spec is already loaded and must
616 -- be analyzed first, before we analyze the body.
618 if Nkind (Unit_Node) = N_Package_Body then
620 -- If no Lib_Unit, then there was a serious previous error, so
621 -- just ignore the entire analysis effort
623 if No (Lib_Unit) then
624 return;
626 else
627 Semantics (Lib_Unit);
628 Check_Unused_Withs (Get_Cunit_Unit_Number (Lib_Unit));
630 -- Verify that the library unit is a package declaration
632 if Nkind (Unit (Lib_Unit)) /= N_Package_Declaration
633 and then
634 Nkind (Unit (Lib_Unit)) /= N_Generic_Package_Declaration
635 then
636 Error_Msg_N
637 ("no legal package declaration for package body", N);
638 return;
640 -- Otherwise, the entity in the declaration is visible. Update
641 -- the version to reflect dependence of this body on the spec.
643 else
644 Spec_Id := Defining_Entity (Unit (Lib_Unit));
645 Set_Is_Immediately_Visible (Spec_Id, True);
646 Version_Update (N, Lib_Unit);
648 if Nkind (Defining_Unit_Name (Unit_Node))
649 = N_Defining_Program_Unit_Name
650 then
651 Generate_Parent_References (Unit_Node, Scope (Spec_Id));
652 end if;
653 end if;
654 end if;
656 -- If the unit is a subprogram body, then we similarly need to analyze
657 -- its spec. However, things are a little simpler in this case, because
658 -- here, this analysis is done only for error checking and consistency
659 -- purposes, so there's nothing else to be done.
661 elsif Nkind (Unit_Node) = N_Subprogram_Body then
662 if Acts_As_Spec (N) then
664 -- If the subprogram body is a child unit, we must create a
665 -- declaration for it, in order to properly load the parent(s).
666 -- After this, the original unit does not acts as a spec, because
667 -- there is an explicit one. If this unit appears in a context
668 -- clause, then an implicit with on the parent will be added when
669 -- installing the context. If this is the main unit, there is no
670 -- Unit_Table entry for the declaration, (It has the unit number
671 -- of the main unit) and code generation is unaffected.
673 Unum := Get_Cunit_Unit_Number (N);
674 Par_Spec_Name := Get_Parent_Spec_Name (Unit_Name (Unum));
676 if Par_Spec_Name /= No_Name then
677 Unum :=
678 Load_Unit
679 (Load_Name => Par_Spec_Name,
680 Required => True,
681 Subunit => False,
682 Error_Node => N);
684 if Unum /= No_Unit then
686 -- Build subprogram declaration and attach parent unit to it
687 -- This subprogram declaration does not come from source,
688 -- Nevertheless the backend must generate debugging info for
689 -- it, and this must be indicated explicitly.
691 declare
692 Loc : constant Source_Ptr := Sloc (N);
693 SCS : constant Boolean :=
694 Get_Comes_From_Source_Default;
696 begin
697 Set_Comes_From_Source_Default (False);
698 Lib_Unit :=
699 Make_Compilation_Unit (Loc,
700 Context_Items => New_Copy_List (Context_Items (N)),
701 Unit =>
702 Make_Subprogram_Declaration (Sloc (N),
703 Specification =>
704 Copy_Separate_Tree
705 (Specification (Unit_Node))),
706 Aux_Decls_Node =>
707 Make_Compilation_Unit_Aux (Loc));
709 Set_Library_Unit (N, Lib_Unit);
710 Set_Parent_Spec (Unit (Lib_Unit), Cunit (Unum));
711 Semantics (Lib_Unit);
712 Set_Acts_As_Spec (N, False);
713 Set_Needs_Debug_Info (Defining_Entity (Unit (Lib_Unit)));
714 Set_Comes_From_Source_Default (SCS);
715 end;
716 end if;
717 end if;
719 -- Here for subprogram with separate declaration
721 else
722 Semantics (Lib_Unit);
723 Check_Unused_Withs (Get_Cunit_Unit_Number (Lib_Unit));
724 Version_Update (N, Lib_Unit);
725 end if;
727 if Nkind (Defining_Unit_Name (Specification (Unit_Node))) =
728 N_Defining_Program_Unit_Name
729 then
730 Generate_Parent_References (
731 Specification (Unit_Node),
732 Scope (Defining_Entity (Unit (Lib_Unit))));
733 end if;
734 end if;
736 -- If it is a child unit, the parent must be elaborated first
737 -- and we update version, since we are dependent on our parent.
739 if Is_Child_Spec (Unit_Node) then
741 -- The analysis of the parent is done with style checks off
743 declare
744 Save_Style_Check : constant Boolean := Style_Check;
745 Save_C_Restrict : constant Save_Cunit_Boolean_Restrictions :=
746 Cunit_Boolean_Restrictions_Save;
748 begin
749 if not GNAT_Mode then
750 Style_Check := False;
751 end if;
753 Semantics (Parent_Spec (Unit_Node));
754 Version_Update (N, Parent_Spec (Unit_Node));
755 Style_Check := Save_Style_Check;
756 Cunit_Boolean_Restrictions_Restore (Save_C_Restrict);
757 end;
758 end if;
760 -- With the analysis done, install the context. Note that we can't
761 -- install the context from the with clauses as we analyze them,
762 -- because each with clause must be analyzed in a clean visibility
763 -- context, so we have to wait and install them all at once.
765 Install_Context (N);
767 if Is_Child_Spec (Unit_Node) then
769 -- Set the entities of all parents in the program_unit_name
771 Generate_Parent_References (
772 Unit_Node, Get_Parent_Entity (Unit (Parent_Spec (Unit_Node))));
773 end if;
775 -- All components of the context: with-clauses, library unit, ancestors
776 -- if any, (and their context) are analyzed and installed. Now analyze
777 -- the unit itself, which is either a package, subprogram spec or body.
779 Analyze (Unit_Node);
781 if Warn_On_Redundant_Constructs then
782 Check_Redundant_Withs (Context_Items (N));
784 if Nkind (Unit_Node) = N_Package_Body then
785 Check_Redundant_Withs
786 (Context_Items => Context_Items (N),
787 Spec_Context_Items => Context_Items (Lib_Unit));
788 end if;
789 end if;
791 -- The above call might have made Unit_Node an N_Subprogram_Body
792 -- from something else, so propagate any Acts_As_Spec flag.
794 if Nkind (Unit_Node) = N_Subprogram_Body
795 and then Acts_As_Spec (Unit_Node)
796 then
797 Set_Acts_As_Spec (N);
798 end if;
800 -- Register predefined units in Rtsfind
802 declare
803 Unum : constant Unit_Number_Type := Get_Source_Unit (Sloc (N));
804 begin
805 if Is_Predefined_File_Name (Unit_File_Name (Unum)) then
806 Set_RTU_Loaded (Unit_Node);
807 end if;
808 end;
810 -- Treat compilation unit pragmas that appear after the library unit
812 if Present (Pragmas_After (Aux_Decls_Node (N))) then
813 declare
814 Prag_Node : Node_Id := First (Pragmas_After (Aux_Decls_Node (N)));
816 begin
817 while Present (Prag_Node) loop
818 Analyze (Prag_Node);
819 Next (Prag_Node);
820 end loop;
821 end;
822 end if;
824 -- Generate distribution stubs if requested and no error
826 if N = Main_Cunit
827 and then (Distribution_Stub_Mode = Generate_Receiver_Stub_Body
828 or else
829 Distribution_Stub_Mode = Generate_Caller_Stub_Body)
830 and then not Fatal_Error (Main_Unit)
831 then
832 if Is_RCI_Pkg_Spec_Or_Body (N) then
834 -- Regular RCI package
836 Add_Stub_Constructs (N);
838 elsif (Nkind (Unit_Node) = N_Package_Declaration
839 and then Is_Shared_Passive (Defining_Entity
840 (Specification (Unit_Node))))
841 or else (Nkind (Unit_Node) = N_Package_Body
842 and then
843 Is_Shared_Passive (Corresponding_Spec (Unit_Node)))
844 then
845 -- Shared passive package
847 Add_Stub_Constructs (N);
849 elsif Nkind (Unit_Node) = N_Package_Instantiation
850 and then
851 Is_Remote_Call_Interface
852 (Defining_Entity (Specification (Instance_Spec (Unit_Node))))
853 then
854 -- Instantiation of a RCI generic package
856 Add_Stub_Constructs (N);
857 end if;
859 end if;
861 if Nkind (Unit_Node) = N_Package_Declaration
862 or else Nkind (Unit_Node) in N_Generic_Declaration
863 or else Nkind (Unit_Node) = N_Package_Renaming_Declaration
864 or else Nkind (Unit_Node) = N_Subprogram_Declaration
865 then
866 Remove_Unit_From_Visibility (Defining_Entity (Unit_Node));
868 -- If the unit is an instantiation whose body will be elaborated
869 -- for inlining purposes, use the the proper entity of the instance.
871 elsif Nkind (Unit_Node) = N_Package_Instantiation
872 and then not Error_Posted (Unit_Node)
873 then
874 Remove_Unit_From_Visibility
875 (Defining_Entity (Instance_Spec (Unit_Node)));
877 elsif Nkind (Unit_Node) = N_Package_Body
878 or else (Nkind (Unit_Node) = N_Subprogram_Body
879 and then not Acts_As_Spec (Unit_Node))
880 then
881 -- Bodies that are not the main unit are compiled if they
882 -- are generic or contain generic or inlined units. Their
883 -- analysis brings in the context of the corresponding spec
884 -- (unit declaration) which must be removed as well, to
885 -- return the compilation environment to its proper state.
887 Remove_Context (Lib_Unit);
888 Set_Is_Immediately_Visible (Defining_Entity (Unit (Lib_Unit)), False);
889 end if;
891 -- Last step is to deinstall the context we just installed
892 -- as well as the unit just compiled.
894 Remove_Context (N);
896 -- If this is the main unit and we are generating code, we must
897 -- check that all generic units in the context have a body if they
898 -- need it, even if they have not been instantiated. In the absence
899 -- of .ali files for generic units, we must force the load of the body,
900 -- just to produce the proper error if the body is absent. We skip this
901 -- verification if the main unit itself is generic.
903 if Get_Cunit_Unit_Number (N) = Main_Unit
904 and then Operating_Mode = Generate_Code
905 and then Expander_Active
906 then
907 -- Check whether the source for the body of the unit must be
908 -- included in a standalone library.
910 Check_Body_Needed_For_SAL (Cunit_Entity (Main_Unit));
912 -- Indicate that the main unit is now analyzed, to catch possible
913 -- circularities between it and generic bodies. Remove main unit
914 -- from visibility. This might seem superfluous, but the main unit
915 -- must not be visible in the generic body expansions that follow.
917 Set_Analyzed (N, True);
918 Set_Is_Immediately_Visible (Cunit_Entity (Main_Unit), False);
920 declare
921 Item : Node_Id;
922 Nam : Entity_Id;
923 Un : Unit_Number_Type;
925 Save_Style_Check : constant Boolean := Style_Check;
926 Save_C_Restrict : constant Save_Cunit_Boolean_Restrictions :=
927 Cunit_Boolean_Restrictions_Save;
929 begin
930 Item := First (Context_Items (N));
931 while Present (Item) loop
933 -- Ada 2005 (AI-50217): Do not consider limited-withed units
935 if Nkind (Item) = N_With_Clause
936 and then not Implicit_With (Item)
937 and then not Limited_Present (Item)
938 then
939 Nam := Entity (Name (Item));
941 if (Is_Generic_Subprogram (Nam)
942 and then not Is_Intrinsic_Subprogram (Nam))
943 or else (Ekind (Nam) = E_Generic_Package
944 and then Unit_Requires_Body (Nam))
945 then
946 Style_Check := False;
948 if Present (Renamed_Object (Nam)) then
949 Un :=
950 Load_Unit
951 (Load_Name => Get_Body_Name
952 (Get_Unit_Name
953 (Unit_Declaration_Node
954 (Renamed_Object (Nam)))),
955 Required => False,
956 Subunit => False,
957 Error_Node => N,
958 Renamings => True);
959 else
960 Un :=
961 Load_Unit
962 (Load_Name => Get_Body_Name
963 (Get_Unit_Name (Item)),
964 Required => False,
965 Subunit => False,
966 Error_Node => N,
967 Renamings => True);
968 end if;
970 if Un = No_Unit then
971 Error_Msg_NE
972 ("body of generic unit& not found", Item, Nam);
973 exit;
975 elsif not Analyzed (Cunit (Un))
976 and then Un /= Main_Unit
977 and then not Fatal_Error (Un)
978 then
979 Style_Check := False;
980 Semantics (Cunit (Un));
981 end if;
982 end if;
983 end if;
985 Next (Item);
986 end loop;
988 Style_Check := Save_Style_Check;
989 Cunit_Boolean_Restrictions_Restore (Save_C_Restrict);
990 end;
991 end if;
993 -- Deal with creating elaboration Boolean if needed. We create an
994 -- elaboration boolean only for units that come from source since
995 -- units manufactured by the compiler never need elab checks.
997 if Comes_From_Source (N)
998 and then
999 (Nkind (Unit (N)) = N_Package_Declaration or else
1000 Nkind (Unit (N)) = N_Generic_Package_Declaration or else
1001 Nkind (Unit (N)) = N_Subprogram_Declaration or else
1002 Nkind (Unit (N)) = N_Generic_Subprogram_Declaration)
1003 then
1004 declare
1005 Loc : constant Source_Ptr := Sloc (N);
1006 Unum : constant Unit_Number_Type := Get_Source_Unit (Loc);
1008 begin
1009 Spec_Id := Defining_Entity (Unit (N));
1010 Generate_Definition (Spec_Id);
1012 -- See if an elaboration entity is required for possible
1013 -- access before elaboration checking. Note that we must
1014 -- allow for this even if -gnatE is not set, since a client
1015 -- may be compiled in -gnatE mode and reference the entity.
1017 -- Case of units which do not require elaboration checks
1020 -- Pure units do not need checks
1022 Is_Pure (Spec_Id)
1024 -- Preelaborated units do not need checks
1026 or else Is_Preelaborated (Spec_Id)
1028 -- No checks needed if pagma Elaborate_Body present
1030 or else Has_Pragma_Elaborate_Body (Spec_Id)
1032 -- No checks needed if unit does not require a body
1034 or else not Unit_Requires_Body (Spec_Id)
1036 -- No checks needed for predefined files
1038 or else Is_Predefined_File_Name (Unit_File_Name (Unum))
1040 -- No checks required if no separate spec
1042 or else Acts_As_Spec (N)
1043 then
1044 -- This is a case where we only need the entity for
1045 -- checking to prevent multiple elaboration checks.
1047 Set_Elaboration_Entity_Required (Spec_Id, False);
1049 -- Case of elaboration entity is required for access before
1050 -- elaboration checking (so certainly we must build it!)
1052 else
1053 Set_Elaboration_Entity_Required (Spec_Id, True);
1054 end if;
1056 Build_Elaboration_Entity (N, Spec_Id);
1057 end;
1058 end if;
1060 -- Finally, freeze the compilation unit entity. This for sure is needed
1061 -- because of some warnings that can be output (see Freeze_Subprogram),
1062 -- but may in general be required. If freezing actions result, place
1063 -- them in the compilation unit actions list, and analyze them.
1065 declare
1066 Loc : constant Source_Ptr := Sloc (N);
1067 L : constant List_Id :=
1068 Freeze_Entity (Cunit_Entity (Current_Sem_Unit), Loc);
1070 begin
1071 while Is_Non_Empty_List (L) loop
1072 Insert_Library_Level_Action (Remove_Head (L));
1073 end loop;
1074 end;
1076 Set_Analyzed (N);
1078 if Nkind (Unit_Node) = N_Package_Declaration
1079 and then Get_Cunit_Unit_Number (N) /= Main_Unit
1080 and then Expander_Active
1081 then
1082 declare
1083 Save_Style_Check : constant Boolean := Style_Check;
1084 Save_Warning : constant Warning_Mode_Type := Warning_Mode;
1085 Options : Style_Check_Options;
1087 begin
1088 Save_Style_Check_Options (Options);
1089 Reset_Style_Check_Options;
1090 Opt.Warning_Mode := Suppress;
1091 Check_Body_For_Inlining (N, Defining_Entity (Unit_Node));
1093 Reset_Style_Check_Options;
1094 Set_Style_Check_Options (Options);
1095 Style_Check := Save_Style_Check;
1096 Warning_Mode := Save_Warning;
1097 end;
1098 end if;
1099 end Analyze_Compilation_Unit;
1101 ---------------------
1102 -- Analyze_Context --
1103 ---------------------
1105 procedure Analyze_Context (N : Node_Id) is
1106 Ukind : constant Node_Kind := Nkind (Unit (N));
1107 Item : Node_Id;
1109 begin
1110 -- First process all configuration pragmas at the start of the context
1111 -- items. Strictly these are not part of the context clause, but that
1112 -- is where the parser puts them. In any case for sure we must analyze
1113 -- these before analyzing the actual context items, since they can have
1114 -- an effect on that analysis (e.g. pragma Ada_2005 may allow a unit to
1115 -- be with'ed as a result of changing categorizations in Ada 2005).
1117 Item := First (Context_Items (N));
1118 while Present (Item)
1119 and then Nkind (Item) = N_Pragma
1120 and then Chars (Item) in Configuration_Pragma_Names
1121 loop
1122 Analyze (Item);
1123 Next (Item);
1124 end loop;
1126 -- Loop through actual context items. This is done in two passes:
1128 -- a) The first pass analyzes non-limited with-clauses and also any
1129 -- configuration pragmas (we need to get the latter analyzed right
1130 -- away, since they can affect processing of subsequent items.
1132 -- b) The second pass analyzes limited_with clauses (Ada 2005: AI-50217)
1134 while Present (Item) loop
1136 -- For with clause, analyze the with clause, and then update
1137 -- the version, since we are dependent on a unit that we with.
1139 if Nkind (Item) = N_With_Clause
1140 and then not Limited_Present (Item)
1141 then
1142 -- Skip analyzing with clause if no unit, nothing to do (this
1143 -- happens for a with that references a non-existant unit)
1145 if Present (Library_Unit (Item)) then
1146 Analyze (Item);
1147 end if;
1149 if not Implicit_With (Item) then
1150 Version_Update (N, Library_Unit (Item));
1151 end if;
1153 -- Skip pragmas. Configuration pragmas at the start were handled in
1154 -- the loop above, and remaining pragmas are not processed until we
1155 -- actually install the context (see Install_Context). We delay the
1156 -- analysis of these pragmas to make sure that we have installed all
1157 -- the implicit with's on parent units.
1159 -- Skip use clauses at this stage, since we don't want to do any
1160 -- installing of potentially use visible entities until we we
1161 -- actually install the complete context (in Install_Context).
1162 -- Otherwise things can get installed in the wrong context.
1164 else
1165 null;
1166 end if;
1168 Next (Item);
1169 end loop;
1171 -- Second pass: examine all limited_with clauses. All other context
1172 -- items are ignored in this pass.
1174 Item := First (Context_Items (N));
1175 while Present (Item) loop
1176 if Nkind (Item) = N_With_Clause
1177 and then Limited_Present (Item)
1178 then
1179 -- No need to check errors on implicitly generated limited-with
1180 -- clauses.
1182 if not Implicit_With (Item) then
1184 -- Check compilation unit containing the limited-with clause
1186 if Ukind /= N_Package_Declaration
1187 and then Ukind /= N_Subprogram_Declaration
1188 and then Ukind /= N_Package_Renaming_Declaration
1189 and then Ukind /= N_Subprogram_Renaming_Declaration
1190 and then Ukind not in N_Generic_Declaration
1191 and then Ukind not in N_Generic_Renaming_Declaration
1192 and then Ukind not in N_Generic_Instantiation
1193 then
1194 Error_Msg_N ("limited with_clause not allowed here", Item);
1196 -- Check wrong use of a limited with clause applied to the
1197 -- compilation unit containing the limited-with clause.
1199 -- limited with P.Q;
1200 -- package P.Q is ...
1202 elsif Unit (Library_Unit (Item)) = Unit (N) then
1203 Error_Msg_N ("wrong use of limited-with clause", Item);
1205 -- Check wrong use of limited-with clause applied to some
1206 -- immediate ancestor.
1208 elsif Is_Child_Spec (Unit (N)) then
1209 declare
1210 Lib_U : constant Entity_Id := Unit (Library_Unit (Item));
1211 P : Node_Id;
1213 begin
1214 P := Parent_Spec (Unit (N));
1215 loop
1216 if Unit (P) = Lib_U then
1217 Error_Msg_N ("limited with_clause of immediate "
1218 & "ancestor not allowed", Item);
1219 exit;
1220 end if;
1222 exit when not Is_Child_Spec (Unit (P));
1223 P := Parent_Spec (Unit (P));
1224 end loop;
1225 end;
1226 end if;
1228 -- Check if the limited-withed unit is already visible through
1229 -- some context clause of the current compilation unit or some
1230 -- ancestor of the current compilation unit.
1232 declare
1233 Lim_Unit_Name : constant Node_Id := Name (Item);
1234 Comp_Unit : Node_Id;
1235 It : Node_Id;
1236 Unit_Name : Node_Id;
1238 begin
1239 Comp_Unit := N;
1240 loop
1241 It := First (Context_Items (Comp_Unit));
1242 while Present (It) loop
1243 if Item /= It
1244 and then Nkind (It) = N_With_Clause
1245 and then not Limited_Present (It)
1246 and then
1247 (Nkind (Unit (Library_Unit (It)))
1248 = N_Package_Declaration
1249 or else
1250 Nkind (Unit (Library_Unit (It)))
1251 = N_Package_Renaming_Declaration)
1252 then
1253 if Nkind (Unit (Library_Unit (It)))
1254 = N_Package_Declaration
1255 then
1256 Unit_Name := Name (It);
1257 else
1258 Unit_Name := Name (Unit (Library_Unit (It)));
1259 end if;
1261 -- Check if the named package (or some ancestor)
1262 -- leaves visible the full-view of the unit given
1263 -- in the limited-with clause
1265 loop
1266 if Designate_Same_Unit (Lim_Unit_Name,
1267 Unit_Name)
1268 then
1269 Error_Msg_Sloc := Sloc (It);
1270 Error_Msg_NE
1271 ("unlimited view visible through the"
1272 & " context clause found #",
1273 Item, It);
1274 Error_Msg_N
1275 ("simultaneous visibility of the limited"
1276 & " and unlimited views not allowed"
1277 , Item);
1278 exit;
1280 elsif Nkind (Unit_Name) = N_Identifier then
1281 exit;
1282 end if;
1284 Unit_Name := Prefix (Unit_Name);
1285 end loop;
1286 end if;
1288 Next (It);
1289 end loop;
1291 exit when not Is_Child_Spec (Unit (Comp_Unit));
1293 Comp_Unit := Parent_Spec (Unit (Comp_Unit));
1294 end loop;
1295 end;
1296 end if;
1298 -- Skip analyzing with clause if no unit, see above
1300 if Present (Library_Unit (Item)) then
1301 Analyze (Item);
1302 end if;
1304 -- A limited_with does not impose an elaboration order, but
1305 -- there is a semantic dependency for recompilation purposes.
1307 if not Implicit_With (Item) then
1308 Version_Update (N, Library_Unit (Item));
1309 end if;
1311 -- Pragmas and use clauses and with clauses other than limited
1312 -- with's are ignored in this pass through the context items.
1314 else
1315 null;
1316 end if;
1318 Next (Item);
1319 end loop;
1320 end Analyze_Context;
1322 -------------------------------
1323 -- Analyze_Package_Body_Stub --
1324 -------------------------------
1326 procedure Analyze_Package_Body_Stub (N : Node_Id) is
1327 Id : constant Entity_Id := Defining_Identifier (N);
1328 Nam : Entity_Id;
1330 begin
1331 -- The package declaration must be in the current declarative part
1333 Check_Stub_Level (N);
1334 Nam := Current_Entity_In_Scope (Id);
1336 if No (Nam) or else not Is_Package_Or_Generic_Package (Nam) then
1337 Error_Msg_N ("missing specification for package stub", N);
1339 elsif Has_Completion (Nam)
1340 and then Present (Corresponding_Body (Unit_Declaration_Node (Nam)))
1341 then
1342 Error_Msg_N ("duplicate or redundant stub for package", N);
1344 else
1345 -- Indicate that the body of the package exists. If we are doing
1346 -- only semantic analysis, the stub stands for the body. If we are
1347 -- generating code, the existence of the body will be confirmed
1348 -- when we load the proper body.
1350 Set_Has_Completion (Nam);
1351 Set_Scope (Defining_Entity (N), Current_Scope);
1352 Generate_Reference (Nam, Id, 'b');
1353 Analyze_Proper_Body (N, Nam);
1354 end if;
1355 end Analyze_Package_Body_Stub;
1357 -------------------------
1358 -- Analyze_Proper_Body --
1359 -------------------------
1361 procedure Analyze_Proper_Body (N : Node_Id; Nam : Entity_Id) is
1362 Subunit_Name : constant Unit_Name_Type := Get_Unit_Name (N);
1363 Unum : Unit_Number_Type;
1365 procedure Optional_Subunit;
1366 -- This procedure is called when the main unit is a stub, or when we
1367 -- are not generating code. In such a case, we analyze the subunit if
1368 -- present, which is user-friendly and in fact required for ASIS, but
1369 -- we don't complain if the subunit is missing.
1371 ----------------------
1372 -- Optional_Subunit --
1373 ----------------------
1375 procedure Optional_Subunit is
1376 Comp_Unit : Node_Id;
1378 begin
1379 -- Try to load subunit, but ignore any errors that occur during
1380 -- the loading of the subunit, by using the special feature in
1381 -- Errout to ignore all errors. Note that Fatal_Error will still
1382 -- be set, so we will be able to check for this case below.
1384 if not ASIS_Mode then
1385 Ignore_Errors_Enable := Ignore_Errors_Enable + 1;
1386 end if;
1388 Unum :=
1389 Load_Unit
1390 (Load_Name => Subunit_Name,
1391 Required => False,
1392 Subunit => True,
1393 Error_Node => N);
1395 if not ASIS_Mode then
1396 Ignore_Errors_Enable := Ignore_Errors_Enable - 1;
1397 end if;
1399 -- All done if we successfully loaded the subunit
1401 if Unum /= No_Unit
1402 and then (not Fatal_Error (Unum) or else Try_Semantics)
1403 then
1404 Comp_Unit := Cunit (Unum);
1406 -- If the file was empty or seriously mangled, the unit
1407 -- itself may be missing.
1409 if No (Unit (Comp_Unit)) then
1410 Error_Msg_N
1411 ("subunit does not contain expected proper body", N);
1413 elsif Nkind (Unit (Comp_Unit)) /= N_Subunit then
1414 Error_Msg_N
1415 ("expected SEPARATE subunit, found child unit",
1416 Cunit_Entity (Unum));
1417 else
1418 Set_Corresponding_Stub (Unit (Comp_Unit), N);
1419 Analyze_Subunit (Comp_Unit);
1420 Set_Library_Unit (N, Comp_Unit);
1421 end if;
1423 elsif Unum = No_Unit
1424 and then Present (Nam)
1425 then
1426 if Is_Protected_Type (Nam) then
1427 Set_Corresponding_Body (Parent (Nam), Defining_Identifier (N));
1428 else
1429 Set_Corresponding_Body (
1430 Unit_Declaration_Node (Nam), Defining_Identifier (N));
1431 end if;
1432 end if;
1433 end Optional_Subunit;
1435 -- Start of processing for Analyze_Proper_Body
1437 begin
1438 -- If the subunit is already loaded, it means that the main unit
1439 -- is a subunit, and that the current unit is one of its parents
1440 -- which was being analyzed to provide the needed context for the
1441 -- analysis of the subunit. In this case we analyze the subunit and
1442 -- continue with the parent, without looking a subsequent subunits.
1444 if Is_Loaded (Subunit_Name) then
1446 -- If the proper body is already linked to the stub node,
1447 -- the stub is in a generic unit and just needs analyzing.
1449 if Present (Library_Unit (N)) then
1450 Set_Corresponding_Stub (Unit (Library_Unit (N)), N);
1451 Analyze_Subunit (Library_Unit (N));
1453 -- Otherwise we must load the subunit and link to it
1455 else
1456 -- Load the subunit, this must work, since we originally
1457 -- loaded the subunit earlier on. So this will not really
1458 -- load it, just give access to it.
1460 Unum :=
1461 Load_Unit
1462 (Load_Name => Subunit_Name,
1463 Required => True,
1464 Subunit => False,
1465 Error_Node => N);
1467 -- And analyze the subunit in the parent context (note that we
1468 -- do not call Semantics, since that would remove the parent
1469 -- context). Because of this, we have to manually reset the
1470 -- compiler state to Analyzing since it got destroyed by Load.
1472 if Unum /= No_Unit then
1473 Compiler_State := Analyzing;
1475 -- Check that the proper body is a subunit and not a child
1476 -- unit. If the unit was previously loaded, the error will
1477 -- have been emitted when copying the generic node, so we
1478 -- just return to avoid cascaded errors.
1480 if Nkind (Unit (Cunit (Unum))) /= N_Subunit then
1481 return;
1482 end if;
1484 Set_Corresponding_Stub (Unit (Cunit (Unum)), N);
1485 Analyze_Subunit (Cunit (Unum));
1486 Set_Library_Unit (N, Cunit (Unum));
1487 end if;
1488 end if;
1490 -- If the main unit is a subunit, then we are just performing semantic
1491 -- analysis on that subunit, and any other subunits of any parent unit
1492 -- should be ignored, except that if we are building trees for ASIS
1493 -- usage we want to annotate the stub properly.
1495 elsif Nkind (Unit (Cunit (Main_Unit))) = N_Subunit
1496 and then Subunit_Name /= Unit_Name (Main_Unit)
1497 then
1498 if ASIS_Mode then
1499 Optional_Subunit;
1500 end if;
1502 -- But before we return, set the flag for unloaded subunits. This
1503 -- will suppress junk warnings of variables in the same declarative
1504 -- part (or a higher level one) that are in danger of looking unused
1505 -- when in fact there might be a declaration in the subunit that we
1506 -- do not intend to load.
1508 Unloaded_Subunits := True;
1509 return;
1511 -- If the subunit is not already loaded, and we are generating code,
1512 -- then this is the case where compilation started from the parent,
1513 -- and we are generating code for an entire subunit tree. In that
1514 -- case we definitely need to load the subunit.
1516 -- In order to continue the analysis with the rest of the parent,
1517 -- and other subunits, we load the unit without requiring its
1518 -- presence, and emit a warning if not found, rather than terminating
1519 -- the compilation abruptly, as for other missing file problems.
1521 elsif Original_Operating_Mode = Generate_Code then
1523 -- If the proper body is already linked to the stub node,
1524 -- the stub is in a generic unit and just needs analyzing.
1526 -- We update the version. Although we are not technically
1527 -- semantically dependent on the subunit, given our approach
1528 -- of macro substitution of subunits, it makes sense to
1529 -- include it in the version identification.
1531 if Present (Library_Unit (N)) then
1532 Set_Corresponding_Stub (Unit (Library_Unit (N)), N);
1533 Analyze_Subunit (Library_Unit (N));
1534 Version_Update (Cunit (Main_Unit), Library_Unit (N));
1536 -- Otherwise we must load the subunit and link to it
1538 else
1539 Unum :=
1540 Load_Unit
1541 (Load_Name => Subunit_Name,
1542 Required => False,
1543 Subunit => True,
1544 Error_Node => N);
1546 if Original_Operating_Mode = Generate_Code
1547 and then Unum = No_Unit
1548 then
1549 Error_Msg_Name_1 := Subunit_Name;
1550 Error_Msg_Name_2 :=
1551 Get_File_Name (Subunit_Name, Subunit => True);
1552 Error_Msg_N
1553 ("subunit% in file{ not found?", N);
1554 Subunits_Missing := True;
1555 end if;
1557 -- Load_Unit may reset Compiler_State, since it may have been
1558 -- necessary to parse an additional units, so we make sure
1559 -- that we reset it to the Analyzing state.
1561 Compiler_State := Analyzing;
1563 if Unum /= No_Unit
1564 and then (not Fatal_Error (Unum) or else Try_Semantics)
1565 then
1566 if Debug_Flag_L then
1567 Write_Str ("*** Loaded subunit from stub. Analyze");
1568 Write_Eol;
1569 end if;
1571 declare
1572 Comp_Unit : constant Node_Id := Cunit (Unum);
1574 begin
1575 -- Check for child unit instead of subunit
1577 if Nkind (Unit (Comp_Unit)) /= N_Subunit then
1578 Error_Msg_N
1579 ("expected SEPARATE subunit, found child unit",
1580 Cunit_Entity (Unum));
1582 -- OK, we have a subunit, so go ahead and analyze it,
1583 -- and set Scope of entity in stub, for ASIS use.
1585 else
1586 Set_Corresponding_Stub (Unit (Comp_Unit), N);
1587 Analyze_Subunit (Comp_Unit);
1588 Set_Library_Unit (N, Comp_Unit);
1590 -- We update the version. Although we are not technically
1591 -- semantically dependent on the subunit, given our
1592 -- approach of macro substitution of subunits, it makes
1593 -- sense to include it in the version identification.
1595 Version_Update (Cunit (Main_Unit), Comp_Unit);
1596 end if;
1597 end;
1598 end if;
1599 end if;
1601 -- The remaining case is when the subunit is not already loaded and
1602 -- we are not generating code. In this case we are just performing
1603 -- semantic analysis on the parent, and we are not interested in
1604 -- the subunit. For subprograms, analyze the stub as a body. For
1605 -- other entities the stub has already been marked as completed.
1607 else
1608 Optional_Subunit;
1609 end if;
1611 end Analyze_Proper_Body;
1613 ----------------------------------
1614 -- Analyze_Protected_Body_Stub --
1615 ----------------------------------
1617 procedure Analyze_Protected_Body_Stub (N : Node_Id) is
1618 Nam : Entity_Id := Current_Entity_In_Scope (Defining_Identifier (N));
1620 begin
1621 Check_Stub_Level (N);
1623 -- First occurence of name may have been as an incomplete type
1625 if Present (Nam) and then Ekind (Nam) = E_Incomplete_Type then
1626 Nam := Full_View (Nam);
1627 end if;
1629 if No (Nam)
1630 or else not Is_Protected_Type (Etype (Nam))
1631 then
1632 Error_Msg_N ("missing specification for Protected body", N);
1633 else
1634 Set_Scope (Defining_Entity (N), Current_Scope);
1635 Set_Has_Completion (Etype (Nam));
1636 Generate_Reference (Nam, Defining_Identifier (N), 'b');
1637 Analyze_Proper_Body (N, Etype (Nam));
1638 end if;
1639 end Analyze_Protected_Body_Stub;
1641 ----------------------------------
1642 -- Analyze_Subprogram_Body_Stub --
1643 ----------------------------------
1645 -- A subprogram body stub can appear with or without a previous
1646 -- specification. If there is one, the analysis of the body will
1647 -- find it and verify conformance. The formals appearing in the
1648 -- specification of the stub play no role, except for requiring an
1649 -- additional conformance check. If there is no previous subprogram
1650 -- declaration, the stub acts as a spec, and provides the defining
1651 -- entity for the subprogram.
1653 procedure Analyze_Subprogram_Body_Stub (N : Node_Id) is
1654 Decl : Node_Id;
1656 begin
1657 Check_Stub_Level (N);
1659 -- Verify that the identifier for the stub is unique within this
1660 -- declarative part.
1662 if Nkind (Parent (N)) = N_Block_Statement
1663 or else Nkind (Parent (N)) = N_Package_Body
1664 or else Nkind (Parent (N)) = N_Subprogram_Body
1665 then
1666 Decl := First (Declarations (Parent (N)));
1667 while Present (Decl)
1668 and then Decl /= N
1669 loop
1670 if Nkind (Decl) = N_Subprogram_Body_Stub
1671 and then (Chars (Defining_Unit_Name (Specification (Decl)))
1672 = Chars (Defining_Unit_Name (Specification (N))))
1673 then
1674 Error_Msg_N ("identifier for stub is not unique", N);
1675 end if;
1677 Next (Decl);
1678 end loop;
1679 end if;
1681 -- Treat stub as a body, which checks conformance if there is a previous
1682 -- declaration, or else introduces entity and its signature.
1684 Analyze_Subprogram_Body (N);
1685 Analyze_Proper_Body (N, Empty);
1686 end Analyze_Subprogram_Body_Stub;
1688 ---------------------
1689 -- Analyze_Subunit --
1690 ---------------------
1692 -- A subunit is compiled either by itself (for semantic checking)
1693 -- or as part of compiling the parent (for code generation). In
1694 -- either case, by the time we actually process the subunit, the
1695 -- parent has already been installed and analyzed. The node N is
1696 -- a compilation unit, whose context needs to be treated here,
1697 -- because we come directly here from the parent without calling
1698 -- Analyze_Compilation_Unit.
1700 -- The compilation context includes the explicit context of the
1701 -- subunit, and the context of the parent, together with the parent
1702 -- itself. In order to compile the current context, we remove the
1703 -- one inherited from the parent, in order to have a clean visibility
1704 -- table. We restore the parent context before analyzing the proper
1705 -- body itself. On exit, we remove only the explicit context of the
1706 -- subunit.
1708 procedure Analyze_Subunit (N : Node_Id) is
1709 Lib_Unit : constant Node_Id := Library_Unit (N);
1710 Par_Unit : constant Entity_Id := Current_Scope;
1712 Lib_Spec : Node_Id := Library_Unit (Lib_Unit);
1713 Num_Scopes : Int := 0;
1714 Use_Clauses : array (1 .. Scope_Stack.Last) of Node_Id;
1715 Enclosing_Child : Entity_Id := Empty;
1716 Svg : constant Suppress_Array := Scope_Suppress;
1718 procedure Analyze_Subunit_Context;
1719 -- Capture names in use clauses of the subunit. This must be done
1720 -- before re-installing parent declarations, because items in the
1721 -- context must not be hidden by declarations local to the parent.
1723 procedure Re_Install_Parents (L : Node_Id; Scop : Entity_Id);
1724 -- Recursive procedure to restore scope of all ancestors of subunit,
1725 -- from outermost in. If parent is not a subunit, the call to install
1726 -- context installs context of spec and (if parent is a child unit)
1727 -- the context of its parents as well. It is confusing that parents
1728 -- should be treated differently in both cases, but the semantics are
1729 -- just not identical.
1731 procedure Re_Install_Use_Clauses;
1732 -- As part of the removal of the parent scope, the use clauses are
1733 -- removed, to be reinstalled when the context of the subunit has
1734 -- been analyzed. Use clauses may also have been affected by the
1735 -- analysis of the context of the subunit, so they have to be applied
1736 -- again, to insure that the compilation environment of the rest of
1737 -- the parent unit is identical.
1739 procedure Remove_Scope;
1740 -- Remove current scope from scope stack, and preserve the list
1741 -- of use clauses in it, to be reinstalled after context is analyzed.
1743 -----------------------------
1744 -- Analyze_Subunit_Context --
1745 -----------------------------
1747 procedure Analyze_Subunit_Context is
1748 Item : Node_Id;
1749 Nam : Node_Id;
1750 Unit_Name : Entity_Id;
1752 begin
1753 Analyze_Context (N);
1755 -- Make withed units immediately visible. If child unit, make the
1756 -- ultimate parent immediately visible.
1758 Item := First (Context_Items (N));
1759 while Present (Item) loop
1760 if Nkind (Item) = N_With_Clause then
1762 -- Protect frontend against previous errors in context clauses
1764 if Nkind (Name (Item)) /= N_Selected_Component then
1765 Unit_Name := Entity (Name (Item));
1766 while Is_Child_Unit (Unit_Name) loop
1767 Set_Is_Visible_Child_Unit (Unit_Name);
1768 Unit_Name := Scope (Unit_Name);
1769 end loop;
1771 if not Is_Immediately_Visible (Unit_Name) then
1772 Set_Is_Immediately_Visible (Unit_Name);
1773 Set_Context_Installed (Item);
1774 end if;
1775 end if;
1777 elsif Nkind (Item) = N_Use_Package_Clause then
1778 Nam := First (Names (Item));
1779 while Present (Nam) loop
1780 Analyze (Nam);
1781 Next (Nam);
1782 end loop;
1784 elsif Nkind (Item) = N_Use_Type_Clause then
1785 Nam := First (Subtype_Marks (Item));
1786 while Present (Nam) loop
1787 Analyze (Nam);
1788 Next (Nam);
1789 end loop;
1790 end if;
1792 Next (Item);
1793 end loop;
1795 -- Reset visibility of withed units. They will be made visible
1796 -- again when we install the subunit context.
1798 Item := First (Context_Items (N));
1799 while Present (Item) loop
1800 if Nkind (Item) = N_With_Clause
1802 -- Protect frontend against previous errors in context clauses
1804 and then Nkind (Name (Item)) /= N_Selected_Component
1805 then
1806 Unit_Name := Entity (Name (Item));
1807 while Is_Child_Unit (Unit_Name) loop
1808 Set_Is_Visible_Child_Unit (Unit_Name, False);
1809 Unit_Name := Scope (Unit_Name);
1810 end loop;
1812 if Context_Installed (Item) then
1813 Set_Is_Immediately_Visible (Unit_Name, False);
1814 Set_Context_Installed (Item, False);
1815 end if;
1816 end if;
1818 Next (Item);
1819 end loop;
1820 end Analyze_Subunit_Context;
1822 ------------------------
1823 -- Re_Install_Parents --
1824 ------------------------
1826 procedure Re_Install_Parents (L : Node_Id; Scop : Entity_Id) is
1827 E : Entity_Id;
1829 begin
1830 if Nkind (Unit (L)) = N_Subunit then
1831 Re_Install_Parents (Library_Unit (L), Scope (Scop));
1832 end if;
1834 Install_Context (L);
1836 -- If the subunit occurs within a child unit, we must restore the
1837 -- immediate visibility of any siblings that may occur in context.
1839 if Present (Enclosing_Child) then
1840 Install_Siblings (Enclosing_Child, L);
1841 end if;
1843 New_Scope (Scop);
1845 if Scop /= Par_Unit then
1846 Set_Is_Immediately_Visible (Scop);
1847 end if;
1849 -- Make entities in scope visible again. For child units, restore
1850 -- visibility only if they are actually in context.
1852 E := First_Entity (Current_Scope);
1853 while Present (E) loop
1854 if not Is_Child_Unit (E)
1855 or else Is_Visible_Child_Unit (E)
1856 then
1857 Set_Is_Immediately_Visible (E);
1858 end if;
1860 Next_Entity (E);
1861 end loop;
1863 -- A subunit appears within a body, and for a nested subunits
1864 -- all the parents are bodies. Restore full visibility of their
1865 -- private entities.
1867 if Ekind (Scop) = E_Package then
1868 Set_In_Package_Body (Scop);
1869 Install_Private_Declarations (Scop);
1870 end if;
1871 end Re_Install_Parents;
1873 ----------------------------
1874 -- Re_Install_Use_Clauses --
1875 ----------------------------
1877 procedure Re_Install_Use_Clauses is
1878 U : Node_Id;
1879 begin
1880 for J in reverse 1 .. Num_Scopes loop
1881 U := Use_Clauses (J);
1882 Scope_Stack.Table (Scope_Stack.Last - J + 1).First_Use_Clause := U;
1883 Install_Use_Clauses (U, Force_Installation => True);
1884 end loop;
1885 end Re_Install_Use_Clauses;
1887 ------------------
1888 -- Remove_Scope --
1889 ------------------
1891 procedure Remove_Scope is
1892 E : Entity_Id;
1894 begin
1895 Num_Scopes := Num_Scopes + 1;
1896 Use_Clauses (Num_Scopes) :=
1897 Scope_Stack.Table (Scope_Stack.Last).First_Use_Clause;
1899 E := First_Entity (Current_Scope);
1900 while Present (E) loop
1901 Set_Is_Immediately_Visible (E, False);
1902 Next_Entity (E);
1903 end loop;
1905 if Is_Child_Unit (Current_Scope) then
1906 Enclosing_Child := Current_Scope;
1907 end if;
1909 Pop_Scope;
1910 end Remove_Scope;
1912 -- Start of processing for Analyze_Subunit
1914 begin
1915 if not Is_Empty_List (Context_Items (N)) then
1917 -- Save current use clauses
1919 Remove_Scope;
1920 Remove_Context (Lib_Unit);
1922 -- Now remove parents and their context, including enclosing
1923 -- subunits and the outer parent body which is not a subunit.
1925 if Present (Lib_Spec) then
1926 Remove_Context (Lib_Spec);
1928 while Nkind (Unit (Lib_Spec)) = N_Subunit loop
1929 Lib_Spec := Library_Unit (Lib_Spec);
1930 Remove_Scope;
1931 Remove_Context (Lib_Spec);
1932 end loop;
1934 if Nkind (Unit (Lib_Unit)) = N_Subunit then
1935 Remove_Scope;
1936 end if;
1938 if Nkind (Unit (Lib_Spec)) = N_Package_Body then
1939 Remove_Context (Library_Unit (Lib_Spec));
1940 end if;
1941 end if;
1943 Set_Is_Immediately_Visible (Par_Unit, False);
1945 Analyze_Subunit_Context;
1947 Re_Install_Parents (Lib_Unit, Par_Unit);
1948 Set_Is_Immediately_Visible (Par_Unit);
1950 -- If the context includes a child unit of the parent of the
1951 -- subunit, the parent will have been removed from visibility,
1952 -- after compiling that cousin in the context. The visibility
1953 -- of the parent must be restored now. This also applies if the
1954 -- context includes another subunit of the same parent which in
1955 -- turn includes a child unit in its context.
1957 if Ekind (Par_Unit) = E_Package then
1958 if not Is_Immediately_Visible (Par_Unit)
1959 or else (Present (First_Entity (Par_Unit))
1960 and then not Is_Immediately_Visible
1961 (First_Entity (Par_Unit)))
1962 then
1963 Set_Is_Immediately_Visible (Par_Unit);
1964 Install_Visible_Declarations (Par_Unit);
1965 Install_Private_Declarations (Par_Unit);
1966 end if;
1967 end if;
1969 Re_Install_Use_Clauses;
1970 Install_Context (N);
1972 -- Restore state of suppress flags for current body
1974 Scope_Suppress := Svg;
1976 -- If the subunit is within a child unit, then siblings of any
1977 -- parent unit that appear in the context clause of the subunit
1978 -- must also be made immediately visible.
1980 if Present (Enclosing_Child) then
1981 Install_Siblings (Enclosing_Child, N);
1982 end if;
1984 end if;
1986 Analyze (Proper_Body (Unit (N)));
1987 Remove_Context (N);
1988 end Analyze_Subunit;
1990 ----------------------------
1991 -- Analyze_Task_Body_Stub --
1992 ----------------------------
1994 procedure Analyze_Task_Body_Stub (N : Node_Id) is
1995 Nam : Entity_Id := Current_Entity_In_Scope (Defining_Identifier (N));
1996 Loc : constant Source_Ptr := Sloc (N);
1998 begin
1999 Check_Stub_Level (N);
2001 -- First occurence of name may have been as an incomplete type
2003 if Present (Nam) and then Ekind (Nam) = E_Incomplete_Type then
2004 Nam := Full_View (Nam);
2005 end if;
2007 if No (Nam)
2008 or else not Is_Task_Type (Etype (Nam))
2009 then
2010 Error_Msg_N ("missing specification for task body", N);
2011 else
2012 Set_Scope (Defining_Entity (N), Current_Scope);
2013 Generate_Reference (Nam, Defining_Identifier (N), 'b');
2014 Set_Has_Completion (Etype (Nam));
2015 Analyze_Proper_Body (N, Etype (Nam));
2017 -- Set elaboration flag to indicate that entity is callable.
2018 -- This cannot be done in the expansion of the body itself,
2019 -- because the proper body is not in a declarative part. This
2020 -- is only done if expansion is active, because the context
2021 -- may be generic and the flag not defined yet.
2023 if Expander_Active then
2024 Insert_After (N,
2025 Make_Assignment_Statement (Loc,
2026 Name =>
2027 Make_Identifier (Loc,
2028 New_External_Name (Chars (Etype (Nam)), 'E')),
2029 Expression => New_Reference_To (Standard_True, Loc)));
2030 end if;
2032 end if;
2033 end Analyze_Task_Body_Stub;
2035 -------------------------
2036 -- Analyze_With_Clause --
2037 -------------------------
2039 -- Analyze the declaration of a unit in a with clause. At end,
2040 -- label the with clause with the defining entity for the unit.
2042 procedure Analyze_With_Clause (N : Node_Id) is
2044 -- Retrieve the original kind of the unit node, before analysis.
2045 -- If it is a subprogram instantiation, its analysis below will
2046 -- rewrite as the declaration of the wrapper package. If the same
2047 -- instantiation appears indirectly elsewhere in the context, it
2048 -- will have been analyzed already.
2050 Unit_Kind : constant Node_Kind :=
2051 Nkind (Original_Node (Unit (Library_Unit (N))));
2053 E_Name : Entity_Id;
2054 Par_Name : Entity_Id;
2055 Pref : Node_Id;
2056 U : Node_Id;
2058 Intunit : Boolean;
2059 -- Set True if the unit currently being compiled is an internal unit
2061 Save_Style_Check : constant Boolean := Opt.Style_Check;
2062 Save_C_Restrict : constant Save_Cunit_Boolean_Restrictions :=
2063 Cunit_Boolean_Restrictions_Save;
2065 begin
2066 if Limited_Present (N) then
2068 -- Ada 2005 (AI-50217): Build visibility structures but do not
2069 -- analyze unit
2071 Build_Limited_Views (N);
2072 return;
2073 end if;
2075 -- We reset ordinary style checking during the analysis of a with'ed
2076 -- unit, but we do NOT reset GNAT special analysis mode (the latter
2077 -- definitely *does* apply to with'ed units).
2079 if not GNAT_Mode then
2080 Style_Check := False;
2081 end if;
2083 -- If the library unit is a predefined unit, and we are in high
2084 -- integrity mode, then temporarily reset Configurable_Run_Time_Mode
2085 -- for the analysis of the with'ed unit. This mode does not prevent
2086 -- explicit with'ing of run-time units.
2088 if Configurable_Run_Time_Mode
2089 and then
2090 Is_Predefined_File_Name
2091 (Unit_File_Name (Get_Source_Unit (Unit (Library_Unit (N)))))
2092 then
2093 Configurable_Run_Time_Mode := False;
2094 Semantics (Library_Unit (N));
2095 Configurable_Run_Time_Mode := True;
2097 else
2098 Semantics (Library_Unit (N));
2099 end if;
2101 U := Unit (Library_Unit (N));
2102 Check_Restriction_No_Dependence (Name (N), N);
2103 Intunit := Is_Internal_File_Name (Unit_File_Name (Current_Sem_Unit));
2105 -- Following checks are skipped for dummy packages (those supplied
2106 -- for with's where no matching file could be found). Such packages
2107 -- are identified by the Sloc value being set to No_Location
2109 if Sloc (U) /= No_Location then
2111 -- Check restrictions, except that we skip the check if this
2112 -- is an internal unit unless we are compiling the internal
2113 -- unit as the main unit. We also skip this for dummy packages.
2115 if not Intunit or else Current_Sem_Unit = Main_Unit then
2116 Check_Restricted_Unit (Unit_Name (Get_Source_Unit (U)), N);
2117 end if;
2119 -- Check for inappropriate with of internal implementation unit
2120 -- if we are currently compiling the main unit and the main unit
2121 -- is itself not an internal unit. We do not issue this message
2122 -- for implicit with's generated by the compiler itself.
2124 if Implementation_Unit_Warnings
2125 and then Current_Sem_Unit = Main_Unit
2126 and then not Intunit
2127 and then not Implicit_With (N)
2128 and then not GNAT_Mode
2129 then
2130 declare
2131 U_Kind : constant Kind_Of_Unit :=
2132 Get_Kind_Of_Unit (Get_Source_Unit (U));
2134 begin
2135 if U_Kind = Implementation_Unit then
2136 Error_Msg_N ("& is an internal 'G'N'A'T unit?", Name (N));
2137 Error_Msg_N
2138 ("\use of this unit is non-portable " &
2139 "and version-dependent?",
2140 Name (N));
2142 elsif U_Kind = Ada_05_Unit
2143 and then Ada_Version < Ada_05
2144 and then Warn_On_Ada_2005_Compatibility
2145 then
2146 Error_Msg_N ("& is an Ada 2005 unit?", Name (N));
2147 end if;
2148 end;
2149 end if;
2150 end if;
2152 -- Semantic analysis of a generic unit is performed on a copy of
2153 -- the original tree. Retrieve the entity on which semantic info
2154 -- actually appears.
2156 if Unit_Kind in N_Generic_Declaration then
2157 E_Name := Defining_Entity (U);
2159 -- Note: in the following test, Unit_Kind is the original Nkind, but
2160 -- in the case of an instantiation, semantic analysis above will
2161 -- have replaced the unit by its instantiated version. If the instance
2162 -- body has been generated, the instance now denotes the body entity.
2163 -- For visibility purposes we need the entity of its spec.
2165 elsif (Unit_Kind = N_Package_Instantiation
2166 or else Nkind (Original_Node (Unit (Library_Unit (N)))) =
2167 N_Package_Instantiation)
2168 and then Nkind (U) = N_Package_Body
2169 then
2170 E_Name := Corresponding_Spec (U);
2172 elsif Unit_Kind = N_Package_Instantiation
2173 and then Nkind (U) = N_Package_Instantiation
2174 then
2175 -- If the instance has not been rewritten as a package declaration,
2176 -- then it appeared already in a previous with clause. Retrieve
2177 -- the entity from the previous instance.
2179 E_Name := Defining_Entity (Specification (Instance_Spec (U)));
2181 elsif Unit_Kind in N_Subprogram_Instantiation then
2183 -- Instantiation node is replaced with a wrapper package.
2184 -- Retrieve the visible subprogram created by the instance from
2185 -- the corresponding attribute of the wrapper.
2187 E_Name := Related_Instance (Defining_Entity (U));
2189 elsif Unit_Kind = N_Package_Renaming_Declaration
2190 or else Unit_Kind in N_Generic_Renaming_Declaration
2191 then
2192 E_Name := Defining_Entity (U);
2194 elsif Unit_Kind = N_Subprogram_Body
2195 and then Nkind (Name (N)) = N_Selected_Component
2196 and then not Acts_As_Spec (Library_Unit (N))
2197 then
2198 -- For a child unit that has no spec, one has been created and
2199 -- analyzed. The entity required is that of the spec.
2201 E_Name := Corresponding_Spec (U);
2203 else
2204 E_Name := Defining_Entity (U);
2205 end if;
2207 if Nkind (Name (N)) = N_Selected_Component then
2209 -- Child unit in a with clause
2211 Change_Selected_Component_To_Expanded_Name (Name (N));
2212 end if;
2214 -- Restore style checks and restrictions
2216 Style_Check := Save_Style_Check;
2217 Cunit_Boolean_Restrictions_Restore (Save_C_Restrict);
2219 -- Record the reference, but do NOT set the unit as referenced, we want
2220 -- to consider the unit as unreferenced if this is the only reference
2221 -- that occurs.
2223 Set_Entity_With_Style_Check (Name (N), E_Name);
2224 Generate_Reference (E_Name, Name (N), 'w', Set_Ref => False);
2226 if Is_Child_Unit (E_Name) then
2227 Pref := Prefix (Name (N));
2228 Par_Name := Scope (E_Name);
2229 while Nkind (Pref) = N_Selected_Component loop
2230 Change_Selected_Component_To_Expanded_Name (Pref);
2231 Set_Entity_With_Style_Check (Pref, Par_Name);
2233 Generate_Reference (Par_Name, Pref);
2234 Pref := Prefix (Pref);
2236 -- If E_Name is the dummy entity for a nonexistent unit, its scope
2237 -- is set to Standard_Standard, and no attempt should be made to
2238 -- further unwind scopes.
2240 if Par_Name /= Standard_Standard then
2241 Par_Name := Scope (Par_Name);
2242 end if;
2243 end loop;
2245 if Present (Entity (Pref))
2246 and then not Analyzed (Parent (Parent (Entity (Pref))))
2247 then
2248 -- If the entity is set without its unit being compiled, the
2249 -- original parent is a renaming, and Par_Name is the renamed
2250 -- entity. For visibility purposes, we need the original entity,
2251 -- which must be analyzed now because Load_Unit directly retrieves
2252 -- the renamed unit, and the renaming declaration itself has not
2253 -- been analyzed.
2255 Analyze (Parent (Parent (Entity (Pref))));
2256 pragma Assert (Renamed_Object (Entity (Pref)) = Par_Name);
2257 Par_Name := Entity (Pref);
2258 end if;
2260 Set_Entity_With_Style_Check (Pref, Par_Name);
2261 Generate_Reference (Par_Name, Pref);
2262 end if;
2264 -- If the withed unit is System, and a system extension pragma is
2265 -- present, compile the extension now, rather than waiting for a
2266 -- visibility check on a specific entity.
2268 if Chars (E_Name) = Name_System
2269 and then Scope (E_Name) = Standard_Standard
2270 and then Present (System_Extend_Unit)
2271 and then Present_System_Aux (N)
2272 then
2273 -- If the extension is not present, an error will have been emitted
2275 null;
2276 end if;
2278 -- Ada 2005 (AI-262): Remove from visibility the entity corresponding
2279 -- to private_with units; they will be made visible later (just before
2280 -- the private part is analyzed)
2282 if Private_Present (N) then
2283 Set_Is_Immediately_Visible (E_Name, False);
2284 end if;
2286 -- Check for with'ing obsolescent package. Exclude subprograms here
2287 -- since we will catch those on the call rather than the WITH.
2289 if Is_Package_Or_Generic_Package (E_Name) then
2290 Check_Obsolescent (E_Name, N);
2291 end if;
2292 end Analyze_With_Clause;
2294 ------------------------------
2295 -- Analyze_With_Type_Clause --
2296 ------------------------------
2298 procedure Analyze_With_Type_Clause (N : Node_Id) is
2299 Loc : constant Source_Ptr := Sloc (N);
2300 Nam : constant Node_Id := Name (N);
2301 Pack : Node_Id;
2302 Decl : Node_Id;
2303 P : Entity_Id;
2304 Unum : Unit_Number_Type;
2305 Sel : Node_Id;
2307 procedure Decorate_Tagged_Type (T : Entity_Id);
2308 -- Set basic attributes of type, including its class_wide type
2310 function In_Chain (E : Entity_Id) return Boolean;
2311 -- Check that the imported type is not already in the homonym chain,
2312 -- for example through a with_type clause in a parent unit.
2314 --------------------------
2315 -- Decorate_Tagged_Type --
2316 --------------------------
2318 procedure Decorate_Tagged_Type (T : Entity_Id) is
2319 CW : Entity_Id;
2321 begin
2322 Set_Ekind (T, E_Record_Type);
2323 Set_Is_Tagged_Type (T);
2324 Set_Etype (T, T);
2325 Set_From_With_Type (T);
2326 Set_Scope (T, P);
2328 if not In_Chain (T) then
2329 Set_Homonym (T, Current_Entity (T));
2330 Set_Current_Entity (T);
2331 end if;
2333 -- Build bogus class_wide type, if not previously done
2335 if No (Class_Wide_Type (T)) then
2336 CW := Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
2338 Set_Ekind (CW, E_Class_Wide_Type);
2339 Set_Etype (CW, T);
2340 Set_Scope (CW, P);
2341 Set_Is_Tagged_Type (CW);
2342 Set_Is_First_Subtype (CW, True);
2343 Init_Size_Align (CW);
2344 Set_Has_Unknown_Discriminants
2345 (CW, True);
2346 Set_Class_Wide_Type (CW, CW);
2347 Set_Equivalent_Type (CW, Empty);
2348 Set_From_With_Type (CW);
2350 Set_Class_Wide_Type (T, CW);
2351 end if;
2352 end Decorate_Tagged_Type;
2354 --------------
2355 -- In_Chain --
2356 --------------
2358 function In_Chain (E : Entity_Id) return Boolean is
2359 H : Entity_Id;
2361 begin
2362 H := Current_Entity (E);
2363 while Present (H) loop
2364 if H = E then
2365 return True;
2366 else
2367 H := Homonym (H);
2368 end if;
2369 end loop;
2371 return False;
2372 end In_Chain;
2374 -- Start of processing for Analyze_With_Type_Clause
2376 begin
2377 if Nkind (Nam) = N_Selected_Component then
2378 Pack := New_Copy_Tree (Prefix (Nam));
2379 Sel := Selector_Name (Nam);
2381 else
2382 Error_Msg_N ("illegal name for imported type", Nam);
2383 return;
2384 end if;
2386 Decl :=
2387 Make_Package_Declaration (Loc,
2388 Specification =>
2389 (Make_Package_Specification (Loc,
2390 Defining_Unit_Name => Pack,
2391 Visible_Declarations => New_List,
2392 End_Label => Empty)));
2394 Unum :=
2395 Load_Unit
2396 (Load_Name => Get_Unit_Name (Decl),
2397 Required => True,
2398 Subunit => False,
2399 Error_Node => Nam);
2401 if Unum = No_Unit
2402 or else Nkind (Unit (Cunit (Unum))) /= N_Package_Declaration
2403 then
2404 Error_Msg_N ("imported type must be declared in package", Nam);
2405 return;
2407 elsif Unum = Current_Sem_Unit then
2409 -- If type is defined in unit being analyzed, then the clause
2410 -- is redundant.
2412 return;
2414 else
2415 P := Cunit_Entity (Unum);
2416 end if;
2418 -- Find declaration for imported type, and set its basic attributes
2419 -- if it has not been analyzed (which will be the case if there is
2420 -- circular dependence).
2422 declare
2423 Decl : Node_Id;
2424 Typ : Entity_Id;
2426 begin
2427 if not Analyzed (Cunit (Unum))
2428 and then not From_With_Type (P)
2429 then
2430 Set_Ekind (P, E_Package);
2431 Set_Etype (P, Standard_Void_Type);
2432 Set_From_With_Type (P);
2433 Set_Scope (P, Standard_Standard);
2434 Set_Homonym (P, Current_Entity (P));
2435 Set_Current_Entity (P);
2437 elsif Analyzed (Cunit (Unum))
2438 and then Is_Child_Unit (P)
2439 then
2440 -- If the child unit is already in scope, indicate that it is
2441 -- visible, and remains so after intervening calls to rtsfind.
2443 Set_Is_Visible_Child_Unit (P);
2444 end if;
2446 if Nkind (Parent (P)) = N_Defining_Program_Unit_Name then
2448 -- Make parent packages visible
2450 declare
2451 Parent_Comp : Node_Id;
2452 Parent_Id : Entity_Id;
2453 Child : Entity_Id;
2455 begin
2456 Child := P;
2457 Parent_Comp := Parent_Spec (Unit (Cunit (Unum)));
2459 loop
2460 Parent_Id := Defining_Entity (Unit (Parent_Comp));
2461 Set_Scope (Child, Parent_Id);
2463 -- The type may be imported from a child unit, in which
2464 -- case the current compilation appears in the name. Do
2465 -- not change its visibility here because it will conflict
2466 -- with the subsequent normal processing.
2468 if not Analyzed (Unit_Declaration_Node (Parent_Id))
2469 and then Parent_Id /= Cunit_Entity (Current_Sem_Unit)
2470 then
2471 Set_Ekind (Parent_Id, E_Package);
2472 Set_Etype (Parent_Id, Standard_Void_Type);
2474 -- The same package may appear is several with_type
2475 -- clauses.
2477 if not From_With_Type (Parent_Id) then
2478 Set_Homonym (Parent_Id, Current_Entity (Parent_Id));
2479 Set_Current_Entity (Parent_Id);
2480 Set_From_With_Type (Parent_Id);
2481 end if;
2482 end if;
2484 Set_Is_Immediately_Visible (Parent_Id);
2486 Child := Parent_Id;
2487 Parent_Comp := Parent_Spec (Unit (Parent_Comp));
2488 exit when No (Parent_Comp);
2489 end loop;
2491 Set_Scope (Parent_Id, Standard_Standard);
2492 end;
2493 end if;
2495 -- Even if analyzed, the package may not be currently visible. It
2496 -- must be while the with_type clause is active.
2498 Set_Is_Immediately_Visible (P);
2500 Decl :=
2501 First (Visible_Declarations (Specification (Unit (Cunit (Unum)))));
2502 while Present (Decl) loop
2503 if Nkind (Decl) = N_Full_Type_Declaration
2504 and then Chars (Defining_Identifier (Decl)) = Chars (Sel)
2505 then
2506 Typ := Defining_Identifier (Decl);
2508 if Tagged_Present (N) then
2510 -- The declaration must indicate that this is a tagged
2511 -- type or a type extension.
2513 if (Nkind (Type_Definition (Decl)) = N_Record_Definition
2514 and then Tagged_Present (Type_Definition (Decl)))
2515 or else
2516 (Nkind (Type_Definition (Decl))
2517 = N_Derived_Type_Definition
2518 and then Present
2519 (Record_Extension_Part (Type_Definition (Decl))))
2520 then
2521 null;
2522 else
2523 Error_Msg_N ("imported type is not a tagged type", Nam);
2524 return;
2525 end if;
2527 if not Analyzed (Decl) then
2529 -- Unit is not currently visible. Add basic attributes
2530 -- to type and build its class-wide type.
2532 Init_Size_Align (Typ);
2533 Decorate_Tagged_Type (Typ);
2534 end if;
2536 else
2537 if Nkind (Type_Definition (Decl))
2538 /= N_Access_To_Object_Definition
2539 then
2540 Error_Msg_N
2541 ("imported type is not an access type", Nam);
2543 elsif not Analyzed (Decl) then
2544 Set_Ekind (Typ, E_Access_Type);
2545 Set_Etype (Typ, Typ);
2546 Set_Scope (Typ, P);
2547 Init_Size (Typ, System_Address_Size);
2548 Init_Alignment (Typ);
2549 Set_Directly_Designated_Type (Typ, Standard_Integer);
2550 Set_From_With_Type (Typ);
2552 if not In_Chain (Typ) then
2553 Set_Homonym (Typ, Current_Entity (Typ));
2554 Set_Current_Entity (Typ);
2555 end if;
2556 end if;
2557 end if;
2559 Set_Entity (Sel, Typ);
2560 return;
2562 elsif ((Nkind (Decl) = N_Private_Type_Declaration
2563 and then Tagged_Present (Decl))
2564 or else (Nkind (Decl) = N_Private_Extension_Declaration))
2565 and then Chars (Defining_Identifier (Decl)) = Chars (Sel)
2566 then
2567 Typ := Defining_Identifier (Decl);
2569 if not Tagged_Present (N) then
2570 Error_Msg_N ("type must be declared tagged", N);
2572 elsif not Analyzed (Decl) then
2573 Decorate_Tagged_Type (Typ);
2574 end if;
2576 Set_Entity (Sel, Typ);
2577 Set_From_With_Type (Typ);
2578 return;
2579 end if;
2581 Decl := Next (Decl);
2582 end loop;
2584 Error_Msg_NE ("not a visible access or tagged type in&", Nam, P);
2585 end;
2586 end Analyze_With_Type_Clause;
2588 -----------------------------
2589 -- Check_With_Type_Clauses --
2590 -----------------------------
2592 procedure Check_With_Type_Clauses (N : Node_Id) is
2593 Lib_Unit : constant Node_Id := Unit (N);
2595 procedure Check_Parent_Context (U : Node_Id);
2596 -- Examine context items of parent unit to locate with_type clauses
2598 --------------------------
2599 -- Check_Parent_Context --
2600 --------------------------
2602 procedure Check_Parent_Context (U : Node_Id) is
2603 Item : Node_Id;
2605 begin
2606 Item := First (Context_Items (U));
2607 while Present (Item) loop
2608 if Nkind (Item) = N_With_Type_Clause
2609 and then not Error_Posted (Item)
2610 and then
2611 From_With_Type (Scope (Entity (Selector_Name (Name (Item)))))
2612 then
2613 Error_Msg_Sloc := Sloc (Item);
2614 Error_Msg_N ("missing With_Clause for With_Type_Clause#", N);
2615 end if;
2617 Next (Item);
2618 end loop;
2619 end Check_Parent_Context;
2621 -- Start of processing for Check_With_Type_Clauses
2623 begin
2624 if Extensions_Allowed
2625 and then (Nkind (Lib_Unit) = N_Package_Body
2626 or else Nkind (Lib_Unit) = N_Subprogram_Body)
2627 then
2628 Check_Parent_Context (Library_Unit (N));
2630 if Is_Child_Spec (Unit (Library_Unit (N))) then
2631 Check_Parent_Context (Parent_Spec (Unit (Library_Unit (N))));
2632 end if;
2633 end if;
2634 end Check_With_Type_Clauses;
2636 ------------------------------
2637 -- Check_Private_Child_Unit --
2638 ------------------------------
2640 procedure Check_Private_Child_Unit (N : Node_Id) is
2641 Lib_Unit : constant Node_Id := Unit (N);
2642 Item : Node_Id;
2643 Curr_Unit : Entity_Id;
2644 Sub_Parent : Node_Id;
2645 Priv_Child : Entity_Id;
2646 Par_Lib : Entity_Id;
2647 Par_Spec : Node_Id;
2649 function Is_Private_Library_Unit (Unit : Entity_Id) return Boolean;
2650 -- Returns true if and only if the library unit is declared with
2651 -- an explicit designation of private.
2653 function Is_Private_Library_Unit (Unit : Entity_Id) return Boolean is
2654 Comp_Unit : constant Node_Id := Parent (Unit_Declaration_Node (Unit));
2656 begin
2657 return Private_Present (Comp_Unit);
2658 end Is_Private_Library_Unit;
2660 -- Start of processing for Check_Private_Child_Unit
2662 begin
2663 if Nkind (Lib_Unit) = N_Package_Body
2664 or else Nkind (Lib_Unit) = N_Subprogram_Body
2665 then
2666 Curr_Unit := Defining_Entity (Unit (Library_Unit (N)));
2667 Par_Lib := Curr_Unit;
2669 elsif Nkind (Lib_Unit) = N_Subunit then
2671 -- The parent is itself a body. The parent entity is to be found
2672 -- in the corresponding spec.
2674 Sub_Parent := Library_Unit (N);
2675 Curr_Unit := Defining_Entity (Unit (Library_Unit (Sub_Parent)));
2677 -- If the parent itself is a subunit, Curr_Unit is the entity
2678 -- of the enclosing body, retrieve the spec entity which is
2679 -- the proper ancestor we need for the following tests.
2681 if Ekind (Curr_Unit) = E_Package_Body then
2682 Curr_Unit := Spec_Entity (Curr_Unit);
2683 end if;
2685 Par_Lib := Curr_Unit;
2687 else
2688 Curr_Unit := Defining_Entity (Lib_Unit);
2690 Par_Lib := Curr_Unit;
2691 Par_Spec := Parent_Spec (Lib_Unit);
2693 if No (Par_Spec) then
2694 Par_Lib := Empty;
2695 else
2696 Par_Lib := Defining_Entity (Unit (Par_Spec));
2697 end if;
2698 end if;
2700 -- Loop through context items
2702 Item := First (Context_Items (N));
2703 while Present (Item) loop
2705 -- Ada 2005 (AI-262): Allow private_with of a private child package
2706 -- in public siblings
2708 if Nkind (Item) = N_With_Clause
2709 and then not Implicit_With (Item)
2710 and then Is_Private_Descendant (Entity (Name (Item)))
2711 then
2712 Priv_Child := Entity (Name (Item));
2714 declare
2715 Curr_Parent : Entity_Id := Par_Lib;
2716 Child_Parent : Entity_Id := Scope (Priv_Child);
2717 Prv_Ancestor : Entity_Id := Child_Parent;
2718 Curr_Private : Boolean := Is_Private_Library_Unit (Curr_Unit);
2720 begin
2721 -- If the child unit is a public child then locate
2722 -- the nearest private ancestor; Child_Parent will
2723 -- then be set to the parent of that ancestor.
2725 if not Is_Private_Library_Unit (Priv_Child) then
2726 while Present (Prv_Ancestor)
2727 and then not Is_Private_Library_Unit (Prv_Ancestor)
2728 loop
2729 Prv_Ancestor := Scope (Prv_Ancestor);
2730 end loop;
2732 if Present (Prv_Ancestor) then
2733 Child_Parent := Scope (Prv_Ancestor);
2734 end if;
2735 end if;
2737 while Present (Curr_Parent)
2738 and then Curr_Parent /= Standard_Standard
2739 and then Curr_Parent /= Child_Parent
2740 loop
2741 Curr_Private :=
2742 Curr_Private or else Is_Private_Library_Unit (Curr_Parent);
2743 Curr_Parent := Scope (Curr_Parent);
2744 end loop;
2746 if No (Curr_Parent) then
2747 Curr_Parent := Standard_Standard;
2748 end if;
2750 if Curr_Parent /= Child_Parent then
2751 if Ekind (Priv_Child) = E_Generic_Package
2752 and then Chars (Priv_Child) in Text_IO_Package_Name
2753 and then Chars (Scope (Scope (Priv_Child))) = Name_Ada
2754 then
2755 Error_Msg_NE
2756 ("& is a nested package, not a compilation unit",
2757 Name (Item), Priv_Child);
2759 else
2760 Error_Msg_N
2761 ("unit in with clause is private child unit!", Item);
2762 Error_Msg_NE
2763 ("current unit must also have parent&!",
2764 Item, Child_Parent);
2765 end if;
2767 elsif not Curr_Private
2768 and then not Private_Present (Item)
2769 and then Nkind (Lib_Unit) /= N_Package_Body
2770 and then Nkind (Lib_Unit) /= N_Subprogram_Body
2771 and then Nkind (Lib_Unit) /= N_Subunit
2772 then
2773 Error_Msg_NE
2774 ("current unit must also be private descendant of&",
2775 Item, Child_Parent);
2776 end if;
2777 end;
2778 end if;
2780 Next (Item);
2781 end loop;
2783 end Check_Private_Child_Unit;
2785 ----------------------
2786 -- Check_Stub_Level --
2787 ----------------------
2789 procedure Check_Stub_Level (N : Node_Id) is
2790 Par : constant Node_Id := Parent (N);
2791 Kind : constant Node_Kind := Nkind (Par);
2793 begin
2794 if (Kind = N_Package_Body
2795 or else Kind = N_Subprogram_Body
2796 or else Kind = N_Task_Body
2797 or else Kind = N_Protected_Body)
2798 and then (Nkind (Parent (Par)) = N_Compilation_Unit
2799 or else Nkind (Parent (Par)) = N_Subunit)
2800 then
2801 null;
2803 -- In an instance, a missing stub appears at any level. A warning
2804 -- message will have been emitted already for the missing file.
2806 elsif not In_Instance then
2807 Error_Msg_N ("stub cannot appear in an inner scope", N);
2809 elsif Expander_Active then
2810 Error_Msg_N ("missing proper body", N);
2811 end if;
2812 end Check_Stub_Level;
2814 ------------------------
2815 -- Expand_With_Clause --
2816 ------------------------
2818 procedure Expand_With_Clause (Item : Node_Id; Nam : Node_Id; N : Node_Id) is
2819 Loc : constant Source_Ptr := Sloc (Nam);
2820 Ent : constant Entity_Id := Entity (Nam);
2821 Withn : Node_Id;
2822 P : Node_Id;
2824 function Build_Unit_Name (Nam : Node_Id) return Node_Id;
2825 -- Comment requireed here ???
2827 ---------------------
2828 -- Build_Unit_Name --
2829 ---------------------
2831 function Build_Unit_Name (Nam : Node_Id) return Node_Id is
2832 Result : Node_Id;
2834 begin
2835 if Nkind (Nam) = N_Identifier then
2836 return New_Occurrence_Of (Entity (Nam), Loc);
2838 else
2839 Result :=
2840 Make_Expanded_Name (Loc,
2841 Chars => Chars (Entity (Nam)),
2842 Prefix => Build_Unit_Name (Prefix (Nam)),
2843 Selector_Name => New_Occurrence_Of (Entity (Nam), Loc));
2844 Set_Entity (Result, Entity (Nam));
2845 return Result;
2846 end if;
2847 end Build_Unit_Name;
2849 -- Start of processing for Expand_With_Clause
2851 begin
2852 New_Nodes_OK := New_Nodes_OK + 1;
2853 Withn :=
2854 Make_With_Clause (Loc, Name => Build_Unit_Name (Nam));
2856 P := Parent (Unit_Declaration_Node (Ent));
2857 Set_Library_Unit (Withn, P);
2858 Set_Corresponding_Spec (Withn, Ent);
2859 Set_First_Name (Withn, True);
2860 Set_Implicit_With (Withn, True);
2862 -- If the unit is a package declaration, a private_with_clause on a
2863 -- child unit implies that the implicit with on the parent is also
2864 -- private.
2866 if Nkind (Unit (N)) = N_Package_Declaration then
2867 Set_Private_Present (Withn, Private_Present (Item));
2868 end if;
2870 Prepend (Withn, Context_Items (N));
2871 Mark_Rewrite_Insertion (Withn);
2872 Install_Withed_Unit (Withn);
2874 if Nkind (Nam) = N_Expanded_Name then
2875 Expand_With_Clause (Item, Prefix (Nam), N);
2876 end if;
2878 New_Nodes_OK := New_Nodes_OK - 1;
2879 end Expand_With_Clause;
2881 -----------------------
2882 -- Get_Parent_Entity --
2883 -----------------------
2885 function Get_Parent_Entity (Unit : Node_Id) return Entity_Id is
2886 begin
2887 if Nkind (Unit) = N_Package_Body
2888 and then Nkind (Original_Node (Unit)) = N_Package_Instantiation
2889 then
2890 return
2891 Defining_Entity
2892 (Specification (Instance_Spec (Original_Node (Unit))));
2894 elsif Nkind (Unit) = N_Package_Instantiation then
2895 return Defining_Entity (Specification (Instance_Spec (Unit)));
2897 else
2898 return Defining_Entity (Unit);
2899 end if;
2900 end Get_Parent_Entity;
2902 -----------------------------
2903 -- Implicit_With_On_Parent --
2904 -----------------------------
2906 procedure Implicit_With_On_Parent
2907 (Child_Unit : Node_Id;
2908 N : Node_Id)
2910 Loc : constant Source_Ptr := Sloc (N);
2911 P : constant Node_Id := Parent_Spec (Child_Unit);
2913 P_Unit : Node_Id := Unit (P);
2915 P_Name : constant Entity_Id := Get_Parent_Entity (P_Unit);
2916 Withn : Node_Id;
2918 function Build_Ancestor_Name (P : Node_Id) return Node_Id;
2919 -- Build prefix of child unit name. Recurse if needed
2921 function Build_Unit_Name return Node_Id;
2922 -- If the unit is a child unit, build qualified name with all
2923 -- ancestors.
2925 -------------------------
2926 -- Build_Ancestor_Name --
2927 -------------------------
2929 function Build_Ancestor_Name (P : Node_Id) return Node_Id is
2930 P_Ref : constant Node_Id :=
2931 New_Reference_To (Defining_Entity (P), Loc);
2932 P_Spec : Node_Id := P;
2934 begin
2935 -- Ancestor may have been rewritten as a package body. Retrieve
2936 -- the original spec to trace earlier ancestors.
2938 if Nkind (P) = N_Package_Body
2939 and then Nkind (Original_Node (P)) = N_Package_Instantiation
2940 then
2941 P_Spec := Original_Node (P);
2942 end if;
2944 if No (Parent_Spec (P_Spec)) then
2945 return P_Ref;
2946 else
2947 return
2948 Make_Selected_Component (Loc,
2949 Prefix => Build_Ancestor_Name (Unit (Parent_Spec (P_Spec))),
2950 Selector_Name => P_Ref);
2951 end if;
2952 end Build_Ancestor_Name;
2954 ---------------------
2955 -- Build_Unit_Name --
2956 ---------------------
2958 function Build_Unit_Name return Node_Id is
2959 Result : Node_Id;
2960 begin
2961 if No (Parent_Spec (P_Unit)) then
2962 return New_Reference_To (P_Name, Loc);
2963 else
2964 Result :=
2965 Make_Expanded_Name (Loc,
2966 Chars => Chars (P_Name),
2967 Prefix => Build_Ancestor_Name (Unit (Parent_Spec (P_Unit))),
2968 Selector_Name => New_Reference_To (P_Name, Loc));
2969 Set_Entity (Result, P_Name);
2970 return Result;
2971 end if;
2972 end Build_Unit_Name;
2974 -- Start of processing for Implicit_With_On_Parent
2976 begin
2977 -- The unit of the current compilation may be a package body
2978 -- that replaces an instance node. In this case we need the
2979 -- original instance node to construct the proper parent name.
2981 if Nkind (P_Unit) = N_Package_Body
2982 and then Nkind (Original_Node (P_Unit)) = N_Package_Instantiation
2983 then
2984 P_Unit := Original_Node (P_Unit);
2985 end if;
2987 -- We add the implicit with if the child unit is the current unit
2988 -- being compiled. If the current unit is a body, we do not want
2989 -- to add an implicit_with a second time to the corresponding spec.
2991 if Nkind (Child_Unit) = N_Package_Declaration
2992 and then Child_Unit /= Unit (Cunit (Current_Sem_Unit))
2993 then
2994 return;
2995 end if;
2997 New_Nodes_OK := New_Nodes_OK + 1;
2998 Withn := Make_With_Clause (Loc, Name => Build_Unit_Name);
3000 Set_Library_Unit (Withn, P);
3001 Set_Corresponding_Spec (Withn, P_Name);
3002 Set_First_Name (Withn, True);
3003 Set_Implicit_With (Withn, True);
3005 -- Node is placed at the beginning of the context items, so that
3006 -- subsequent use clauses on the parent can be validated.
3008 Prepend (Withn, Context_Items (N));
3009 Mark_Rewrite_Insertion (Withn);
3010 Install_Withed_Unit (Withn);
3012 if Is_Child_Spec (P_Unit) then
3013 Implicit_With_On_Parent (P_Unit, N);
3014 end if;
3016 New_Nodes_OK := New_Nodes_OK - 1;
3017 end Implicit_With_On_Parent;
3019 --------------
3020 -- In_Chain --
3021 --------------
3023 function In_Chain (E : Entity_Id) return Boolean is
3024 H : Entity_Id;
3026 begin
3027 H := Current_Entity (E);
3028 while Present (H) loop
3029 if H = E then
3030 return True;
3031 else
3032 H := Homonym (H);
3033 end if;
3034 end loop;
3036 return False;
3037 end In_Chain;
3039 ---------------------
3040 -- Install_Context --
3041 ---------------------
3043 procedure Install_Context (N : Node_Id) is
3044 Lib_Unit : constant Node_Id := Unit (N);
3046 begin
3047 Install_Context_Clauses (N);
3049 if Is_Child_Spec (Lib_Unit) then
3050 Install_Parents (Lib_Unit, Private_Present (Parent (Lib_Unit)));
3051 end if;
3053 Install_Limited_Context_Clauses (N);
3055 Check_With_Type_Clauses (N);
3056 end Install_Context;
3058 -----------------------------
3059 -- Install_Context_Clauses --
3060 -----------------------------
3062 procedure Install_Context_Clauses (N : Node_Id) is
3063 Lib_Unit : constant Node_Id := Unit (N);
3064 Item : Node_Id;
3065 Uname_Node : Entity_Id;
3066 Check_Private : Boolean := False;
3067 Decl_Node : Node_Id;
3068 Lib_Parent : Entity_Id;
3070 begin
3071 -- First skip configuration pragmas at the start of the context. They
3072 -- are not technically part of the context clause, but that's where the
3073 -- parser puts them. Note they were analyzed in Analyze_Context.
3075 Item := First (Context_Items (N));
3076 while Present (Item)
3077 and then Nkind (Item) = N_Pragma
3078 and then Chars (Item) in Configuration_Pragma_Names
3079 loop
3080 Next (Item);
3081 end loop;
3083 -- Loop through the actual context clause items. We process everything
3084 -- except Limited_With clauses in this routine. Limited_With clauses
3085 -- are separately installed (see Install_Limited_Context_Clauses).
3087 while Present (Item) loop
3089 -- Case of explicit WITH clause
3091 if Nkind (Item) = N_With_Clause
3092 and then not Implicit_With (Item)
3093 then
3094 if Limited_Present (Item) then
3096 -- Limited withed units will be installed later
3098 goto Continue;
3100 -- If Name (Item) is not an entity name, something is wrong, and
3101 -- this will be detected in due course, for now ignore the item
3103 elsif not Is_Entity_Name (Name (Item)) then
3104 goto Continue;
3106 elsif No (Entity (Name (Item))) then
3107 Set_Entity (Name (Item), Any_Id);
3108 goto Continue;
3109 end if;
3111 Uname_Node := Entity (Name (Item));
3113 if Is_Private_Descendant (Uname_Node) then
3114 Check_Private := True;
3115 end if;
3117 Install_Withed_Unit (Item);
3119 Decl_Node := Unit_Declaration_Node (Uname_Node);
3121 -- If the unit is a subprogram instance, it appears nested
3122 -- within a package that carries the parent information.
3124 if Is_Generic_Instance (Uname_Node)
3125 and then Ekind (Uname_Node) /= E_Package
3126 then
3127 Decl_Node := Parent (Parent (Decl_Node));
3128 end if;
3130 if Is_Child_Spec (Decl_Node) then
3131 if Nkind (Name (Item)) = N_Expanded_Name then
3132 Expand_With_Clause (Item, Prefix (Name (Item)), N);
3133 else
3134 -- if not an expanded name, the child unit must be a
3135 -- renaming, nothing to do.
3137 null;
3138 end if;
3140 elsif Nkind (Decl_Node) = N_Subprogram_Body
3141 and then not Acts_As_Spec (Parent (Decl_Node))
3142 and then Is_Child_Spec (Unit (Library_Unit (Parent (Decl_Node))))
3143 then
3144 Implicit_With_On_Parent
3145 (Unit (Library_Unit (Parent (Decl_Node))), N);
3146 end if;
3148 -- Check license conditions unless this is a dummy unit
3150 if Sloc (Library_Unit (Item)) /= No_Location then
3151 License_Check : declare
3153 Withu : constant Unit_Number_Type :=
3154 Get_Source_Unit (Library_Unit (Item));
3156 Withl : constant License_Type :=
3157 License (Source_Index (Withu));
3159 Unitl : constant License_Type :=
3160 License (Source_Index (Current_Sem_Unit));
3162 procedure License_Error;
3163 -- Signal error of bad license
3165 -------------------
3166 -- License_Error --
3167 -------------------
3169 procedure License_Error is
3170 begin
3171 Error_Msg_N
3172 ("?license of with'ed unit & may be inconsistent",
3173 Name (Item));
3174 end License_Error;
3176 -- Start of processing for License_Check
3178 begin
3179 -- Exclude license check if withed unit is an internal unit.
3180 -- This situation arises e.g. with the GPL version of GNAT.
3182 if Is_Internal_File_Name (Unit_File_Name (Withu)) then
3183 null;
3185 -- Otherwise check various cases
3186 else
3187 case Unitl is
3188 when Unknown =>
3189 null;
3191 when Restricted =>
3192 if Withl = GPL then
3193 License_Error;
3194 end if;
3196 when GPL =>
3197 if Withl = Restricted then
3198 License_Error;
3199 end if;
3201 when Modified_GPL =>
3202 if Withl = Restricted or else Withl = GPL then
3203 License_Error;
3204 end if;
3206 when Unrestricted =>
3207 null;
3208 end case;
3209 end if;
3210 end License_Check;
3211 end if;
3213 -- Case of USE PACKAGE clause
3215 elsif Nkind (Item) = N_Use_Package_Clause then
3216 Analyze_Use_Package (Item);
3218 -- Case of USE TYPE clause
3220 elsif Nkind (Item) = N_Use_Type_Clause then
3221 Analyze_Use_Type (Item);
3223 -- Case of WITH TYPE clause
3225 -- A With_Type_Clause is processed when installing the context,
3226 -- because it is a visibility mechanism and does not create a
3227 -- semantic dependence on other units, as a With_Clause does.
3229 elsif Nkind (Item) = N_With_Type_Clause then
3230 Analyze_With_Type_Clause (Item);
3232 -- case of PRAGMA
3234 elsif Nkind (Item) = N_Pragma then
3235 Analyze (Item);
3236 end if;
3238 <<Continue>>
3239 Next (Item);
3240 end loop;
3242 if Is_Child_Spec (Lib_Unit) then
3244 -- The unit also has implicit withs on its own parents
3246 if No (Context_Items (N)) then
3247 Set_Context_Items (N, New_List);
3248 end if;
3250 Implicit_With_On_Parent (Lib_Unit, N);
3251 end if;
3253 -- If the unit is a body, the context of the specification must also
3254 -- be installed.
3256 if Nkind (Lib_Unit) = N_Package_Body
3257 or else (Nkind (Lib_Unit) = N_Subprogram_Body
3258 and then not Acts_As_Spec (N))
3259 then
3260 Install_Context (Library_Unit (N));
3262 if Is_Child_Spec (Unit (Library_Unit (N))) then
3264 -- If the unit is the body of a public child unit, the private
3265 -- declarations of the parent must be made visible. If the child
3266 -- unit is private, the private declarations have been installed
3267 -- already in the call to Install_Parents for the spec. Installing
3268 -- private declarations must be done for all ancestors of public
3269 -- child units. In addition, sibling units mentioned in the
3270 -- context clause of the body are directly visible.
3272 declare
3273 Lib_Spec : Node_Id;
3274 P : Node_Id;
3275 P_Name : Entity_Id;
3277 begin
3278 Lib_Spec := Unit (Library_Unit (N));
3279 while Is_Child_Spec (Lib_Spec) loop
3280 P := Unit (Parent_Spec (Lib_Spec));
3281 P_Name := Defining_Entity (P);
3283 if not (Private_Present (Parent (Lib_Spec)))
3284 and then not In_Private_Part (P_Name)
3285 then
3286 Install_Private_Declarations (P_Name);
3287 Install_Private_With_Clauses (P_Name);
3288 Set_Use (Private_Declarations (Specification (P)));
3289 end if;
3291 Lib_Spec := P;
3292 end loop;
3293 end;
3294 end if;
3296 -- For a package body, children in context are immediately visible
3298 Install_Siblings (Defining_Entity (Unit (Library_Unit (N))), N);
3299 end if;
3301 if Nkind (Lib_Unit) = N_Generic_Package_Declaration
3302 or else Nkind (Lib_Unit) = N_Generic_Subprogram_Declaration
3303 or else Nkind (Lib_Unit) = N_Package_Declaration
3304 or else Nkind (Lib_Unit) = N_Subprogram_Declaration
3305 then
3306 if Is_Child_Spec (Lib_Unit) then
3307 Lib_Parent := Defining_Entity (Unit (Parent_Spec (Lib_Unit)));
3308 Set_Is_Private_Descendant
3309 (Defining_Entity (Lib_Unit),
3310 Is_Private_Descendant (Lib_Parent)
3311 or else Private_Present (Parent (Lib_Unit)));
3313 else
3314 Set_Is_Private_Descendant
3315 (Defining_Entity (Lib_Unit),
3316 Private_Present (Parent (Lib_Unit)));
3317 end if;
3318 end if;
3320 if Check_Private then
3321 Check_Private_Child_Unit (N);
3322 end if;
3323 end Install_Context_Clauses;
3325 -------------------------------------
3326 -- Install_Limited_Context_Clauses --
3327 -------------------------------------
3329 procedure Install_Limited_Context_Clauses (N : Node_Id) is
3330 Item : Node_Id;
3332 procedure Check_Renamings (P : Node_Id; W : Node_Id);
3333 -- Check that the unlimited view of a given compilation_unit is not
3334 -- already visible through "use + renamings".
3336 procedure Check_Private_Limited_Withed_Unit (Item : Node_Id);
3337 -- Check that if a limited_with clause of a given compilation_unit
3338 -- mentions a descendant of a private child of some library unit,
3339 -- then the given compilation_unit shall be the declaration of a
3340 -- private descendant of that library unit.
3342 procedure Expand_Limited_With_Clause
3343 (Comp_Unit : Node_Id; Nam : Node_Id; N : Node_Id);
3344 -- If a child unit appears in a limited_with clause, there are implicit
3345 -- limited_with clauses on all parents that are not already visible
3346 -- through a regular with clause. This procedure creates the implicit
3347 -- limited with_clauses for the parents and loads the corresponding
3348 -- units. The shadow entities are created when the inserted clause is
3349 -- analyzed. Implements Ada 2005 (AI-50217).
3351 ---------------------
3352 -- Check_Renamings --
3353 ---------------------
3355 procedure Check_Renamings (P : Node_Id; W : Node_Id) is
3356 Item : Node_Id;
3357 Spec : Node_Id;
3358 WEnt : Entity_Id;
3359 Nam : Node_Id;
3360 E : Entity_Id;
3361 E2 : Entity_Id;
3363 begin
3364 pragma Assert (Nkind (W) = N_With_Clause);
3366 -- Protect the frontend against previous critical errors
3368 case Nkind (Unit (Library_Unit (W))) is
3369 when N_Subprogram_Declaration |
3370 N_Package_Declaration |
3371 N_Generic_Subprogram_Declaration |
3372 N_Generic_Package_Declaration =>
3373 null;
3375 when others =>
3376 return;
3377 end case;
3379 -- Check "use + renamings"
3381 WEnt := Defining_Unit_Name (Specification (Unit (Library_Unit (W))));
3382 Spec := Specification (Unit (P));
3384 Item := First (Visible_Declarations (Spec));
3385 while Present (Item) loop
3387 if Nkind (Item) = N_Use_Package_Clause then
3389 -- Traverse the list of packages
3391 Nam := First (Names (Item));
3392 while Present (Nam) loop
3393 E := Entity (Nam);
3395 pragma Assert (Present (Parent (E)));
3397 if Nkind (Parent (E)) = N_Package_Renaming_Declaration
3398 and then Renamed_Entity (E) = WEnt
3399 then
3400 Error_Msg_N ("unlimited view visible through " &
3401 "use clause and renamings", W);
3402 return;
3404 elsif Nkind (Parent (E)) = N_Package_Specification then
3406 -- The use clause may refer to a local package.
3407 -- Check all the enclosing scopes.
3409 E2 := E;
3410 while E2 /= Standard_Standard
3411 and then E2 /= WEnt loop
3412 E2 := Scope (E2);
3413 end loop;
3415 if E2 = WEnt then
3416 Error_Msg_N
3417 ("unlimited view visible through use clause ", W);
3418 return;
3419 end if;
3421 end if;
3422 Next (Nam);
3423 end loop;
3425 end if;
3427 Next (Item);
3428 end loop;
3430 -- Recursive call to check all the ancestors
3432 if Is_Child_Spec (Unit (P)) then
3433 Check_Renamings (P => Parent_Spec (Unit (P)), W => W);
3434 end if;
3435 end Check_Renamings;
3437 ---------------------------------------
3438 -- Check_Private_Limited_Withed_Unit --
3439 ---------------------------------------
3441 procedure Check_Private_Limited_Withed_Unit (Item : Node_Id) is
3442 Curr_Parent : Node_Id;
3443 Child_Parent : Node_Id;
3445 begin
3446 -- Compilation unit of the parent of the withed library unit
3448 Child_Parent := Parent_Spec (Unit (Library_Unit (Item)));
3450 -- If the child unit is a public child, then locate its nearest
3451 -- private ancestor, if any; Child_Parent will then be set to
3452 -- the parent of that ancestor.
3454 if not Private_Present (Library_Unit (Item)) then
3455 while Present (Child_Parent)
3456 and then not Private_Present (Child_Parent)
3457 loop
3458 Child_Parent := Parent_Spec (Unit (Child_Parent));
3459 end loop;
3461 if No (Child_Parent) then
3462 return;
3463 end if;
3465 Child_Parent := Parent_Spec (Unit (Child_Parent));
3466 end if;
3468 -- Traverse all the ancestors of the current compilation
3469 -- unit to check if it is a descendant of named library unit.
3471 Curr_Parent := Parent (Item);
3473 while Present (Parent_Spec (Unit (Curr_Parent)))
3474 and then Curr_Parent /= Child_Parent
3475 loop
3476 Curr_Parent := Parent_Spec (Unit (Curr_Parent));
3477 end loop;
3479 if Curr_Parent /= Child_Parent then
3480 Error_Msg_N
3481 ("unit in with clause is private child unit!", Item);
3482 Error_Msg_NE
3483 ("current unit must also have parent&!",
3484 Item, Defining_Unit_Name (Specification (Unit (Child_Parent))));
3486 elsif not Private_Present (Parent (Item))
3487 and then not Private_Present (Item)
3488 and then Nkind (Unit (Parent (Item))) /= N_Package_Body
3489 and then Nkind (Unit (Parent (Item))) /= N_Subprogram_Body
3490 and then Nkind (Unit (Parent (Item))) /= N_Subunit
3491 then
3492 Error_Msg_NE
3493 ("current unit must also be private descendant of&",
3494 Item, Defining_Unit_Name (Specification (Unit (Child_Parent))));
3495 end if;
3496 end Check_Private_Limited_Withed_Unit;
3498 --------------------------------
3499 -- Expand_Limited_With_Clause --
3500 --------------------------------
3502 procedure Expand_Limited_With_Clause
3503 (Comp_Unit : Node_Id;
3504 Nam : Node_Id;
3505 N : Node_Id)
3507 Loc : constant Source_Ptr := Sloc (Nam);
3508 Unum : Unit_Number_Type;
3509 Withn : Node_Id;
3511 function Previous_Withed_Unit (W : Node_Id) return Boolean;
3512 -- Returns true if the context already includes a with_clause for
3513 -- this unit. If the with_clause is non-limited, the unit is fully
3514 -- visible and an implicit limited_with should not be created. If
3515 -- there is already a limited_with clause for W, a second one is
3516 -- simply redundant.
3518 --------------------------
3519 -- Previous_Withed_Unit --
3520 --------------------------
3522 function Previous_Withed_Unit (W : Node_Id) return Boolean is
3523 Item : Node_Id;
3525 begin
3526 -- A limited with_clause cannot appear in the same context_clause
3527 -- as a nonlimited with_clause which mentions the same library.
3529 Item := First (Context_Items (Comp_Unit));
3530 while Present (Item) loop
3531 if Nkind (Item) = N_With_Clause
3532 and then Library_Unit (Item) = Library_Unit (W)
3533 then
3534 return True;
3535 end if;
3537 Next (Item);
3538 end loop;
3540 return False;
3541 end Previous_Withed_Unit;
3543 -- Start of processing for Expand_Limited_With_Clause
3545 begin
3546 New_Nodes_OK := New_Nodes_OK + 1;
3548 if Nkind (Nam) = N_Identifier then
3549 Withn :=
3550 Make_With_Clause (Loc,
3551 Name => Nam);
3553 else pragma Assert (Nkind (Nam) = N_Selected_Component);
3554 Withn :=
3555 Make_With_Clause (Loc,
3556 Name => Make_Selected_Component (Loc,
3557 Prefix => New_Copy_Tree (Prefix (Nam)),
3558 Selector_Name => Selector_Name (Nam)));
3559 Set_Parent (Withn, Parent (N));
3560 end if;
3562 Set_Limited_Present (Withn);
3563 Set_First_Name (Withn);
3564 Set_Implicit_With (Withn);
3566 Unum :=
3567 Load_Unit
3568 (Load_Name => Get_Spec_Name (Get_Unit_Name (Nam)),
3569 Required => True,
3570 Subunit => False,
3571 Error_Node => Nam);
3573 -- Do not generate a limited_with_clause on the current unit.
3574 -- This path is taken when a unit has a limited_with clause on
3575 -- one of its child units.
3577 if Unum = Current_Sem_Unit then
3578 return;
3579 end if;
3581 Set_Library_Unit (Withn, Cunit (Unum));
3582 Set_Corresponding_Spec
3583 (Withn, Specification (Unit (Cunit (Unum))));
3585 if not Previous_Withed_Unit (Withn) then
3586 Prepend (Withn, Context_Items (Parent (N)));
3587 Mark_Rewrite_Insertion (Withn);
3589 -- Add implicit limited_with_clauses for parents of child units
3590 -- mentioned in limited_with clauses.
3592 if Nkind (Nam) = N_Selected_Component then
3593 Expand_Limited_With_Clause (Comp_Unit, Prefix (Nam), N);
3594 end if;
3596 Analyze (Withn);
3598 if not Limited_View_Installed (Withn) then
3599 Install_Limited_Withed_Unit (Withn);
3600 end if;
3601 end if;
3603 New_Nodes_OK := New_Nodes_OK - 1;
3604 end Expand_Limited_With_Clause;
3606 -- Start of processing for Install_Limited_Context_Clauses
3608 begin
3609 Item := First (Context_Items (N));
3610 while Present (Item) loop
3611 if Nkind (Item) = N_With_Clause
3612 and then Limited_Present (Item)
3613 then
3614 if Nkind (Name (Item)) = N_Selected_Component then
3615 Expand_Limited_With_Clause
3616 (Comp_Unit => N, Nam => Prefix (Name (Item)), N => Item);
3617 end if;
3619 Check_Private_Limited_Withed_Unit (Item);
3621 if not Implicit_With (Item)
3622 and then Is_Child_Spec (Unit (N))
3623 then
3624 Check_Renamings (Parent_Spec (Unit (N)), Item);
3625 end if;
3627 -- A unit may have a limited with on itself if it has a
3628 -- limited with_clause on one of its child units. In that
3629 -- case it is already being compiled and it makes no sense
3630 -- to install its limited view.
3632 if Library_Unit (Item) /= Cunit (Current_Sem_Unit)
3633 and then not Limited_View_Installed (Item)
3634 then
3635 Install_Limited_Withed_Unit (Item);
3636 end if;
3638 -- All items other than Limited_With clauses are ignored (they were
3639 -- installed separately early on by Install_Context_Clause).
3641 else
3642 null;
3643 end if;
3645 Next (Item);
3646 end loop;
3647 end Install_Limited_Context_Clauses;
3649 ---------------------
3650 -- Install_Parents --
3651 ---------------------
3653 procedure Install_Parents (Lib_Unit : Node_Id; Is_Private : Boolean) is
3654 P : Node_Id;
3655 E_Name : Entity_Id;
3656 P_Name : Entity_Id;
3657 P_Spec : Node_Id;
3659 begin
3660 P := Unit (Parent_Spec (Lib_Unit));
3661 P_Name := Get_Parent_Entity (P);
3663 if Etype (P_Name) = Any_Type then
3664 return;
3665 end if;
3667 if Ekind (P_Name) = E_Generic_Package
3668 and then Nkind (Lib_Unit) /= N_Generic_Subprogram_Declaration
3669 and then Nkind (Lib_Unit) /= N_Generic_Package_Declaration
3670 and then Nkind (Lib_Unit) not in N_Generic_Renaming_Declaration
3671 then
3672 Error_Msg_N
3673 ("child of a generic package must be a generic unit", Lib_Unit);
3675 elsif not Is_Package_Or_Generic_Package (P_Name) then
3676 Error_Msg_N
3677 ("parent unit must be package or generic package", Lib_Unit);
3678 raise Unrecoverable_Error;
3680 elsif Present (Renamed_Object (P_Name)) then
3681 Error_Msg_N ("parent unit cannot be a renaming", Lib_Unit);
3682 raise Unrecoverable_Error;
3684 -- Verify that a child of an instance is itself an instance, or
3685 -- the renaming of one. Given that an instance that is a unit is
3686 -- replaced with a package declaration, check against the original
3687 -- node. The parent may be currently being instantiated, in which
3688 -- case it appears as a declaration, but the generic_parent is
3689 -- already established indicating that we deal with an instance.
3691 elsif Nkind (Original_Node (P)) = N_Package_Instantiation then
3693 if Nkind (Lib_Unit) in N_Renaming_Declaration
3694 or else Nkind (Original_Node (Lib_Unit)) in N_Generic_Instantiation
3695 or else
3696 (Nkind (Lib_Unit) = N_Package_Declaration
3697 and then Present (Generic_Parent (Specification (Lib_Unit))))
3698 then
3699 null;
3700 else
3701 Error_Msg_N
3702 ("child of an instance must be an instance or renaming",
3703 Lib_Unit);
3704 end if;
3705 end if;
3707 -- This is the recursive call that ensures all parents are loaded
3709 if Is_Child_Spec (P) then
3710 Install_Parents (P,
3711 Is_Private or else Private_Present (Parent (Lib_Unit)));
3712 end if;
3714 -- Now we can install the context for this parent
3716 Install_Context_Clauses (Parent_Spec (Lib_Unit));
3717 Install_Limited_Context_Clauses (Parent_Spec (Lib_Unit));
3718 Install_Siblings (P_Name, Parent (Lib_Unit));
3720 -- The child unit is in the declarative region of the parent. The
3721 -- parent must therefore appear in the scope stack and be visible,
3722 -- as when compiling the corresponding body. If the child unit is
3723 -- private or it is a package body, private declarations must be
3724 -- accessible as well. Use declarations in the parent must also
3725 -- be installed. Finally, other child units of the same parent that
3726 -- are in the context are immediately visible.
3728 -- Find entity for compilation unit, and set its private descendant
3729 -- status as needed.
3731 E_Name := Defining_Entity (Lib_Unit);
3733 Set_Is_Child_Unit (E_Name);
3735 Set_Is_Private_Descendant (E_Name,
3736 Is_Private_Descendant (P_Name)
3737 or else Private_Present (Parent (Lib_Unit)));
3739 P_Spec := Specification (Unit_Declaration_Node (P_Name));
3740 New_Scope (P_Name);
3742 -- Save current visibility of unit
3744 Scope_Stack.Table (Scope_Stack.Last).Previous_Visibility :=
3745 Is_Immediately_Visible (P_Name);
3746 Set_Is_Immediately_Visible (P_Name);
3747 Install_Visible_Declarations (P_Name);
3748 Set_Use (Visible_Declarations (P_Spec));
3750 -- If the parent is a generic unit, its formal part may contain
3751 -- formal packages and use clauses for them.
3753 if Ekind (P_Name) = E_Generic_Package then
3754 Set_Use (Generic_Formal_Declarations (Parent (P_Spec)));
3755 end if;
3757 if Is_Private
3758 or else Private_Present (Parent (Lib_Unit))
3759 then
3760 Install_Private_Declarations (P_Name);
3761 Install_Private_With_Clauses (P_Name);
3762 Set_Use (Private_Declarations (P_Spec));
3763 end if;
3764 end Install_Parents;
3766 ----------------------------------
3767 -- Install_Private_With_Clauses --
3768 ----------------------------------
3770 procedure Install_Private_With_Clauses (P : Entity_Id) is
3771 Decl : constant Node_Id := Unit_Declaration_Node (P);
3772 Item : Node_Id;
3774 begin
3775 if Debug_Flag_I then
3776 Write_Str ("install private with clauses of ");
3777 Write_Name (Chars (P));
3778 Write_Eol;
3779 end if;
3781 if Nkind (Parent (Decl)) = N_Compilation_Unit then
3782 Item := First (Context_Items (Parent (Decl)));
3783 while Present (Item) loop
3784 if Nkind (Item) = N_With_Clause
3785 and then Private_Present (Item)
3786 then
3787 if Limited_Present (Item) then
3788 if not Limited_View_Installed (Item) then
3789 Install_Limited_Withed_Unit (Item);
3790 end if;
3791 else
3792 Install_Withed_Unit (Item, Private_With_OK => True);
3793 end if;
3794 end if;
3796 Next (Item);
3797 end loop;
3798 end if;
3799 end Install_Private_With_Clauses;
3801 ----------------------
3802 -- Install_Siblings --
3803 ----------------------
3805 procedure Install_Siblings (U_Name : Entity_Id; N : Node_Id) is
3806 Item : Node_Id;
3807 Id : Entity_Id;
3808 Prev : Entity_Id;
3809 begin
3810 -- Iterate over explicit with clauses, and check whether the
3811 -- scope of each entity is an ancestor of the current unit.
3813 Item := First (Context_Items (N));
3814 while Present (Item) loop
3816 -- Do not install private_with_clauses if the unit is a package
3817 -- declaration, unless it is itself a private child unit.
3819 if Nkind (Item) = N_With_Clause
3820 and then not Implicit_With (Item)
3821 and then not Limited_Present (Item)
3822 and then
3823 (not Private_Present (Item)
3824 or else Nkind (Unit (N)) /= N_Package_Declaration
3825 or else Private_Present (N))
3826 then
3827 Id := Entity (Name (Item));
3829 if Is_Child_Unit (Id)
3830 and then Is_Ancestor_Package (Scope (Id), U_Name)
3831 then
3832 Set_Is_Immediately_Visible (Id);
3834 -- Check for the presence of another unit in the context,
3835 -- that may be inadvertently hidden by the child.
3837 Prev := Current_Entity (Id);
3839 if Present (Prev)
3840 and then Is_Immediately_Visible (Prev)
3841 and then not Is_Child_Unit (Prev)
3842 then
3843 declare
3844 Clause : Node_Id;
3846 begin
3847 Clause := First (Context_Items (N));
3848 while Present (Clause) loop
3849 if Nkind (Clause) = N_With_Clause
3850 and then Entity (Name (Clause)) = Prev
3851 then
3852 Error_Msg_NE
3853 ("child unit& hides compilation unit " &
3854 "with the same name?",
3855 Name (Item), Id);
3856 exit;
3857 end if;
3859 Next (Clause);
3860 end loop;
3861 end;
3862 end if;
3864 -- the With_Clause may be on a grand-child, which makes
3865 -- the child immediately visible.
3867 elsif Is_Child_Unit (Scope (Id))
3868 and then Is_Ancestor_Package (Scope (Scope (Id)), U_Name)
3869 then
3870 Set_Is_Immediately_Visible (Scope (Id));
3871 end if;
3872 end if;
3874 Next (Item);
3875 end loop;
3876 end Install_Siblings;
3878 -------------------------------
3879 -- Install_Limited_With_Unit --
3880 -------------------------------
3882 procedure Install_Limited_Withed_Unit (N : Node_Id) is
3883 P_Unit : constant Entity_Id := Unit (Library_Unit (N));
3884 P : Entity_Id;
3885 Is_Child_Package : Boolean := False;
3887 Lim_Header : Entity_Id;
3888 Lim_Typ : Entity_Id;
3890 function Is_Visible_Through_Renamings (P : Entity_Id) return Boolean;
3891 -- Check if some package installed though normal with-clauses has a
3892 -- renaming declaration of package P. AARM 10.1.2(21/2).
3894 ----------------------------------
3895 -- Is_Visible_Through_Renamings --
3896 ----------------------------------
3898 function Is_Visible_Through_Renamings (P : Entity_Id) return Boolean is
3899 Kind : constant Node_Kind :=
3900 Nkind (Unit (Cunit (Current_Sem_Unit)));
3901 Aux_Unit : Node_Id;
3902 Item : Node_Id;
3903 Decl : Entity_Id;
3905 begin
3906 -- Example of the error detected by this subprogram:
3908 -- package P is
3909 -- type T is ...
3910 -- end P;
3912 -- with P;
3913 -- package Q is
3914 -- package Ren_P renames P;
3915 -- end Q;
3917 -- with Q;
3918 -- package R is ...
3920 -- limited with P; -- ERROR
3921 -- package R.C is ...
3923 Aux_Unit := Cunit (Current_Sem_Unit);
3925 loop
3926 Item := First (Context_Items (Aux_Unit));
3927 while Present (Item) loop
3928 if Nkind (Item) = N_With_Clause
3929 and then not Limited_Present (Item)
3930 and then Nkind (Unit (Library_Unit (Item)))
3931 = N_Package_Declaration
3932 then
3933 Decl :=
3934 First (Visible_Declarations
3935 (Specification (Unit (Library_Unit (Item)))));
3936 while Present (Decl) loop
3937 if Nkind (Decl) = N_Package_Renaming_Declaration
3938 and then Entity (Name (Decl)) = P
3939 then
3940 -- Generate the error message only if the current unit
3941 -- is a package declaration; in case of subprogram
3942 -- bodies and package bodies we just return true to
3943 -- indicate that the limited view must not be
3944 -- installed.
3946 if Kind = N_Package_Declaration then
3947 Error_Msg_Sloc := Sloc (Item);
3948 Error_Msg_NE
3949 ("unlimited view of & visible through the context"
3950 & " clause found #", N, P);
3952 Error_Msg_Sloc := Sloc (Decl);
3953 Error_Msg_NE
3954 ("unlimited view of & visible through the"
3955 & " renaming found #", N, P);
3957 Error_Msg_N
3958 ("simultaneous visibility of the limited and"
3959 & " unlimited views not allowed", N);
3960 end if;
3962 return True;
3963 end if;
3965 Next (Decl);
3966 end loop;
3967 end if;
3969 Next (Item);
3970 end loop;
3972 if Present (Library_Unit (Aux_Unit)) then
3973 if Aux_Unit = Library_Unit (Aux_Unit) then
3975 -- Aux_Unit is a body that acts as a spec. Clause has
3976 -- already been flagged as illegal.
3978 return False;
3980 else
3981 Aux_Unit := Library_Unit (Aux_Unit);
3982 end if;
3983 else
3984 Aux_Unit := Parent_Spec (Unit (Aux_Unit));
3985 end if;
3987 exit when No (Aux_Unit);
3988 end loop;
3990 return False;
3991 end Is_Visible_Through_Renamings;
3993 -- Start of processing for Install_Limited_Withed_Unit
3995 begin
3996 pragma Assert (not Limited_View_Installed (N));
3998 -- In case of limited with_clause on subprograms, generics, instances,
3999 -- or renamings, the corresponding error was previously posted and we
4000 -- have nothing to do here.
4002 if Nkind (P_Unit) /= N_Package_Declaration then
4003 return;
4004 end if;
4006 P := Defining_Unit_Name (Specification (P_Unit));
4008 -- Handle child packages
4010 if Nkind (P) = N_Defining_Program_Unit_Name then
4011 Is_Child_Package := True;
4012 P := Defining_Identifier (P);
4013 end if;
4015 -- Do not install the limited-view if the full-view is already visible
4016 -- through renaming declarations.
4018 if Is_Visible_Through_Renamings (P) then
4019 return;
4020 end if;
4022 -- A common use of the limited-with is to have a limited-with
4023 -- in the package spec, and a normal with in its package body.
4024 -- For example:
4026 -- limited with X; -- [1]
4027 -- package A is ...
4029 -- with X; -- [2]
4030 -- package body A is ...
4032 -- The compilation of A's body installs the context clauses found at [2]
4033 -- and then the context clauses of its specification (found at [1]). As
4034 -- a consequence, at [1] the specification of X has been analyzed and it
4035 -- is immediately visible. According to the semantics of limited-with
4036 -- context clauses we don't install the limited view because the full
4037 -- view of X supersedes its limited view.
4039 if Analyzed (P_Unit)
4040 and then (Is_Immediately_Visible (P)
4041 or else (Is_Child_Package
4042 and then Is_Visible_Child_Unit (P)))
4043 then
4044 -- Ada 2005 (AI-262): Install the private declarations of P
4046 if Private_Present (N)
4047 and then not In_Private_Part (P)
4048 then
4049 declare
4050 Id : Entity_Id;
4052 begin
4053 Id := First_Private_Entity (P);
4054 while Present (Id) loop
4055 if not Is_Internal (Id)
4056 and then not Is_Child_Unit (Id)
4057 then
4058 if not In_Chain (Id) then
4059 Set_Homonym (Id, Current_Entity (Id));
4060 Set_Current_Entity (Id);
4061 end if;
4063 Set_Is_Immediately_Visible (Id);
4064 end if;
4066 Next_Entity (Id);
4067 end loop;
4069 Set_In_Private_Part (P);
4070 end;
4071 end if;
4073 return;
4074 end if;
4076 if Debug_Flag_I then
4077 Write_Str ("install limited view of ");
4078 Write_Name (Chars (P));
4079 Write_Eol;
4080 end if;
4082 -- If the unit has not been analyzed and the limited view has not been
4083 -- already installed then we install it.
4085 if not Analyzed (P_Unit) then
4086 if not In_Chain (P) then
4088 -- Minimum decoration
4090 Set_Ekind (P, E_Package);
4091 Set_Etype (P, Standard_Void_Type);
4092 Set_Scope (P, Standard_Standard);
4094 if Is_Child_Package then
4095 Set_Is_Child_Unit (P);
4096 Set_Is_Visible_Child_Unit (P);
4097 Set_Scope (P, Defining_Entity (Unit (Parent_Spec (P_Unit))));
4098 end if;
4100 -- Place entity on visibility structure
4102 Set_Homonym (P, Current_Entity (P));
4103 Set_Current_Entity (P);
4105 if Debug_Flag_I then
4106 Write_Str (" (homonym) chain ");
4107 Write_Name (Chars (P));
4108 Write_Eol;
4109 end if;
4111 -- Install the incomplete view. The first element of the limited
4112 -- view is a header (an E_Package entity) used to reference the
4113 -- first shadow entity in the private part of the package.
4115 Lim_Header := Limited_View (P);
4116 Lim_Typ := First_Entity (Lim_Header);
4118 while Present (Lim_Typ)
4119 and then Lim_Typ /= First_Private_Entity (Lim_Header)
4120 loop
4121 Set_Homonym (Lim_Typ, Current_Entity (Lim_Typ));
4122 Set_Current_Entity (Lim_Typ);
4124 if Debug_Flag_I then
4125 Write_Str (" (homonym) chain ");
4126 Write_Name (Chars (Lim_Typ));
4127 Write_Eol;
4128 end if;
4130 Next_Entity (Lim_Typ);
4131 end loop;
4132 end if;
4134 -- If the unit appears in a previous regular with_clause, the regular
4135 -- entities of the public part of the withed package must be replaced
4136 -- by the shadow ones.
4138 -- This code must be kept synchronized with the code that replaces the
4139 -- the shadow entities by the real entities (see body of Remove_Limited
4140 -- With_Clause); otherwise the contents of the homonym chains are not
4141 -- consistent.
4143 else
4144 -- Hide all the type entities of the public part of the package to
4145 -- avoid its usage. This is needed to cover all the subtype decla-
4146 -- rations because we do not remove them from the homonym chain.
4148 declare
4149 E : Entity_Id;
4151 begin
4152 E := First_Entity (P);
4153 while Present (E) and then E /= First_Private_Entity (P) loop
4154 if Is_Type (E) then
4155 Set_Was_Hidden (E, Is_Hidden (E));
4156 Set_Is_Hidden (E);
4157 end if;
4159 Next_Entity (E);
4160 end loop;
4161 end;
4163 -- Replace the real entities by the shadow entities of the limited
4164 -- view. The first element of the limited view is a header that is
4165 -- used to reference the first shadow entity in the private part
4166 -- of the package.
4168 Lim_Header := Limited_View (P);
4170 Lim_Typ := First_Entity (Lim_Header);
4171 while Present (Lim_Typ)
4172 and then Lim_Typ /= First_Private_Entity (Lim_Header)
4173 loop
4174 pragma Assert (not In_Chain (Lim_Typ));
4176 -- Do not unchain child units
4178 if not Is_Child_Unit (Lim_Typ) then
4179 declare
4180 Prev : Entity_Id;
4182 begin
4183 Set_Homonym (Lim_Typ, Homonym (Non_Limited_View (Lim_Typ)));
4184 Prev := Current_Entity (Lim_Typ);
4186 if Prev = Non_Limited_View (Lim_Typ) then
4187 Set_Current_Entity (Lim_Typ);
4188 else
4189 while Present (Prev)
4190 and then Homonym (Prev) /= Non_Limited_View (Lim_Typ)
4191 loop
4192 Prev := Homonym (Prev);
4193 end loop;
4195 Set_Homonym (Prev, Lim_Typ);
4196 end if;
4197 end;
4199 if Debug_Flag_I then
4200 Write_Str (" (homonym) chain ");
4201 Write_Name (Chars (Lim_Typ));
4202 Write_Eol;
4203 end if;
4204 end if;
4206 Next_Entity (Lim_Typ);
4207 end loop;
4208 end if;
4210 -- The package must be visible while the limited-with clause is active
4211 -- because references to the type P.T must resolve in the usual way.
4212 -- In addition, we remember that the limited-view has been installed to
4213 -- uninstall it at the point of context removal.
4215 Set_Is_Immediately_Visible (P);
4216 Set_Limited_View_Installed (N);
4218 -- If the package in the limited_with clause is a child unit, the
4219 -- clause is unanalyzed and appears as a selected component. Recast
4220 -- it as an expanded name so that the entity can be properly set. Use
4221 -- entity of parent, if available, for higher ancestors in the name.
4223 if Nkind (Name (N)) = N_Selected_Component then
4224 declare
4225 Nam : Node_Id;
4226 Ent : Entity_Id;
4227 begin
4228 Nam := Name (N);
4229 Ent := P;
4230 while Nkind (Nam) = N_Selected_Component
4231 and then Present (Ent)
4232 loop
4233 Change_Selected_Component_To_Expanded_Name (Nam);
4234 Nam := Prefix (Nam);
4235 Ent := Scope (Ent);
4236 end loop;
4237 end;
4238 end if;
4240 Set_Entity (Name (N), P);
4241 Set_From_With_Type (P);
4242 end Install_Limited_Withed_Unit;
4244 -------------------------
4245 -- Install_Withed_Unit --
4246 -------------------------
4248 procedure Install_Withed_Unit
4249 (With_Clause : Node_Id;
4250 Private_With_OK : Boolean := False)
4252 Uname : constant Entity_Id := Entity (Name (With_Clause));
4253 P : constant Entity_Id := Scope (Uname);
4255 begin
4256 -- Ada 2005 (AI-262): Do not install the private withed unit if we are
4257 -- compiling a package declaration and the Private_With_OK flag was not
4258 -- set by the caller. These declarations will be installed later (before
4259 -- analyzing the private part of the package).
4261 if Private_Present (With_Clause)
4262 and then Nkind (Unit (Parent (With_Clause))) = N_Package_Declaration
4263 and then not (Private_With_OK)
4264 then
4265 return;
4266 end if;
4268 if Debug_Flag_I then
4269 if Private_Present (With_Clause) then
4270 Write_Str ("install private withed unit ");
4271 else
4272 Write_Str ("install withed unit ");
4273 end if;
4275 Write_Name (Chars (Uname));
4276 Write_Eol;
4277 end if;
4279 -- We do not apply the restrictions to an internal unit unless
4280 -- we are compiling the internal unit as a main unit. This check
4281 -- is also skipped for dummy units (for missing packages).
4283 if Sloc (Uname) /= No_Location
4284 and then (not Is_Internal_File_Name (Unit_File_Name (Current_Sem_Unit))
4285 or else Current_Sem_Unit = Main_Unit)
4286 then
4287 Check_Restricted_Unit
4288 (Unit_Name (Get_Source_Unit (Uname)), With_Clause);
4289 end if;
4291 if P /= Standard_Standard then
4293 -- If the unit is not analyzed after analysis of the with clause and
4294 -- it is an instantiation then it awaits a body and is the main unit.
4295 -- Its appearance in the context of some other unit indicates a
4296 -- circular dependency (DEC suite perversity).
4298 if not Analyzed (Uname)
4299 and then Nkind (Parent (Uname)) = N_Package_Instantiation
4300 then
4301 Error_Msg_N
4302 ("instantiation depends on itself", Name (With_Clause));
4304 elsif not Is_Visible_Child_Unit (Uname) then
4305 Set_Is_Visible_Child_Unit (Uname);
4307 -- If the child unit appears in the context of its parent, it is
4308 -- immediately visible.
4310 if In_Open_Scopes (Scope (Uname)) then
4311 Set_Is_Immediately_Visible (Uname);
4312 end if;
4314 if Is_Generic_Instance (Uname)
4315 and then Ekind (Uname) in Subprogram_Kind
4316 then
4317 -- Set flag as well on the visible entity that denotes the
4318 -- instance, which renames the current one.
4320 Set_Is_Visible_Child_Unit
4321 (Related_Instance
4322 (Defining_Entity (Unit (Library_Unit (With_Clause)))));
4323 end if;
4325 -- The parent unit may have been installed already, and may have
4326 -- appeared in a use clause.
4328 if In_Use (Scope (Uname)) then
4329 Set_Is_Potentially_Use_Visible (Uname);
4330 end if;
4332 Set_Context_Installed (With_Clause);
4333 end if;
4335 elsif not Is_Immediately_Visible (Uname) then
4336 if not Private_Present (With_Clause)
4337 or else Private_With_OK
4338 then
4339 Set_Is_Immediately_Visible (Uname);
4340 end if;
4342 Set_Context_Installed (With_Clause);
4343 end if;
4345 -- A with-clause overrides a with-type clause: there are no restric-
4346 -- tions on the use of package entities.
4348 if Ekind (Uname) = E_Package then
4349 Set_From_With_Type (Uname, False);
4350 end if;
4352 -- Ada 2005 (AI-377): it is illegal for a with_clause to name a child
4353 -- unit if there is a visible homograph for it declared in the same
4354 -- declarative region. This pathological case can only arise when an
4355 -- instance I1 of a generic unit G1 has an explicit child unit I1.G2,
4356 -- G1 has a generic child also named G2, and the context includes with_
4357 -- clauses for both I1.G2 and for G1.G2, making an implicit declaration
4358 -- of I1.G2 visible as well. If the child unit is named Standard, do
4359 -- not apply the check to the Standard package itself.
4361 if Is_Child_Unit (Uname)
4362 and then Is_Visible_Child_Unit (Uname)
4363 and then Ada_Version >= Ada_05
4364 then
4365 declare
4366 Decl1 : constant Node_Id := Unit_Declaration_Node (P);
4367 Decl2 : Node_Id;
4368 P2 : Entity_Id;
4369 U2 : Entity_Id;
4371 begin
4372 U2 := Homonym (Uname);
4373 while Present (U2)
4374 and U2 /= Standard_Standard
4375 loop
4376 P2 := Scope (U2);
4377 Decl2 := Unit_Declaration_Node (P2);
4379 if Is_Child_Unit (U2)
4380 and then Is_Visible_Child_Unit (U2)
4381 then
4382 if Is_Generic_Instance (P)
4383 and then Nkind (Decl1) = N_Package_Declaration
4384 and then Generic_Parent (Specification (Decl1)) = P2
4385 then
4386 Error_Msg_N ("illegal with_clause", With_Clause);
4387 Error_Msg_N
4388 ("\child unit has visible homograph" &
4389 " ('R'M 8.3(26), 10.1.1(19))",
4390 With_Clause);
4391 exit;
4393 elsif Is_Generic_Instance (P2)
4394 and then Nkind (Decl2) = N_Package_Declaration
4395 and then Generic_Parent (Specification (Decl2)) = P
4396 then
4397 -- With_clause for child unit of instance appears before
4398 -- in the context. We want to place the error message on
4399 -- it, not on the generic child unit itself.
4401 declare
4402 Prev_Clause : Node_Id;
4404 begin
4405 Prev_Clause := First (List_Containing (With_Clause));
4406 while Entity (Name (Prev_Clause)) /= U2 loop
4407 Next (Prev_Clause);
4408 end loop;
4410 pragma Assert (Present (Prev_Clause));
4411 Error_Msg_N ("illegal with_clause", Prev_Clause);
4412 Error_Msg_N
4413 ("\child unit has visible homograph" &
4414 " ('R'M 8.3(26), 10.1.1(19))",
4415 Prev_Clause);
4416 exit;
4417 end;
4418 end if;
4419 end if;
4421 U2 := Homonym (U2);
4422 end loop;
4423 end;
4424 end if;
4425 end Install_Withed_Unit;
4427 -------------------
4428 -- Is_Child_Spec --
4429 -------------------
4431 function Is_Child_Spec (Lib_Unit : Node_Id) return Boolean is
4432 K : constant Node_Kind := Nkind (Lib_Unit);
4434 begin
4435 return (K in N_Generic_Declaration or else
4436 K in N_Generic_Instantiation or else
4437 K in N_Generic_Renaming_Declaration or else
4438 K = N_Package_Declaration or else
4439 K = N_Package_Renaming_Declaration or else
4440 K = N_Subprogram_Declaration or else
4441 K = N_Subprogram_Renaming_Declaration)
4442 and then Present (Parent_Spec (Lib_Unit));
4443 end Is_Child_Spec;
4445 -----------------------
4446 -- Load_Needed_Body --
4447 -----------------------
4449 -- N is a generic unit named in a with clause, or else it is
4450 -- a unit that contains a generic unit or an inlined function.
4451 -- In order to perform an instantiation, the body of the unit
4452 -- must be present. If the unit itself is generic, we assume
4453 -- that an instantiation follows, and load and analyze the body
4454 -- unconditionally. This forces analysis of the spec as well.
4456 -- If the unit is not generic, but contains a generic unit, it
4457 -- is loaded on demand, at the point of instantiation (see ch12).
4459 procedure Load_Needed_Body (N : Node_Id; OK : out Boolean) is
4460 Body_Name : Unit_Name_Type;
4461 Unum : Unit_Number_Type;
4463 Save_Style_Check : constant Boolean := Opt.Style_Check;
4464 -- The loading and analysis is done with style checks off
4466 begin
4467 if not GNAT_Mode then
4468 Style_Check := False;
4469 end if;
4471 Body_Name := Get_Body_Name (Get_Unit_Name (Unit (N)));
4472 Unum :=
4473 Load_Unit
4474 (Load_Name => Body_Name,
4475 Required => False,
4476 Subunit => False,
4477 Error_Node => N,
4478 Renamings => True);
4480 if Unum = No_Unit then
4481 OK := False;
4483 else
4484 Compiler_State := Analyzing; -- reset after load
4486 if not Fatal_Error (Unum) or else Try_Semantics then
4487 if Debug_Flag_L then
4488 Write_Str ("*** Loaded generic body");
4489 Write_Eol;
4490 end if;
4492 Semantics (Cunit (Unum));
4493 end if;
4495 OK := True;
4496 end if;
4498 Style_Check := Save_Style_Check;
4499 end Load_Needed_Body;
4501 -------------------------
4502 -- Build_Limited_Views --
4503 -------------------------
4505 procedure Build_Limited_Views (N : Node_Id) is
4506 Unum : constant Unit_Number_Type := Get_Source_Unit (Library_Unit (N));
4507 P : constant Entity_Id := Cunit_Entity (Unum);
4509 Spec : Node_Id; -- To denote a package specification
4510 Lim_Typ : Entity_Id; -- To denote shadow entities
4511 Comp_Typ : Entity_Id; -- To denote real entities
4513 Lim_Header : Entity_Id; -- Package entity
4514 Last_Lim_E : Entity_Id := Empty; -- Last limited entity built
4515 Last_Pub_Lim_E : Entity_Id; -- To set the first private entity
4517 procedure Decorate_Incomplete_Type
4518 (E : Entity_Id;
4519 Scop : Entity_Id);
4520 -- Add attributes of an incomplete type to a shadow entity. The same
4521 -- attributes are placed on the real entity, so that gigi receives
4522 -- a consistent view.
4524 procedure Decorate_Package_Specification (P : Entity_Id);
4525 -- Add attributes of a package entity to the entity in a package
4526 -- declaration
4528 procedure Decorate_Tagged_Type
4529 (Loc : Source_Ptr;
4530 T : Entity_Id;
4531 Scop : Entity_Id);
4532 -- Set basic attributes of tagged type T, including its class_wide type.
4533 -- The parameters Loc, Scope are used to decorate the class_wide type.
4535 procedure Build_Chain
4536 (Scope : Entity_Id;
4537 First_Decl : Node_Id);
4538 -- Construct list of shadow entities and attach it to entity of
4539 -- package that is mentioned in a limited_with clause.
4541 function New_Internal_Shadow_Entity
4542 (Kind : Entity_Kind;
4543 Sloc_Value : Source_Ptr;
4544 Id_Char : Character) return Entity_Id;
4545 -- Build a new internal entity and append it to the list of shadow
4546 -- entities available through the limited-header
4548 ------------------------------
4549 -- Decorate_Incomplete_Type --
4550 ------------------------------
4552 procedure Decorate_Incomplete_Type
4553 (E : Entity_Id;
4554 Scop : Entity_Id)
4556 begin
4557 Set_Ekind (E, E_Incomplete_Type);
4558 Set_Scope (E, Scop);
4559 Set_Etype (E, E);
4560 Set_Is_First_Subtype (E, True);
4561 Set_Stored_Constraint (E, No_Elist);
4562 Set_Full_View (E, Empty);
4563 Init_Size_Align (E);
4564 end Decorate_Incomplete_Type;
4566 --------------------------
4567 -- Decorate_Tagged_Type --
4568 --------------------------
4570 procedure Decorate_Tagged_Type
4571 (Loc : Source_Ptr;
4572 T : Entity_Id;
4573 Scop : Entity_Id)
4575 CW : Entity_Id;
4577 begin
4578 Decorate_Incomplete_Type (T, Scop);
4579 Set_Is_Tagged_Type (T);
4581 -- Build corresponding class_wide type, if not previously done
4583 if No (Class_Wide_Type (T)) then
4584 CW := Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
4586 Set_Ekind (CW, E_Class_Wide_Type);
4587 Set_Etype (CW, T);
4588 Set_Scope (CW, Scop);
4589 Set_Is_Tagged_Type (CW);
4590 Set_Is_First_Subtype (CW, True);
4591 Init_Size_Align (CW);
4592 Set_Has_Unknown_Discriminants (CW, True);
4593 Set_Class_Wide_Type (CW, CW);
4594 Set_Equivalent_Type (CW, Empty);
4595 Set_From_With_Type (CW, From_With_Type (T));
4597 Set_Class_Wide_Type (T, CW);
4598 end if;
4599 end Decorate_Tagged_Type;
4601 ------------------------------------
4602 -- Decorate_Package_Specification --
4603 ------------------------------------
4605 procedure Decorate_Package_Specification (P : Entity_Id) is
4606 begin
4607 -- Place only the most basic attributes
4609 Set_Ekind (P, E_Package);
4610 Set_Etype (P, Standard_Void_Type);
4611 end Decorate_Package_Specification;
4613 -------------------------
4614 -- New_Internal_Entity --
4615 -------------------------
4617 function New_Internal_Shadow_Entity
4618 (Kind : Entity_Kind;
4619 Sloc_Value : Source_Ptr;
4620 Id_Char : Character) return Entity_Id
4622 E : constant Entity_Id :=
4623 Make_Defining_Identifier (Sloc_Value,
4624 Chars => New_Internal_Name (Id_Char));
4626 begin
4627 Set_Ekind (E, Kind);
4628 Set_Is_Internal (E, True);
4630 if Kind in Type_Kind then
4631 Init_Size_Align (E);
4632 end if;
4634 Append_Entity (E, Lim_Header);
4635 Last_Lim_E := E;
4636 return E;
4637 end New_Internal_Shadow_Entity;
4639 -----------------
4640 -- Build_Chain --
4641 -----------------
4643 procedure Build_Chain
4644 (Scope : Entity_Id;
4645 First_Decl : Node_Id)
4647 Analyzed_Unit : constant Boolean := Analyzed (Cunit (Unum));
4648 Is_Tagged : Boolean;
4649 Decl : Node_Id;
4651 begin
4652 Decl := First_Decl;
4653 while Present (Decl) loop
4655 -- For each library_package_declaration in the environment, there
4656 -- is an implicit declaration of a *limited view* of that library
4657 -- package. The limited view of a package contains:
4659 -- * For each nested package_declaration, a declaration of the
4660 -- limited view of that package, with the same defining-
4661 -- program-unit name.
4663 -- * For each type_declaration in the visible part, an incomplete
4664 -- type-declaration with the same defining_identifier, whose
4665 -- completion is the type_declaration. If the type_declaration
4666 -- is tagged, then the incomplete_type_declaration is tagged
4667 -- incomplete.
4669 if Nkind (Decl) = N_Full_Type_Declaration then
4670 Is_Tagged :=
4671 Nkind (Type_Definition (Decl)) = N_Record_Definition
4672 and then Tagged_Present (Type_Definition (Decl));
4674 Comp_Typ := Defining_Identifier (Decl);
4676 if not Analyzed_Unit then
4677 if Is_Tagged then
4678 Decorate_Tagged_Type (Sloc (Decl), Comp_Typ, Scope);
4679 else
4680 Decorate_Incomplete_Type (Comp_Typ, Scope);
4681 end if;
4682 end if;
4684 -- Create shadow entity for type
4686 Lim_Typ := New_Internal_Shadow_Entity
4687 (Kind => Ekind (Comp_Typ),
4688 Sloc_Value => Sloc (Comp_Typ),
4689 Id_Char => 'Z');
4691 Set_Chars (Lim_Typ, Chars (Comp_Typ));
4692 Set_Parent (Lim_Typ, Parent (Comp_Typ));
4693 Set_From_With_Type (Lim_Typ);
4695 if Is_Tagged then
4696 Decorate_Tagged_Type (Sloc (Decl), Lim_Typ, Scope);
4697 else
4698 Decorate_Incomplete_Type (Lim_Typ, Scope);
4699 end if;
4701 Set_Non_Limited_View (Lim_Typ, Comp_Typ);
4703 elsif Nkind (Decl) = N_Private_Type_Declaration then
4704 Comp_Typ := Defining_Identifier (Decl);
4706 if not Analyzed_Unit then
4707 if Tagged_Present (Decl) then
4708 Decorate_Tagged_Type (Sloc (Decl), Comp_Typ, Scope);
4709 else
4710 Decorate_Incomplete_Type (Comp_Typ, Scope);
4711 end if;
4712 end if;
4714 Lim_Typ := New_Internal_Shadow_Entity
4715 (Kind => Ekind (Comp_Typ),
4716 Sloc_Value => Sloc (Comp_Typ),
4717 Id_Char => 'Z');
4719 Set_Chars (Lim_Typ, Chars (Comp_Typ));
4720 Set_Parent (Lim_Typ, Parent (Comp_Typ));
4721 Set_From_With_Type (Lim_Typ);
4723 if Tagged_Present (Decl) then
4724 Decorate_Tagged_Type (Sloc (Decl), Lim_Typ, Scope);
4725 else
4726 Decorate_Incomplete_Type (Lim_Typ, Scope);
4727 end if;
4729 Set_Non_Limited_View (Lim_Typ, Comp_Typ);
4731 elsif Nkind (Decl) = N_Private_Extension_Declaration then
4732 Comp_Typ := Defining_Identifier (Decl);
4734 if not Analyzed_Unit then
4735 Decorate_Tagged_Type (Sloc (Decl), Comp_Typ, Scope);
4736 end if;
4738 -- Create shadow entity for type
4740 Lim_Typ := New_Internal_Shadow_Entity
4741 (Kind => Ekind (Comp_Typ),
4742 Sloc_Value => Sloc (Comp_Typ),
4743 Id_Char => 'Z');
4745 Set_Chars (Lim_Typ, Chars (Comp_Typ));
4746 Set_Parent (Lim_Typ, Parent (Comp_Typ));
4747 Set_From_With_Type (Lim_Typ);
4749 Decorate_Tagged_Type (Sloc (Decl), Lim_Typ, Scope);
4750 Set_Non_Limited_View (Lim_Typ, Comp_Typ);
4752 elsif Nkind (Decl) = N_Package_Declaration then
4754 -- Local package
4756 declare
4757 Spec : constant Node_Id := Specification (Decl);
4759 begin
4760 Comp_Typ := Defining_Unit_Name (Spec);
4762 if not Analyzed (Cunit (Unum)) then
4763 Decorate_Package_Specification (Comp_Typ);
4764 Set_Scope (Comp_Typ, Scope);
4765 end if;
4767 Lim_Typ := New_Internal_Shadow_Entity
4768 (Kind => Ekind (Comp_Typ),
4769 Sloc_Value => Sloc (Comp_Typ),
4770 Id_Char => 'Z');
4772 Decorate_Package_Specification (Lim_Typ);
4773 Set_Scope (Lim_Typ, Scope);
4775 Set_Chars (Lim_Typ, Chars (Comp_Typ));
4776 Set_Parent (Lim_Typ, Parent (Comp_Typ));
4777 Set_From_With_Type (Lim_Typ);
4779 -- Note: The non_limited_view attribute is not used
4780 -- for local packages.
4782 Build_Chain
4783 (Scope => Lim_Typ,
4784 First_Decl => First (Visible_Declarations (Spec)));
4785 end;
4786 end if;
4788 Next (Decl);
4789 end loop;
4790 end Build_Chain;
4792 -- Start of processing for Build_Limited_Views
4794 begin
4795 pragma Assert (Limited_Present (N));
4797 -- A library_item mentioned in a limited_with_clause shall be
4798 -- a package_declaration, not a subprogram_declaration,
4799 -- generic_declaration, generic_instantiation, or
4800 -- package_renaming_declaration
4802 case Nkind (Unit (Library_Unit (N))) is
4804 when N_Package_Declaration =>
4805 null;
4807 when N_Subprogram_Declaration =>
4808 Error_Msg_N ("subprograms not allowed in "
4809 & "limited with_clauses", N);
4810 return;
4812 when N_Generic_Package_Declaration |
4813 N_Generic_Subprogram_Declaration =>
4814 Error_Msg_N ("generics not allowed in "
4815 & "limited with_clauses", N);
4816 return;
4818 when N_Generic_Instantiation =>
4819 Error_Msg_N ("generic instantiations not allowed in "
4820 & "limited with_clauses", N);
4821 return;
4823 when N_Generic_Renaming_Declaration =>
4824 Error_Msg_N ("generic renamings not allowed in "
4825 & "limited with_clauses", N);
4826 return;
4828 when N_Subprogram_Renaming_Declaration =>
4829 Error_Msg_N ("renamed subprograms not allowed in "
4830 & "limited with_clauses", N);
4831 return;
4833 when N_Package_Renaming_Declaration =>
4834 Error_Msg_N ("renamed packages not allowed in "
4835 & "limited with_clauses", N);
4836 return;
4838 when others =>
4839 raise Program_Error;
4840 end case;
4842 -- Check if the chain is already built
4844 Spec := Specification (Unit (Library_Unit (N)));
4846 if Limited_View_Installed (Spec) then
4847 return;
4848 end if;
4850 Set_Ekind (P, E_Package);
4852 -- Build the header of the limited_view
4854 Lim_Header := Make_Defining_Identifier (Sloc (N),
4855 Chars => New_Internal_Name (Id_Char => 'Z'));
4856 Set_Ekind (Lim_Header, E_Package);
4857 Set_Is_Internal (Lim_Header);
4858 Set_Limited_View (P, Lim_Header);
4860 -- Create the auxiliary chain. All the shadow entities are appended
4861 -- to the list of entities of the limited-view header
4863 Build_Chain
4864 (Scope => P,
4865 First_Decl => First (Visible_Declarations (Spec)));
4867 -- Save the last built shadow entity. It is needed later to set the
4868 -- reference to the first shadow entity in the private part
4870 Last_Pub_Lim_E := Last_Lim_E;
4872 -- Ada 2005 (AI-262): Add the limited view of the private declarations
4873 -- Required to give support to limited-private-with clauses
4875 Build_Chain (Scope => P,
4876 First_Decl => First (Private_Declarations (Spec)));
4878 if Last_Pub_Lim_E /= Empty then
4879 Set_First_Private_Entity (Lim_Header,
4880 Next_Entity (Last_Pub_Lim_E));
4881 else
4882 Set_First_Private_Entity (Lim_Header,
4883 First_Entity (P));
4884 end if;
4886 Set_Limited_View_Installed (Spec);
4887 end Build_Limited_Views;
4889 -------------------------------
4890 -- Check_Body_Needed_For_SAL --
4891 -------------------------------
4893 procedure Check_Body_Needed_For_SAL (Unit_Name : Entity_Id) is
4895 function Entity_Needs_Body (E : Entity_Id) return Boolean;
4896 -- Determine whether use of entity E might require the presence
4897 -- of its body. For a package this requires a recursive traversal
4898 -- of all nested declarations.
4900 ---------------------------
4901 -- Entity_Needed_For_SAL --
4902 ---------------------------
4904 function Entity_Needs_Body (E : Entity_Id) return Boolean is
4905 Ent : Entity_Id;
4907 begin
4908 if Is_Subprogram (E)
4909 and then Has_Pragma_Inline (E)
4910 then
4911 return True;
4913 elsif Ekind (E) = E_Generic_Function
4914 or else Ekind (E) = E_Generic_Procedure
4915 then
4916 return True;
4918 elsif Ekind (E) = E_Generic_Package
4919 and then
4920 Nkind (Unit_Declaration_Node (E)) = N_Generic_Package_Declaration
4921 and then Present (Corresponding_Body (Unit_Declaration_Node (E)))
4922 then
4923 return True;
4925 elsif Ekind (E) = E_Package
4926 and then
4927 Nkind (Unit_Declaration_Node (E)) = N_Package_Declaration
4928 and then Present (Corresponding_Body (Unit_Declaration_Node (E)))
4929 then
4930 Ent := First_Entity (E);
4931 while Present (Ent) loop
4932 if Entity_Needs_Body (Ent) then
4933 return True;
4934 end if;
4936 Next_Entity (Ent);
4937 end loop;
4939 return False;
4941 else
4942 return False;
4943 end if;
4944 end Entity_Needs_Body;
4946 -- Start of processing for Check_Body_Needed_For_SAL
4948 begin
4949 if Ekind (Unit_Name) = E_Generic_Package
4950 and then
4951 Nkind (Unit_Declaration_Node (Unit_Name)) =
4952 N_Generic_Package_Declaration
4953 and then
4954 Present (Corresponding_Body (Unit_Declaration_Node (Unit_Name)))
4955 then
4956 Set_Body_Needed_For_SAL (Unit_Name);
4958 elsif Ekind (Unit_Name) = E_Generic_Procedure
4959 or else Ekind (Unit_Name) = E_Generic_Function
4960 then
4961 Set_Body_Needed_For_SAL (Unit_Name);
4963 elsif Is_Subprogram (Unit_Name)
4964 and then Nkind (Unit_Declaration_Node (Unit_Name)) =
4965 N_Subprogram_Declaration
4966 and then Has_Pragma_Inline (Unit_Name)
4967 then
4968 Set_Body_Needed_For_SAL (Unit_Name);
4970 elsif Ekind (Unit_Name) = E_Subprogram_Body then
4971 Check_Body_Needed_For_SAL
4972 (Corresponding_Spec (Unit_Declaration_Node (Unit_Name)));
4974 elsif Ekind (Unit_Name) = E_Package
4975 and then Entity_Needs_Body (Unit_Name)
4976 then
4977 Set_Body_Needed_For_SAL (Unit_Name);
4979 elsif Ekind (Unit_Name) = E_Package_Body
4980 and then Nkind (Unit_Declaration_Node (Unit_Name)) = N_Package_Body
4981 then
4982 Check_Body_Needed_For_SAL
4983 (Corresponding_Spec (Unit_Declaration_Node (Unit_Name)));
4984 end if;
4985 end Check_Body_Needed_For_SAL;
4987 --------------------
4988 -- Remove_Context --
4989 --------------------
4991 procedure Remove_Context (N : Node_Id) is
4992 Lib_Unit : constant Node_Id := Unit (N);
4994 begin
4995 -- If this is a child unit, first remove the parent units
4997 if Is_Child_Spec (Lib_Unit) then
4998 Remove_Parents (Lib_Unit);
4999 end if;
5001 Remove_Context_Clauses (N);
5002 end Remove_Context;
5004 ----------------------------
5005 -- Remove_Context_Clauses --
5006 ----------------------------
5008 procedure Remove_Context_Clauses (N : Node_Id) is
5009 Item : Node_Id;
5010 Unit_Name : Entity_Id;
5012 begin
5013 -- Ada 2005 (AI-50217): We remove the context clauses in two phases:
5014 -- limited-views first and regular-views later (to maintain the
5015 -- stack model).
5017 -- First Phase: Remove limited_with context clauses
5019 Item := First (Context_Items (N));
5020 while Present (Item) loop
5022 -- We are interested only in with clauses which got installed
5023 -- on entry.
5025 if Nkind (Item) = N_With_Clause
5026 and then Limited_Present (Item)
5027 and then Limited_View_Installed (Item)
5028 then
5029 Remove_Limited_With_Clause (Item);
5030 end if;
5032 Next (Item);
5033 end loop;
5035 -- Second Phase: Loop through context items and undo regular
5036 -- with_clauses and use_clauses.
5038 Item := First (Context_Items (N));
5039 while Present (Item) loop
5041 -- We are interested only in with clauses which got installed
5042 -- on entry, as indicated by their Context_Installed flag set
5044 if Nkind (Item) = N_With_Clause
5045 and then Limited_Present (Item)
5046 and then Limited_View_Installed (Item)
5047 then
5048 null;
5050 elsif Nkind (Item) = N_With_Clause
5051 and then Context_Installed (Item)
5052 then
5053 -- Remove items from one with'ed unit
5055 Unit_Name := Entity (Name (Item));
5056 Remove_Unit_From_Visibility (Unit_Name);
5057 Set_Context_Installed (Item, False);
5059 elsif Nkind (Item) = N_Use_Package_Clause then
5060 End_Use_Package (Item);
5062 elsif Nkind (Item) = N_Use_Type_Clause then
5063 End_Use_Type (Item);
5065 elsif Nkind (Item) = N_With_Type_Clause then
5066 Remove_With_Type_Clause (Name (Item));
5067 end if;
5069 Next (Item);
5070 end loop;
5071 end Remove_Context_Clauses;
5073 --------------------------------
5074 -- Remove_Limited_With_Clause --
5075 --------------------------------
5077 procedure Remove_Limited_With_Clause (N : Node_Id) is
5078 P_Unit : constant Entity_Id := Unit (Library_Unit (N));
5079 P : Entity_Id;
5080 Lim_Header : Entity_Id;
5081 Lim_Typ : Entity_Id;
5082 Prev : Entity_Id;
5084 begin
5085 pragma Assert (Limited_View_Installed (N));
5087 -- In case of limited with_clause on subprograms, generics, instances,
5088 -- or renamings, the corresponding error was previously posted and we
5089 -- have nothing to do here.
5091 if Nkind (P_Unit) /= N_Package_Declaration then
5092 return;
5093 end if;
5095 P := Defining_Unit_Name (Specification (P_Unit));
5097 -- Handle child packages
5099 if Nkind (P) = N_Defining_Program_Unit_Name then
5100 P := Defining_Identifier (P);
5101 end if;
5103 if Debug_Flag_I then
5104 Write_Str ("remove limited view of ");
5105 Write_Name (Chars (P));
5106 Write_Str (" from visibility");
5107 Write_Eol;
5108 end if;
5110 -- Prepare the removal of the shadow entities from visibility. The
5111 -- first element of the limited view is a header (an E_Package
5112 -- entity) that is used to reference the first shadow entity in the
5113 -- private part of the package
5115 Lim_Header := Limited_View (P);
5116 Lim_Typ := First_Entity (Lim_Header);
5118 -- Remove package and shadow entities from visibility if it has not
5119 -- been analyzed
5121 if not Analyzed (P_Unit) then
5122 Unchain (P);
5123 Set_Is_Immediately_Visible (P, False);
5125 while Present (Lim_Typ) loop
5126 Unchain (Lim_Typ);
5127 Next_Entity (Lim_Typ);
5128 end loop;
5130 -- Otherwise this package has already appeared in the closure and its
5131 -- shadow entities must be replaced by its real entities. This code
5132 -- must be kept synchronized with the complementary code in Install
5133 -- Limited_Withed_Unit.
5135 else
5136 -- Real entities that are type or subtype declarations were hidden
5137 -- from visibility at the point of installation of the limited-view.
5138 -- Now we recover the previous value of the hidden attribute.
5140 declare
5141 E : Entity_Id;
5143 begin
5144 E := First_Entity (P);
5145 while Present (E) and then E /= First_Private_Entity (P) loop
5146 if Is_Type (E) then
5147 Set_Is_Hidden (E, Was_Hidden (E));
5148 end if;
5150 Next_Entity (E);
5151 end loop;
5152 end;
5154 while Present (Lim_Typ)
5155 and then Lim_Typ /= First_Private_Entity (Lim_Header)
5156 loop
5157 pragma Assert (not In_Chain (Non_Limited_View (Lim_Typ)));
5159 -- Child units have not been unchained
5161 if not Is_Child_Unit (Non_Limited_View (Lim_Typ)) then
5162 Prev := Current_Entity (Lim_Typ);
5164 if Prev = Lim_Typ then
5165 Set_Current_Entity (Non_Limited_View (Lim_Typ));
5166 else
5167 while Present (Prev)
5168 and then Homonym (Prev) /= Lim_Typ
5169 loop
5170 Prev := Homonym (Prev);
5171 end loop;
5173 pragma Assert (Present (Prev));
5174 Set_Homonym (Prev, Non_Limited_View (Lim_Typ));
5175 end if;
5177 -- We must also set the next homonym entity of the real entity
5178 -- to handle the case in which the next homonym was a shadow
5179 -- entity.
5181 Set_Homonym (Non_Limited_View (Lim_Typ), Homonym (Lim_Typ));
5182 end if;
5184 Next_Entity (Lim_Typ);
5185 end loop;
5186 end if;
5188 -- Indicate that the limited view of the package is not installed
5190 Set_From_With_Type (P, False);
5191 Set_Limited_View_Installed (N, False);
5192 end Remove_Limited_With_Clause;
5194 --------------------
5195 -- Remove_Parents --
5196 --------------------
5198 procedure Remove_Parents (Lib_Unit : Node_Id) is
5199 P : Node_Id;
5200 P_Name : Entity_Id;
5201 P_Spec : Node_Id := Empty;
5202 E : Entity_Id;
5203 Vis : constant Boolean :=
5204 Scope_Stack.Table (Scope_Stack.Last).Previous_Visibility;
5206 begin
5207 if Is_Child_Spec (Lib_Unit) then
5208 P_Spec := Parent_Spec (Lib_Unit);
5210 elsif Nkind (Lib_Unit) = N_Package_Body
5211 and then Nkind (Original_Node (Lib_Unit)) = N_Package_Instantiation
5212 then
5213 P_Spec := Parent_Spec (Original_Node (Lib_Unit));
5214 end if;
5216 if Present (P_Spec) then
5218 P := Unit (P_Spec);
5219 P_Name := Get_Parent_Entity (P);
5220 Remove_Context_Clauses (P_Spec);
5221 End_Package_Scope (P_Name);
5222 Set_Is_Immediately_Visible (P_Name, Vis);
5224 -- Remove from visibility the siblings as well, which are directly
5225 -- visible while the parent is in scope.
5227 E := First_Entity (P_Name);
5228 while Present (E) loop
5229 if Is_Child_Unit (E) then
5230 Set_Is_Immediately_Visible (E, False);
5231 end if;
5233 Next_Entity (E);
5234 end loop;
5236 Set_In_Package_Body (P_Name, False);
5238 -- This is the recursive call to remove the context of any
5239 -- higher level parent. This recursion ensures that all parents
5240 -- are removed in the reverse order of their installation.
5242 Remove_Parents (P);
5243 end if;
5244 end Remove_Parents;
5246 -----------------------------
5247 -- Remove_With_Type_Clause --
5248 -----------------------------
5250 procedure Remove_With_Type_Clause (Name : Node_Id) is
5251 Typ : Entity_Id;
5252 P : Entity_Id;
5254 procedure Unchain (E : Entity_Id);
5255 -- Remove entity from visibility list
5257 -------------
5258 -- Unchain --
5259 -------------
5261 procedure Unchain (E : Entity_Id) is
5262 Prev : Entity_Id;
5264 begin
5265 Prev := Current_Entity (E);
5267 -- Package entity may appear is several with_type_clauses, and
5268 -- may have been removed already.
5270 if No (Prev) then
5271 return;
5273 elsif Prev = E then
5274 Set_Name_Entity_Id (Chars (E), Homonym (E));
5276 else
5277 while Present (Prev)
5278 and then Homonym (Prev) /= E
5279 loop
5280 Prev := Homonym (Prev);
5281 end loop;
5283 if Present (Prev) then
5284 Set_Homonym (Prev, Homonym (E));
5285 end if;
5286 end if;
5287 end Unchain;
5289 -- Start of processing for Remove_With_Type_Clause
5291 begin
5292 if Nkind (Name) = N_Selected_Component then
5293 Typ := Entity (Selector_Name (Name));
5295 -- If no Typ, then error in declaration, ignore
5297 if No (Typ) then
5298 return;
5299 end if;
5300 else
5301 return;
5302 end if;
5304 P := Scope (Typ);
5306 -- If the exporting package has been analyzed, it has appeared in the
5307 -- context already and should be left alone. Otherwise, remove from
5308 -- visibility.
5310 if not Analyzed (Unit_Declaration_Node (P)) then
5311 Unchain (P);
5312 Unchain (Typ);
5313 Set_Is_Frozen (Typ, False);
5314 end if;
5316 if Ekind (Typ) = E_Record_Type then
5317 Set_From_With_Type (Class_Wide_Type (Typ), False);
5318 Set_From_With_Type (Typ, False);
5319 end if;
5321 Set_From_With_Type (P, False);
5323 -- If P is a child unit, remove parents as well
5325 P := Scope (P);
5326 while Present (P)
5327 and then P /= Standard_Standard
5328 loop
5329 Set_From_With_Type (P, False);
5331 if not Analyzed (Unit_Declaration_Node (P)) then
5332 Unchain (P);
5333 end if;
5335 P := Scope (P);
5336 end loop;
5338 -- The back-end needs to know that an access type is imported, so it
5339 -- does not need elaboration and can appear in a mutually recursive
5340 -- record definition, so the imported flag on an access type is
5341 -- preserved.
5343 end Remove_With_Type_Clause;
5345 ---------------------------------
5346 -- Remove_Unit_From_Visibility --
5347 ---------------------------------
5349 procedure Remove_Unit_From_Visibility (Unit_Name : Entity_Id) is
5350 P : constant Entity_Id := Scope (Unit_Name);
5352 begin
5354 if Debug_Flag_I then
5355 Write_Str ("remove unit ");
5356 Write_Name (Chars (Unit_Name));
5357 Write_Str (" from visibility");
5358 Write_Eol;
5359 end if;
5361 if P /= Standard_Standard then
5362 Set_Is_Visible_Child_Unit (Unit_Name, False);
5363 end if;
5365 Set_Is_Potentially_Use_Visible (Unit_Name, False);
5366 Set_Is_Immediately_Visible (Unit_Name, False);
5368 end Remove_Unit_From_Visibility;
5370 -------------
5371 -- Unchain --
5372 -------------
5374 procedure Unchain (E : Entity_Id) is
5375 Prev : Entity_Id;
5377 begin
5378 Prev := Current_Entity (E);
5380 if No (Prev) then
5381 return;
5383 elsif Prev = E then
5384 Set_Name_Entity_Id (Chars (E), Homonym (E));
5386 else
5387 while Present (Prev)
5388 and then Homonym (Prev) /= E
5389 loop
5390 Prev := Homonym (Prev);
5391 end loop;
5393 if Present (Prev) then
5394 Set_Homonym (Prev, Homonym (E));
5395 end if;
5396 end if;
5398 if Debug_Flag_I then
5399 Write_Str (" (homonym) unchain ");
5400 Write_Name (Chars (E));
5401 Write_Eol;
5402 end if;
5404 end Unchain;
5406 end Sem_Ch10;