1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2015, 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 Snames; use Snames;
36 with Stand; use Stand;
37 with Uintp; use Uintp;
39 package body Sem_Aux is
41 ----------------------
42 -- Ancestor_Subtype --
43 ----------------------
45 function Ancestor_Subtype (Typ : Entity_Id) return Entity_Id is
47 -- If this is first subtype, or is a base type, then there is no
48 -- ancestor subtype, so we return Empty to indicate this fact.
50 if Is_First_Subtype (Typ) or else Is_Base_Type (Typ) then
55 D : constant Node_Id := Declaration_Node (Typ);
58 -- If we have a subtype declaration, get the ancestor subtype
60 if Nkind (D) = N_Subtype_Declaration then
61 if Nkind (Subtype_Indication (D)) = N_Subtype_Indication then
62 return Entity (Subtype_Mark (Subtype_Indication (D)));
64 return Entity (Subtype_Indication (D));
67 -- If not, then no subtype indication is available
79 function Available_View (Ent : Entity_Id) return Entity_Id is
81 -- Obtain the non-limited view (if available)
83 if Has_Non_Limited_View (Ent) then
84 return Get_Full_View (Non_Limited_View (Ent));
86 -- In all other cases, return entity unchanged
97 function Constant_Value (Ent : Entity_Id) return Node_Id is
98 D : constant Node_Id := Declaration_Node (Ent);
102 -- If we have no declaration node, then return no constant value. Not
103 -- clear how this can happen, but it does sometimes and this is the
109 -- Normal case where a declaration node is present
111 elsif Nkind (D) = N_Object_Renaming_Declaration then
112 return Renamed_Object (Ent);
114 -- If this is a component declaration whose entity is a constant, it is
115 -- a prival within a protected function (and so has no constant value).
117 elsif Nkind (D) = N_Component_Declaration then
120 -- If there is an expression, return it
122 elsif Present (Expression (D)) then
123 return (Expression (D));
125 -- For a constant, see if we have a full view
127 elsif Ekind (Ent) = E_Constant
128 and then Present (Full_View (Ent))
130 Full_D := Parent (Full_View (Ent));
132 -- The full view may have been rewritten as an object renaming
134 if Nkind (Full_D) = N_Object_Renaming_Declaration then
135 return Name (Full_D);
137 return Expression (Full_D);
140 -- Otherwise we have no expression to return
147 ---------------------------------
148 -- Corresponding_Unsigned_Type --
149 ---------------------------------
151 function Corresponding_Unsigned_Type (Typ : Entity_Id) return Entity_Id is
152 pragma Assert (Is_Signed_Integer_Type (Typ));
153 Siz : constant Uint := Esize (Base_Type (Typ));
155 if Siz = Esize (Standard_Short_Short_Integer) then
156 return Standard_Short_Short_Unsigned;
157 elsif Siz = Esize (Standard_Short_Integer) then
158 return Standard_Short_Unsigned;
159 elsif Siz = Esize (Standard_Unsigned) then
160 return Standard_Unsigned;
161 elsif Siz = Esize (Standard_Long_Integer) then
162 return Standard_Long_Unsigned;
163 elsif Siz = Esize (Standard_Long_Long_Integer) then
164 return Standard_Long_Long_Unsigned;
168 end Corresponding_Unsigned_Type;
170 -----------------------------
171 -- Enclosing_Dynamic_Scope --
172 -----------------------------
174 function Enclosing_Dynamic_Scope (Ent : Entity_Id) return Entity_Id is
178 -- The following test is an error defense against some syntax errors
179 -- that can leave scopes very messed up.
181 if Ent = Standard_Standard then
185 -- Normal case, search enclosing scopes
187 -- Note: the test for Present (S) should not be required, it defends
188 -- against an ill-formed tree.
192 -- If we somehow got an empty value for Scope, the tree must be
193 -- malformed. Rather than blow up we return Standard in this case.
196 return Standard_Standard;
198 -- Quit if we get to standard or a dynamic scope. We must also
199 -- handle enclosing scopes that have a full view; required to
200 -- locate enclosing scopes that are synchronized private types
201 -- whose full view is a task type.
203 elsif S = Standard_Standard
204 or else Is_Dynamic_Scope (S)
205 or else (Is_Private_Type (S)
206 and then Present (Full_View (S))
207 and then Is_Dynamic_Scope (Full_View (S)))
211 -- Otherwise keep climbing
217 end Enclosing_Dynamic_Scope;
219 ------------------------
220 -- First_Discriminant --
221 ------------------------
223 function First_Discriminant (Typ : Entity_Id) return Entity_Id is
228 (Has_Discriminants (Typ) or else Has_Unknown_Discriminants (Typ));
230 Ent := First_Entity (Typ);
232 -- The discriminants are not necessarily contiguous, because access
233 -- discriminants will generate itypes. They are not the first entities
234 -- either because the tag must be ahead of them.
236 if Chars (Ent) = Name_uTag then
237 Ent := Next_Entity (Ent);
240 -- Skip all hidden stored discriminants if any
242 while Present (Ent) loop
243 exit when Ekind (Ent) = E_Discriminant
244 and then not Is_Completely_Hidden (Ent);
246 Ent := Next_Entity (Ent);
249 -- Call may be on a private type with unknown discriminants, in which
250 -- case Ent is Empty, and as per the spec, we return Empty in this case.
252 -- Historical note: The assertion in previous versions that Ent is a
253 -- discriminant was overly cautious and prevented convenient application
254 -- of this function in the gnatprove context.
257 end First_Discriminant;
259 -------------------------------
260 -- First_Stored_Discriminant --
261 -------------------------------
263 function First_Stored_Discriminant (Typ : Entity_Id) return Entity_Id is
266 function Has_Completely_Hidden_Discriminant
267 (Typ : Entity_Id) return Boolean;
268 -- Scans the Discriminants to see whether any are Completely_Hidden
269 -- (the mechanism for describing non-specified stored discriminants)
270 -- Note that the entity list for the type may contain anonymous access
271 -- types created by expressions that constrain access discriminants.
273 ----------------------------------------
274 -- Has_Completely_Hidden_Discriminant --
275 ----------------------------------------
277 function Has_Completely_Hidden_Discriminant
278 (Typ : Entity_Id) return Boolean
283 pragma Assert (Ekind (Typ) = E_Discriminant);
286 while Present (Ent) loop
288 -- Skip anonymous types that may be created by expressions
289 -- used as discriminant constraints on inherited discriminants.
291 if Is_Itype (Ent) then
294 elsif Ekind (Ent) = E_Discriminant
295 and then Is_Completely_Hidden (Ent)
300 Ent := Next_Entity (Ent);
304 end Has_Completely_Hidden_Discriminant;
306 -- Start of processing for First_Stored_Discriminant
310 (Has_Discriminants (Typ)
311 or else Has_Unknown_Discriminants (Typ));
313 Ent := First_Entity (Typ);
315 if Chars (Ent) = Name_uTag then
316 Ent := Next_Entity (Ent);
319 if Has_Completely_Hidden_Discriminant (Ent) then
320 while Present (Ent) loop
321 exit when Ekind (Ent) = E_Discriminant
322 and then Is_Completely_Hidden (Ent);
323 Ent := Next_Entity (Ent);
327 pragma Assert (Ekind (Ent) = E_Discriminant);
330 end First_Stored_Discriminant;
336 function First_Subtype (Typ : Entity_Id) return Entity_Id is
337 B : constant Entity_Id := Base_Type (Typ);
338 F : constant Node_Id := Freeze_Node (B);
342 -- If the base type has no freeze node, it is a type in Standard, and
343 -- always acts as its own first subtype, except where it is one of the
344 -- predefined integer types. If the type is formal, it is also a first
345 -- subtype, and its base type has no freeze node. On the other hand, a
346 -- subtype of a generic formal is not its own first subtype. Its base
347 -- type, if anonymous, is attached to the formal type decl. from which
348 -- the first subtype is obtained.
351 if B = Base_Type (Standard_Integer) then
352 return Standard_Integer;
354 elsif B = Base_Type (Standard_Long_Integer) then
355 return Standard_Long_Integer;
357 elsif B = Base_Type (Standard_Short_Short_Integer) then
358 return Standard_Short_Short_Integer;
360 elsif B = Base_Type (Standard_Short_Integer) then
361 return Standard_Short_Integer;
363 elsif B = Base_Type (Standard_Long_Long_Integer) then
364 return Standard_Long_Long_Integer;
366 elsif Is_Generic_Type (Typ) then
367 if Present (Parent (B)) then
368 return Defining_Identifier (Parent (B));
370 return Defining_Identifier (Associated_Node_For_Itype (B));
377 -- Otherwise we check the freeze node, if it has a First_Subtype_Link
378 -- then we use that link, otherwise (happens with some Itypes), we use
379 -- the base type itself.
382 Ent := First_Subtype_Link (F);
384 if Present (Ent) then
392 -------------------------
393 -- First_Tag_Component --
394 -------------------------
396 function First_Tag_Component (Typ : Entity_Id) return Entity_Id is
402 pragma Assert (Is_Tagged_Type (Ctyp));
404 if Is_Class_Wide_Type (Ctyp) then
405 Ctyp := Root_Type (Ctyp);
408 if Is_Private_Type (Ctyp) then
409 Ctyp := Underlying_Type (Ctyp);
411 -- If the underlying type is missing then the source program has
412 -- errors and there is nothing else to do (the full-type declaration
413 -- associated with the private type declaration is missing).
420 Comp := First_Entity (Ctyp);
421 while Present (Comp) loop
422 if Is_Tag (Comp) then
426 Comp := Next_Entity (Comp);
429 -- No tag component found
432 end First_Tag_Component;
434 ---------------------
435 -- Get_Binary_Nkind --
436 ---------------------
438 function Get_Binary_Nkind (Op : Entity_Id) return Node_Kind is
443 when Name_Op_Concat =>
445 when Name_Op_Expon =>
447 when Name_Op_Subtract =>
448 return N_Op_Subtract;
451 when Name_Op_Multiply =>
452 return N_Op_Multiply;
453 when Name_Op_Divide =>
478 end Get_Binary_Nkind;
484 function Get_Low_Bound (E : Entity_Id) return Node_Id is
486 if Ekind (E) = E_String_Literal_Subtype then
487 return String_Literal_Low_Bound (E);
489 return Type_Low_Bound (E);
497 function Get_Rep_Item
500 Check_Parents : Boolean := True) return Node_Id
505 N := First_Rep_Item (E);
506 while Present (N) loop
508 -- Only one of Priority / Interrupt_Priority can be specified, so
509 -- return whichever one is present to catch illegal duplication.
511 if Nkind (N) = N_Pragma
513 (Pragma_Name (N) = Nam
514 or else (Nam = Name_Priority
515 and then Pragma_Name (N) = Name_Interrupt_Priority)
516 or else (Nam = Name_Interrupt_Priority
517 and then Pragma_Name (N) = Name_Priority))
519 if Check_Parents then
522 -- If Check_Parents is False, return N if the pragma doesn't
523 -- appear in the Rep_Item chain of the parent.
527 Par : constant Entity_Id := Nearest_Ancestor (E);
528 -- This node represents the parent type of type E (if any)
534 elsif not Present_In_Rep_Item (Par, N) then
540 elsif Nkind (N) = N_Attribute_Definition_Clause
543 or else (Nam = Name_Priority
544 and then Chars (N) = Name_Interrupt_Priority))
546 if Check_Parents or else Entity (N) = E then
550 elsif Nkind (N) = N_Aspect_Specification
552 (Chars (Identifier (N)) = Nam
555 and then Chars (Identifier (N)) = Name_Interrupt_Priority))
557 if Check_Parents then
560 elsif Entity (N) = E then
571 function Get_Rep_Item
575 Check_Parents : Boolean := True) return Node_Id
577 Nam1_Item : constant Node_Id := Get_Rep_Item (E, Nam1, Check_Parents);
578 Nam2_Item : constant Node_Id := Get_Rep_Item (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 Get_Rep_Pragma
612 Check_Parents : Boolean := True) return Node_Id
617 N := Get_Rep_Item (E, Nam, Check_Parents);
619 if Present (N) and then Nkind (N) = N_Pragma then
626 function Get_Rep_Pragma
630 Check_Parents : Boolean := True) return Node_Id
632 Nam1_Item : constant Node_Id := Get_Rep_Pragma (E, Nam1, Check_Parents);
633 Nam2_Item : constant Node_Id := Get_Rep_Pragma (E, Nam2, Check_Parents);
638 -- Check both Nam1_Item and Nam2_Item are present
640 if No (Nam1_Item) then
642 elsif No (Nam2_Item) then
646 -- Return the first node encountered in the list
648 N := First_Rep_Item (E);
649 while Present (N) loop
650 if N = Nam1_Item or else N = Nam2_Item then
660 ---------------------
661 -- Get_Unary_Nkind --
662 ---------------------
664 function Get_Unary_Nkind (Op : Entity_Id) return Node_Kind is
669 when Name_Op_Subtract =>
680 ---------------------------------
681 -- Has_External_Tag_Rep_Clause --
682 ---------------------------------
684 function Has_External_Tag_Rep_Clause (T : Entity_Id) return Boolean is
686 pragma Assert (Is_Tagged_Type (T));
687 return Has_Rep_Item (T, Name_External_Tag, Check_Parents => False);
688 end Has_External_Tag_Rep_Clause;
694 function Has_Rep_Item
697 Check_Parents : Boolean := True) return Boolean
700 return Present (Get_Rep_Item (E, Nam, Check_Parents));
703 function Has_Rep_Item
707 Check_Parents : Boolean := True) return Boolean
710 return Present (Get_Rep_Item (E, Nam1, Nam2, Check_Parents));
717 function Has_Rep_Pragma
720 Check_Parents : Boolean := True) return Boolean
723 return Present (Get_Rep_Pragma (E, Nam, Check_Parents));
726 function Has_Rep_Pragma
730 Check_Parents : Boolean := True) return Boolean
733 return Present (Get_Rep_Pragma (E, Nam1, Nam2, Check_Parents));
736 --------------------------------
737 -- Has_Unconstrained_Elements --
738 --------------------------------
740 function Has_Unconstrained_Elements (T : Entity_Id) return Boolean is
741 U_T : constant Entity_Id := Underlying_Type (T);
745 elsif Is_Record_Type (U_T) then
746 return Has_Discriminants (U_T) and then not Is_Constrained (U_T);
747 elsif Is_Array_Type (U_T) then
748 return Has_Unconstrained_Elements (Component_Type (U_T));
752 end Has_Unconstrained_Elements;
754 ----------------------
755 -- Has_Variant_Part --
756 ----------------------
758 function Has_Variant_Part (Typ : Entity_Id) return Boolean is
765 if not Is_Type (Typ) then
769 FSTyp := First_Subtype (Typ);
771 if not Has_Discriminants (FSTyp) then
775 -- Proceed with cautious checks here, return False if tree is not
776 -- as expected (may be caused by prior errors).
778 Decl := Declaration_Node (FSTyp);
780 if Nkind (Decl) /= N_Full_Type_Declaration then
784 TDef := Type_Definition (Decl);
786 if Nkind (TDef) /= N_Record_Definition then
790 CList := Component_List (TDef);
792 if Nkind (CList) /= N_Component_List then
795 return Present (Variant_Part (CList));
797 end Has_Variant_Part;
799 ---------------------
800 -- In_Generic_Body --
801 ---------------------
803 function In_Generic_Body (Id : Entity_Id) return Boolean is
807 -- Climb scopes looking for generic body
810 while Present (S) and then S /= Standard_Standard loop
812 -- Generic package body
814 if Ekind (S) = E_Generic_Package
815 and then In_Package_Body (S)
819 -- Generic subprogram body
821 elsif Is_Subprogram (S)
822 and then Nkind (Unit_Declaration_Node (S))
823 = N_Generic_Subprogram_Declaration
831 -- False if top of scope stack without finding a generic body
836 -------------------------------
837 -- Initialization_Suppressed --
838 -------------------------------
840 function Initialization_Suppressed (Typ : Entity_Id) return Boolean is
842 return Suppress_Initialization (Typ)
843 or else Suppress_Initialization (Base_Type (Typ));
844 end Initialization_Suppressed;
850 procedure Initialize is
852 Obsolescent_Warnings.Init;
859 function Is_Body (N : Node_Id) return Boolean is
862 Nkind (N) in N_Body_Stub
863 or else Nkind_In (N, N_Entry_Body,
870 ---------------------
871 -- Is_By_Copy_Type --
872 ---------------------
874 function Is_By_Copy_Type (Ent : Entity_Id) return Boolean is
876 -- If Id is a private type whose full declaration has not been seen,
877 -- we assume for now that it is not a By_Copy type. Clearly this
878 -- attribute should not be used before the type is frozen, but it is
879 -- needed to build the associated record of a protected type. Another
880 -- place where some lookahead for a full view is needed ???
883 Is_Elementary_Type (Ent)
884 or else (Is_Private_Type (Ent)
885 and then Present (Underlying_Type (Ent))
886 and then Is_Elementary_Type (Underlying_Type (Ent)));
889 --------------------------
890 -- Is_By_Reference_Type --
891 --------------------------
893 function Is_By_Reference_Type (Ent : Entity_Id) return Boolean is
894 Btype : constant Entity_Id := Base_Type (Ent);
897 if Error_Posted (Ent) or else Error_Posted (Btype) then
900 elsif Is_Private_Type (Btype) then
902 Utyp : constant Entity_Id := Underlying_Type (Btype);
907 return Is_By_Reference_Type (Utyp);
911 elsif Is_Incomplete_Type (Btype) then
913 Ftyp : constant Entity_Id := Full_View (Btype);
918 return Is_By_Reference_Type (Ftyp);
922 elsif Is_Concurrent_Type (Btype) then
925 elsif Is_Record_Type (Btype) then
926 if Is_Limited_Record (Btype)
927 or else Is_Tagged_Type (Btype)
928 or else Is_Volatile (Btype)
937 C := First_Component (Btype);
938 while Present (C) loop
940 -- For each component, test if its type is a by reference
941 -- type and if its type is volatile. Also test the component
942 -- itself for being volatile. This happens for example when
943 -- a Volatile aspect is added to a component.
945 if Is_By_Reference_Type (Etype (C))
946 or else Is_Volatile (Etype (C))
947 or else Is_Volatile (C)
952 C := Next_Component (C);
959 elsif Is_Array_Type (Btype) then
962 or else Is_By_Reference_Type (Component_Type (Btype))
963 or else Is_Volatile (Component_Type (Btype))
964 or else Has_Volatile_Components (Btype);
969 end Is_By_Reference_Type;
971 -------------------------
972 -- Is_Definite_Subtype --
973 -------------------------
975 function Is_Definite_Subtype (T : Entity_Id) return Boolean is
976 pragma Assert (Is_Type (T));
977 K : constant Entity_Kind := Ekind (T);
980 if Is_Constrained (T) then
983 elsif K in Array_Kind
984 or else K in Class_Wide_Kind
985 or else Has_Unknown_Discriminants (T)
989 -- Known discriminants: definite if there are default values. Note that
990 -- if any discriminant has a default, they all do.
992 elsif Has_Discriminants (T) then
993 return Present (Discriminant_Default_Value (First_Discriminant (T)));
998 end Is_Definite_Subtype;
1000 ---------------------
1001 -- Is_Derived_Type --
1002 ---------------------
1004 function Is_Derived_Type (Ent : E) return B is
1009 and then Base_Type (Ent) /= Root_Type (Ent)
1010 and then not Is_Class_Wide_Type (Ent)
1012 -- An access_to_subprogram whose result type is a limited view can
1013 -- appear in a return statement, without the full view of the result
1014 -- type being available. Do not interpret this as a derived type.
1016 and then Ekind (Ent) /= E_Subprogram_Type
1018 if not Is_Numeric_Type (Root_Type (Ent)) then
1022 Par := Parent (First_Subtype (Ent));
1024 return Present (Par)
1025 and then Nkind (Par) = N_Full_Type_Declaration
1026 and then Nkind (Type_Definition (Par)) =
1027 N_Derived_Type_Definition;
1033 end Is_Derived_Type;
1035 -----------------------
1036 -- Is_Generic_Formal --
1037 -----------------------
1039 function Is_Generic_Formal (E : Entity_Id) return Boolean is
1045 Kind := Nkind (Parent (E));
1047 Nkind_In (Kind, N_Formal_Object_Declaration,
1048 N_Formal_Package_Declaration,
1049 N_Formal_Type_Declaration)
1050 or else Is_Formal_Subprogram (E);
1052 end Is_Generic_Formal;
1054 -------------------------------
1055 -- Is_Immutably_Limited_Type --
1056 -------------------------------
1058 function Is_Immutably_Limited_Type (Ent : Entity_Id) return Boolean is
1059 Btype : constant Entity_Id := Available_View (Base_Type (Ent));
1062 if Is_Limited_Record (Btype) then
1065 elsif Ekind (Btype) = E_Limited_Private_Type
1066 and then Nkind (Parent (Btype)) = N_Formal_Type_Declaration
1068 return not In_Package_Body (Scope ((Btype)));
1070 elsif Is_Private_Type (Btype) then
1072 -- AI05-0063: A type derived from a limited private formal type is
1073 -- not immutably limited in a generic body.
1075 if Is_Derived_Type (Btype)
1076 and then Is_Generic_Type (Etype (Btype))
1078 if not Is_Limited_Type (Etype (Btype)) then
1081 -- A descendant of a limited formal type is not immutably limited
1082 -- in the generic body, or in the body of a generic child.
1084 elsif Ekind (Scope (Etype (Btype))) = E_Generic_Package then
1085 return not In_Package_Body (Scope (Btype));
1093 Utyp : constant Entity_Id := Underlying_Type (Btype);
1098 return Is_Immutably_Limited_Type (Utyp);
1103 elsif Is_Concurrent_Type (Btype) then
1109 end Is_Immutably_Limited_Type;
1111 ---------------------
1112 -- Is_Limited_Type --
1113 ---------------------
1115 function Is_Limited_Type (Ent : Entity_Id) return Boolean is
1116 Btype : constant E := Base_Type (Ent);
1117 Rtype : constant E := Root_Type (Btype);
1120 if not Is_Type (Ent) then
1123 elsif Ekind (Btype) = E_Limited_Private_Type
1124 or else Is_Limited_Composite (Btype)
1128 elsif Is_Concurrent_Type (Btype) then
1131 -- The Is_Limited_Record flag normally indicates that the type is
1132 -- limited. The exception is that a type does not inherit limitedness
1133 -- from its interface ancestor. So the type may be derived from a
1134 -- limited interface, but is not limited.
1136 elsif Is_Limited_Record (Ent)
1137 and then not Is_Interface (Ent)
1141 -- Otherwise we will look around to see if there is some other reason
1142 -- for it to be limited, except that if an error was posted on the
1143 -- entity, then just assume it is non-limited, because it can cause
1144 -- trouble to recurse into a murky entity resulting from other errors.
1146 elsif Error_Posted (Ent) then
1149 elsif Is_Record_Type (Btype) then
1151 if Is_Limited_Interface (Ent) then
1154 -- AI-419: limitedness is not inherited from a limited interface
1156 elsif Is_Limited_Record (Rtype) then
1157 return not Is_Interface (Rtype)
1158 or else Is_Protected_Interface (Rtype)
1159 or else Is_Synchronized_Interface (Rtype)
1160 or else Is_Task_Interface (Rtype);
1162 elsif Is_Class_Wide_Type (Btype) then
1163 return Is_Limited_Type (Rtype);
1170 C := First_Component (Btype);
1171 while Present (C) loop
1172 if Is_Limited_Type (Etype (C)) then
1176 C := Next_Component (C);
1183 elsif Is_Array_Type (Btype) then
1184 return Is_Limited_Type (Component_Type (Btype));
1189 end Is_Limited_Type;
1191 ---------------------
1192 -- Is_Limited_View --
1193 ---------------------
1195 function Is_Limited_View (Ent : Entity_Id) return Boolean is
1196 Btype : constant Entity_Id := Available_View (Base_Type (Ent));
1199 if Is_Limited_Record (Btype) then
1202 elsif Ekind (Btype) = E_Limited_Private_Type
1203 and then Nkind (Parent (Btype)) = N_Formal_Type_Declaration
1205 return not In_Package_Body (Scope ((Btype)));
1207 elsif Is_Private_Type (Btype) then
1209 -- AI05-0063: A type derived from a limited private formal type is
1210 -- not immutably limited in a generic body.
1212 if Is_Derived_Type (Btype)
1213 and then Is_Generic_Type (Etype (Btype))
1215 if not Is_Limited_Type (Etype (Btype)) then
1218 -- A descendant of a limited formal type is not immutably limited
1219 -- in the generic body, or in the body of a generic child.
1221 elsif Ekind (Scope (Etype (Btype))) = E_Generic_Package then
1222 return not In_Package_Body (Scope (Btype));
1230 Utyp : constant Entity_Id := Underlying_Type (Btype);
1235 return Is_Limited_View (Utyp);
1240 elsif Is_Concurrent_Type (Btype) then
1243 elsif Is_Record_Type (Btype) then
1245 -- Note that we return True for all limited interfaces, even though
1246 -- (unsynchronized) limited interfaces can have descendants that are
1247 -- nonlimited, because this is a predicate on the type itself, and
1248 -- things like functions with limited interface results need to be
1249 -- handled as build in place even though they might return objects
1250 -- of a type that is not inherently limited.
1252 if Is_Class_Wide_Type (Btype) then
1253 return Is_Limited_View (Root_Type (Btype));
1260 C := First_Component (Btype);
1261 while Present (C) loop
1263 -- Don't consider components with interface types (which can
1264 -- only occur in the case of a _parent component anyway).
1265 -- They don't have any components, plus it would cause this
1266 -- function to return true for nonlimited types derived from
1267 -- limited interfaces.
1269 if not Is_Interface (Etype (C))
1270 and then Is_Limited_View (Etype (C))
1275 C := Next_Component (C);
1282 elsif Is_Array_Type (Btype) then
1283 return Is_Limited_View (Component_Type (Btype));
1288 end Is_Limited_View;
1290 ----------------------
1291 -- Nearest_Ancestor --
1292 ----------------------
1294 function Nearest_Ancestor (Typ : Entity_Id) return Entity_Id is
1295 D : constant Node_Id := Declaration_Node (Typ);
1298 -- If we have a subtype declaration, get the ancestor subtype
1300 if Nkind (D) = N_Subtype_Declaration then
1301 if Nkind (Subtype_Indication (D)) = N_Subtype_Indication then
1302 return Entity (Subtype_Mark (Subtype_Indication (D)));
1304 return Entity (Subtype_Indication (D));
1307 -- If derived type declaration, find who we are derived from
1309 elsif Nkind (D) = N_Full_Type_Declaration
1310 and then Nkind (Type_Definition (D)) = N_Derived_Type_Definition
1313 DTD : constant Entity_Id := Type_Definition (D);
1314 SI : constant Entity_Id := Subtype_Indication (DTD);
1316 if Is_Entity_Name (SI) then
1319 return Entity (Subtype_Mark (SI));
1323 -- If derived type and private type, get the full view to find who we
1324 -- are derived from.
1326 elsif Is_Derived_Type (Typ)
1327 and then Is_Private_Type (Typ)
1328 and then Present (Full_View (Typ))
1330 return Nearest_Ancestor (Full_View (Typ));
1332 -- Otherwise, nothing useful to return, return Empty
1337 end Nearest_Ancestor;
1339 ---------------------------
1340 -- Nearest_Dynamic_Scope --
1341 ---------------------------
1343 function Nearest_Dynamic_Scope (Ent : Entity_Id) return Entity_Id is
1345 if Is_Dynamic_Scope (Ent) then
1348 return Enclosing_Dynamic_Scope (Ent);
1350 end Nearest_Dynamic_Scope;
1352 ------------------------
1353 -- Next_Tag_Component --
1354 ------------------------
1356 function Next_Tag_Component (Tag : Entity_Id) return Entity_Id is
1360 pragma Assert (Is_Tag (Tag));
1362 -- Loop to look for next tag component
1364 Comp := Next_Entity (Tag);
1365 while Present (Comp) loop
1366 if Is_Tag (Comp) then
1367 pragma Assert (Chars (Comp) /= Name_uTag);
1371 Comp := Next_Entity (Comp);
1374 -- No tag component found
1377 end Next_Tag_Component;
1379 -----------------------
1380 -- Number_Components --
1381 -----------------------
1383 function Number_Components (Typ : Entity_Id) return Pos is
1390 -- We do not call Einfo.First_Component_Or_Discriminant, as this
1391 -- function does not skip completely hidden discriminants, which we
1392 -- want to skip here.
1394 if Has_Discriminants (Typ) then
1395 Comp := First_Discriminant (Typ);
1397 Comp := First_Component (Typ);
1400 while Present (Comp) loop
1402 Comp := Next_Component_Or_Discriminant (Comp);
1406 end Number_Components;
1408 --------------------------
1409 -- Number_Discriminants --
1410 --------------------------
1412 function Number_Discriminants (Typ : Entity_Id) return Pos is
1418 Discr := First_Discriminant (Typ);
1419 while Present (Discr) loop
1421 Discr := Next_Discriminant (Discr);
1425 end Number_Discriminants;
1427 ----------------------------------------------
1428 -- Object_Type_Has_Constrained_Partial_View --
1429 ----------------------------------------------
1431 function Object_Type_Has_Constrained_Partial_View
1433 Scop : Entity_Id) return Boolean
1436 return Has_Constrained_Partial_View (Typ)
1437 or else (In_Generic_Body (Scop)
1438 and then Is_Generic_Type (Base_Type (Typ))
1439 and then Is_Private_Type (Base_Type (Typ))
1440 and then not Is_Tagged_Type (Typ)
1441 and then not (Is_Array_Type (Typ)
1442 and then not Is_Constrained (Typ))
1443 and then Has_Discriminants (Typ));
1444 end Object_Type_Has_Constrained_Partial_View;
1450 function Package_Body (E : Entity_Id) return Node_Id is
1454 if Ekind (E) = E_Package_Body then
1457 if Nkind (N) = N_Defining_Program_Unit_Name then
1462 N := Package_Spec (E);
1464 if Present (Corresponding_Body (N)) then
1465 N := Parent (Corresponding_Body (N));
1467 if Nkind (N) = N_Defining_Program_Unit_Name then
1482 function Package_Spec (E : Entity_Id) return Node_Id is
1484 return Parent (Package_Specification (E));
1487 ---------------------------
1488 -- Package_Specification --
1489 ---------------------------
1491 function Package_Specification (E : Entity_Id) return Node_Id is
1497 if Nkind (N) = N_Defining_Program_Unit_Name then
1502 end Package_Specification;
1504 ---------------------
1505 -- Subprogram_Body --
1506 ---------------------
1508 function Subprogram_Body (E : Entity_Id) return Node_Id is
1509 Body_E : constant Entity_Id := Subprogram_Body_Entity (E);
1515 return Parent (Subprogram_Specification (Body_E));
1517 end Subprogram_Body;
1519 ----------------------------
1520 -- Subprogram_Body_Entity --
1521 ----------------------------
1523 function Subprogram_Body_Entity (E : Entity_Id) return Entity_Id is
1527 -- Retrieve the declaration for E
1529 N := Parent (Subprogram_Specification (E));
1531 -- If this declaration is not a subprogram body, then it must be a
1532 -- subprogram declaration or body stub, from which we can retrieve the
1533 -- entity for the corresponding subprogram body if any, or an abstract
1534 -- subprogram declaration, for which we return Empty.
1537 when N_Subprogram_Body =>
1540 when N_Subprogram_Declaration | N_Subprogram_Body_Stub =>
1541 return Corresponding_Body (N);
1546 end Subprogram_Body_Entity;
1548 ---------------------
1549 -- Subprogram_Spec --
1550 ---------------------
1552 function Subprogram_Spec (E : Entity_Id) return Node_Id is
1556 -- Retrieve the declaration for E
1558 N := Parent (Subprogram_Specification (E));
1560 -- This declaration is either subprogram declaration or a subprogram
1561 -- body, in which case return Empty.
1563 if Nkind (N) = N_Subprogram_Declaration then
1568 end Subprogram_Spec;
1570 ------------------------------
1571 -- Subprogram_Specification --
1572 ------------------------------
1574 function Subprogram_Specification (E : Entity_Id) return Node_Id is
1580 if Nkind (N) = N_Defining_Program_Unit_Name then
1584 -- If the Parent pointer of E is not a subprogram specification node
1585 -- (going through an intermediate N_Defining_Program_Unit_Name node
1586 -- for subprogram units), then E is an inherited operation. Its parent
1587 -- points to the type derivation that produces the inheritance: that's
1588 -- the node that generates the subprogram specification. Its alias
1589 -- is the parent subprogram, and that one points to a subprogram
1590 -- declaration, or to another type declaration if this is a hierarchy
1593 if Nkind (N) not in N_Subprogram_Specification then
1594 pragma Assert (Present (Alias (E)));
1595 N := Subprogram_Specification (Alias (E));
1599 end Subprogram_Specification;
1605 procedure Tree_Read is
1607 Obsolescent_Warnings.Tree_Read;
1614 procedure Tree_Write is
1616 Obsolescent_Warnings.Tree_Write;
1619 --------------------
1620 -- Ultimate_Alias --
1621 --------------------
1623 function Ultimate_Alias (Prim : Entity_Id) return Entity_Id is
1624 E : Entity_Id := Prim;
1627 while Present (Alias (E)) loop
1628 pragma Assert (Alias (E) /= E);
1635 --------------------------
1636 -- Unit_Declaration_Node --
1637 --------------------------
1639 function Unit_Declaration_Node (Unit_Id : Entity_Id) return Node_Id is
1640 N : Node_Id := Parent (Unit_Id);
1643 -- Predefined operators do not have a full function declaration
1645 if Ekind (Unit_Id) = E_Operator then
1649 -- Isn't there some better way to express the following ???
1651 while Nkind (N) /= N_Abstract_Subprogram_Declaration
1652 and then Nkind (N) /= N_Formal_Package_Declaration
1653 and then Nkind (N) /= N_Function_Instantiation
1654 and then Nkind (N) /= N_Generic_Package_Declaration
1655 and then Nkind (N) /= N_Generic_Subprogram_Declaration
1656 and then Nkind (N) /= N_Package_Declaration
1657 and then Nkind (N) /= N_Package_Body
1658 and then Nkind (N) /= N_Package_Instantiation
1659 and then Nkind (N) /= N_Package_Renaming_Declaration
1660 and then Nkind (N) /= N_Procedure_Instantiation
1661 and then Nkind (N) /= N_Protected_Body
1662 and then Nkind (N) /= N_Subprogram_Declaration
1663 and then Nkind (N) /= N_Subprogram_Body
1664 and then Nkind (N) /= N_Subprogram_Body_Stub
1665 and then Nkind (N) /= N_Subprogram_Renaming_Declaration
1666 and then Nkind (N) /= N_Task_Body
1667 and then Nkind (N) /= N_Task_Type_Declaration
1668 and then Nkind (N) not in N_Formal_Subprogram_Declaration
1669 and then Nkind (N) not in N_Generic_Renaming_Declaration
1673 -- We don't use Assert here, because that causes an infinite loop
1674 -- when assertions are turned off. Better to crash.
1677 raise Program_Error;
1682 end Unit_Declaration_Node;