1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2014, 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 Sinfo; use Sinfo;
36 with Snames; use Snames;
37 with Stand; use Stand;
38 with Uintp; use Uintp;
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 Is_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 (Ent : Entity_Id) return Entity_Id is
82 -- Obtain the non-limited (non-abstract) view of a state or variable
84 if Ekind (Ent) = E_Abstract_State
85 and then Present (Non_Limited_View (Ent))
87 return Non_Limited_View (Ent);
89 -- The non-limited view of an incomplete type may itself be incomplete
90 -- in which case obtain its full view.
92 elsif Is_Incomplete_Type (Ent)
93 and then Present (Non_Limited_View (Ent))
95 return Get_Full_View (Non_Limited_View (Ent));
97 -- If it is class_wide, check whether the specific type comes from a
100 elsif Is_Class_Wide_Type (Ent)
101 and then Is_Incomplete_Type (Etype (Ent))
102 and then From_Limited_With (Etype (Ent))
103 and then Present (Non_Limited_View (Etype (Ent)))
105 return Class_Wide_Type (Non_Limited_View (Etype (Ent)));
107 -- In all other cases, return entity unchanged
118 function Constant_Value (Ent : Entity_Id) return Node_Id is
119 D : constant Node_Id := Declaration_Node (Ent);
123 -- If we have no declaration node, then return no constant value. Not
124 -- clear how this can happen, but it does sometimes and this is the
130 -- Normal case where a declaration node is present
132 elsif Nkind (D) = N_Object_Renaming_Declaration then
133 return Renamed_Object (Ent);
135 -- If this is a component declaration whose entity is a constant, it is
136 -- a prival within a protected function (and so has no constant value).
138 elsif Nkind (D) = N_Component_Declaration then
141 -- If there is an expression, return it
143 elsif Present (Expression (D)) then
144 return (Expression (D));
146 -- For a constant, see if we have a full view
148 elsif Ekind (Ent) = E_Constant
149 and then Present (Full_View (Ent))
151 Full_D := Parent (Full_View (Ent));
153 -- The full view may have been rewritten as an object renaming
155 if Nkind (Full_D) = N_Object_Renaming_Declaration then
156 return Name (Full_D);
158 return Expression (Full_D);
161 -- Otherwise we have no expression to return
168 ---------------------------------
169 -- Corresponding_Unsigned_Type --
170 ---------------------------------
172 function Corresponding_Unsigned_Type (Typ : Entity_Id) return Entity_Id is
173 pragma Assert (Is_Signed_Integer_Type (Typ));
174 Siz : constant Uint := Esize (Base_Type (Typ));
176 if Siz = Esize (Standard_Short_Short_Integer) then
177 return Standard_Short_Short_Unsigned;
178 elsif Siz = Esize (Standard_Short_Integer) then
179 return Standard_Short_Unsigned;
180 elsif Siz = Esize (Standard_Unsigned) then
181 return Standard_Unsigned;
182 elsif Siz = Esize (Standard_Long_Integer) then
183 return Standard_Long_Unsigned;
184 elsif Siz = Esize (Standard_Long_Long_Integer) then
185 return Standard_Long_Long_Unsigned;
189 end Corresponding_Unsigned_Type;
191 -----------------------------
192 -- Enclosing_Dynamic_Scope --
193 -----------------------------
195 function Enclosing_Dynamic_Scope (Ent : Entity_Id) return Entity_Id is
199 -- The following test is an error defense against some syntax errors
200 -- that can leave scopes very messed up.
202 if Ent = Standard_Standard then
206 -- Normal case, search enclosing scopes
208 -- Note: the test for Present (S) should not be required, it defends
209 -- against an ill-formed tree.
213 -- If we somehow got an empty value for Scope, the tree must be
214 -- malformed. Rather than blow up we return Standard in this case.
217 return Standard_Standard;
219 -- Quit if we get to standard or a dynamic scope. We must also
220 -- handle enclosing scopes that have a full view; required to
221 -- locate enclosing scopes that are synchronized private types
222 -- whose full view is a task type.
224 elsif S = Standard_Standard
225 or else Is_Dynamic_Scope (S)
226 or else (Is_Private_Type (S)
227 and then Present (Full_View (S))
228 and then Is_Dynamic_Scope (Full_View (S)))
232 -- Otherwise keep climbing
238 end Enclosing_Dynamic_Scope;
240 ------------------------
241 -- First_Discriminant --
242 ------------------------
244 function First_Discriminant (Typ : Entity_Id) return Entity_Id is
249 (Has_Discriminants (Typ) or else Has_Unknown_Discriminants (Typ));
251 Ent := First_Entity (Typ);
253 -- The discriminants are not necessarily contiguous, because access
254 -- discriminants will generate itypes. They are not the first entities
255 -- either because the tag must be ahead of them.
257 if Chars (Ent) = Name_uTag then
258 Ent := Next_Entity (Ent);
261 -- Skip all hidden stored discriminants if any
263 while Present (Ent) loop
264 exit when Ekind (Ent) = E_Discriminant
265 and then not Is_Completely_Hidden (Ent);
267 Ent := Next_Entity (Ent);
270 pragma Assert (Ekind (Ent) = E_Discriminant);
273 end First_Discriminant;
275 -------------------------------
276 -- First_Stored_Discriminant --
277 -------------------------------
279 function First_Stored_Discriminant (Typ : Entity_Id) return Entity_Id is
282 function Has_Completely_Hidden_Discriminant
283 (Typ : Entity_Id) return Boolean;
284 -- Scans the Discriminants to see whether any are Completely_Hidden
285 -- (the mechanism for describing non-specified stored discriminants)
287 ----------------------------------------
288 -- Has_Completely_Hidden_Discriminant --
289 ----------------------------------------
291 function Has_Completely_Hidden_Discriminant
292 (Typ : Entity_Id) return Boolean
297 pragma Assert (Ekind (Typ) = E_Discriminant);
300 while Present (Ent) and then Ekind (Ent) = E_Discriminant loop
301 if Is_Completely_Hidden (Ent) then
305 Ent := Next_Entity (Ent);
309 end Has_Completely_Hidden_Discriminant;
311 -- Start of processing for First_Stored_Discriminant
315 (Has_Discriminants (Typ)
316 or else Has_Unknown_Discriminants (Typ));
318 Ent := First_Entity (Typ);
320 if Chars (Ent) = Name_uTag then
321 Ent := Next_Entity (Ent);
324 if Has_Completely_Hidden_Discriminant (Ent) then
325 while Present (Ent) loop
326 exit when Is_Completely_Hidden (Ent);
327 Ent := Next_Entity (Ent);
331 pragma Assert (Ekind (Ent) = E_Discriminant);
334 end First_Stored_Discriminant;
340 function First_Subtype (Typ : Entity_Id) return Entity_Id is
341 B : constant Entity_Id := Base_Type (Typ);
342 F : constant Node_Id := Freeze_Node (B);
346 -- If the base type has no freeze node, it is a type in Standard, and
347 -- always acts as its own first subtype, except where it is one of the
348 -- predefined integer types. If the type is formal, it is also a first
349 -- subtype, and its base type has no freeze node. On the other hand, a
350 -- subtype of a generic formal is not its own first subtype. Its base
351 -- type, if anonymous, is attached to the formal type decl. from which
352 -- the first subtype is obtained.
355 if B = Base_Type (Standard_Integer) then
356 return Standard_Integer;
358 elsif B = Base_Type (Standard_Long_Integer) then
359 return Standard_Long_Integer;
361 elsif B = Base_Type (Standard_Short_Short_Integer) then
362 return Standard_Short_Short_Integer;
364 elsif B = Base_Type (Standard_Short_Integer) then
365 return Standard_Short_Integer;
367 elsif B = Base_Type (Standard_Long_Long_Integer) then
368 return Standard_Long_Long_Integer;
370 elsif Is_Generic_Type (Typ) then
371 if Present (Parent (B)) then
372 return Defining_Identifier (Parent (B));
374 return Defining_Identifier (Associated_Node_For_Itype (B));
381 -- Otherwise we check the freeze node, if it has a First_Subtype_Link
382 -- then we use that link, otherwise (happens with some Itypes), we use
383 -- the base type itself.
386 Ent := First_Subtype_Link (F);
388 if Present (Ent) then
396 -------------------------
397 -- First_Tag_Component --
398 -------------------------
400 function First_Tag_Component (Typ : Entity_Id) return Entity_Id is
406 pragma Assert (Is_Tagged_Type (Ctyp));
408 if Is_Class_Wide_Type (Ctyp) then
409 Ctyp := Root_Type (Ctyp);
412 if Is_Private_Type (Ctyp) then
413 Ctyp := Underlying_Type (Ctyp);
415 -- If the underlying type is missing then the source program has
416 -- errors and there is nothing else to do (the full-type declaration
417 -- associated with the private type declaration is missing).
424 Comp := First_Entity (Ctyp);
425 while Present (Comp) loop
426 if Is_Tag (Comp) then
430 Comp := Next_Entity (Comp);
433 -- No tag component found
436 end First_Tag_Component;
442 function Get_Rep_Item
445 Check_Parents : Boolean := True) return Node_Id
450 N := First_Rep_Item (E);
451 while Present (N) loop
453 -- Only one of Priority / Interrupt_Priority can be specified, so
454 -- return whichever one is present to catch illegal duplication.
456 if Nkind (N) = N_Pragma
458 (Pragma_Name (N) = Nam
459 or else (Nam = Name_Priority
460 and then Pragma_Name (N) = Name_Interrupt_Priority)
461 or else (Nam = Name_Interrupt_Priority
462 and then Pragma_Name (N) = Name_Priority))
464 if Check_Parents then
467 -- If Check_Parents is False, return N if the pragma doesn't
468 -- appear in the Rep_Item chain of the parent.
472 Par : constant Entity_Id := Nearest_Ancestor (E);
473 -- This node represents the parent type of type E (if any)
479 elsif not Present_In_Rep_Item (Par, N) then
485 elsif Nkind (N) = N_Attribute_Definition_Clause
488 or else (Nam = Name_Priority
489 and then Chars (N) = Name_Interrupt_Priority))
491 if Check_Parents or else Entity (N) = E then
495 elsif Nkind (N) = N_Aspect_Specification
497 (Chars (Identifier (N)) = Nam
500 and then Chars (Identifier (N)) = Name_Interrupt_Priority))
502 if Check_Parents then
505 elsif Entity (N) = E then
516 function Get_Rep_Item
520 Check_Parents : Boolean := True) return Node_Id
522 Nam1_Item : constant Node_Id := Get_Rep_Item (E, Nam1, Check_Parents);
523 Nam2_Item : constant Node_Id := Get_Rep_Item (E, Nam2, Check_Parents);
528 -- Check both Nam1_Item and Nam2_Item are present
530 if No (Nam1_Item) then
532 elsif No (Nam2_Item) then
536 -- Return the first node encountered in the list
538 N := First_Rep_Item (E);
539 while Present (N) loop
540 if N = Nam1_Item or else N = Nam2_Item then
554 function Get_Rep_Pragma
557 Check_Parents : Boolean := True) return Node_Id
562 N := Get_Rep_Item (E, Nam, Check_Parents);
564 if Present (N) and then Nkind (N) = N_Pragma then
571 function Get_Rep_Pragma
575 Check_Parents : Boolean := True) return Node_Id
577 Nam1_Item : constant Node_Id := Get_Rep_Pragma (E, Nam1, Check_Parents);
578 Nam2_Item : constant Node_Id := Get_Rep_Pragma (E, Nam2, Check_Parents);
583 -- Check both Nam1_Item and Nam2_Item are present
585 if No (Nam1_Item) then
587 elsif No (Nam2_Item) then
591 -- Return the first node encountered in the list
593 N := First_Rep_Item (E);
594 while Present (N) loop
595 if N = Nam1_Item or else N = Nam2_Item then
609 function Has_Rep_Item
612 Check_Parents : Boolean := True) return Boolean
615 return Present (Get_Rep_Item (E, Nam, Check_Parents));
618 function Has_Rep_Item
622 Check_Parents : Boolean := True) return Boolean
625 return Present (Get_Rep_Item (E, Nam1, Nam2, Check_Parents));
632 function Has_Rep_Pragma
635 Check_Parents : Boolean := True) return Boolean
638 return Present (Get_Rep_Pragma (E, Nam, Check_Parents));
641 function Has_Rep_Pragma
645 Check_Parents : Boolean := True) return Boolean
648 return Present (Get_Rep_Pragma (E, Nam1, Nam2, Check_Parents));
651 --------------------------------
652 -- Has_Unconstrained_Elements --
653 --------------------------------
655 function Has_Unconstrained_Elements (T : Entity_Id) return Boolean is
656 U_T : constant Entity_Id := Underlying_Type (T);
660 elsif Is_Record_Type (U_T) then
661 return Has_Discriminants (U_T) and then not Is_Constrained (U_T);
662 elsif Is_Array_Type (U_T) then
663 return Has_Unconstrained_Elements (Component_Type (U_T));
667 end Has_Unconstrained_Elements;
669 ----------------------
670 -- Has_Variant_Part --
671 ----------------------
673 function Has_Variant_Part (Typ : Entity_Id) return Boolean is
680 if not Is_Type (Typ) then
684 FSTyp := First_Subtype (Typ);
686 if not Has_Discriminants (FSTyp) then
690 -- Proceed with cautious checks here, return False if tree is not
691 -- as expected (may be caused by prior errors).
693 Decl := Declaration_Node (FSTyp);
695 if Nkind (Decl) /= N_Full_Type_Declaration then
699 TDef := Type_Definition (Decl);
701 if Nkind (TDef) /= N_Record_Definition then
705 CList := Component_List (TDef);
707 if Nkind (CList) /= N_Component_List then
710 return Present (Variant_Part (CList));
712 end Has_Variant_Part;
714 ---------------------
715 -- In_Generic_Body --
716 ---------------------
718 function In_Generic_Body (Id : Entity_Id) return Boolean is
722 -- Climb scopes looking for generic body
725 while Present (S) and then S /= Standard_Standard loop
727 -- Generic package body
729 if Ekind (S) = E_Generic_Package
730 and then In_Package_Body (S)
734 -- Generic subprogram body
736 elsif Is_Subprogram (S)
737 and then Nkind (Unit_Declaration_Node (S))
738 = N_Generic_Subprogram_Declaration
746 -- False if top of scope stack without finding a generic body
751 -------------------------------
752 -- Initialization_Suppressed --
753 -------------------------------
755 function Initialization_Suppressed (Typ : Entity_Id) return Boolean is
757 return Suppress_Initialization (Typ)
758 or else Suppress_Initialization (Base_Type (Typ));
759 end Initialization_Suppressed;
765 procedure Initialize is
767 Obsolescent_Warnings.Init;
774 function Is_Body (N : Node_Id) return Boolean is
777 Nkind (N) in N_Body_Stub
778 or else Nkind_In (N, N_Entry_Body,
785 ---------------------
786 -- Is_By_Copy_Type --
787 ---------------------
789 function Is_By_Copy_Type (Ent : Entity_Id) return Boolean is
791 -- If Id is a private type whose full declaration has not been seen,
792 -- we assume for now that it is not a By_Copy type. Clearly this
793 -- attribute should not be used before the type is frozen, but it is
794 -- needed to build the associated record of a protected type. Another
795 -- place where some lookahead for a full view is needed ???
798 Is_Elementary_Type (Ent)
799 or else (Is_Private_Type (Ent)
800 and then Present (Underlying_Type (Ent))
801 and then Is_Elementary_Type (Underlying_Type (Ent)));
804 --------------------------
805 -- Is_By_Reference_Type --
806 --------------------------
808 function Is_By_Reference_Type (Ent : Entity_Id) return Boolean is
809 Btype : constant Entity_Id := Base_Type (Ent);
812 if Error_Posted (Ent) or else Error_Posted (Btype) then
815 elsif Is_Private_Type (Btype) then
817 Utyp : constant Entity_Id := Underlying_Type (Btype);
822 return Is_By_Reference_Type (Utyp);
826 elsif Is_Incomplete_Type (Btype) then
828 Ftyp : constant Entity_Id := Full_View (Btype);
833 return Is_By_Reference_Type (Ftyp);
837 elsif Is_Concurrent_Type (Btype) then
840 elsif Is_Record_Type (Btype) then
841 if Is_Limited_Record (Btype)
842 or else Is_Tagged_Type (Btype)
843 or else Is_Volatile (Btype)
852 C := First_Component (Btype);
853 while Present (C) loop
855 -- For each component, test if its type is a by reference
856 -- type and if its type is volatile. Also test the component
857 -- itself for being volatile. This happens for example when
858 -- a Volatile aspect is added to a component.
860 if Is_By_Reference_Type (Etype (C))
861 or else Is_Volatile (Etype (C))
862 or else Is_Volatile (C)
867 C := Next_Component (C);
874 elsif Is_Array_Type (Btype) then
877 or else Is_By_Reference_Type (Component_Type (Btype))
878 or else Is_Volatile (Component_Type (Btype))
879 or else Has_Volatile_Components (Btype);
884 end Is_By_Reference_Type;
886 ---------------------
887 -- Is_Derived_Type --
888 ---------------------
890 function Is_Derived_Type (Ent : E) return B is
895 and then Base_Type (Ent) /= Root_Type (Ent)
896 and then not Is_Class_Wide_Type (Ent)
898 if not Is_Numeric_Type (Root_Type (Ent)) then
902 Par := Parent (First_Subtype (Ent));
905 and then Nkind (Par) = N_Full_Type_Declaration
906 and then Nkind (Type_Definition (Par)) =
907 N_Derived_Type_Definition;
915 -----------------------
916 -- Is_Generic_Formal --
917 -----------------------
919 function Is_Generic_Formal (E : Entity_Id) return Boolean is
925 Kind := Nkind (Parent (E));
927 Nkind_In (Kind, N_Formal_Object_Declaration,
928 N_Formal_Package_Declaration,
929 N_Formal_Type_Declaration)
930 or else Is_Formal_Subprogram (E);
932 end Is_Generic_Formal;
934 -------------------------------
935 -- Is_Immutably_Limited_Type --
936 -------------------------------
938 function Is_Immutably_Limited_Type (Ent : Entity_Id) return Boolean is
939 Btype : constant Entity_Id := Available_View (Base_Type (Ent));
942 if Is_Limited_Record (Btype) then
945 elsif Ekind (Btype) = E_Limited_Private_Type
946 and then Nkind (Parent (Btype)) = N_Formal_Type_Declaration
948 return not In_Package_Body (Scope ((Btype)));
950 elsif Is_Private_Type (Btype) then
952 -- AI05-0063: A type derived from a limited private formal type is
953 -- not immutably limited in a generic body.
955 if Is_Derived_Type (Btype)
956 and then Is_Generic_Type (Etype (Btype))
958 if not Is_Limited_Type (Etype (Btype)) then
961 -- A descendant of a limited formal type is not immutably limited
962 -- in the generic body, or in the body of a generic child.
964 elsif Ekind (Scope (Etype (Btype))) = E_Generic_Package then
965 return not In_Package_Body (Scope (Btype));
973 Utyp : constant Entity_Id := Underlying_Type (Btype);
978 return Is_Immutably_Limited_Type (Utyp);
983 elsif Is_Concurrent_Type (Btype) then
989 end Is_Immutably_Limited_Type;
991 ---------------------------
992 -- Is_Indefinite_Subtype --
993 ---------------------------
995 function Is_Indefinite_Subtype (Ent : Entity_Id) return Boolean is
996 K : constant Entity_Kind := Ekind (Ent);
999 if Is_Constrained (Ent) then
1002 elsif K in Array_Kind
1003 or else K in Class_Wide_Kind
1004 or else Has_Unknown_Discriminants (Ent)
1008 -- Known discriminants: indefinite if there are no default values
1010 elsif K in Record_Kind
1011 or else Is_Incomplete_Or_Private_Type (Ent)
1012 or else Is_Concurrent_Type (Ent)
1014 return (Has_Discriminants (Ent)
1016 No (Discriminant_Default_Value (First_Discriminant (Ent))));
1021 end Is_Indefinite_Subtype;
1023 ---------------------
1024 -- Is_Limited_Type --
1025 ---------------------
1027 function Is_Limited_Type (Ent : Entity_Id) return Boolean is
1028 Btype : constant E := Base_Type (Ent);
1029 Rtype : constant E := Root_Type (Btype);
1032 if not Is_Type (Ent) then
1035 elsif Ekind (Btype) = E_Limited_Private_Type
1036 or else Is_Limited_Composite (Btype)
1040 elsif Is_Concurrent_Type (Btype) then
1043 -- The Is_Limited_Record flag normally indicates that the type is
1044 -- limited. The exception is that a type does not inherit limitedness
1045 -- from its interface ancestor. So the type may be derived from a
1046 -- limited interface, but is not limited.
1048 elsif Is_Limited_Record (Ent)
1049 and then not Is_Interface (Ent)
1053 -- Otherwise we will look around to see if there is some other reason
1054 -- for it to be limited, except that if an error was posted on the
1055 -- entity, then just assume it is non-limited, because it can cause
1056 -- trouble to recurse into a murky entity resulting from other errors.
1058 elsif Error_Posted (Ent) then
1061 elsif Is_Record_Type (Btype) then
1063 if Is_Limited_Interface (Ent) then
1066 -- AI-419: limitedness is not inherited from a limited interface
1068 elsif Is_Limited_Record (Rtype) then
1069 return not Is_Interface (Rtype)
1070 or else Is_Protected_Interface (Rtype)
1071 or else Is_Synchronized_Interface (Rtype)
1072 or else Is_Task_Interface (Rtype);
1074 elsif Is_Class_Wide_Type (Btype) then
1075 return Is_Limited_Type (Rtype);
1082 C := First_Component (Btype);
1083 while Present (C) loop
1084 if Is_Limited_Type (Etype (C)) then
1088 C := Next_Component (C);
1095 elsif Is_Array_Type (Btype) then
1096 return Is_Limited_Type (Component_Type (Btype));
1101 end Is_Limited_Type;
1103 ---------------------
1104 -- Is_Limited_View --
1105 ---------------------
1107 function Is_Limited_View (Ent : Entity_Id) return Boolean is
1108 Btype : constant Entity_Id := Available_View (Base_Type (Ent));
1111 if Is_Limited_Record (Btype) then
1114 elsif Ekind (Btype) = E_Limited_Private_Type
1115 and then Nkind (Parent (Btype)) = N_Formal_Type_Declaration
1117 return not In_Package_Body (Scope ((Btype)));
1119 elsif Is_Private_Type (Btype) then
1121 -- AI05-0063: A type derived from a limited private formal type is
1122 -- not immutably limited in a generic body.
1124 if Is_Derived_Type (Btype)
1125 and then Is_Generic_Type (Etype (Btype))
1127 if not Is_Limited_Type (Etype (Btype)) then
1130 -- A descendant of a limited formal type is not immutably limited
1131 -- in the generic body, or in the body of a generic child.
1133 elsif Ekind (Scope (Etype (Btype))) = E_Generic_Package then
1134 return not In_Package_Body (Scope (Btype));
1142 Utyp : constant Entity_Id := Underlying_Type (Btype);
1147 return Is_Limited_View (Utyp);
1152 elsif Is_Concurrent_Type (Btype) then
1155 elsif Is_Record_Type (Btype) then
1157 -- Note that we return True for all limited interfaces, even though
1158 -- (unsynchronized) limited interfaces can have descendants that are
1159 -- nonlimited, because this is a predicate on the type itself, and
1160 -- things like functions with limited interface results need to be
1161 -- handled as build in place even though they might return objects
1162 -- of a type that is not inherently limited.
1164 if Is_Class_Wide_Type (Btype) then
1165 return Is_Limited_View (Root_Type (Btype));
1172 C := First_Component (Btype);
1173 while Present (C) loop
1175 -- Don't consider components with interface types (which can
1176 -- only occur in the case of a _parent component anyway).
1177 -- They don't have any components, plus it would cause this
1178 -- function to return true for nonlimited types derived from
1179 -- limited interfaces.
1181 if not Is_Interface (Etype (C))
1182 and then Is_Limited_View (Etype (C))
1187 C := Next_Component (C);
1194 elsif Is_Array_Type (Btype) then
1195 return Is_Limited_View (Component_Type (Btype));
1200 end Is_Limited_View;
1202 ----------------------
1203 -- Nearest_Ancestor --
1204 ----------------------
1206 function Nearest_Ancestor (Typ : Entity_Id) return Entity_Id is
1207 D : constant Node_Id := Declaration_Node (Typ);
1210 -- If we have a subtype declaration, get the ancestor subtype
1212 if Nkind (D) = N_Subtype_Declaration then
1213 if Nkind (Subtype_Indication (D)) = N_Subtype_Indication then
1214 return Entity (Subtype_Mark (Subtype_Indication (D)));
1216 return Entity (Subtype_Indication (D));
1219 -- If derived type declaration, find who we are derived from
1221 elsif Nkind (D) = N_Full_Type_Declaration
1222 and then Nkind (Type_Definition (D)) = N_Derived_Type_Definition
1225 DTD : constant Entity_Id := Type_Definition (D);
1226 SI : constant Entity_Id := Subtype_Indication (DTD);
1228 if Is_Entity_Name (SI) then
1231 return Entity (Subtype_Mark (SI));
1235 -- If derived type and private type, get the full view to find who we
1236 -- are derived from.
1238 elsif Is_Derived_Type (Typ)
1239 and then Is_Private_Type (Typ)
1240 and then Present (Full_View (Typ))
1242 return Nearest_Ancestor (Full_View (Typ));
1244 -- Otherwise, nothing useful to return, return Empty
1249 end Nearest_Ancestor;
1251 ---------------------------
1252 -- Nearest_Dynamic_Scope --
1253 ---------------------------
1255 function Nearest_Dynamic_Scope (Ent : Entity_Id) return Entity_Id is
1257 if Is_Dynamic_Scope (Ent) then
1260 return Enclosing_Dynamic_Scope (Ent);
1262 end Nearest_Dynamic_Scope;
1264 ------------------------
1265 -- Next_Tag_Component --
1266 ------------------------
1268 function Next_Tag_Component (Tag : Entity_Id) return Entity_Id is
1272 pragma Assert (Is_Tag (Tag));
1274 -- Loop to look for next tag component
1276 Comp := Next_Entity (Tag);
1277 while Present (Comp) loop
1278 if Is_Tag (Comp) then
1279 pragma Assert (Chars (Comp) /= Name_uTag);
1283 Comp := Next_Entity (Comp);
1286 -- No tag component found
1289 end Next_Tag_Component;
1291 --------------------------
1292 -- Number_Discriminants --
1293 --------------------------
1295 function Number_Discriminants (Typ : Entity_Id) return Pos is
1301 Discr := First_Discriminant (Typ);
1302 while Present (Discr) loop
1304 Discr := Next_Discriminant (Discr);
1308 end Number_Discriminants;
1310 ----------------------------------------------
1311 -- Object_Type_Has_Constrained_Partial_View --
1312 ----------------------------------------------
1314 function Object_Type_Has_Constrained_Partial_View
1316 Scop : Entity_Id) return Boolean
1319 return Has_Constrained_Partial_View (Typ)
1320 or else (In_Generic_Body (Scop)
1321 and then Is_Generic_Type (Base_Type (Typ))
1322 and then Is_Private_Type (Base_Type (Typ))
1323 and then not Is_Tagged_Type (Typ)
1324 and then not (Is_Array_Type (Typ)
1325 and then not Is_Constrained (Typ))
1326 and then Has_Discriminants (Typ));
1327 end Object_Type_Has_Constrained_Partial_View;
1329 ---------------------------
1330 -- Package_Specification --
1331 ---------------------------
1333 function Package_Specification (Pack_Id : Entity_Id) return Node_Id is
1337 N := Parent (Pack_Id);
1338 while Nkind (N) /= N_Package_Specification loop
1342 raise Program_Error;
1347 end Package_Specification;
1353 procedure Tree_Read is
1355 Obsolescent_Warnings.Tree_Read;
1362 procedure Tree_Write is
1364 Obsolescent_Warnings.Tree_Write;
1367 --------------------
1368 -- Ultimate_Alias --
1369 --------------------
1371 function Ultimate_Alias (Prim : Entity_Id) return Entity_Id is
1372 E : Entity_Id := Prim;
1375 while Present (Alias (E)) loop
1376 pragma Assert (Alias (E) /= E);
1383 --------------------------
1384 -- Unit_Declaration_Node --
1385 --------------------------
1387 function Unit_Declaration_Node (Unit_Id : Entity_Id) return Node_Id is
1388 N : Node_Id := Parent (Unit_Id);
1391 -- Predefined operators do not have a full function declaration
1393 if Ekind (Unit_Id) = E_Operator then
1397 -- Isn't there some better way to express the following ???
1399 while Nkind (N) /= N_Abstract_Subprogram_Declaration
1400 and then Nkind (N) /= N_Formal_Package_Declaration
1401 and then Nkind (N) /= N_Function_Instantiation
1402 and then Nkind (N) /= N_Generic_Package_Declaration
1403 and then Nkind (N) /= N_Generic_Subprogram_Declaration
1404 and then Nkind (N) /= N_Package_Declaration
1405 and then Nkind (N) /= N_Package_Body
1406 and then Nkind (N) /= N_Package_Instantiation
1407 and then Nkind (N) /= N_Package_Renaming_Declaration
1408 and then Nkind (N) /= N_Procedure_Instantiation
1409 and then Nkind (N) /= N_Protected_Body
1410 and then Nkind (N) /= N_Subprogram_Declaration
1411 and then Nkind (N) /= N_Subprogram_Body
1412 and then Nkind (N) /= N_Subprogram_Body_Stub
1413 and then Nkind (N) /= N_Subprogram_Renaming_Declaration
1414 and then Nkind (N) /= N_Task_Body
1415 and then Nkind (N) /= N_Task_Type_Declaration
1416 and then Nkind (N) not in N_Formal_Subprogram_Declaration
1417 and then Nkind (N) not in N_Generic_Renaming_Declaration
1421 -- We don't use Assert here, because that causes an infinite loop
1422 -- when assertions are turned off. Better to crash.
1425 raise Program_Error;
1430 end Unit_Declaration_Node;