1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
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 3, 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 COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- As a special exception, if other files instantiate generics from this --
22 -- unit, or you link this unit with other files to produce an executable, --
23 -- this unit does not by itself cause the resulting executable to be --
24 -- covered by the GNU General Public License. This exception does not --
25 -- however invalidate any other reasons why the executable file might be --
26 -- covered by the GNU Public License. --
28 -- GNAT was originally developed by the GNAT team at New York University. --
29 -- Extensive contributions were provided by Ada Core Technologies Inc. --
31 ------------------------------------------------------------------------------
33 with Atree; use Atree;
34 with Einfo; use Einfo;
35 with Namet; use Namet;
36 with Sinfo; use Sinfo;
37 with Snames; use Snames;
38 with Stand; use Stand;
40 package body Sem_Aux is
42 ----------------------
43 -- Ancestor_Subtype --
44 ----------------------
46 function Ancestor_Subtype (Typ : Entity_Id) return Entity_Id is
48 -- If this is first subtype, or is a base type, then there is no
49 -- ancestor subtype, so we return Empty to indicate this fact.
51 if Is_First_Subtype (Typ) or else Typ = Base_Type (Typ) then
56 D : constant Node_Id := Declaration_Node (Typ);
59 -- If we have a subtype declaration, get the ancestor subtype
61 if Nkind (D) = N_Subtype_Declaration then
62 if Nkind (Subtype_Indication (D)) = N_Subtype_Indication then
63 return Entity (Subtype_Mark (Subtype_Indication (D)));
65 return Entity (Subtype_Indication (D));
68 -- If not, then no subtype indication is available
80 function Available_View (Typ : Entity_Id) return Entity_Id is
82 if Is_Incomplete_Type (Typ)
83 and then Present (Non_Limited_View (Typ))
85 -- The non-limited view may itself be an incomplete type, in which
86 -- case get its full view.
88 return Get_Full_View (Non_Limited_View (Typ));
90 elsif Is_Class_Wide_Type (Typ)
91 and then Is_Incomplete_Type (Etype (Typ))
92 and then Present (Non_Limited_View (Etype (Typ)))
94 return Class_Wide_Type (Non_Limited_View (Etype (Typ)));
105 function Constant_Value (Ent : Entity_Id) return Node_Id is
106 D : constant Node_Id := Declaration_Node (Ent);
110 -- If we have no declaration node, then return no constant value. Not
111 -- clear how this can happen, but it does sometimes and this is the
117 -- Normal case where a declaration node is present
119 elsif Nkind (D) = N_Object_Renaming_Declaration then
120 return Renamed_Object (Ent);
122 -- If this is a component declaration whose entity is a constant, it is
123 -- a prival within a protected function (and so has no constant value).
125 elsif Nkind (D) = N_Component_Declaration then
128 -- If there is an expression, return it
130 elsif Present (Expression (D)) then
131 return (Expression (D));
133 -- For a constant, see if we have a full view
135 elsif Ekind (Ent) = E_Constant
136 and then Present (Full_View (Ent))
138 Full_D := Parent (Full_View (Ent));
140 -- The full view may have been rewritten as an object renaming
142 if Nkind (Full_D) = N_Object_Renaming_Declaration then
143 return Name (Full_D);
145 return Expression (Full_D);
148 -- Otherwise we have no expression to return
155 -----------------------------
156 -- Enclosing_Dynamic_Scope --
157 -----------------------------
159 function Enclosing_Dynamic_Scope (Ent : Entity_Id) return Entity_Id is
163 -- The following test is an error defense against some syntax errors
164 -- that can leave scopes very messed up.
166 if Ent = Standard_Standard then
170 -- Normal case, search enclosing scopes
172 -- Note: the test for Present (S) should not be required, it defends
173 -- against an ill-formed tree.
177 -- If we somehow got an empty value for Scope, the tree must be
178 -- malformed. Rather than blow up we return Standard in this case.
181 return Standard_Standard;
183 -- Quit if we get to standard or a dynamic scope
185 elsif S = Standard_Standard
186 or else Is_Dynamic_Scope (S)
190 -- Otherwise keep climbing
196 end Enclosing_Dynamic_Scope;
198 ------------------------
199 -- First_Discriminant --
200 ------------------------
202 function First_Discriminant (Typ : Entity_Id) return Entity_Id is
207 (Has_Discriminants (Typ)
208 or else Has_Unknown_Discriminants (Typ));
210 Ent := First_Entity (Typ);
212 -- The discriminants are not necessarily contiguous, because access
213 -- discriminants will generate itypes. They are not the first entities
214 -- either, because tag and controller record must be ahead of them.
216 if Chars (Ent) = Name_uTag then
217 Ent := Next_Entity (Ent);
220 if Chars (Ent) = Name_uController then
221 Ent := Next_Entity (Ent);
224 -- Skip all hidden stored discriminants if any
226 while Present (Ent) loop
227 exit when Ekind (Ent) = E_Discriminant
228 and then not Is_Completely_Hidden (Ent);
230 Ent := Next_Entity (Ent);
233 pragma Assert (Ekind (Ent) = E_Discriminant);
236 end First_Discriminant;
238 -------------------------------
239 -- First_Stored_Discriminant --
240 -------------------------------
242 function First_Stored_Discriminant (Typ : Entity_Id) return Entity_Id is
245 function Has_Completely_Hidden_Discriminant
246 (Typ : Entity_Id) return Boolean;
247 -- Scans the Discriminants to see whether any are Completely_Hidden
248 -- (the mechanism for describing non-specified stored discriminants)
250 ----------------------------------------
251 -- Has_Completely_Hidden_Discriminant --
252 ----------------------------------------
254 function Has_Completely_Hidden_Discriminant
255 (Typ : Entity_Id) return Boolean
260 pragma Assert (Ekind (Typ) = E_Discriminant);
263 while Present (Ent) and then Ekind (Ent) = E_Discriminant loop
264 if Is_Completely_Hidden (Ent) then
268 Ent := Next_Entity (Ent);
272 end Has_Completely_Hidden_Discriminant;
274 -- Start of processing for First_Stored_Discriminant
278 (Has_Discriminants (Typ)
279 or else Has_Unknown_Discriminants (Typ));
281 Ent := First_Entity (Typ);
283 if Chars (Ent) = Name_uTag then
284 Ent := Next_Entity (Ent);
287 if Chars (Ent) = Name_uController then
288 Ent := Next_Entity (Ent);
291 if Has_Completely_Hidden_Discriminant (Ent) then
293 while Present (Ent) loop
294 exit when Is_Completely_Hidden (Ent);
295 Ent := Next_Entity (Ent);
300 pragma Assert (Ekind (Ent) = E_Discriminant);
303 end First_Stored_Discriminant;
309 function First_Subtype (Typ : Entity_Id) return Entity_Id is
310 B : constant Entity_Id := Base_Type (Typ);
311 F : constant Node_Id := Freeze_Node (B);
315 -- If the base type has no freeze node, it is a type in Standard, and
316 -- always acts as its own first subtype, except where it is one of the
317 -- predefined integer types. If the type is formal, it is also a first
318 -- subtype, and its base type has no freeze node. On the other hand, a
319 -- subtype of a generic formal is not its own first subtype. Its base
320 -- type, if anonymous, is attached to the formal type decl. from which
321 -- the first subtype is obtained.
324 if B = Base_Type (Standard_Integer) then
325 return Standard_Integer;
327 elsif B = Base_Type (Standard_Long_Integer) then
328 return Standard_Long_Integer;
330 elsif B = Base_Type (Standard_Short_Short_Integer) then
331 return Standard_Short_Short_Integer;
333 elsif B = Base_Type (Standard_Short_Integer) then
334 return Standard_Short_Integer;
336 elsif B = Base_Type (Standard_Long_Long_Integer) then
337 return Standard_Long_Long_Integer;
339 elsif Is_Generic_Type (Typ) then
340 if Present (Parent (B)) then
341 return Defining_Identifier (Parent (B));
343 return Defining_Identifier (Associated_Node_For_Itype (B));
350 -- Otherwise we check the freeze node, if it has a First_Subtype_Link
351 -- then we use that link, otherwise (happens with some Itypes), we use
352 -- the base type itself.
355 Ent := First_Subtype_Link (F);
357 if Present (Ent) then
365 -------------------------
366 -- First_Tag_Component --
367 -------------------------
369 function First_Tag_Component (Typ : Entity_Id) return Entity_Id is
375 pragma Assert (Is_Tagged_Type (Ctyp));
377 if Is_Class_Wide_Type (Ctyp) then
378 Ctyp := Root_Type (Ctyp);
381 if Is_Private_Type (Ctyp) then
382 Ctyp := Underlying_Type (Ctyp);
384 -- If the underlying type is missing then the source program has
385 -- errors and there is nothing else to do (the full-type declaration
386 -- associated with the private type declaration is missing).
393 Comp := First_Entity (Ctyp);
394 while Present (Comp) loop
395 if Is_Tag (Comp) then
399 Comp := Next_Entity (Comp);
402 -- No tag component found
405 end First_Tag_Component;
411 procedure Initialize is
413 Obsolescent_Warnings.Init;
416 ---------------------
417 -- Is_By_Copy_Type --
418 ---------------------
420 function Is_By_Copy_Type (Ent : Entity_Id) return Boolean is
422 -- If Id is a private type whose full declaration has not been seen,
423 -- we assume for now that it is not a By_Copy type. Clearly this
424 -- attribute should not be used before the type is frozen, but it is
425 -- needed to build the associated record of a protected type. Another
426 -- place where some lookahead for a full view is needed ???
429 Is_Elementary_Type (Ent)
430 or else (Is_Private_Type (Ent)
431 and then Present (Underlying_Type (Ent))
432 and then Is_Elementary_Type (Underlying_Type (Ent)));
435 --------------------------
436 -- Is_By_Reference_Type --
437 --------------------------
439 function Is_By_Reference_Type (Ent : Entity_Id) return Boolean is
440 Btype : constant Entity_Id := Base_Type (Ent);
443 if Error_Posted (Ent)
444 or else Error_Posted (Btype)
448 elsif Is_Private_Type (Btype) then
450 Utyp : constant Entity_Id := Underlying_Type (Btype);
455 return Is_By_Reference_Type (Utyp);
459 elsif Is_Incomplete_Type (Btype) then
461 Ftyp : constant Entity_Id := Full_View (Btype);
466 return Is_By_Reference_Type (Ftyp);
470 elsif Is_Concurrent_Type (Btype) then
473 elsif Is_Record_Type (Btype) then
474 if Is_Limited_Record (Btype)
475 or else Is_Tagged_Type (Btype)
476 or else Is_Volatile (Btype)
485 C := First_Component (Btype);
486 while Present (C) loop
487 if Is_By_Reference_Type (Etype (C))
488 or else Is_Volatile (Etype (C))
493 C := Next_Component (C);
500 elsif Is_Array_Type (Btype) then
503 or else Is_By_Reference_Type (Component_Type (Btype))
504 or else Is_Volatile (Component_Type (Btype))
505 or else Has_Volatile_Components (Btype);
510 end Is_By_Reference_Type;
512 ---------------------
513 -- Is_Derived_Type --
514 ---------------------
516 function Is_Derived_Type (Ent : E) return B is
521 and then Base_Type (Ent) /= Root_Type (Ent)
522 and then not Is_Class_Wide_Type (Ent)
524 if not Is_Numeric_Type (Root_Type (Ent)) then
528 Par := Parent (First_Subtype (Ent));
531 and then Nkind (Par) = N_Full_Type_Declaration
532 and then Nkind (Type_Definition (Par)) =
533 N_Derived_Type_Definition;
541 ---------------------------
542 -- Is_Indefinite_Subtype --
543 ---------------------------
545 function Is_Indefinite_Subtype (Ent : Entity_Id) return Boolean is
546 K : constant Entity_Kind := Ekind (Ent);
549 if Is_Constrained (Ent) then
552 elsif K in Array_Kind
553 or else K in Class_Wide_Kind
554 or else Has_Unknown_Discriminants (Ent)
558 -- Known discriminants: indefinite if there are no default values
560 elsif K in Record_Kind
561 or else Is_Incomplete_Or_Private_Type (Ent)
562 or else Is_Concurrent_Type (Ent)
564 return (Has_Discriminants (Ent)
566 No (Discriminant_Default_Value (First_Discriminant (Ent))));
571 end Is_Indefinite_Subtype;
573 -------------------------------
574 -- Is_Immutably_Limited_Type --
575 -------------------------------
577 function Is_Immutably_Limited_Type (Ent : Entity_Id) return Boolean is
578 Btype : constant Entity_Id := Base_Type (Ent);
581 if Ekind (Btype) = E_Limited_Private_Type
582 and then Nkind (Parent (Btype)) = N_Formal_Type_Declaration
584 return not In_Package_Body (Scope ((Btype)));
587 if Is_Private_Type (Btype) then
589 -- AI05-0063: A type derived from a limited private formal type is
590 -- not immutably limited in a generic body.
592 if Is_Derived_Type (Btype)
593 and then Is_Generic_Type (Etype (Btype))
595 if not Is_Limited_Type (Etype (Btype)) then
598 elsif Ekind (Scope (Etype (Btype))) = E_Generic_Package then
599 return not In_Package_Body (Scope (Etype (Btype)));
607 Utyp : constant Entity_Id := Underlying_Type (Btype);
612 return Is_Immutably_Limited_Type (Utyp);
617 elsif Is_Concurrent_Type (Btype) then
620 elsif Is_Record_Type (Btype) then
622 -- Note that we return True for all limited interfaces, even though
623 -- (unsynchronized) limited interfaces can have descendants that are
624 -- nonlimited, because this is a predicate on the type itself, and
625 -- things like functions with limited interface results need to be
626 -- handled as build in place even though they might return objects
627 -- of a type that is not inherently limited.
629 if Is_Limited_Record (Btype) then
632 elsif Is_Class_Wide_Type (Btype) then
633 return Is_Immutably_Limited_Type (Root_Type (Btype));
640 C := First_Component (Btype);
641 while Present (C) loop
643 -- Don't consider components with interface types (which can
644 -- only occur in the case of a _parent component anyway).
645 -- They don't have any components, plus it would cause this
646 -- function to return true for nonlimited types derived from
647 -- limited intefaces.
649 if not Is_Interface (Etype (C))
650 and then Is_Immutably_Limited_Type (Etype (C))
655 C := Next_Component (C);
662 elsif Is_Array_Type (Btype) then
663 return Is_Immutably_Limited_Type (Component_Type (Btype));
668 end Is_Immutably_Limited_Type;
670 ---------------------
671 -- Is_Limited_Type --
672 ---------------------
674 function Is_Limited_Type (Ent : Entity_Id) return Boolean is
675 Btype : constant E := Base_Type (Ent);
676 Rtype : constant E := Root_Type (Btype);
679 if not Is_Type (Ent) then
682 elsif Ekind (Btype) = E_Limited_Private_Type
683 or else Is_Limited_Composite (Btype)
687 elsif Is_Concurrent_Type (Btype) then
690 -- The Is_Limited_Record flag normally indicates that the type is
691 -- limited. The exception is that a type does not inherit limitedness
692 -- from its interface ancestor. So the type may be derived from a
693 -- limited interface, but is not limited.
695 elsif Is_Limited_Record (Ent)
696 and then not Is_Interface (Ent)
700 -- Otherwise we will look around to see if there is some other reason
701 -- for it to be limited, except that if an error was posted on the
702 -- entity, then just assume it is non-limited, because it can cause
703 -- trouble to recurse into a murky erroneous entity!
705 elsif Error_Posted (Ent) then
708 elsif Is_Record_Type (Btype) then
710 if Is_Limited_Interface (Ent) then
713 -- AI-419: limitedness is not inherited from a limited interface
715 elsif Is_Limited_Record (Rtype) then
716 return not Is_Interface (Rtype)
717 or else Is_Protected_Interface (Rtype)
718 or else Is_Synchronized_Interface (Rtype)
719 or else Is_Task_Interface (Rtype);
721 elsif Is_Class_Wide_Type (Btype) then
722 return Is_Limited_Type (Rtype);
729 C := First_Component (Btype);
730 while Present (C) loop
731 if Is_Limited_Type (Etype (C)) then
735 C := Next_Component (C);
742 elsif Is_Array_Type (Btype) then
743 return Is_Limited_Type (Component_Type (Btype));
750 ---------------------------
751 -- Nearest_Dynamic_Scope --
752 ---------------------------
754 function Nearest_Dynamic_Scope (Ent : Entity_Id) return Entity_Id is
756 if Is_Dynamic_Scope (Ent) then
759 return Enclosing_Dynamic_Scope (Ent);
761 end Nearest_Dynamic_Scope;
763 ------------------------
764 -- Next_Tag_Component --
765 ------------------------
767 function Next_Tag_Component (Tag : Entity_Id) return Entity_Id is
771 pragma Assert (Is_Tag (Tag));
773 -- Loop to look for next tag component
775 Comp := Next_Entity (Tag);
776 while Present (Comp) loop
777 if Is_Tag (Comp) then
778 pragma Assert (Chars (Comp) /= Name_uTag);
782 Comp := Next_Entity (Comp);
785 -- No tag component found
788 end Next_Tag_Component;
790 --------------------------
791 -- Number_Discriminants --
792 --------------------------
794 function Number_Discriminants (Typ : Entity_Id) return Pos is
800 Discr := First_Discriminant (Typ);
801 while Present (Discr) loop
803 Discr := Next_Discriminant (Discr);
807 end Number_Discriminants;
813 procedure Tree_Read is
815 Obsolescent_Warnings.Tree_Read;
822 procedure Tree_Write is
824 Obsolescent_Warnings.Tree_Write;
831 function Ultimate_Alias (Prim : Entity_Id) return Entity_Id is
832 E : Entity_Id := Prim;
835 while Present (Alias (E)) loop
836 pragma Assert (Alias (E) /= E);