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 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 (non-abstract) view of a state or variable
83 if Ekind
(Ent
) = E_Abstract_State
84 and then Present
(Non_Limited_View
(Ent
))
86 return Non_Limited_View
(Ent
);
88 -- The non-limited view of an incomplete type may itself be incomplete
89 -- in which case obtain its full view.
91 elsif Is_Incomplete_Type
(Ent
)
92 and then Present
(Non_Limited_View
(Ent
))
94 return Get_Full_View
(Non_Limited_View
(Ent
));
96 -- If it is class_wide, check whether the specific type comes from a
99 elsif Is_Class_Wide_Type
(Ent
)
100 and then Is_Incomplete_Type
(Etype
(Ent
))
101 and then From_Limited_With
(Etype
(Ent
))
102 and then Present
(Non_Limited_View
(Etype
(Ent
)))
104 return Class_Wide_Type
(Non_Limited_View
(Etype
(Ent
)));
106 -- In all other cases, return entity unchanged
117 function Constant_Value
(Ent
: Entity_Id
) return Node_Id
is
118 D
: constant Node_Id
:= Declaration_Node
(Ent
);
122 -- If we have no declaration node, then return no constant value. Not
123 -- clear how this can happen, but it does sometimes and this is the
129 -- Normal case where a declaration node is present
131 elsif Nkind
(D
) = N_Object_Renaming_Declaration
then
132 return Renamed_Object
(Ent
);
134 -- If this is a component declaration whose entity is a constant, it is
135 -- a prival within a protected function (and so has no constant value).
137 elsif Nkind
(D
) = N_Component_Declaration
then
140 -- If there is an expression, return it
142 elsif Present
(Expression
(D
)) then
143 return (Expression
(D
));
145 -- For a constant, see if we have a full view
147 elsif Ekind
(Ent
) = E_Constant
148 and then Present
(Full_View
(Ent
))
150 Full_D
:= Parent
(Full_View
(Ent
));
152 -- The full view may have been rewritten as an object renaming
154 if Nkind
(Full_D
) = N_Object_Renaming_Declaration
then
155 return Name
(Full_D
);
157 return Expression
(Full_D
);
160 -- Otherwise we have no expression to return
167 ---------------------------------
168 -- Corresponding_Unsigned_Type --
169 ---------------------------------
171 function Corresponding_Unsigned_Type
(Typ
: Entity_Id
) return Entity_Id
is
172 pragma Assert
(Is_Signed_Integer_Type
(Typ
));
173 Siz
: constant Uint
:= Esize
(Base_Type
(Typ
));
175 if Siz
= Esize
(Standard_Short_Short_Integer
) then
176 return Standard_Short_Short_Unsigned
;
177 elsif Siz
= Esize
(Standard_Short_Integer
) then
178 return Standard_Short_Unsigned
;
179 elsif Siz
= Esize
(Standard_Unsigned
) then
180 return Standard_Unsigned
;
181 elsif Siz
= Esize
(Standard_Long_Integer
) then
182 return Standard_Long_Unsigned
;
183 elsif Siz
= Esize
(Standard_Long_Long_Integer
) then
184 return Standard_Long_Long_Unsigned
;
188 end Corresponding_Unsigned_Type
;
190 -----------------------------
191 -- Enclosing_Dynamic_Scope --
192 -----------------------------
194 function Enclosing_Dynamic_Scope
(Ent
: Entity_Id
) return Entity_Id
is
198 -- The following test is an error defense against some syntax errors
199 -- that can leave scopes very messed up.
201 if Ent
= Standard_Standard
then
205 -- Normal case, search enclosing scopes
207 -- Note: the test for Present (S) should not be required, it defends
208 -- against an ill-formed tree.
212 -- If we somehow got an empty value for Scope, the tree must be
213 -- malformed. Rather than blow up we return Standard in this case.
216 return Standard_Standard
;
218 -- Quit if we get to standard or a dynamic scope. We must also
219 -- handle enclosing scopes that have a full view; required to
220 -- locate enclosing scopes that are synchronized private types
221 -- whose full view is a task type.
223 elsif S
= Standard_Standard
224 or else Is_Dynamic_Scope
(S
)
225 or else (Is_Private_Type
(S
)
226 and then Present
(Full_View
(S
))
227 and then Is_Dynamic_Scope
(Full_View
(S
)))
231 -- Otherwise keep climbing
237 end Enclosing_Dynamic_Scope
;
239 ------------------------
240 -- First_Discriminant --
241 ------------------------
243 function First_Discriminant
(Typ
: Entity_Id
) return Entity_Id
is
248 (Has_Discriminants
(Typ
) or else Has_Unknown_Discriminants
(Typ
));
250 Ent
:= First_Entity
(Typ
);
252 -- The discriminants are not necessarily contiguous, because access
253 -- discriminants will generate itypes. They are not the first entities
254 -- either because the tag must be ahead of them.
256 if Chars
(Ent
) = Name_uTag
then
257 Ent
:= Next_Entity
(Ent
);
260 -- Skip all hidden stored discriminants if any
262 while Present
(Ent
) loop
263 exit when Ekind
(Ent
) = E_Discriminant
264 and then not Is_Completely_Hidden
(Ent
);
266 Ent
:= Next_Entity
(Ent
);
269 pragma Assert
(Ekind
(Ent
) = E_Discriminant
);
272 end First_Discriminant
;
274 -------------------------------
275 -- First_Stored_Discriminant --
276 -------------------------------
278 function First_Stored_Discriminant
(Typ
: Entity_Id
) return Entity_Id
is
281 function Has_Completely_Hidden_Discriminant
282 (Typ
: Entity_Id
) return Boolean;
283 -- Scans the Discriminants to see whether any are Completely_Hidden
284 -- (the mechanism for describing non-specified stored discriminants)
285 -- Note that the entity list for the type may contain anonymous access
286 -- types created by expressions that constrain access discriminants.
288 ----------------------------------------
289 -- Has_Completely_Hidden_Discriminant --
290 ----------------------------------------
292 function Has_Completely_Hidden_Discriminant
293 (Typ
: Entity_Id
) return Boolean
298 pragma Assert
(Ekind
(Typ
) = E_Discriminant
);
301 while Present
(Ent
) loop
303 -- Skip anonymous types that may be created by expressions
304 -- used as discriminant constraints on inherited discriminants.
306 if Is_Itype
(Ent
) then
309 elsif Ekind
(Ent
) = E_Discriminant
310 and then Is_Completely_Hidden
(Ent
)
315 Ent
:= Next_Entity
(Ent
);
319 end Has_Completely_Hidden_Discriminant
;
321 -- Start of processing for First_Stored_Discriminant
325 (Has_Discriminants
(Typ
)
326 or else Has_Unknown_Discriminants
(Typ
));
328 Ent
:= First_Entity
(Typ
);
330 if Chars
(Ent
) = Name_uTag
then
331 Ent
:= Next_Entity
(Ent
);
334 if Has_Completely_Hidden_Discriminant
(Ent
) then
335 while Present
(Ent
) loop
336 exit when Ekind
(Ent
) = E_Discriminant
337 and then Is_Completely_Hidden
(Ent
);
338 Ent
:= Next_Entity
(Ent
);
342 pragma Assert
(Ekind
(Ent
) = E_Discriminant
);
345 end First_Stored_Discriminant
;
351 function First_Subtype
(Typ
: Entity_Id
) return Entity_Id
is
352 B
: constant Entity_Id
:= Base_Type
(Typ
);
353 F
: constant Node_Id
:= Freeze_Node
(B
);
357 -- If the base type has no freeze node, it is a type in Standard, and
358 -- always acts as its own first subtype, except where it is one of the
359 -- predefined integer types. If the type is formal, it is also a first
360 -- subtype, and its base type has no freeze node. On the other hand, a
361 -- subtype of a generic formal is not its own first subtype. Its base
362 -- type, if anonymous, is attached to the formal type decl. from which
363 -- the first subtype is obtained.
366 if B
= Base_Type
(Standard_Integer
) then
367 return Standard_Integer
;
369 elsif B
= Base_Type
(Standard_Long_Integer
) then
370 return Standard_Long_Integer
;
372 elsif B
= Base_Type
(Standard_Short_Short_Integer
) then
373 return Standard_Short_Short_Integer
;
375 elsif B
= Base_Type
(Standard_Short_Integer
) then
376 return Standard_Short_Integer
;
378 elsif B
= Base_Type
(Standard_Long_Long_Integer
) then
379 return Standard_Long_Long_Integer
;
381 elsif Is_Generic_Type
(Typ
) then
382 if Present
(Parent
(B
)) then
383 return Defining_Identifier
(Parent
(B
));
385 return Defining_Identifier
(Associated_Node_For_Itype
(B
));
392 -- Otherwise we check the freeze node, if it has a First_Subtype_Link
393 -- then we use that link, otherwise (happens with some Itypes), we use
394 -- the base type itself.
397 Ent
:= First_Subtype_Link
(F
);
399 if Present
(Ent
) then
407 -------------------------
408 -- First_Tag_Component --
409 -------------------------
411 function First_Tag_Component
(Typ
: Entity_Id
) return Entity_Id
is
417 pragma Assert
(Is_Tagged_Type
(Ctyp
));
419 if Is_Class_Wide_Type
(Ctyp
) then
420 Ctyp
:= Root_Type
(Ctyp
);
423 if Is_Private_Type
(Ctyp
) then
424 Ctyp
:= Underlying_Type
(Ctyp
);
426 -- If the underlying type is missing then the source program has
427 -- errors and there is nothing else to do (the full-type declaration
428 -- associated with the private type declaration is missing).
435 Comp
:= First_Entity
(Ctyp
);
436 while Present
(Comp
) loop
437 if Is_Tag
(Comp
) then
441 Comp
:= Next_Entity
(Comp
);
444 -- No tag component found
447 end First_Tag_Component
;
449 ---------------------
450 -- Get_Binary_Nkind --
451 ---------------------
453 function Get_Binary_Nkind
(Op
: Entity_Id
) return Node_Kind
is
458 when Name_Op_Concat
=>
460 when Name_Op_Expon
=>
462 when Name_Op_Subtract
=>
463 return N_Op_Subtract
;
466 when Name_Op_Multiply
=>
467 return N_Op_Multiply
;
468 when Name_Op_Divide
=>
493 end Get_Binary_Nkind
;
499 function Get_Rep_Item
502 Check_Parents
: Boolean := True) return Node_Id
507 N
:= First_Rep_Item
(E
);
508 while Present
(N
) loop
510 -- Only one of Priority / Interrupt_Priority can be specified, so
511 -- return whichever one is present to catch illegal duplication.
513 if Nkind
(N
) = N_Pragma
515 (Pragma_Name
(N
) = Nam
516 or else (Nam
= Name_Priority
517 and then Pragma_Name
(N
) = Name_Interrupt_Priority
)
518 or else (Nam
= Name_Interrupt_Priority
519 and then Pragma_Name
(N
) = Name_Priority
))
521 if Check_Parents
then
524 -- If Check_Parents is False, return N if the pragma doesn't
525 -- appear in the Rep_Item chain of the parent.
529 Par
: constant Entity_Id
:= Nearest_Ancestor
(E
);
530 -- This node represents the parent type of type E (if any)
536 elsif not Present_In_Rep_Item
(Par
, N
) then
542 elsif Nkind
(N
) = N_Attribute_Definition_Clause
545 or else (Nam
= Name_Priority
546 and then Chars
(N
) = Name_Interrupt_Priority
))
548 if Check_Parents
or else Entity
(N
) = E
then
552 elsif Nkind
(N
) = N_Aspect_Specification
554 (Chars
(Identifier
(N
)) = Nam
557 and then Chars
(Identifier
(N
)) = Name_Interrupt_Priority
))
559 if Check_Parents
then
562 elsif Entity
(N
) = E
then
573 function Get_Rep_Item
577 Check_Parents
: Boolean := True) return Node_Id
579 Nam1_Item
: constant Node_Id
:= Get_Rep_Item
(E
, Nam1
, Check_Parents
);
580 Nam2_Item
: constant Node_Id
:= Get_Rep_Item
(E
, Nam2
, Check_Parents
);
585 -- Check both Nam1_Item and Nam2_Item are present
587 if No
(Nam1_Item
) then
589 elsif No
(Nam2_Item
) then
593 -- Return the first node encountered in the list
595 N
:= First_Rep_Item
(E
);
596 while Present
(N
) loop
597 if N
= Nam1_Item
or else N
= Nam2_Item
then
611 function Get_Rep_Pragma
614 Check_Parents
: Boolean := True) return Node_Id
619 N
:= Get_Rep_Item
(E
, Nam
, Check_Parents
);
621 if Present
(N
) and then Nkind
(N
) = N_Pragma
then
628 function Get_Rep_Pragma
632 Check_Parents
: Boolean := True) return Node_Id
634 Nam1_Item
: constant Node_Id
:= Get_Rep_Pragma
(E
, Nam1
, Check_Parents
);
635 Nam2_Item
: constant Node_Id
:= Get_Rep_Pragma
(E
, Nam2
, Check_Parents
);
640 -- Check both Nam1_Item and Nam2_Item are present
642 if No
(Nam1_Item
) then
644 elsif No
(Nam2_Item
) then
648 -- Return the first node encountered in the list
650 N
:= First_Rep_Item
(E
);
651 while Present
(N
) loop
652 if N
= Nam1_Item
or else N
= Nam2_Item
then
662 ---------------------
663 -- Get_Unary_Nkind --
664 ---------------------
666 function Get_Unary_Nkind
(Op
: Entity_Id
) return Node_Kind
is
671 when Name_Op_Subtract
=>
682 ---------------------------------
683 -- Has_External_Tag_Rep_Clause --
684 ---------------------------------
686 function Has_External_Tag_Rep_Clause
(T
: Entity_Id
) return Boolean is
688 pragma Assert
(Is_Tagged_Type
(T
));
689 return Has_Rep_Item
(T
, Name_External_Tag
, Check_Parents
=> False);
690 end Has_External_Tag_Rep_Clause
;
696 function Has_Rep_Item
699 Check_Parents
: Boolean := True) return Boolean
702 return Present
(Get_Rep_Item
(E
, Nam
, Check_Parents
));
705 function Has_Rep_Item
709 Check_Parents
: Boolean := True) return Boolean
712 return Present
(Get_Rep_Item
(E
, Nam1
, Nam2
, Check_Parents
));
719 function Has_Rep_Pragma
722 Check_Parents
: Boolean := True) return Boolean
725 return Present
(Get_Rep_Pragma
(E
, Nam
, Check_Parents
));
728 function Has_Rep_Pragma
732 Check_Parents
: Boolean := True) return Boolean
735 return Present
(Get_Rep_Pragma
(E
, Nam1
, Nam2
, Check_Parents
));
738 --------------------------------
739 -- Has_Unconstrained_Elements --
740 --------------------------------
742 function Has_Unconstrained_Elements
(T
: Entity_Id
) return Boolean is
743 U_T
: constant Entity_Id
:= Underlying_Type
(T
);
747 elsif Is_Record_Type
(U_T
) then
748 return Has_Discriminants
(U_T
) and then not Is_Constrained
(U_T
);
749 elsif Is_Array_Type
(U_T
) then
750 return Has_Unconstrained_Elements
(Component_Type
(U_T
));
754 end Has_Unconstrained_Elements
;
756 ----------------------
757 -- Has_Variant_Part --
758 ----------------------
760 function Has_Variant_Part
(Typ
: Entity_Id
) return Boolean is
767 if not Is_Type
(Typ
) then
771 FSTyp
:= First_Subtype
(Typ
);
773 if not Has_Discriminants
(FSTyp
) then
777 -- Proceed with cautious checks here, return False if tree is not
778 -- as expected (may be caused by prior errors).
780 Decl
:= Declaration_Node
(FSTyp
);
782 if Nkind
(Decl
) /= N_Full_Type_Declaration
then
786 TDef
:= Type_Definition
(Decl
);
788 if Nkind
(TDef
) /= N_Record_Definition
then
792 CList
:= Component_List
(TDef
);
794 if Nkind
(CList
) /= N_Component_List
then
797 return Present
(Variant_Part
(CList
));
799 end Has_Variant_Part
;
801 ---------------------
802 -- In_Generic_Body --
803 ---------------------
805 function In_Generic_Body
(Id
: Entity_Id
) return Boolean is
809 -- Climb scopes looking for generic body
812 while Present
(S
) and then S
/= Standard_Standard
loop
814 -- Generic package body
816 if Ekind
(S
) = E_Generic_Package
817 and then In_Package_Body
(S
)
821 -- Generic subprogram body
823 elsif Is_Subprogram
(S
)
824 and then Nkind
(Unit_Declaration_Node
(S
))
825 = N_Generic_Subprogram_Declaration
833 -- False if top of scope stack without finding a generic body
838 -------------------------------
839 -- Initialization_Suppressed --
840 -------------------------------
842 function Initialization_Suppressed
(Typ
: Entity_Id
) return Boolean is
844 return Suppress_Initialization
(Typ
)
845 or else Suppress_Initialization
(Base_Type
(Typ
));
846 end Initialization_Suppressed
;
852 procedure Initialize
is
854 Obsolescent_Warnings
.Init
;
861 function Is_Body
(N
: Node_Id
) return Boolean is
864 Nkind
(N
) in N_Body_Stub
865 or else Nkind_In
(N
, N_Entry_Body
,
872 ---------------------
873 -- Is_By_Copy_Type --
874 ---------------------
876 function Is_By_Copy_Type
(Ent
: Entity_Id
) return Boolean is
878 -- If Id is a private type whose full declaration has not been seen,
879 -- we assume for now that it is not a By_Copy type. Clearly this
880 -- attribute should not be used before the type is frozen, but it is
881 -- needed to build the associated record of a protected type. Another
882 -- place where some lookahead for a full view is needed ???
885 Is_Elementary_Type
(Ent
)
886 or else (Is_Private_Type
(Ent
)
887 and then Present
(Underlying_Type
(Ent
))
888 and then Is_Elementary_Type
(Underlying_Type
(Ent
)));
891 --------------------------
892 -- Is_By_Reference_Type --
893 --------------------------
895 function Is_By_Reference_Type
(Ent
: Entity_Id
) return Boolean is
896 Btype
: constant Entity_Id
:= Base_Type
(Ent
);
899 if Error_Posted
(Ent
) or else Error_Posted
(Btype
) then
902 elsif Is_Private_Type
(Btype
) then
904 Utyp
: constant Entity_Id
:= Underlying_Type
(Btype
);
909 return Is_By_Reference_Type
(Utyp
);
913 elsif Is_Incomplete_Type
(Btype
) then
915 Ftyp
: constant Entity_Id
:= Full_View
(Btype
);
920 return Is_By_Reference_Type
(Ftyp
);
924 elsif Is_Concurrent_Type
(Btype
) then
927 elsif Is_Record_Type
(Btype
) then
928 if Is_Limited_Record
(Btype
)
929 or else Is_Tagged_Type
(Btype
)
930 or else Is_Volatile
(Btype
)
939 C
:= First_Component
(Btype
);
940 while Present
(C
) loop
942 -- For each component, test if its type is a by reference
943 -- type and if its type is volatile. Also test the component
944 -- itself for being volatile. This happens for example when
945 -- a Volatile aspect is added to a component.
947 if Is_By_Reference_Type
(Etype
(C
))
948 or else Is_Volatile
(Etype
(C
))
949 or else Is_Volatile
(C
)
954 C
:= Next_Component
(C
);
961 elsif Is_Array_Type
(Btype
) then
964 or else Is_By_Reference_Type
(Component_Type
(Btype
))
965 or else Is_Volatile
(Component_Type
(Btype
))
966 or else Has_Volatile_Components
(Btype
);
971 end Is_By_Reference_Type
;
973 ---------------------
974 -- Is_Derived_Type --
975 ---------------------
977 function Is_Derived_Type
(Ent
: E
) return B
is
982 and then Base_Type
(Ent
) /= Root_Type
(Ent
)
983 and then not Is_Class_Wide_Type
(Ent
)
985 if not Is_Numeric_Type
(Root_Type
(Ent
)) then
989 Par
:= Parent
(First_Subtype
(Ent
));
992 and then Nkind
(Par
) = N_Full_Type_Declaration
993 and then Nkind
(Type_Definition
(Par
)) =
994 N_Derived_Type_Definition
;
1000 end Is_Derived_Type
;
1002 -----------------------
1003 -- Is_Generic_Formal --
1004 -----------------------
1006 function Is_Generic_Formal
(E
: Entity_Id
) return Boolean is
1012 Kind
:= Nkind
(Parent
(E
));
1014 Nkind_In
(Kind
, N_Formal_Object_Declaration
,
1015 N_Formal_Package_Declaration
,
1016 N_Formal_Type_Declaration
)
1017 or else Is_Formal_Subprogram
(E
);
1019 end Is_Generic_Formal
;
1021 -------------------------------
1022 -- Is_Immutably_Limited_Type --
1023 -------------------------------
1025 function Is_Immutably_Limited_Type
(Ent
: Entity_Id
) return Boolean is
1026 Btype
: constant Entity_Id
:= Available_View
(Base_Type
(Ent
));
1029 if Is_Limited_Record
(Btype
) then
1032 elsif Ekind
(Btype
) = E_Limited_Private_Type
1033 and then Nkind
(Parent
(Btype
)) = N_Formal_Type_Declaration
1035 return not In_Package_Body
(Scope
((Btype
)));
1037 elsif Is_Private_Type
(Btype
) then
1039 -- AI05-0063: A type derived from a limited private formal type is
1040 -- not immutably limited in a generic body.
1042 if Is_Derived_Type
(Btype
)
1043 and then Is_Generic_Type
(Etype
(Btype
))
1045 if not Is_Limited_Type
(Etype
(Btype
)) then
1048 -- A descendant of a limited formal type is not immutably limited
1049 -- in the generic body, or in the body of a generic child.
1051 elsif Ekind
(Scope
(Etype
(Btype
))) = E_Generic_Package
then
1052 return not In_Package_Body
(Scope
(Btype
));
1060 Utyp
: constant Entity_Id
:= Underlying_Type
(Btype
);
1065 return Is_Immutably_Limited_Type
(Utyp
);
1070 elsif Is_Concurrent_Type
(Btype
) then
1076 end Is_Immutably_Limited_Type
;
1078 ---------------------------
1079 -- Is_Indefinite_Subtype --
1080 ---------------------------
1082 function Is_Indefinite_Subtype
(Ent
: Entity_Id
) return Boolean is
1083 K
: constant Entity_Kind
:= Ekind
(Ent
);
1086 if Is_Constrained
(Ent
) then
1089 elsif K
in Array_Kind
1090 or else K
in Class_Wide_Kind
1091 or else Has_Unknown_Discriminants
(Ent
)
1095 -- Known discriminants: indefinite if there are no default values
1097 elsif K
in Record_Kind
1098 or else Is_Incomplete_Or_Private_Type
(Ent
)
1099 or else Is_Concurrent_Type
(Ent
)
1101 return (Has_Discriminants
(Ent
)
1103 No
(Discriminant_Default_Value
(First_Discriminant
(Ent
))));
1108 end Is_Indefinite_Subtype
;
1110 ---------------------
1111 -- Is_Limited_Type --
1112 ---------------------
1114 function Is_Limited_Type
(Ent
: Entity_Id
) return Boolean is
1115 Btype
: constant E
:= Base_Type
(Ent
);
1116 Rtype
: constant E
:= Root_Type
(Btype
);
1119 if not Is_Type
(Ent
) then
1122 elsif Ekind
(Btype
) = E_Limited_Private_Type
1123 or else Is_Limited_Composite
(Btype
)
1127 elsif Is_Concurrent_Type
(Btype
) then
1130 -- The Is_Limited_Record flag normally indicates that the type is
1131 -- limited. The exception is that a type does not inherit limitedness
1132 -- from its interface ancestor. So the type may be derived from a
1133 -- limited interface, but is not limited.
1135 elsif Is_Limited_Record
(Ent
)
1136 and then not Is_Interface
(Ent
)
1140 -- Otherwise we will look around to see if there is some other reason
1141 -- for it to be limited, except that if an error was posted on the
1142 -- entity, then just assume it is non-limited, because it can cause
1143 -- trouble to recurse into a murky entity resulting from other errors.
1145 elsif Error_Posted
(Ent
) then
1148 elsif Is_Record_Type
(Btype
) then
1150 if Is_Limited_Interface
(Ent
) then
1153 -- AI-419: limitedness is not inherited from a limited interface
1155 elsif Is_Limited_Record
(Rtype
) then
1156 return not Is_Interface
(Rtype
)
1157 or else Is_Protected_Interface
(Rtype
)
1158 or else Is_Synchronized_Interface
(Rtype
)
1159 or else Is_Task_Interface
(Rtype
);
1161 elsif Is_Class_Wide_Type
(Btype
) then
1162 return Is_Limited_Type
(Rtype
);
1169 C
:= First_Component
(Btype
);
1170 while Present
(C
) loop
1171 if Is_Limited_Type
(Etype
(C
)) then
1175 C
:= Next_Component
(C
);
1182 elsif Is_Array_Type
(Btype
) then
1183 return Is_Limited_Type
(Component_Type
(Btype
));
1188 end Is_Limited_Type
;
1190 ---------------------
1191 -- Is_Limited_View --
1192 ---------------------
1194 function Is_Limited_View
(Ent
: Entity_Id
) return Boolean is
1195 Btype
: constant Entity_Id
:= Available_View
(Base_Type
(Ent
));
1198 if Is_Limited_Record
(Btype
) then
1201 elsif Ekind
(Btype
) = E_Limited_Private_Type
1202 and then Nkind
(Parent
(Btype
)) = N_Formal_Type_Declaration
1204 return not In_Package_Body
(Scope
((Btype
)));
1206 elsif Is_Private_Type
(Btype
) then
1208 -- AI05-0063: A type derived from a limited private formal type is
1209 -- not immutably limited in a generic body.
1211 if Is_Derived_Type
(Btype
)
1212 and then Is_Generic_Type
(Etype
(Btype
))
1214 if not Is_Limited_Type
(Etype
(Btype
)) then
1217 -- A descendant of a limited formal type is not immutably limited
1218 -- in the generic body, or in the body of a generic child.
1220 elsif Ekind
(Scope
(Etype
(Btype
))) = E_Generic_Package
then
1221 return not In_Package_Body
(Scope
(Btype
));
1229 Utyp
: constant Entity_Id
:= Underlying_Type
(Btype
);
1234 return Is_Limited_View
(Utyp
);
1239 elsif Is_Concurrent_Type
(Btype
) then
1242 elsif Is_Record_Type
(Btype
) then
1244 -- Note that we return True for all limited interfaces, even though
1245 -- (unsynchronized) limited interfaces can have descendants that are
1246 -- nonlimited, because this is a predicate on the type itself, and
1247 -- things like functions with limited interface results need to be
1248 -- handled as build in place even though they might return objects
1249 -- of a type that is not inherently limited.
1251 if Is_Class_Wide_Type
(Btype
) then
1252 return Is_Limited_View
(Root_Type
(Btype
));
1259 C
:= First_Component
(Btype
);
1260 while Present
(C
) loop
1262 -- Don't consider components with interface types (which can
1263 -- only occur in the case of a _parent component anyway).
1264 -- They don't have any components, plus it would cause this
1265 -- function to return true for nonlimited types derived from
1266 -- limited interfaces.
1268 if not Is_Interface
(Etype
(C
))
1269 and then Is_Limited_View
(Etype
(C
))
1274 C
:= Next_Component
(C
);
1281 elsif Is_Array_Type
(Btype
) then
1282 return Is_Limited_View
(Component_Type
(Btype
));
1287 end Is_Limited_View
;
1289 ----------------------
1290 -- Nearest_Ancestor --
1291 ----------------------
1293 function Nearest_Ancestor
(Typ
: Entity_Id
) return Entity_Id
is
1294 D
: constant Node_Id
:= Declaration_Node
(Typ
);
1297 -- If we have a subtype declaration, get the ancestor subtype
1299 if Nkind
(D
) = N_Subtype_Declaration
then
1300 if Nkind
(Subtype_Indication
(D
)) = N_Subtype_Indication
then
1301 return Entity
(Subtype_Mark
(Subtype_Indication
(D
)));
1303 return Entity
(Subtype_Indication
(D
));
1306 -- If derived type declaration, find who we are derived from
1308 elsif Nkind
(D
) = N_Full_Type_Declaration
1309 and then Nkind
(Type_Definition
(D
)) = N_Derived_Type_Definition
1312 DTD
: constant Entity_Id
:= Type_Definition
(D
);
1313 SI
: constant Entity_Id
:= Subtype_Indication
(DTD
);
1315 if Is_Entity_Name
(SI
) then
1318 return Entity
(Subtype_Mark
(SI
));
1322 -- If derived type and private type, get the full view to find who we
1323 -- are derived from.
1325 elsif Is_Derived_Type
(Typ
)
1326 and then Is_Private_Type
(Typ
)
1327 and then Present
(Full_View
(Typ
))
1329 return Nearest_Ancestor
(Full_View
(Typ
));
1331 -- Otherwise, nothing useful to return, return Empty
1336 end Nearest_Ancestor
;
1338 ---------------------------
1339 -- Nearest_Dynamic_Scope --
1340 ---------------------------
1342 function Nearest_Dynamic_Scope
(Ent
: Entity_Id
) return Entity_Id
is
1344 if Is_Dynamic_Scope
(Ent
) then
1347 return Enclosing_Dynamic_Scope
(Ent
);
1349 end Nearest_Dynamic_Scope
;
1351 ------------------------
1352 -- Next_Tag_Component --
1353 ------------------------
1355 function Next_Tag_Component
(Tag
: Entity_Id
) return Entity_Id
is
1359 pragma Assert
(Is_Tag
(Tag
));
1361 -- Loop to look for next tag component
1363 Comp
:= Next_Entity
(Tag
);
1364 while Present
(Comp
) loop
1365 if Is_Tag
(Comp
) then
1366 pragma Assert
(Chars
(Comp
) /= Name_uTag
);
1370 Comp
:= Next_Entity
(Comp
);
1373 -- No tag component found
1376 end Next_Tag_Component
;
1378 --------------------------
1379 -- Number_Discriminants --
1380 --------------------------
1382 function Number_Discriminants
(Typ
: Entity_Id
) return Pos
is
1388 Discr
:= First_Discriminant
(Typ
);
1389 while Present
(Discr
) loop
1391 Discr
:= Next_Discriminant
(Discr
);
1395 end Number_Discriminants
;
1397 ----------------------------------------------
1398 -- Object_Type_Has_Constrained_Partial_View --
1399 ----------------------------------------------
1401 function Object_Type_Has_Constrained_Partial_View
1403 Scop
: Entity_Id
) return Boolean
1406 return Has_Constrained_Partial_View
(Typ
)
1407 or else (In_Generic_Body
(Scop
)
1408 and then Is_Generic_Type
(Base_Type
(Typ
))
1409 and then Is_Private_Type
(Base_Type
(Typ
))
1410 and then not Is_Tagged_Type
(Typ
)
1411 and then not (Is_Array_Type
(Typ
)
1412 and then not Is_Constrained
(Typ
))
1413 and then Has_Discriminants
(Typ
));
1414 end Object_Type_Has_Constrained_Partial_View
;
1416 ---------------------------
1417 -- Package_Specification --
1418 ---------------------------
1420 function Package_Specification
(Pack_Id
: Entity_Id
) return Node_Id
is
1424 N
:= Parent
(Pack_Id
);
1425 while Nkind
(N
) /= N_Package_Specification
loop
1429 raise Program_Error
;
1434 end Package_Specification
;
1440 procedure Tree_Read
is
1442 Obsolescent_Warnings
.Tree_Read
;
1449 procedure Tree_Write
is
1451 Obsolescent_Warnings
.Tree_Write
;
1454 --------------------
1455 -- Ultimate_Alias --
1456 --------------------
1458 function Ultimate_Alias
(Prim
: Entity_Id
) return Entity_Id
is
1459 E
: Entity_Id
:= Prim
;
1462 while Present
(Alias
(E
)) loop
1463 pragma Assert
(Alias
(E
) /= E
);
1470 --------------------------
1471 -- Unit_Declaration_Node --
1472 --------------------------
1474 function Unit_Declaration_Node
(Unit_Id
: Entity_Id
) return Node_Id
is
1475 N
: Node_Id
:= Parent
(Unit_Id
);
1478 -- Predefined operators do not have a full function declaration
1480 if Ekind
(Unit_Id
) = E_Operator
then
1484 -- Isn't there some better way to express the following ???
1486 while Nkind
(N
) /= N_Abstract_Subprogram_Declaration
1487 and then Nkind
(N
) /= N_Formal_Package_Declaration
1488 and then Nkind
(N
) /= N_Function_Instantiation
1489 and then Nkind
(N
) /= N_Generic_Package_Declaration
1490 and then Nkind
(N
) /= N_Generic_Subprogram_Declaration
1491 and then Nkind
(N
) /= N_Package_Declaration
1492 and then Nkind
(N
) /= N_Package_Body
1493 and then Nkind
(N
) /= N_Package_Instantiation
1494 and then Nkind
(N
) /= N_Package_Renaming_Declaration
1495 and then Nkind
(N
) /= N_Procedure_Instantiation
1496 and then Nkind
(N
) /= N_Protected_Body
1497 and then Nkind
(N
) /= N_Subprogram_Declaration
1498 and then Nkind
(N
) /= N_Subprogram_Body
1499 and then Nkind
(N
) /= N_Subprogram_Body_Stub
1500 and then Nkind
(N
) /= N_Subprogram_Renaming_Declaration
1501 and then Nkind
(N
) /= N_Task_Body
1502 and then Nkind
(N
) /= N_Task_Type_Declaration
1503 and then Nkind
(N
) not in N_Formal_Subprogram_Declaration
1504 and then Nkind
(N
) not in N_Generic_Renaming_Declaration
1508 -- We don't use Assert here, because that causes an infinite loop
1509 -- when assertions are turned off. Better to crash.
1512 raise Program_Error
;
1517 end Unit_Declaration_Node
;