1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2011, 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 Is_Base_Type (Typ) then
56 D : constant Node_Id := Declaration_Node (Typ);
59 -- If we have a subtype declaration, get the ancestor subtype
61 if Nkind (D) = N_Subtype_Declaration then
62 if Nkind (Subtype_Indication (D)) = N_Subtype_Indication then
63 return Entity (Subtype_Mark (Subtype_Indication (D)));
65 return Entity (Subtype_Indication (D));
68 -- If not, then no subtype indication is available
80 function Available_View (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 -- Effectively_Has_Constrained_Partial_View --
157 ----------------------------------------------
159 function Effectively_Has_Constrained_Partial_View
161 Scop : Entity_Id) return Boolean
164 return Has_Constrained_Partial_View (Typ)
165 or else (In_Generic_Body (Scop)
166 and then Is_Generic_Type (Base_Type (Typ))
167 and then Is_Private_Type (Base_Type (Typ))
168 and then not Is_Tagged_Type (Typ)
169 and then not (Is_Array_Type (Typ)
170 and then not Is_Constrained (Typ))
171 and then Has_Discriminants (Typ));
172 end Effectively_Has_Constrained_Partial_View;
174 -----------------------------
175 -- Enclosing_Dynamic_Scope --
176 -----------------------------
178 function Enclosing_Dynamic_Scope (Ent : Entity_Id) return Entity_Id is
182 -- The following test is an error defense against some syntax errors
183 -- that can leave scopes very messed up.
185 if Ent = Standard_Standard then
189 -- Normal case, search enclosing scopes
191 -- Note: the test for Present (S) should not be required, it defends
192 -- against an ill-formed tree.
196 -- If we somehow got an empty value for Scope, the tree must be
197 -- malformed. Rather than blow up we return Standard in this case.
200 return Standard_Standard;
202 -- Quit if we get to standard or a dynamic scope. We must also
203 -- handle enclosing scopes that have a full view; required to
204 -- locate enclosing scopes that are synchronized private types
205 -- whose full view is a task type.
207 elsif S = Standard_Standard
208 or else Is_Dynamic_Scope (S)
209 or else (Is_Private_Type (S)
210 and then Present (Full_View (S))
211 and then Is_Dynamic_Scope (Full_View (S)))
215 -- Otherwise keep climbing
221 end Enclosing_Dynamic_Scope;
223 ------------------------
224 -- First_Discriminant --
225 ------------------------
227 function First_Discriminant (Typ : Entity_Id) return Entity_Id is
232 (Has_Discriminants (Typ) or else Has_Unknown_Discriminants (Typ));
234 Ent := First_Entity (Typ);
236 -- The discriminants are not necessarily contiguous, because access
237 -- discriminants will generate itypes. They are not the first entities
238 -- either because the tag must be ahead of them.
240 if Chars (Ent) = Name_uTag then
241 Ent := Next_Entity (Ent);
244 -- Skip all hidden stored discriminants if any
246 while Present (Ent) loop
247 exit when Ekind (Ent) = E_Discriminant
248 and then not Is_Completely_Hidden (Ent);
250 Ent := Next_Entity (Ent);
253 pragma Assert (Ekind (Ent) = E_Discriminant);
256 end First_Discriminant;
258 -------------------------------
259 -- First_Stored_Discriminant --
260 -------------------------------
262 function First_Stored_Discriminant (Typ : Entity_Id) return Entity_Id is
265 function Has_Completely_Hidden_Discriminant
266 (Typ : Entity_Id) return Boolean;
267 -- Scans the Discriminants to see whether any are Completely_Hidden
268 -- (the mechanism for describing non-specified stored discriminants)
270 ----------------------------------------
271 -- Has_Completely_Hidden_Discriminant --
272 ----------------------------------------
274 function Has_Completely_Hidden_Discriminant
275 (Typ : Entity_Id) return Boolean
280 pragma Assert (Ekind (Typ) = E_Discriminant);
283 while Present (Ent) and then Ekind (Ent) = E_Discriminant loop
284 if Is_Completely_Hidden (Ent) then
288 Ent := Next_Entity (Ent);
292 end Has_Completely_Hidden_Discriminant;
294 -- Start of processing for First_Stored_Discriminant
298 (Has_Discriminants (Typ)
299 or else Has_Unknown_Discriminants (Typ));
301 Ent := First_Entity (Typ);
303 if Chars (Ent) = Name_uTag then
304 Ent := Next_Entity (Ent);
307 if Has_Completely_Hidden_Discriminant (Ent) then
308 while Present (Ent) loop
309 exit when Is_Completely_Hidden (Ent);
310 Ent := Next_Entity (Ent);
314 pragma Assert (Ekind (Ent) = E_Discriminant);
317 end First_Stored_Discriminant;
323 function First_Subtype (Typ : Entity_Id) return Entity_Id is
324 B : constant Entity_Id := Base_Type (Typ);
325 F : constant Node_Id := Freeze_Node (B);
329 -- If the base type has no freeze node, it is a type in Standard, and
330 -- always acts as its own first subtype, except where it is one of the
331 -- predefined integer types. If the type is formal, it is also a first
332 -- subtype, and its base type has no freeze node. On the other hand, a
333 -- subtype of a generic formal is not its own first subtype. Its base
334 -- type, if anonymous, is attached to the formal type decl. from which
335 -- the first subtype is obtained.
338 if B = Base_Type (Standard_Integer) then
339 return Standard_Integer;
341 elsif B = Base_Type (Standard_Long_Integer) then
342 return Standard_Long_Integer;
344 elsif B = Base_Type (Standard_Short_Short_Integer) then
345 return Standard_Short_Short_Integer;
347 elsif B = Base_Type (Standard_Short_Integer) then
348 return Standard_Short_Integer;
350 elsif B = Base_Type (Standard_Long_Long_Integer) then
351 return Standard_Long_Long_Integer;
353 elsif Is_Generic_Type (Typ) then
354 if Present (Parent (B)) then
355 return Defining_Identifier (Parent (B));
357 return Defining_Identifier (Associated_Node_For_Itype (B));
364 -- Otherwise we check the freeze node, if it has a First_Subtype_Link
365 -- then we use that link, otherwise (happens with some Itypes), we use
366 -- the base type itself.
369 Ent := First_Subtype_Link (F);
371 if Present (Ent) then
379 -------------------------
380 -- First_Tag_Component --
381 -------------------------
383 function First_Tag_Component (Typ : Entity_Id) return Entity_Id is
389 pragma Assert (Is_Tagged_Type (Ctyp));
391 if Is_Class_Wide_Type (Ctyp) then
392 Ctyp := Root_Type (Ctyp);
395 if Is_Private_Type (Ctyp) then
396 Ctyp := Underlying_Type (Ctyp);
398 -- If the underlying type is missing then the source program has
399 -- errors and there is nothing else to do (the full-type declaration
400 -- associated with the private type declaration is missing).
407 Comp := First_Entity (Ctyp);
408 while Present (Comp) loop
409 if Is_Tag (Comp) then
413 Comp := Next_Entity (Comp);
416 -- No tag component found
419 end First_Tag_Component;
421 -------------------------------
422 -- Initialization_Suppressed --
423 -------------------------------
425 function Initialization_Suppressed (Typ : Entity_Id) return Boolean is
427 return Suppress_Initialization (Typ)
428 or else Suppress_Initialization (Base_Type (Typ));
429 end Initialization_Suppressed;
435 procedure Initialize is
437 Obsolescent_Warnings.Init;
440 ---------------------
441 -- In_Generic_Body --
442 ---------------------
444 function In_Generic_Body (Id : Entity_Id) return Boolean is
448 -- Climb scopes looking for generic body
451 while Present (S) and then S /= Standard_Standard loop
453 -- Generic package body
455 if Ekind (S) = E_Generic_Package
456 and then In_Package_Body (S)
460 -- Generic subprogram body
462 elsif Is_Subprogram (S)
463 and then Nkind (Unit_Declaration_Node (S))
464 = N_Generic_Subprogram_Declaration
472 -- False if top of scope stack without finding a generic body
477 ---------------------
478 -- Is_By_Copy_Type --
479 ---------------------
481 function Is_By_Copy_Type (Ent : Entity_Id) return Boolean is
483 -- If Id is a private type whose full declaration has not been seen,
484 -- we assume for now that it is not a By_Copy type. Clearly this
485 -- attribute should not be used before the type is frozen, but it is
486 -- needed to build the associated record of a protected type. Another
487 -- place where some lookahead for a full view is needed ???
490 Is_Elementary_Type (Ent)
491 or else (Is_Private_Type (Ent)
492 and then Present (Underlying_Type (Ent))
493 and then Is_Elementary_Type (Underlying_Type (Ent)));
496 --------------------------
497 -- Is_By_Reference_Type --
498 --------------------------
500 function Is_By_Reference_Type (Ent : Entity_Id) return Boolean is
501 Btype : constant Entity_Id := Base_Type (Ent);
504 if Error_Posted (Ent) or else Error_Posted (Btype) then
507 elsif Is_Private_Type (Btype) then
509 Utyp : constant Entity_Id := Underlying_Type (Btype);
514 return Is_By_Reference_Type (Utyp);
518 elsif Is_Incomplete_Type (Btype) then
520 Ftyp : constant Entity_Id := Full_View (Btype);
525 return Is_By_Reference_Type (Ftyp);
529 elsif Is_Concurrent_Type (Btype) then
532 elsif Is_Record_Type (Btype) then
533 if Is_Limited_Record (Btype)
534 or else Is_Tagged_Type (Btype)
535 or else Is_Volatile (Btype)
544 C := First_Component (Btype);
545 while Present (C) loop
546 if Is_By_Reference_Type (Etype (C))
547 or else Is_Volatile (Etype (C))
552 C := Next_Component (C);
559 elsif Is_Array_Type (Btype) then
562 or else Is_By_Reference_Type (Component_Type (Btype))
563 or else Is_Volatile (Component_Type (Btype))
564 or else Has_Volatile_Components (Btype);
569 end Is_By_Reference_Type;
571 ---------------------
572 -- Is_Derived_Type --
573 ---------------------
575 function Is_Derived_Type (Ent : E) return B is
580 and then Base_Type (Ent) /= Root_Type (Ent)
581 and then not Is_Class_Wide_Type (Ent)
583 if not Is_Numeric_Type (Root_Type (Ent)) then
587 Par := Parent (First_Subtype (Ent));
590 and then Nkind (Par) = N_Full_Type_Declaration
591 and then Nkind (Type_Definition (Par)) =
592 N_Derived_Type_Definition;
600 -----------------------
601 -- Is_Generic_Formal --
602 -----------------------
604 function Is_Generic_Formal (E : Entity_Id) return Boolean is
610 Kind := Nkind (Parent (E));
612 Nkind_In (Kind, N_Formal_Object_Declaration,
613 N_Formal_Package_Declaration,
614 N_Formal_Type_Declaration)
615 or else Is_Formal_Subprogram (E);
617 end Is_Generic_Formal;
619 ---------------------------
620 -- Is_Indefinite_Subtype --
621 ---------------------------
623 function Is_Indefinite_Subtype (Ent : Entity_Id) return Boolean is
624 K : constant Entity_Kind := Ekind (Ent);
627 if Is_Constrained (Ent) then
630 elsif K in Array_Kind
631 or else K in Class_Wide_Kind
632 or else Has_Unknown_Discriminants (Ent)
636 -- Known discriminants: indefinite if there are no default values
638 elsif K in Record_Kind
639 or else Is_Incomplete_Or_Private_Type (Ent)
640 or else Is_Concurrent_Type (Ent)
642 return (Has_Discriminants (Ent)
644 No (Discriminant_Default_Value (First_Discriminant (Ent))));
649 end Is_Indefinite_Subtype;
651 -------------------------------
652 -- Is_Immutably_Limited_Type --
653 -------------------------------
655 function Is_Immutably_Limited_Type (Ent : Entity_Id) return Boolean is
656 Btype : constant Entity_Id := Available_View (Base_Type (Ent));
659 if Is_Limited_Record (Btype) then
662 elsif Ekind (Btype) = E_Limited_Private_Type
663 and then Nkind (Parent (Btype)) = N_Formal_Type_Declaration
665 return not In_Package_Body (Scope ((Btype)));
667 elsif Is_Private_Type (Btype) then
669 -- AI05-0063: A type derived from a limited private formal type is
670 -- not immutably limited in a generic body.
672 if Is_Derived_Type (Btype)
673 and then Is_Generic_Type (Etype (Btype))
675 if not Is_Limited_Type (Etype (Btype)) then
678 -- A descendant of a limited formal type is not immutably limited
679 -- in the generic body, or in the body of a generic child.
681 elsif Ekind (Scope (Etype (Btype))) = E_Generic_Package then
682 return not In_Package_Body (Scope (Btype));
690 Utyp : constant Entity_Id := Underlying_Type (Btype);
695 return Is_Immutably_Limited_Type (Utyp);
700 elsif Is_Concurrent_Type (Btype) then
703 elsif Is_Record_Type (Btype) then
705 -- Note that we return True for all limited interfaces, even though
706 -- (unsynchronized) limited interfaces can have descendants that are
707 -- nonlimited, because this is a predicate on the type itself, and
708 -- things like functions with limited interface results need to be
709 -- handled as build in place even though they might return objects
710 -- of a type that is not inherently limited.
712 if Is_Class_Wide_Type (Btype) then
713 return Is_Immutably_Limited_Type (Root_Type (Btype));
720 C := First_Component (Btype);
721 while Present (C) loop
723 -- Don't consider components with interface types (which can
724 -- only occur in the case of a _parent component anyway).
725 -- They don't have any components, plus it would cause this
726 -- function to return true for nonlimited types derived from
727 -- limited interfaces.
729 if not Is_Interface (Etype (C))
730 and then Is_Immutably_Limited_Type (Etype (C))
735 C := Next_Component (C);
742 elsif Is_Array_Type (Btype) then
743 return Is_Immutably_Limited_Type (Component_Type (Btype));
748 end Is_Immutably_Limited_Type;
750 ---------------------
751 -- Is_Limited_Type --
752 ---------------------
754 function Is_Limited_Type (Ent : Entity_Id) return Boolean is
755 Btype : constant E := Base_Type (Ent);
756 Rtype : constant E := Root_Type (Btype);
759 if not Is_Type (Ent) then
762 elsif Ekind (Btype) = E_Limited_Private_Type
763 or else Is_Limited_Composite (Btype)
767 elsif Is_Concurrent_Type (Btype) then
770 -- The Is_Limited_Record flag normally indicates that the type is
771 -- limited. The exception is that a type does not inherit limitedness
772 -- from its interface ancestor. So the type may be derived from a
773 -- limited interface, but is not limited.
775 elsif Is_Limited_Record (Ent)
776 and then not Is_Interface (Ent)
780 -- Otherwise we will look around to see if there is some other reason
781 -- for it to be limited, except that if an error was posted on the
782 -- entity, then just assume it is non-limited, because it can cause
783 -- trouble to recurse into a murky erroneous entity!
785 elsif Error_Posted (Ent) then
788 elsif Is_Record_Type (Btype) then
790 if Is_Limited_Interface (Ent) then
793 -- AI-419: limitedness is not inherited from a limited interface
795 elsif Is_Limited_Record (Rtype) then
796 return not Is_Interface (Rtype)
797 or else Is_Protected_Interface (Rtype)
798 or else Is_Synchronized_Interface (Rtype)
799 or else Is_Task_Interface (Rtype);
801 elsif Is_Class_Wide_Type (Btype) then
802 return Is_Limited_Type (Rtype);
809 C := First_Component (Btype);
810 while Present (C) loop
811 if Is_Limited_Type (Etype (C)) then
815 C := Next_Component (C);
822 elsif Is_Array_Type (Btype) then
823 return Is_Limited_Type (Component_Type (Btype));
830 ----------------------
831 -- Nearest_Ancestor --
832 ----------------------
834 function Nearest_Ancestor (Typ : Entity_Id) return Entity_Id is
835 D : constant Node_Id := Declaration_Node (Typ);
838 -- If we have a subtype declaration, get the ancestor subtype
840 if Nkind (D) = N_Subtype_Declaration then
841 if Nkind (Subtype_Indication (D)) = N_Subtype_Indication then
842 return Entity (Subtype_Mark (Subtype_Indication (D)));
844 return Entity (Subtype_Indication (D));
847 -- If derived type declaration, find who we are derived from
849 elsif Nkind (D) = N_Full_Type_Declaration
850 and then Nkind (Type_Definition (D)) = N_Derived_Type_Definition
853 DTD : constant Entity_Id := Type_Definition (D);
854 SI : constant Entity_Id := Subtype_Indication (DTD);
856 if Is_Entity_Name (SI) then
859 return Entity (Subtype_Mark (SI));
863 -- Otherwise, nothing useful to return, return Empty
868 end Nearest_Ancestor;
870 ---------------------------
871 -- Nearest_Dynamic_Scope --
872 ---------------------------
874 function Nearest_Dynamic_Scope (Ent : Entity_Id) return Entity_Id is
876 if Is_Dynamic_Scope (Ent) then
879 return Enclosing_Dynamic_Scope (Ent);
881 end Nearest_Dynamic_Scope;
883 ------------------------
884 -- Next_Tag_Component --
885 ------------------------
887 function Next_Tag_Component (Tag : Entity_Id) return Entity_Id is
891 pragma Assert (Is_Tag (Tag));
893 -- Loop to look for next tag component
895 Comp := Next_Entity (Tag);
896 while Present (Comp) loop
897 if Is_Tag (Comp) then
898 pragma Assert (Chars (Comp) /= Name_uTag);
902 Comp := Next_Entity (Comp);
905 -- No tag component found
908 end Next_Tag_Component;
910 --------------------------
911 -- Number_Discriminants --
912 --------------------------
914 function Number_Discriminants (Typ : Entity_Id) return Pos is
920 Discr := First_Discriminant (Typ);
921 while Present (Discr) loop
923 Discr := Next_Discriminant (Discr);
927 end Number_Discriminants;
933 procedure Tree_Read is
935 Obsolescent_Warnings.Tree_Read;
942 procedure Tree_Write is
944 Obsolescent_Warnings.Tree_Write;
951 function Ultimate_Alias (Prim : Entity_Id) return Entity_Id is
952 E : Entity_Id := Prim;
955 while Present (Alias (E)) loop
956 pragma Assert (Alias (E) /= E);
963 --------------------------
964 -- Unit_Declaration_Node --
965 --------------------------
967 function Unit_Declaration_Node (Unit_Id : Entity_Id) return Node_Id is
968 N : Node_Id := Parent (Unit_Id);
971 -- Predefined operators do not have a full function declaration
973 if Ekind (Unit_Id) = E_Operator then
977 -- Isn't there some better way to express the following ???
979 while Nkind (N) /= N_Abstract_Subprogram_Declaration
980 and then Nkind (N) /= N_Formal_Package_Declaration
981 and then Nkind (N) /= N_Function_Instantiation
982 and then Nkind (N) /= N_Generic_Package_Declaration
983 and then Nkind (N) /= N_Generic_Subprogram_Declaration
984 and then Nkind (N) /= N_Package_Declaration
985 and then Nkind (N) /= N_Package_Body
986 and then Nkind (N) /= N_Package_Instantiation
987 and then Nkind (N) /= N_Package_Renaming_Declaration
988 and then Nkind (N) /= N_Procedure_Instantiation
989 and then Nkind (N) /= N_Protected_Body
990 and then Nkind (N) /= N_Subprogram_Declaration
991 and then Nkind (N) /= N_Subprogram_Body
992 and then Nkind (N) /= N_Subprogram_Body_Stub
993 and then Nkind (N) /= N_Subprogram_Renaming_Declaration
994 and then Nkind (N) /= N_Task_Body
995 and then Nkind (N) /= N_Task_Type_Declaration
996 and then Nkind (N) not in N_Formal_Subprogram_Declaration
997 and then Nkind (N) not in N_Generic_Renaming_Declaration
1001 -- We don't use Assert here, because that causes an infinite loop
1002 -- when assertions are turned off. Better to crash.
1005 raise Program_Error;
1010 end Unit_Declaration_Node;