1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2017, 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
441 when Name_Op_Add
=> return N_Op_Add
;
442 when Name_Op_Concat
=> return N_Op_Concat
;
443 when Name_Op_Expon
=> return N_Op_Expon
;
444 when Name_Op_Subtract
=> return N_Op_Subtract
;
445 when Name_Op_Mod
=> return N_Op_Mod
;
446 when Name_Op_Multiply
=> return N_Op_Multiply
;
447 when Name_Op_Divide
=> return N_Op_Divide
;
448 when Name_Op_Rem
=> return N_Op_Rem
;
449 when Name_Op_And
=> return N_Op_And
;
450 when Name_Op_Eq
=> return N_Op_Eq
;
451 when Name_Op_Ge
=> return N_Op_Ge
;
452 when Name_Op_Gt
=> return N_Op_Gt
;
453 when Name_Op_Le
=> return N_Op_Le
;
454 when Name_Op_Lt
=> return N_Op_Lt
;
455 when Name_Op_Ne
=> return N_Op_Ne
;
456 when Name_Op_Or
=> return N_Op_Or
;
457 when Name_Op_Xor
=> return N_Op_Xor
;
458 when others => raise Program_Error
;
460 end Get_Binary_Nkind
;
466 function Get_Low_Bound
(E
: Entity_Id
) return Node_Id
is
468 if Ekind
(E
) = E_String_Literal_Subtype
then
469 return String_Literal_Low_Bound
(E
);
471 return Type_Low_Bound
(E
);
479 function Get_Rep_Item
482 Check_Parents
: Boolean := True) return Node_Id
487 N
:= First_Rep_Item
(E
);
488 while Present
(N
) loop
490 -- Only one of Priority / Interrupt_Priority can be specified, so
491 -- return whichever one is present to catch illegal duplication.
493 if Nkind
(N
) = N_Pragma
495 (Pragma_Name_Unmapped
(N
) = Nam
496 or else (Nam
= Name_Priority
497 and then Pragma_Name
(N
) =
498 Name_Interrupt_Priority
)
499 or else (Nam
= Name_Interrupt_Priority
500 and then Pragma_Name
(N
) = Name_Priority
))
502 if Check_Parents
then
505 -- If Check_Parents is False, return N if the pragma doesn't
506 -- appear in the Rep_Item chain of the parent.
510 Par
: constant Entity_Id
:= Nearest_Ancestor
(E
);
511 -- This node represents the parent type of type E (if any)
517 elsif not Present_In_Rep_Item
(Par
, N
) then
523 elsif Nkind
(N
) = N_Attribute_Definition_Clause
526 or else (Nam
= Name_Priority
527 and then Chars
(N
) = Name_Interrupt_Priority
))
529 if Check_Parents
or else Entity
(N
) = E
then
533 elsif Nkind
(N
) = N_Aspect_Specification
535 (Chars
(Identifier
(N
)) = Nam
538 and then Chars
(Identifier
(N
)) = Name_Interrupt_Priority
))
540 if Check_Parents
then
543 elsif Entity
(N
) = E
then
554 function Get_Rep_Item
558 Check_Parents
: Boolean := True) return Node_Id
560 Nam1_Item
: constant Node_Id
:= Get_Rep_Item
(E
, Nam1
, Check_Parents
);
561 Nam2_Item
: constant Node_Id
:= Get_Rep_Item
(E
, Nam2
, Check_Parents
);
566 -- Check both Nam1_Item and Nam2_Item are present
568 if No
(Nam1_Item
) then
570 elsif No
(Nam2_Item
) then
574 -- Return the first node encountered in the list
576 N
:= First_Rep_Item
(E
);
577 while Present
(N
) loop
578 if N
= Nam1_Item
or else N
= Nam2_Item
then
592 function Get_Rep_Pragma
595 Check_Parents
: Boolean := True) return Node_Id
597 N
: constant Node_Id
:= Get_Rep_Item
(E
, Nam
, Check_Parents
);
600 if Present
(N
) and then Nkind
(N
) = N_Pragma
then
607 function Get_Rep_Pragma
611 Check_Parents
: Boolean := True) return Node_Id
613 Nam1_Item
: constant Node_Id
:= Get_Rep_Pragma
(E
, Nam1
, Check_Parents
);
614 Nam2_Item
: constant Node_Id
:= Get_Rep_Pragma
(E
, Nam2
, Check_Parents
);
619 -- Check both Nam1_Item and Nam2_Item are present
621 if No
(Nam1_Item
) then
623 elsif No
(Nam2_Item
) then
627 -- Return the first node encountered in the list
629 N
:= First_Rep_Item
(E
);
630 while Present
(N
) loop
631 if N
= Nam1_Item
or else N
= Nam2_Item
then
641 ---------------------
642 -- Get_Unary_Nkind --
643 ---------------------
645 function Get_Unary_Nkind
(Op
: Entity_Id
) return Node_Kind
is
648 when Name_Op_Abs
=> return N_Op_Abs
;
649 when Name_Op_Subtract
=> return N_Op_Minus
;
650 when Name_Op_Not
=> return N_Op_Not
;
651 when Name_Op_Add
=> return N_Op_Plus
;
652 when others => raise Program_Error
;
656 ---------------------------------
657 -- Has_External_Tag_Rep_Clause --
658 ---------------------------------
660 function Has_External_Tag_Rep_Clause
(T
: Entity_Id
) return Boolean is
662 pragma Assert
(Is_Tagged_Type
(T
));
663 return Has_Rep_Item
(T
, Name_External_Tag
, Check_Parents
=> False);
664 end Has_External_Tag_Rep_Clause
;
670 function Has_Rep_Item
673 Check_Parents
: Boolean := True) return Boolean
676 return Present
(Get_Rep_Item
(E
, Nam
, Check_Parents
));
679 function Has_Rep_Item
683 Check_Parents
: Boolean := True) return Boolean
686 return Present
(Get_Rep_Item
(E
, Nam1
, Nam2
, Check_Parents
));
689 function Has_Rep_Item
(E
: Entity_Id
; N
: Node_Id
) return Boolean is
694 (Nkind_In
(N
, N_Aspect_Specification
,
695 N_Attribute_Definition_Clause
,
696 N_Enumeration_Representation_Clause
,
698 N_Record_Representation_Clause
));
700 Item
:= First_Rep_Item
(E
);
701 while Present
(Item
) loop
706 Item
:= Next_Rep_Item
(Item
);
716 function Has_Rep_Pragma
719 Check_Parents
: Boolean := True) return Boolean
722 return Present
(Get_Rep_Pragma
(E
, Nam
, Check_Parents
));
725 function Has_Rep_Pragma
729 Check_Parents
: Boolean := True) return Boolean
732 return Present
(Get_Rep_Pragma
(E
, Nam1
, Nam2
, Check_Parents
));
735 --------------------------------
736 -- Has_Unconstrained_Elements --
737 --------------------------------
739 function Has_Unconstrained_Elements
(T
: Entity_Id
) return Boolean is
740 U_T
: constant Entity_Id
:= Underlying_Type
(T
);
744 elsif Is_Record_Type
(U_T
) then
745 return Has_Discriminants
(U_T
) and then not Is_Constrained
(U_T
);
746 elsif Is_Array_Type
(U_T
) then
747 return Has_Unconstrained_Elements
(Component_Type
(U_T
));
751 end Has_Unconstrained_Elements
;
753 ----------------------
754 -- Has_Variant_Part --
755 ----------------------
757 function Has_Variant_Part
(Typ
: Entity_Id
) return Boolean is
764 if not Is_Type
(Typ
) then
768 FSTyp
:= First_Subtype
(Typ
);
770 if not Has_Discriminants
(FSTyp
) then
774 -- Proceed with cautious checks here, return False if tree is not
775 -- as expected (may be caused by prior errors).
777 Decl
:= Declaration_Node
(FSTyp
);
779 if Nkind
(Decl
) /= N_Full_Type_Declaration
then
783 TDef
:= Type_Definition
(Decl
);
785 if Nkind
(TDef
) /= N_Record_Definition
then
789 CList
:= Component_List
(TDef
);
791 if Nkind
(CList
) /= N_Component_List
then
794 return Present
(Variant_Part
(CList
));
796 end Has_Variant_Part
;
798 ---------------------
799 -- In_Generic_Body --
800 ---------------------
802 function In_Generic_Body
(Id
: Entity_Id
) return Boolean is
806 -- Climb scopes looking for generic body
809 while Present
(S
) and then S
/= Standard_Standard
loop
811 -- Generic package body
813 if Ekind
(S
) = E_Generic_Package
814 and then In_Package_Body
(S
)
818 -- Generic subprogram body
820 elsif Is_Subprogram
(S
)
821 and then Nkind
(Unit_Declaration_Node
(S
)) =
822 N_Generic_Subprogram_Declaration
830 -- False if top of scope stack without finding a generic body
835 -------------------------------
836 -- Initialization_Suppressed --
837 -------------------------------
839 function Initialization_Suppressed
(Typ
: Entity_Id
) return Boolean is
841 return Suppress_Initialization
(Typ
)
842 or else Suppress_Initialization
(Base_Type
(Typ
));
843 end Initialization_Suppressed
;
849 procedure Initialize
is
851 Obsolescent_Warnings
.Init
;
858 function Is_Body
(N
: Node_Id
) return Boolean is
861 Nkind
(N
) in N_Body_Stub
862 or else Nkind_In
(N
, N_Entry_Body
,
869 ---------------------
870 -- Is_By_Copy_Type --
871 ---------------------
873 function Is_By_Copy_Type
(Ent
: Entity_Id
) return Boolean is
875 -- If Id is a private type whose full declaration has not been seen,
876 -- we assume for now that it is not a By_Copy type. Clearly this
877 -- attribute should not be used before the type is frozen, but it is
878 -- needed to build the associated record of a protected type. Another
879 -- place where some lookahead for a full view is needed ???
882 Is_Elementary_Type
(Ent
)
883 or else (Is_Private_Type
(Ent
)
884 and then Present
(Underlying_Type
(Ent
))
885 and then Is_Elementary_Type
(Underlying_Type
(Ent
)));
888 --------------------------
889 -- Is_By_Reference_Type --
890 --------------------------
892 function Is_By_Reference_Type
(Ent
: Entity_Id
) return Boolean is
893 Btype
: constant Entity_Id
:= Base_Type
(Ent
);
896 if Error_Posted
(Ent
) or else Error_Posted
(Btype
) then
899 elsif Is_Private_Type
(Btype
) then
901 Utyp
: constant Entity_Id
:= Underlying_Type
(Btype
);
906 return Is_By_Reference_Type
(Utyp
);
910 elsif Is_Incomplete_Type
(Btype
) then
912 Ftyp
: constant Entity_Id
:= Full_View
(Btype
);
914 -- Return true for a tagged incomplete type built as a shadow
915 -- entity in Build_Limited_Views. It can appear in the profile
916 -- of a thunk and the back end needs to know how it is passed.
919 return Is_Tagged_Type
(Btype
);
921 return Is_By_Reference_Type
(Ftyp
);
925 elsif Is_Concurrent_Type
(Btype
) then
928 elsif Is_Record_Type
(Btype
) then
929 if Is_Limited_Record
(Btype
)
930 or else Is_Tagged_Type
(Btype
)
931 or else Is_Volatile
(Btype
)
940 C
:= First_Component
(Btype
);
941 while Present
(C
) loop
943 -- For each component, test if its type is a by reference
944 -- type and if its type is volatile. Also test the component
945 -- itself for being volatile. This happens for example when
946 -- a Volatile aspect is added to a component.
948 if Is_By_Reference_Type
(Etype
(C
))
949 or else Is_Volatile
(Etype
(C
))
950 or else Is_Volatile
(C
)
955 C
:= Next_Component
(C
);
962 elsif Is_Array_Type
(Btype
) then
965 or else Is_By_Reference_Type
(Component_Type
(Btype
))
966 or else Is_Volatile
(Component_Type
(Btype
))
967 or else Has_Volatile_Components
(Btype
);
972 end Is_By_Reference_Type
;
974 -------------------------
975 -- Is_Definite_Subtype --
976 -------------------------
978 function Is_Definite_Subtype
(T
: Entity_Id
) return Boolean is
979 pragma Assert
(Is_Type
(T
));
980 K
: constant Entity_Kind
:= Ekind
(T
);
983 if Is_Constrained
(T
) then
986 elsif K
in Array_Kind
987 or else K
in Class_Wide_Kind
988 or else Has_Unknown_Discriminants
(T
)
992 -- Known discriminants: definite if there are default values. Note that
993 -- if any discriminant has a default, they all do.
995 elsif Has_Discriminants
(T
) then
996 return Present
(Discriminant_Default_Value
(First_Discriminant
(T
)));
1001 end Is_Definite_Subtype
;
1003 ---------------------
1004 -- Is_Derived_Type --
1005 ---------------------
1007 function Is_Derived_Type
(Ent
: E
) return B
is
1012 and then Base_Type
(Ent
) /= Root_Type
(Ent
)
1013 and then not Is_Class_Wide_Type
(Ent
)
1015 -- An access_to_subprogram whose result type is a limited view can
1016 -- appear in a return statement, without the full view of the result
1017 -- type being available. Do not interpret this as a derived type.
1019 and then Ekind
(Ent
) /= E_Subprogram_Type
1021 if not Is_Numeric_Type
(Root_Type
(Ent
)) then
1025 Par
:= Parent
(First_Subtype
(Ent
));
1027 return Present
(Par
)
1028 and then Nkind
(Par
) = N_Full_Type_Declaration
1029 and then Nkind
(Type_Definition
(Par
)) =
1030 N_Derived_Type_Definition
;
1036 end Is_Derived_Type
;
1038 -----------------------
1039 -- Is_Generic_Formal --
1040 -----------------------
1042 function Is_Generic_Formal
(E
: Entity_Id
) return Boolean is
1049 -- Formal derived types are rewritten as private extensions, so
1050 -- examine original node.
1052 Kind
:= Nkind
(Original_Node
(Parent
(E
)));
1055 Nkind_In
(Kind
, N_Formal_Object_Declaration
,
1056 N_Formal_Package_Declaration
,
1057 N_Formal_Type_Declaration
)
1058 or else Is_Formal_Subprogram
(E
);
1060 end Is_Generic_Formal
;
1062 -------------------------------
1063 -- Is_Immutably_Limited_Type --
1064 -------------------------------
1066 function Is_Immutably_Limited_Type
(Ent
: Entity_Id
) return Boolean is
1067 Btype
: constant Entity_Id
:= Available_View
(Base_Type
(Ent
));
1070 if Is_Limited_Record
(Btype
) then
1073 elsif Ekind
(Btype
) = E_Limited_Private_Type
1074 and then Nkind
(Parent
(Btype
)) = N_Formal_Type_Declaration
1076 return not In_Package_Body
(Scope
((Btype
)));
1078 elsif Is_Private_Type
(Btype
) then
1080 -- AI05-0063: A type derived from a limited private formal type is
1081 -- not immutably limited in a generic body.
1083 if Is_Derived_Type
(Btype
)
1084 and then Is_Generic_Type
(Etype
(Btype
))
1086 if not Is_Limited_Type
(Etype
(Btype
)) then
1089 -- A descendant of a limited formal type is not immutably limited
1090 -- in the generic body, or in the body of a generic child.
1092 elsif Ekind
(Scope
(Etype
(Btype
))) = E_Generic_Package
then
1093 return not In_Package_Body
(Scope
(Btype
));
1101 Utyp
: constant Entity_Id
:= Underlying_Type
(Btype
);
1106 return Is_Immutably_Limited_Type
(Utyp
);
1111 elsif Is_Concurrent_Type
(Btype
) then
1117 end Is_Immutably_Limited_Type
;
1119 ---------------------
1120 -- Is_Limited_Type --
1121 ---------------------
1123 function Is_Limited_Type
(Ent
: Entity_Id
) return Boolean is
1124 Btype
: constant E
:= Base_Type
(Ent
);
1125 Rtype
: constant E
:= Root_Type
(Btype
);
1128 if not Is_Type
(Ent
) then
1131 elsif Ekind
(Btype
) = E_Limited_Private_Type
1132 or else Is_Limited_Composite
(Btype
)
1136 elsif Is_Concurrent_Type
(Btype
) then
1139 -- The Is_Limited_Record flag normally indicates that the type is
1140 -- limited. The exception is that a type does not inherit limitedness
1141 -- from its interface ancestor. So the type may be derived from a
1142 -- limited interface, but is not limited.
1144 elsif Is_Limited_Record
(Ent
)
1145 and then not Is_Interface
(Ent
)
1149 -- Otherwise we will look around to see if there is some other reason
1150 -- for it to be limited, except that if an error was posted on the
1151 -- entity, then just assume it is non-limited, because it can cause
1152 -- trouble to recurse into a murky entity resulting from other errors.
1154 elsif Error_Posted
(Ent
) then
1157 elsif Is_Record_Type
(Btype
) then
1159 if Is_Limited_Interface
(Ent
) then
1162 -- AI-419: limitedness is not inherited from a limited interface
1164 elsif Is_Limited_Record
(Rtype
) then
1165 return not Is_Interface
(Rtype
)
1166 or else Is_Protected_Interface
(Rtype
)
1167 or else Is_Synchronized_Interface
(Rtype
)
1168 or else Is_Task_Interface
(Rtype
);
1170 elsif Is_Class_Wide_Type
(Btype
) then
1171 return Is_Limited_Type
(Rtype
);
1178 C
:= First_Component
(Btype
);
1179 while Present
(C
) loop
1180 if Is_Limited_Type
(Etype
(C
)) then
1184 C
:= Next_Component
(C
);
1191 elsif Is_Array_Type
(Btype
) then
1192 return Is_Limited_Type
(Component_Type
(Btype
));
1197 end Is_Limited_Type
;
1199 ---------------------
1200 -- Is_Limited_View --
1201 ---------------------
1203 function Is_Limited_View
(Ent
: Entity_Id
) return Boolean is
1204 Btype
: constant Entity_Id
:= Available_View
(Base_Type
(Ent
));
1207 if Is_Limited_Record
(Btype
) then
1210 elsif Ekind
(Btype
) = E_Limited_Private_Type
1211 and then Nkind
(Parent
(Btype
)) = N_Formal_Type_Declaration
1213 return not In_Package_Body
(Scope
((Btype
)));
1215 elsif Is_Private_Type
(Btype
) then
1217 -- AI05-0063: A type derived from a limited private formal type is
1218 -- not immutably limited in a generic body.
1220 if Is_Derived_Type
(Btype
)
1221 and then Is_Generic_Type
(Etype
(Btype
))
1223 if not Is_Limited_Type
(Etype
(Btype
)) then
1226 -- A descendant of a limited formal type is not immutably limited
1227 -- in the generic body, or in the body of a generic child.
1229 elsif Ekind
(Scope
(Etype
(Btype
))) = E_Generic_Package
then
1230 return not In_Package_Body
(Scope
(Btype
));
1238 Utyp
: constant Entity_Id
:= Underlying_Type
(Btype
);
1243 return Is_Limited_View
(Utyp
);
1248 elsif Is_Concurrent_Type
(Btype
) then
1251 elsif Is_Record_Type
(Btype
) then
1253 -- Note that we return True for all limited interfaces, even though
1254 -- (unsynchronized) limited interfaces can have descendants that are
1255 -- nonlimited, because this is a predicate on the type itself, and
1256 -- things like functions with limited interface results need to be
1257 -- handled as build in place even though they might return objects
1258 -- of a type that is not inherently limited.
1260 if Is_Class_Wide_Type
(Btype
) then
1261 return Is_Limited_View
(Root_Type
(Btype
));
1268 C
:= First_Component
(Btype
);
1269 while Present
(C
) loop
1271 -- Don't consider components with interface types (which can
1272 -- only occur in the case of a _parent component anyway).
1273 -- They don't have any components, plus it would cause this
1274 -- function to return true for nonlimited types derived from
1275 -- limited interfaces.
1277 if not Is_Interface
(Etype
(C
))
1278 and then Is_Limited_View
(Etype
(C
))
1283 C
:= Next_Component
(C
);
1290 elsif Is_Array_Type
(Btype
) then
1291 return Is_Limited_View
(Component_Type
(Btype
));
1296 end Is_Limited_View
;
1298 ----------------------
1299 -- Nearest_Ancestor --
1300 ----------------------
1302 function Nearest_Ancestor
(Typ
: Entity_Id
) return Entity_Id
is
1303 D
: constant Node_Id
:= Original_Node
(Declaration_Node
(Typ
));
1304 -- We use the original node of the declaration, because derived
1305 -- types from record subtypes are rewritten as record declarations,
1306 -- and it is the original declaration that carries the ancestor.
1309 -- If we have a subtype declaration, get the ancestor subtype
1311 if Nkind
(D
) = N_Subtype_Declaration
then
1312 if Nkind
(Subtype_Indication
(D
)) = N_Subtype_Indication
then
1313 return Entity
(Subtype_Mark
(Subtype_Indication
(D
)));
1315 return Entity
(Subtype_Indication
(D
));
1318 -- If derived type declaration, find who we are derived from
1320 elsif Nkind
(D
) = N_Full_Type_Declaration
1321 and then Nkind
(Type_Definition
(D
)) = N_Derived_Type_Definition
1324 DTD
: constant Entity_Id
:= Type_Definition
(D
);
1325 SI
: constant Entity_Id
:= Subtype_Indication
(DTD
);
1327 if Is_Entity_Name
(SI
) then
1330 return Entity
(Subtype_Mark
(SI
));
1334 -- If derived type and private type, get the full view to find who we
1335 -- are derived from.
1337 elsif Is_Derived_Type
(Typ
)
1338 and then Is_Private_Type
(Typ
)
1339 and then Present
(Full_View
(Typ
))
1341 return Nearest_Ancestor
(Full_View
(Typ
));
1343 -- Otherwise, nothing useful to return, return Empty
1348 end Nearest_Ancestor
;
1350 ---------------------------
1351 -- Nearest_Dynamic_Scope --
1352 ---------------------------
1354 function Nearest_Dynamic_Scope
(Ent
: Entity_Id
) return Entity_Id
is
1356 if Is_Dynamic_Scope
(Ent
) then
1359 return Enclosing_Dynamic_Scope
(Ent
);
1361 end Nearest_Dynamic_Scope
;
1363 ------------------------
1364 -- Next_Tag_Component --
1365 ------------------------
1367 function Next_Tag_Component
(Tag
: Entity_Id
) return Entity_Id
is
1371 pragma Assert
(Is_Tag
(Tag
));
1373 -- Loop to look for next tag component
1375 Comp
:= Next_Entity
(Tag
);
1376 while Present
(Comp
) loop
1377 if Is_Tag
(Comp
) then
1378 pragma Assert
(Chars
(Comp
) /= Name_uTag
);
1382 Comp
:= Next_Entity
(Comp
);
1385 -- No tag component found
1388 end Next_Tag_Component
;
1390 -----------------------
1391 -- Number_Components --
1392 -----------------------
1394 function Number_Components
(Typ
: Entity_Id
) return Nat
is
1399 -- We do not call Einfo.First_Component_Or_Discriminant, as this
1400 -- function does not skip completely hidden discriminants, which we
1401 -- want to skip here.
1403 if Has_Discriminants
(Typ
) then
1404 Comp
:= First_Discriminant
(Typ
);
1406 Comp
:= First_Component
(Typ
);
1409 while Present
(Comp
) loop
1411 Comp
:= Next_Component_Or_Discriminant
(Comp
);
1415 end Number_Components
;
1417 --------------------------
1418 -- Number_Discriminants --
1419 --------------------------
1421 function Number_Discriminants
(Typ
: Entity_Id
) return Pos
is
1423 Discr
: Entity_Id
:= First_Discriminant
(Typ
);
1426 while Present
(Discr
) loop
1428 Discr
:= Next_Discriminant
(Discr
);
1432 end Number_Discriminants
;
1434 ----------------------------------------------
1435 -- Object_Type_Has_Constrained_Partial_View --
1436 ----------------------------------------------
1438 function Object_Type_Has_Constrained_Partial_View
1440 Scop
: Entity_Id
) return Boolean
1443 return Has_Constrained_Partial_View
(Typ
)
1444 or else (In_Generic_Body
(Scop
)
1445 and then Is_Generic_Type
(Base_Type
(Typ
))
1446 and then Is_Private_Type
(Base_Type
(Typ
))
1447 and then not Is_Tagged_Type
(Typ
)
1448 and then not (Is_Array_Type
(Typ
)
1449 and then not Is_Constrained
(Typ
))
1450 and then Has_Discriminants
(Typ
));
1451 end Object_Type_Has_Constrained_Partial_View
;
1457 function Package_Body
(E
: Entity_Id
) return Node_Id
is
1461 if Ekind
(E
) = E_Package_Body
then
1464 if Nkind
(N
) = N_Defining_Program_Unit_Name
then
1469 N
:= Package_Spec
(E
);
1471 if Present
(Corresponding_Body
(N
)) then
1472 N
:= Parent
(Corresponding_Body
(N
));
1474 if Nkind
(N
) = N_Defining_Program_Unit_Name
then
1489 function Package_Spec
(E
: Entity_Id
) return Node_Id
is
1491 return Parent
(Package_Specification
(E
));
1494 ---------------------------
1495 -- Package_Specification --
1496 ---------------------------
1498 function Package_Specification
(E
: Entity_Id
) return Node_Id
is
1504 if Nkind
(N
) = N_Defining_Program_Unit_Name
then
1509 end Package_Specification
;
1511 ---------------------
1512 -- Subprogram_Body --
1513 ---------------------
1515 function Subprogram_Body
(E
: Entity_Id
) return Node_Id
is
1516 Body_E
: constant Entity_Id
:= Subprogram_Body_Entity
(E
);
1522 return Parent
(Subprogram_Specification
(Body_E
));
1524 end Subprogram_Body
;
1526 ----------------------------
1527 -- Subprogram_Body_Entity --
1528 ----------------------------
1530 function Subprogram_Body_Entity
(E
: Entity_Id
) return Entity_Id
is
1531 N
: constant Node_Id
:= Parent
(Subprogram_Specification
(E
));
1532 -- Declaration for E
1535 -- If this declaration is not a subprogram body, then it must be a
1536 -- subprogram declaration or body stub, from which we can retrieve the
1537 -- entity for the corresponding subprogram body if any, or an abstract
1538 -- subprogram declaration, for which we return Empty.
1541 when N_Subprogram_Body
=>
1544 when N_Subprogram_Body_Stub
1545 | N_Subprogram_Declaration
1547 return Corresponding_Body
(N
);
1552 end Subprogram_Body_Entity
;
1554 ---------------------
1555 -- Subprogram_Spec --
1556 ---------------------
1558 function Subprogram_Spec
(E
: Entity_Id
) return Node_Id
is
1559 N
: constant Node_Id
:= Parent
(Subprogram_Specification
(E
));
1560 -- Declaration for E
1563 -- This declaration is either subprogram declaration or a subprogram
1564 -- body, in which case return Empty.
1566 if Nkind
(N
) = N_Subprogram_Declaration
then
1571 end Subprogram_Spec
;
1573 ------------------------------
1574 -- Subprogram_Specification --
1575 ------------------------------
1577 function Subprogram_Specification
(E
: Entity_Id
) return Node_Id
is
1583 if Nkind
(N
) = N_Defining_Program_Unit_Name
then
1587 -- If the Parent pointer of E is not a subprogram specification node
1588 -- (going through an intermediate N_Defining_Program_Unit_Name node
1589 -- for subprogram units), then E is an inherited operation. Its parent
1590 -- points to the type derivation that produces the inheritance: that's
1591 -- the node that generates the subprogram specification. Its alias
1592 -- is the parent subprogram, and that one points to a subprogram
1593 -- declaration, or to another type declaration if this is a hierarchy
1596 if Nkind
(N
) not in N_Subprogram_Specification
then
1597 pragma Assert
(Present
(Alias
(E
)));
1598 N
:= Subprogram_Specification
(Alias
(E
));
1602 end Subprogram_Specification
;
1608 procedure Tree_Read
is
1610 Obsolescent_Warnings
.Tree_Read
;
1617 procedure Tree_Write
is
1619 Obsolescent_Warnings
.Tree_Write
;
1622 --------------------
1623 -- Ultimate_Alias --
1624 --------------------
1626 function Ultimate_Alias
(Prim
: Entity_Id
) return Entity_Id
is
1627 E
: Entity_Id
:= Prim
;
1630 while Present
(Alias
(E
)) loop
1631 pragma Assert
(Alias
(E
) /= E
);
1638 --------------------------
1639 -- Unit_Declaration_Node --
1640 --------------------------
1642 function Unit_Declaration_Node
(Unit_Id
: Entity_Id
) return Node_Id
is
1643 N
: Node_Id
:= Parent
(Unit_Id
);
1646 -- Predefined operators do not have a full function declaration
1648 if Ekind
(Unit_Id
) = E_Operator
then
1652 -- Isn't there some better way to express the following ???
1654 while Nkind
(N
) /= N_Abstract_Subprogram_Declaration
1655 and then Nkind
(N
) /= N_Entry_Body
1656 and then Nkind
(N
) /= N_Entry_Declaration
1657 and then Nkind
(N
) /= N_Formal_Package_Declaration
1658 and then Nkind
(N
) /= N_Function_Instantiation
1659 and then Nkind
(N
) /= N_Generic_Package_Declaration
1660 and then Nkind
(N
) /= N_Generic_Subprogram_Declaration
1661 and then Nkind
(N
) /= N_Package_Declaration
1662 and then Nkind
(N
) /= N_Package_Body
1663 and then Nkind
(N
) /= N_Package_Instantiation
1664 and then Nkind
(N
) /= N_Package_Renaming_Declaration
1665 and then Nkind
(N
) /= N_Procedure_Instantiation
1666 and then Nkind
(N
) /= N_Protected_Body
1667 and then Nkind
(N
) /= N_Subprogram_Declaration
1668 and then Nkind
(N
) /= N_Subprogram_Body
1669 and then Nkind
(N
) /= N_Subprogram_Body_Stub
1670 and then Nkind
(N
) /= N_Subprogram_Renaming_Declaration
1671 and then Nkind
(N
) /= N_Task_Body
1672 and then Nkind
(N
) /= N_Task_Type_Declaration
1673 and then Nkind
(N
) not in N_Formal_Subprogram_Declaration
1674 and then Nkind
(N
) not in N_Generic_Renaming_Declaration
1678 -- We don't use Assert here, because that causes an infinite loop
1679 -- when assertions are turned off. Better to crash.
1682 raise Program_Error
;
1687 end Unit_Declaration_Node
;