1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- As a special exception, if other files instantiate generics from this --
22 -- unit, or you link this unit with other files to produce an executable, --
23 -- this unit does not by itself cause the resulting executable to be --
24 -- covered by the GNU General Public License. This exception does not --
25 -- however invalidate any other reasons why the executable file might be --
26 -- covered by the GNU Public License. --
28 -- GNAT was originally developed by the GNAT team at New York University. --
29 -- Extensive contributions were provided by Ada Core Technologies Inc. --
31 ------------------------------------------------------------------------------
33 with Atree
; use Atree
;
34 with Einfo
; use Einfo
;
35 with Namet
; use Namet
;
36 with Sinfo
; use Sinfo
;
37 with Snames
; use Snames
;
38 with Stand
; use Stand
;
40 package body Sem_Aux
is
42 ----------------------
43 -- Ancestor_Subtype --
44 ----------------------
46 function Ancestor_Subtype
(Typ
: Entity_Id
) return Entity_Id
is
48 -- If this is first subtype, or is a base type, then there is no
49 -- ancestor subtype, so we return Empty to indicate this fact.
51 if Is_First_Subtype
(Typ
) or else Typ
= Base_Type
(Typ
) then
56 D
: constant Node_Id
:= Declaration_Node
(Typ
);
59 -- If we have a subtype declaration, get the ancestor subtype
61 if Nkind
(D
) = N_Subtype_Declaration
then
62 if Nkind
(Subtype_Indication
(D
)) = N_Subtype_Indication
then
63 return Entity
(Subtype_Mark
(Subtype_Indication
(D
)));
65 return Entity
(Subtype_Indication
(D
));
68 -- If not, then no subtype indication is available
80 function Available_View
(Typ
: Entity_Id
) return Entity_Id
is
82 if Is_Incomplete_Type
(Typ
)
83 and then Present
(Non_Limited_View
(Typ
))
85 -- The non-limited view may itself be an incomplete type, in which
86 -- case get its full view.
88 return Get_Full_View
(Non_Limited_View
(Typ
));
90 elsif Is_Class_Wide_Type
(Typ
)
91 and then Is_Incomplete_Type
(Etype
(Typ
))
92 and then Present
(Non_Limited_View
(Etype
(Typ
)))
94 return Class_Wide_Type
(Non_Limited_View
(Etype
(Typ
)));
105 function Constant_Value
(Ent
: Entity_Id
) return Node_Id
is
106 D
: constant Node_Id
:= Declaration_Node
(Ent
);
110 -- If we have no declaration node, then return no constant value. Not
111 -- clear how this can happen, but it does sometimes and this is the
117 -- Normal case where a declaration node is present
119 elsif Nkind
(D
) = N_Object_Renaming_Declaration
then
120 return Renamed_Object
(Ent
);
122 -- If this is a component declaration whose entity is a constant, it is
123 -- a prival within a protected function (and so has no constant value).
125 elsif Nkind
(D
) = N_Component_Declaration
then
128 -- If there is an expression, return it
130 elsif Present
(Expression
(D
)) then
131 return (Expression
(D
));
133 -- For a constant, see if we have a full view
135 elsif Ekind
(Ent
) = E_Constant
136 and then Present
(Full_View
(Ent
))
138 Full_D
:= Parent
(Full_View
(Ent
));
140 -- The full view may have been rewritten as an object renaming
142 if Nkind
(Full_D
) = N_Object_Renaming_Declaration
then
143 return Name
(Full_D
);
145 return Expression
(Full_D
);
148 -- Otherwise we have no expression to return
155 -----------------------------
156 -- Enclosing_Dynamic_Scope --
157 -----------------------------
159 function Enclosing_Dynamic_Scope
(Ent
: Entity_Id
) return Entity_Id
is
163 -- The following test is an error defense against some syntax errors
164 -- that can leave scopes very messed up.
166 if Ent
= Standard_Standard
then
170 -- Normal case, search enclosing scopes
172 -- Note: the test for Present (S) should not be required, it defends
173 -- against an ill-formed tree.
177 -- If we somehow got an empty value for Scope, the tree must be
178 -- malformed. Rather than blow up we return Standard in this case.
181 return Standard_Standard
;
183 -- Quit if we get to standard or a dynamic scope
185 elsif S
= Standard_Standard
186 or else Is_Dynamic_Scope
(S
)
190 -- Otherwise keep climbing
196 end Enclosing_Dynamic_Scope
;
198 ------------------------
199 -- First_Discriminant --
200 ------------------------
202 function First_Discriminant
(Typ
: Entity_Id
) return Entity_Id
is
207 (Has_Discriminants
(Typ
) or else Has_Unknown_Discriminants
(Typ
));
209 Ent
:= First_Entity
(Typ
);
211 -- The discriminants are not necessarily contiguous, because access
212 -- discriminants will generate itypes. They are not the first entities
213 -- either, because tag and controller record must be ahead of them.
215 if Chars
(Ent
) = Name_uTag
then
216 Ent
:= Next_Entity
(Ent
);
219 if Chars
(Ent
) = Name_uController
then
220 Ent
:= Next_Entity
(Ent
);
223 -- Skip all hidden stored discriminants if any
225 while Present
(Ent
) loop
226 exit when Ekind
(Ent
) = E_Discriminant
227 and then not Is_Completely_Hidden
(Ent
);
229 Ent
:= Next_Entity
(Ent
);
232 pragma Assert
(Ekind
(Ent
) = E_Discriminant
);
235 end First_Discriminant
;
237 -------------------------------
238 -- First_Stored_Discriminant --
239 -------------------------------
241 function First_Stored_Discriminant
(Typ
: Entity_Id
) return Entity_Id
is
244 function Has_Completely_Hidden_Discriminant
245 (Typ
: Entity_Id
) return Boolean;
246 -- Scans the Discriminants to see whether any are Completely_Hidden
247 -- (the mechanism for describing non-specified stored discriminants)
249 ----------------------------------------
250 -- Has_Completely_Hidden_Discriminant --
251 ----------------------------------------
253 function Has_Completely_Hidden_Discriminant
254 (Typ
: Entity_Id
) return Boolean
259 pragma Assert
(Ekind
(Typ
) = E_Discriminant
);
262 while Present
(Ent
) and then Ekind
(Ent
) = E_Discriminant
loop
263 if Is_Completely_Hidden
(Ent
) then
267 Ent
:= Next_Entity
(Ent
);
271 end Has_Completely_Hidden_Discriminant
;
273 -- Start of processing for First_Stored_Discriminant
277 (Has_Discriminants
(Typ
)
278 or else Has_Unknown_Discriminants
(Typ
));
280 Ent
:= First_Entity
(Typ
);
282 if Chars
(Ent
) = Name_uTag
then
283 Ent
:= Next_Entity
(Ent
);
286 if Chars
(Ent
) = Name_uController
then
287 Ent
:= Next_Entity
(Ent
);
290 if Has_Completely_Hidden_Discriminant
(Ent
) then
292 while Present
(Ent
) loop
293 exit when Is_Completely_Hidden
(Ent
);
294 Ent
:= Next_Entity
(Ent
);
299 pragma Assert
(Ekind
(Ent
) = E_Discriminant
);
302 end First_Stored_Discriminant
;
308 function First_Subtype
(Typ
: Entity_Id
) return Entity_Id
is
309 B
: constant Entity_Id
:= Base_Type
(Typ
);
310 F
: constant Node_Id
:= Freeze_Node
(B
);
314 -- If the base type has no freeze node, it is a type in Standard, and
315 -- always acts as its own first subtype, except where it is one of the
316 -- predefined integer types. If the type is formal, it is also a first
317 -- subtype, and its base type has no freeze node. On the other hand, a
318 -- subtype of a generic formal is not its own first subtype. Its base
319 -- type, if anonymous, is attached to the formal type decl. from which
320 -- the first subtype is obtained.
323 if B
= Base_Type
(Standard_Integer
) then
324 return Standard_Integer
;
326 elsif B
= Base_Type
(Standard_Long_Integer
) then
327 return Standard_Long_Integer
;
329 elsif B
= Base_Type
(Standard_Short_Short_Integer
) then
330 return Standard_Short_Short_Integer
;
332 elsif B
= Base_Type
(Standard_Short_Integer
) then
333 return Standard_Short_Integer
;
335 elsif B
= Base_Type
(Standard_Long_Long_Integer
) then
336 return Standard_Long_Long_Integer
;
338 elsif Is_Generic_Type
(Typ
) then
339 if Present
(Parent
(B
)) then
340 return Defining_Identifier
(Parent
(B
));
342 return Defining_Identifier
(Associated_Node_For_Itype
(B
));
349 -- Otherwise we check the freeze node, if it has a First_Subtype_Link
350 -- then we use that link, otherwise (happens with some Itypes), we use
351 -- the base type itself.
354 Ent
:= First_Subtype_Link
(F
);
356 if Present
(Ent
) then
364 -------------------------
365 -- First_Tag_Component --
366 -------------------------
368 function First_Tag_Component
(Typ
: Entity_Id
) return Entity_Id
is
374 pragma Assert
(Is_Tagged_Type
(Ctyp
));
376 if Is_Class_Wide_Type
(Ctyp
) then
377 Ctyp
:= Root_Type
(Ctyp
);
380 if Is_Private_Type
(Ctyp
) then
381 Ctyp
:= Underlying_Type
(Ctyp
);
383 -- If the underlying type is missing then the source program has
384 -- errors and there is nothing else to do (the full-type declaration
385 -- associated with the private type declaration is missing).
392 Comp
:= First_Entity
(Ctyp
);
393 while Present
(Comp
) loop
394 if Is_Tag
(Comp
) then
398 Comp
:= Next_Entity
(Comp
);
401 -- No tag component found
404 end First_Tag_Component
;
410 procedure Initialize
is
412 Obsolescent_Warnings
.Init
;
415 ---------------------
416 -- Is_By_Copy_Type --
417 ---------------------
419 function Is_By_Copy_Type
(Ent
: Entity_Id
) return Boolean is
421 -- If Id is a private type whose full declaration has not been seen,
422 -- we assume for now that it is not a By_Copy type. Clearly this
423 -- attribute should not be used before the type is frozen, but it is
424 -- needed to build the associated record of a protected type. Another
425 -- place where some lookahead for a full view is needed ???
428 Is_Elementary_Type
(Ent
)
429 or else (Is_Private_Type
(Ent
)
430 and then Present
(Underlying_Type
(Ent
))
431 and then Is_Elementary_Type
(Underlying_Type
(Ent
)));
434 --------------------------
435 -- Is_By_Reference_Type --
436 --------------------------
438 function Is_By_Reference_Type
(Ent
: Entity_Id
) return Boolean is
439 Btype
: constant Entity_Id
:= Base_Type
(Ent
);
442 if Error_Posted
(Ent
)
443 or else Error_Posted
(Btype
)
447 elsif Is_Private_Type
(Btype
) then
449 Utyp
: constant Entity_Id
:= Underlying_Type
(Btype
);
454 return Is_By_Reference_Type
(Utyp
);
458 elsif Is_Incomplete_Type
(Btype
) then
460 Ftyp
: constant Entity_Id
:= Full_View
(Btype
);
465 return Is_By_Reference_Type
(Ftyp
);
469 elsif Is_Concurrent_Type
(Btype
) then
472 elsif Is_Record_Type
(Btype
) then
473 if Is_Limited_Record
(Btype
)
474 or else Is_Tagged_Type
(Btype
)
475 or else Is_Volatile
(Btype
)
484 C
:= First_Component
(Btype
);
485 while Present
(C
) loop
486 if Is_By_Reference_Type
(Etype
(C
))
487 or else Is_Volatile
(Etype
(C
))
492 C
:= Next_Component
(C
);
499 elsif Is_Array_Type
(Btype
) then
502 or else Is_By_Reference_Type
(Component_Type
(Btype
))
503 or else Is_Volatile
(Component_Type
(Btype
))
504 or else Has_Volatile_Components
(Btype
);
509 end Is_By_Reference_Type
;
511 ---------------------
512 -- Is_Derived_Type --
513 ---------------------
515 function Is_Derived_Type
(Ent
: E
) return B
is
520 and then Base_Type
(Ent
) /= Root_Type
(Ent
)
521 and then not Is_Class_Wide_Type
(Ent
)
523 if not Is_Numeric_Type
(Root_Type
(Ent
)) then
527 Par
:= Parent
(First_Subtype
(Ent
));
530 and then Nkind
(Par
) = N_Full_Type_Declaration
531 and then Nkind
(Type_Definition
(Par
)) =
532 N_Derived_Type_Definition
;
540 ---------------------------
541 -- Is_Indefinite_Subtype --
542 ---------------------------
544 function Is_Indefinite_Subtype
(Ent
: Entity_Id
) return Boolean is
545 K
: constant Entity_Kind
:= Ekind
(Ent
);
548 if Is_Constrained
(Ent
) then
551 elsif K
in Array_Kind
552 or else K
in Class_Wide_Kind
553 or else Has_Unknown_Discriminants
(Ent
)
557 -- Known discriminants: indefinite if there are no default values
559 elsif K
in Record_Kind
560 or else Is_Incomplete_Or_Private_Type
(Ent
)
561 or else Is_Concurrent_Type
(Ent
)
563 return (Has_Discriminants
(Ent
)
565 No
(Discriminant_Default_Value
(First_Discriminant
(Ent
))));
570 end Is_Indefinite_Subtype
;
572 -------------------------------
573 -- Is_Immutably_Limited_Type --
574 -------------------------------
576 function Is_Immutably_Limited_Type
(Ent
: Entity_Id
) return Boolean is
577 Btype
: constant Entity_Id
:= Base_Type
(Ent
);
580 if Is_Limited_Record
(Btype
) then
583 elsif Ekind
(Btype
) = E_Limited_Private_Type
584 and then Nkind
(Parent
(Btype
)) = N_Formal_Type_Declaration
586 return not In_Package_Body
(Scope
((Btype
)));
589 if Is_Private_Type
(Btype
) then
591 -- AI05-0063: A type derived from a limited private formal type is
592 -- not immutably limited in a generic body.
594 if Is_Derived_Type
(Btype
)
595 and then Is_Generic_Type
(Etype
(Btype
))
597 if not Is_Limited_Type
(Etype
(Btype
)) then
600 -- A descendant of a limited formal type is not immutably limited
601 -- in the generic body, or in the body of a generic child.
603 elsif Ekind
(Scope
(Etype
(Btype
))) = E_Generic_Package
then
604 return not In_Package_Body
(Scope
(Btype
));
612 Utyp
: constant Entity_Id
:= Underlying_Type
(Btype
);
617 return Is_Immutably_Limited_Type
(Utyp
);
622 elsif Is_Concurrent_Type
(Btype
) then
625 elsif Is_Record_Type
(Btype
) then
627 -- Note that we return True for all limited interfaces, even though
628 -- (unsynchronized) limited interfaces can have descendants that are
629 -- nonlimited, because this is a predicate on the type itself, and
630 -- things like functions with limited interface results need to be
631 -- handled as build in place even though they might return objects
632 -- of a type that is not inherently limited.
634 if Is_Class_Wide_Type
(Btype
) then
635 return Is_Immutably_Limited_Type
(Root_Type
(Btype
));
642 C
:= First_Component
(Btype
);
643 while Present
(C
) loop
645 -- Don't consider components with interface types (which can
646 -- only occur in the case of a _parent component anyway).
647 -- They don't have any components, plus it would cause this
648 -- function to return true for nonlimited types derived from
649 -- limited intefaces.
651 if not Is_Interface
(Etype
(C
))
652 and then Is_Immutably_Limited_Type
(Etype
(C
))
657 C
:= Next_Component
(C
);
664 elsif Is_Array_Type
(Btype
) then
665 return Is_Immutably_Limited_Type
(Component_Type
(Btype
));
670 end Is_Immutably_Limited_Type
;
672 ---------------------
673 -- Is_Limited_Type --
674 ---------------------
676 function Is_Limited_Type
(Ent
: Entity_Id
) return Boolean is
677 Btype
: constant E
:= Base_Type
(Ent
);
678 Rtype
: constant E
:= Root_Type
(Btype
);
681 if not Is_Type
(Ent
) then
684 elsif Ekind
(Btype
) = E_Limited_Private_Type
685 or else Is_Limited_Composite
(Btype
)
689 elsif Is_Concurrent_Type
(Btype
) then
692 -- The Is_Limited_Record flag normally indicates that the type is
693 -- limited. The exception is that a type does not inherit limitedness
694 -- from its interface ancestor. So the type may be derived from a
695 -- limited interface, but is not limited.
697 elsif Is_Limited_Record
(Ent
)
698 and then not Is_Interface
(Ent
)
702 -- Otherwise we will look around to see if there is some other reason
703 -- for it to be limited, except that if an error was posted on the
704 -- entity, then just assume it is non-limited, because it can cause
705 -- trouble to recurse into a murky erroneous entity!
707 elsif Error_Posted
(Ent
) then
710 elsif Is_Record_Type
(Btype
) then
712 if Is_Limited_Interface
(Ent
) then
715 -- AI-419: limitedness is not inherited from a limited interface
717 elsif Is_Limited_Record
(Rtype
) then
718 return not Is_Interface
(Rtype
)
719 or else Is_Protected_Interface
(Rtype
)
720 or else Is_Synchronized_Interface
(Rtype
)
721 or else Is_Task_Interface
(Rtype
);
723 elsif Is_Class_Wide_Type
(Btype
) then
724 return Is_Limited_Type
(Rtype
);
731 C
:= First_Component
(Btype
);
732 while Present
(C
) loop
733 if Is_Limited_Type
(Etype
(C
)) then
737 C
:= Next_Component
(C
);
744 elsif Is_Array_Type
(Btype
) then
745 return Is_Limited_Type
(Component_Type
(Btype
));
752 ---------------------------
753 -- Nearest_Dynamic_Scope --
754 ---------------------------
756 function Nearest_Dynamic_Scope
(Ent
: Entity_Id
) return Entity_Id
is
758 if Is_Dynamic_Scope
(Ent
) then
761 return Enclosing_Dynamic_Scope
(Ent
);
763 end Nearest_Dynamic_Scope
;
765 ------------------------
766 -- Next_Tag_Component --
767 ------------------------
769 function Next_Tag_Component
(Tag
: Entity_Id
) return Entity_Id
is
773 pragma Assert
(Is_Tag
(Tag
));
775 -- Loop to look for next tag component
777 Comp
:= Next_Entity
(Tag
);
778 while Present
(Comp
) loop
779 if Is_Tag
(Comp
) then
780 pragma Assert
(Chars
(Comp
) /= Name_uTag
);
784 Comp
:= Next_Entity
(Comp
);
787 -- No tag component found
790 end Next_Tag_Component
;
792 --------------------------
793 -- Number_Discriminants --
794 --------------------------
796 function Number_Discriminants
(Typ
: Entity_Id
) return Pos
is
802 Discr
:= First_Discriminant
(Typ
);
803 while Present
(Discr
) loop
805 Discr
:= Next_Discriminant
(Discr
);
809 end Number_Discriminants
;
815 procedure Tree_Read
is
817 Obsolescent_Warnings
.Tree_Read
;
824 procedure Tree_Write
is
826 Obsolescent_Warnings
.Tree_Write
;
833 function Ultimate_Alias
(Prim
: Entity_Id
) return Entity_Id
is
834 E
: Entity_Id
:= Prim
;
837 while Present
(Alias
(E
)) loop
838 pragma Assert
(Alias
(E
) /= E
);