1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2012, 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 Sinfo; use Sinfo;
36 with Snames; use Snames;
37 with Stand; use Stand;
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 (Typ : Entity_Id) return Entity_Id is
81 if Is_Incomplete_Type (Typ)
82 and then Present (Non_Limited_View (Typ))
84 -- The non-limited view may itself be an incomplete type, in which
85 -- case get its full view.
87 return Get_Full_View (Non_Limited_View (Typ));
89 elsif Is_Class_Wide_Type (Typ)
90 and then Is_Incomplete_Type (Etype (Typ))
91 and then Present (Non_Limited_View (Etype (Typ)))
93 return Class_Wide_Type (Non_Limited_View (Etype (Typ)));
104 function Constant_Value (Ent : Entity_Id) return Node_Id is
105 D : constant Node_Id := Declaration_Node (Ent);
109 -- If we have no declaration node, then return no constant value. Not
110 -- clear how this can happen, but it does sometimes and this is the
116 -- Normal case where a declaration node is present
118 elsif Nkind (D) = N_Object_Renaming_Declaration then
119 return Renamed_Object (Ent);
121 -- If this is a component declaration whose entity is a constant, it is
122 -- a prival within a protected function (and so has no constant value).
124 elsif Nkind (D) = N_Component_Declaration then
127 -- If there is an expression, return it
129 elsif Present (Expression (D)) then
130 return (Expression (D));
132 -- For a constant, see if we have a full view
134 elsif Ekind (Ent) = E_Constant
135 and then Present (Full_View (Ent))
137 Full_D := Parent (Full_View (Ent));
139 -- The full view may have been rewritten as an object renaming
141 if Nkind (Full_D) = N_Object_Renaming_Declaration then
142 return Name (Full_D);
144 return Expression (Full_D);
147 -- Otherwise we have no expression to return
154 ----------------------------------------------
155 -- Effectively_Has_Constrained_Partial_View --
156 ----------------------------------------------
158 function Effectively_Has_Constrained_Partial_View
160 Scop : Entity_Id) return Boolean
163 return Has_Constrained_Partial_View (Typ)
164 or else (In_Generic_Body (Scop)
165 and then Is_Generic_Type (Base_Type (Typ))
166 and then Is_Private_Type (Base_Type (Typ))
167 and then not Is_Tagged_Type (Typ)
168 and then not (Is_Array_Type (Typ)
169 and then not Is_Constrained (Typ))
170 and then Has_Discriminants (Typ));
171 end Effectively_Has_Constrained_Partial_View;
173 -----------------------------
174 -- Enclosing_Dynamic_Scope --
175 -----------------------------
177 function Enclosing_Dynamic_Scope (Ent : Entity_Id) return Entity_Id is
181 -- The following test is an error defense against some syntax errors
182 -- that can leave scopes very messed up.
184 if Ent = Standard_Standard then
188 -- Normal case, search enclosing scopes
190 -- Note: the test for Present (S) should not be required, it defends
191 -- against an ill-formed tree.
195 -- If we somehow got an empty value for Scope, the tree must be
196 -- malformed. Rather than blow up we return Standard in this case.
199 return Standard_Standard;
201 -- Quit if we get to standard or a dynamic scope. We must also
202 -- handle enclosing scopes that have a full view; required to
203 -- locate enclosing scopes that are synchronized private types
204 -- whose full view is a task type.
206 elsif S = Standard_Standard
207 or else Is_Dynamic_Scope (S)
208 or else (Is_Private_Type (S)
209 and then Present (Full_View (S))
210 and then Is_Dynamic_Scope (Full_View (S)))
214 -- Otherwise keep climbing
220 end Enclosing_Dynamic_Scope;
222 ------------------------
223 -- First_Discriminant --
224 ------------------------
226 function First_Discriminant (Typ : Entity_Id) return Entity_Id is
231 (Has_Discriminants (Typ) or else Has_Unknown_Discriminants (Typ));
233 Ent := First_Entity (Typ);
235 -- The discriminants are not necessarily contiguous, because access
236 -- discriminants will generate itypes. They are not the first entities
237 -- either because the tag must be ahead of them.
239 if Chars (Ent) = Name_uTag then
240 Ent := Next_Entity (Ent);
243 -- Skip all hidden stored discriminants if any
245 while Present (Ent) loop
246 exit when Ekind (Ent) = E_Discriminant
247 and then not Is_Completely_Hidden (Ent);
249 Ent := Next_Entity (Ent);
252 pragma Assert (Ekind (Ent) = E_Discriminant);
255 end First_Discriminant;
257 -------------------------------
258 -- First_Stored_Discriminant --
259 -------------------------------
261 function First_Stored_Discriminant (Typ : Entity_Id) return Entity_Id is
264 function Has_Completely_Hidden_Discriminant
265 (Typ : Entity_Id) return Boolean;
266 -- Scans the Discriminants to see whether any are Completely_Hidden
267 -- (the mechanism for describing non-specified stored discriminants)
269 ----------------------------------------
270 -- Has_Completely_Hidden_Discriminant --
271 ----------------------------------------
273 function Has_Completely_Hidden_Discriminant
274 (Typ : Entity_Id) return Boolean
279 pragma Assert (Ekind (Typ) = E_Discriminant);
282 while Present (Ent) and then Ekind (Ent) = E_Discriminant loop
283 if Is_Completely_Hidden (Ent) then
287 Ent := Next_Entity (Ent);
291 end Has_Completely_Hidden_Discriminant;
293 -- Start of processing for First_Stored_Discriminant
297 (Has_Discriminants (Typ)
298 or else Has_Unknown_Discriminants (Typ));
300 Ent := First_Entity (Typ);
302 if Chars (Ent) = Name_uTag then
303 Ent := Next_Entity (Ent);
306 if Has_Completely_Hidden_Discriminant (Ent) then
307 while Present (Ent) loop
308 exit when Is_Completely_Hidden (Ent);
309 Ent := Next_Entity (Ent);
313 pragma Assert (Ekind (Ent) = E_Discriminant);
316 end First_Stored_Discriminant;
322 function First_Subtype (Typ : Entity_Id) return Entity_Id is
323 B : constant Entity_Id := Base_Type (Typ);
324 F : constant Node_Id := Freeze_Node (B);
328 -- If the base type has no freeze node, it is a type in Standard, and
329 -- always acts as its own first subtype, except where it is one of the
330 -- predefined integer types. If the type is formal, it is also a first
331 -- subtype, and its base type has no freeze node. On the other hand, a
332 -- subtype of a generic formal is not its own first subtype. Its base
333 -- type, if anonymous, is attached to the formal type decl. from which
334 -- the first subtype is obtained.
337 if B = Base_Type (Standard_Integer) then
338 return Standard_Integer;
340 elsif B = Base_Type (Standard_Long_Integer) then
341 return Standard_Long_Integer;
343 elsif B = Base_Type (Standard_Short_Short_Integer) then
344 return Standard_Short_Short_Integer;
346 elsif B = Base_Type (Standard_Short_Integer) then
347 return Standard_Short_Integer;
349 elsif B = Base_Type (Standard_Long_Long_Integer) then
350 return Standard_Long_Long_Integer;
352 elsif Is_Generic_Type (Typ) then
353 if Present (Parent (B)) then
354 return Defining_Identifier (Parent (B));
356 return Defining_Identifier (Associated_Node_For_Itype (B));
363 -- Otherwise we check the freeze node, if it has a First_Subtype_Link
364 -- then we use that link, otherwise (happens with some Itypes), we use
365 -- the base type itself.
368 Ent := First_Subtype_Link (F);
370 if Present (Ent) then
378 -------------------------
379 -- First_Tag_Component --
380 -------------------------
382 function First_Tag_Component (Typ : Entity_Id) return Entity_Id is
388 pragma Assert (Is_Tagged_Type (Ctyp));
390 if Is_Class_Wide_Type (Ctyp) then
391 Ctyp := Root_Type (Ctyp);
394 if Is_Private_Type (Ctyp) then
395 Ctyp := Underlying_Type (Ctyp);
397 -- If the underlying type is missing then the source program has
398 -- errors and there is nothing else to do (the full-type declaration
399 -- associated with the private type declaration is missing).
406 Comp := First_Entity (Ctyp);
407 while Present (Comp) loop
408 if Is_Tag (Comp) then
412 Comp := Next_Entity (Comp);
415 -- No tag component found
418 end First_Tag_Component;
424 function Get_Rep_Item
427 Check_Parents : Boolean := True) return Node_Id
432 N := First_Rep_Item (E);
433 while Present (N) loop
435 -- Only one of Priority / Interrupt_Priority can be specified, so
436 -- return whichever one is present to catch illegal duplication.
438 if Nkind (N) = N_Pragma
440 (Pragma_Name (N) = Nam
441 or else (Nam = Name_Priority
442 and then Pragma_Name (N) = Name_Interrupt_Priority)
443 or else (Nam = Name_Interrupt_Priority
444 and then Pragma_Name (N) = Name_Priority))
446 if Check_Parents then
449 -- If Check_Parents is False, return N if the pragma doesn't
450 -- appear in the Rep_Item chain of the parent.
454 Par : constant Entity_Id := Nearest_Ancestor (E);
455 -- This node represents the parent type of type E (if any)
461 elsif not Present_In_Rep_Item (Par, N) then
467 elsif Nkind (N) = N_Attribute_Definition_Clause
470 or else (Nam = Name_Priority
471 and then Chars (N) = Name_Interrupt_Priority))
473 if Check_Parents or else Entity (N) = E then
477 elsif Nkind (N) = N_Aspect_Specification
479 (Chars (Identifier (N)) = Nam
480 or else (Nam = Name_Priority
481 and then Chars (Identifier (N)) =
482 Name_Interrupt_Priority))
484 if Check_Parents then
487 elsif Entity (N) = E then
498 function Get_Rep_Item
502 Check_Parents : Boolean := True) return Node_Id
504 Nam1_Item : constant Node_Id := Get_Rep_Item (E, Nam1, Check_Parents);
505 Nam2_Item : constant Node_Id := Get_Rep_Item (E, Nam2, Check_Parents);
510 -- Check both Nam1_Item and Nam2_Item are present
512 if No (Nam1_Item) then
514 elsif No (Nam2_Item) then
518 -- Return the first node encountered in the list
520 N := First_Rep_Item (E);
521 while Present (N) loop
522 if N = Nam1_Item or else N = Nam2_Item then
536 function Get_Rep_Pragma
539 Check_Parents : Boolean := True) return Node_Id
544 N := Get_Rep_Item (E, Nam, Check_Parents);
546 if Present (N) and then Nkind (N) = N_Pragma then
553 function Get_Rep_Pragma
557 Check_Parents : Boolean := True) return Node_Id
559 Nam1_Item : constant Node_Id := Get_Rep_Pragma (E, Nam1, Check_Parents);
560 Nam2_Item : constant Node_Id := Get_Rep_Pragma (E, Nam2, Check_Parents);
565 -- Check both Nam1_Item and Nam2_Item are present
567 if No (Nam1_Item) then
569 elsif No (Nam2_Item) then
573 -- Return the first node encountered in the list
575 N := First_Rep_Item (E);
576 while Present (N) loop
577 if N = Nam1_Item or else N = Nam2_Item then
591 function Has_Rep_Item
594 Check_Parents : Boolean := True) return Boolean
597 return Present (Get_Rep_Item (E, Nam, Check_Parents));
600 function Has_Rep_Item
604 Check_Parents : Boolean := True) return Boolean
607 return Present (Get_Rep_Item (E, Nam1, Nam2, Check_Parents));
614 function Has_Rep_Pragma
617 Check_Parents : Boolean := True) return Boolean
620 return Present (Get_Rep_Pragma (E, Nam, Check_Parents));
623 function Has_Rep_Pragma
627 Check_Parents : Boolean := True) return Boolean
630 return Present (Get_Rep_Pragma (E, Nam1, Nam2, Check_Parents));
633 -------------------------------
634 -- Initialization_Suppressed --
635 -------------------------------
637 function Initialization_Suppressed (Typ : Entity_Id) return Boolean is
639 return Suppress_Initialization (Typ)
640 or else Suppress_Initialization (Base_Type (Typ));
641 end Initialization_Suppressed;
647 procedure Initialize is
649 Obsolescent_Warnings.Init;
652 ---------------------
653 -- In_Generic_Body --
654 ---------------------
656 function In_Generic_Body (Id : Entity_Id) return Boolean is
660 -- Climb scopes looking for generic body
663 while Present (S) and then S /= Standard_Standard loop
665 -- Generic package body
667 if Ekind (S) = E_Generic_Package
668 and then In_Package_Body (S)
672 -- Generic subprogram body
674 elsif Is_Subprogram (S)
675 and then Nkind (Unit_Declaration_Node (S))
676 = N_Generic_Subprogram_Declaration
684 -- False if top of scope stack without finding a generic body
689 ---------------------
690 -- Is_By_Copy_Type --
691 ---------------------
693 function Is_By_Copy_Type (Ent : Entity_Id) return Boolean is
695 -- If Id is a private type whose full declaration has not been seen,
696 -- we assume for now that it is not a By_Copy type. Clearly this
697 -- attribute should not be used before the type is frozen, but it is
698 -- needed to build the associated record of a protected type. Another
699 -- place where some lookahead for a full view is needed ???
702 Is_Elementary_Type (Ent)
703 or else (Is_Private_Type (Ent)
704 and then Present (Underlying_Type (Ent))
705 and then Is_Elementary_Type (Underlying_Type (Ent)));
708 --------------------------
709 -- Is_By_Reference_Type --
710 --------------------------
712 function Is_By_Reference_Type (Ent : Entity_Id) return Boolean is
713 Btype : constant Entity_Id := Base_Type (Ent);
716 if Error_Posted (Ent) or else Error_Posted (Btype) then
719 elsif Is_Private_Type (Btype) then
721 Utyp : constant Entity_Id := Underlying_Type (Btype);
726 return Is_By_Reference_Type (Utyp);
730 elsif Is_Incomplete_Type (Btype) then
732 Ftyp : constant Entity_Id := Full_View (Btype);
737 return Is_By_Reference_Type (Ftyp);
741 elsif Is_Concurrent_Type (Btype) then
744 elsif Is_Record_Type (Btype) then
745 if Is_Limited_Record (Btype)
746 or else Is_Tagged_Type (Btype)
747 or else Is_Volatile (Btype)
756 C := First_Component (Btype);
757 while Present (C) loop
758 if Is_By_Reference_Type (Etype (C))
759 or else Is_Volatile (Etype (C))
764 C := Next_Component (C);
771 elsif Is_Array_Type (Btype) then
774 or else Is_By_Reference_Type (Component_Type (Btype))
775 or else Is_Volatile (Component_Type (Btype))
776 or else Has_Volatile_Components (Btype);
781 end Is_By_Reference_Type;
783 ---------------------
784 -- Is_Derived_Type --
785 ---------------------
787 function Is_Derived_Type (Ent : E) return B is
792 and then Base_Type (Ent) /= Root_Type (Ent)
793 and then not Is_Class_Wide_Type (Ent)
795 if not Is_Numeric_Type (Root_Type (Ent)) then
799 Par := Parent (First_Subtype (Ent));
802 and then Nkind (Par) = N_Full_Type_Declaration
803 and then Nkind (Type_Definition (Par)) =
804 N_Derived_Type_Definition;
812 -----------------------
813 -- Is_Generic_Formal --
814 -----------------------
816 function Is_Generic_Formal (E : Entity_Id) return Boolean is
822 Kind := Nkind (Parent (E));
824 Nkind_In (Kind, N_Formal_Object_Declaration,
825 N_Formal_Package_Declaration,
826 N_Formal_Type_Declaration)
827 or else Is_Formal_Subprogram (E);
829 end Is_Generic_Formal;
831 ---------------------------
832 -- Is_Indefinite_Subtype --
833 ---------------------------
835 function Is_Indefinite_Subtype (Ent : Entity_Id) return Boolean is
836 K : constant Entity_Kind := Ekind (Ent);
839 if Is_Constrained (Ent) then
842 elsif K in Array_Kind
843 or else K in Class_Wide_Kind
844 or else Has_Unknown_Discriminants (Ent)
848 -- Known discriminants: indefinite if there are no default values
850 elsif K in Record_Kind
851 or else Is_Incomplete_Or_Private_Type (Ent)
852 or else Is_Concurrent_Type (Ent)
854 return (Has_Discriminants (Ent)
856 No (Discriminant_Default_Value (First_Discriminant (Ent))));
861 end Is_Indefinite_Subtype;
863 -------------------------------
864 -- Is_Immutably_Limited_Type --
865 -------------------------------
867 function Is_Immutably_Limited_Type (Ent : Entity_Id) return Boolean is
868 Btype : constant Entity_Id := Available_View (Base_Type (Ent));
871 if Is_Limited_Record (Btype) then
874 elsif Ekind (Btype) = E_Limited_Private_Type
875 and then Nkind (Parent (Btype)) = N_Formal_Type_Declaration
877 return not In_Package_Body (Scope ((Btype)));
879 elsif Is_Private_Type (Btype) then
881 -- AI05-0063: A type derived from a limited private formal type is
882 -- not immutably limited in a generic body.
884 if Is_Derived_Type (Btype)
885 and then Is_Generic_Type (Etype (Btype))
887 if not Is_Limited_Type (Etype (Btype)) then
890 -- A descendant of a limited formal type is not immutably limited
891 -- in the generic body, or in the body of a generic child.
893 elsif Ekind (Scope (Etype (Btype))) = E_Generic_Package then
894 return not In_Package_Body (Scope (Btype));
902 Utyp : constant Entity_Id := Underlying_Type (Btype);
907 return Is_Immutably_Limited_Type (Utyp);
912 elsif Is_Concurrent_Type (Btype) then
915 elsif Is_Record_Type (Btype) then
917 -- Note that we return True for all limited interfaces, even though
918 -- (unsynchronized) limited interfaces can have descendants that are
919 -- nonlimited, because this is a predicate on the type itself, and
920 -- things like functions with limited interface results need to be
921 -- handled as build in place even though they might return objects
922 -- of a type that is not inherently limited.
924 if Is_Class_Wide_Type (Btype) then
925 return Is_Immutably_Limited_Type (Root_Type (Btype));
932 C := First_Component (Btype);
933 while Present (C) loop
935 -- Don't consider components with interface types (which can
936 -- only occur in the case of a _parent component anyway).
937 -- They don't have any components, plus it would cause this
938 -- function to return true for nonlimited types derived from
939 -- limited interfaces.
941 if not Is_Interface (Etype (C))
942 and then Is_Immutably_Limited_Type (Etype (C))
947 C := Next_Component (C);
954 elsif Is_Array_Type (Btype) then
955 return Is_Immutably_Limited_Type (Component_Type (Btype));
960 end Is_Immutably_Limited_Type;
962 ---------------------
963 -- Is_Limited_Type --
964 ---------------------
966 function Is_Limited_Type (Ent : Entity_Id) return Boolean is
967 Btype : constant E := Base_Type (Ent);
968 Rtype : constant E := Root_Type (Btype);
971 if not Is_Type (Ent) then
974 elsif Ekind (Btype) = E_Limited_Private_Type
975 or else Is_Limited_Composite (Btype)
979 elsif Is_Concurrent_Type (Btype) then
982 -- The Is_Limited_Record flag normally indicates that the type is
983 -- limited. The exception is that a type does not inherit limitedness
984 -- from its interface ancestor. So the type may be derived from a
985 -- limited interface, but is not limited.
987 elsif Is_Limited_Record (Ent)
988 and then not Is_Interface (Ent)
992 -- Otherwise we will look around to see if there is some other reason
993 -- for it to be limited, except that if an error was posted on the
994 -- entity, then just assume it is non-limited, because it can cause
995 -- trouble to recurse into a murky erroneous entity!
997 elsif Error_Posted (Ent) then
1000 elsif Is_Record_Type (Btype) then
1002 if Is_Limited_Interface (Ent) then
1005 -- AI-419: limitedness is not inherited from a limited interface
1007 elsif Is_Limited_Record (Rtype) then
1008 return not Is_Interface (Rtype)
1009 or else Is_Protected_Interface (Rtype)
1010 or else Is_Synchronized_Interface (Rtype)
1011 or else Is_Task_Interface (Rtype);
1013 elsif Is_Class_Wide_Type (Btype) then
1014 return Is_Limited_Type (Rtype);
1021 C := First_Component (Btype);
1022 while Present (C) loop
1023 if Is_Limited_Type (Etype (C)) then
1027 C := Next_Component (C);
1034 elsif Is_Array_Type (Btype) then
1035 return Is_Limited_Type (Component_Type (Btype));
1040 end Is_Limited_Type;
1042 ----------------------
1043 -- Nearest_Ancestor --
1044 ----------------------
1046 function Nearest_Ancestor (Typ : Entity_Id) return Entity_Id is
1047 D : constant Node_Id := Declaration_Node (Typ);
1050 -- If we have a subtype declaration, get the ancestor subtype
1052 if Nkind (D) = N_Subtype_Declaration then
1053 if Nkind (Subtype_Indication (D)) = N_Subtype_Indication then
1054 return Entity (Subtype_Mark (Subtype_Indication (D)));
1056 return Entity (Subtype_Indication (D));
1059 -- If derived type declaration, find who we are derived from
1061 elsif Nkind (D) = N_Full_Type_Declaration
1062 and then Nkind (Type_Definition (D)) = N_Derived_Type_Definition
1065 DTD : constant Entity_Id := Type_Definition (D);
1066 SI : constant Entity_Id := Subtype_Indication (DTD);
1068 if Is_Entity_Name (SI) then
1071 return Entity (Subtype_Mark (SI));
1075 -- If derived type and private type, get the full view to find who we
1076 -- are derived from.
1078 elsif Is_Derived_Type (Typ)
1079 and then Is_Private_Type (Typ)
1080 and then Present (Full_View (Typ))
1082 return Nearest_Ancestor (Full_View (Typ));
1084 -- Otherwise, nothing useful to return, return Empty
1089 end Nearest_Ancestor;
1091 ---------------------------
1092 -- Nearest_Dynamic_Scope --
1093 ---------------------------
1095 function Nearest_Dynamic_Scope (Ent : Entity_Id) return Entity_Id is
1097 if Is_Dynamic_Scope (Ent) then
1100 return Enclosing_Dynamic_Scope (Ent);
1102 end Nearest_Dynamic_Scope;
1104 ------------------------
1105 -- Next_Tag_Component --
1106 ------------------------
1108 function Next_Tag_Component (Tag : Entity_Id) return Entity_Id is
1112 pragma Assert (Is_Tag (Tag));
1114 -- Loop to look for next tag component
1116 Comp := Next_Entity (Tag);
1117 while Present (Comp) loop
1118 if Is_Tag (Comp) then
1119 pragma Assert (Chars (Comp) /= Name_uTag);
1123 Comp := Next_Entity (Comp);
1126 -- No tag component found
1129 end Next_Tag_Component;
1131 --------------------------
1132 -- Number_Discriminants --
1133 --------------------------
1135 function Number_Discriminants (Typ : Entity_Id) return Pos is
1141 Discr := First_Discriminant (Typ);
1142 while Present (Discr) loop
1144 Discr := Next_Discriminant (Discr);
1148 end Number_Discriminants;
1154 procedure Tree_Read is
1156 Obsolescent_Warnings.Tree_Read;
1163 procedure Tree_Write is
1165 Obsolescent_Warnings.Tree_Write;
1168 --------------------
1169 -- Ultimate_Alias --
1170 --------------------
1172 function Ultimate_Alias (Prim : Entity_Id) return Entity_Id is
1173 E : Entity_Id := Prim;
1176 while Present (Alias (E)) loop
1177 pragma Assert (Alias (E) /= E);
1184 --------------------------
1185 -- Unit_Declaration_Node --
1186 --------------------------
1188 function Unit_Declaration_Node (Unit_Id : Entity_Id) return Node_Id is
1189 N : Node_Id := Parent (Unit_Id);
1192 -- Predefined operators do not have a full function declaration
1194 if Ekind (Unit_Id) = E_Operator then
1198 -- Isn't there some better way to express the following ???
1200 while Nkind (N) /= N_Abstract_Subprogram_Declaration
1201 and then Nkind (N) /= N_Formal_Package_Declaration
1202 and then Nkind (N) /= N_Function_Instantiation
1203 and then Nkind (N) /= N_Generic_Package_Declaration
1204 and then Nkind (N) /= N_Generic_Subprogram_Declaration
1205 and then Nkind (N) /= N_Package_Declaration
1206 and then Nkind (N) /= N_Package_Body
1207 and then Nkind (N) /= N_Package_Instantiation
1208 and then Nkind (N) /= N_Package_Renaming_Declaration
1209 and then Nkind (N) /= N_Procedure_Instantiation
1210 and then Nkind (N) /= N_Protected_Body
1211 and then Nkind (N) /= N_Subprogram_Declaration
1212 and then Nkind (N) /= N_Subprogram_Body
1213 and then Nkind (N) /= N_Subprogram_Body_Stub
1214 and then Nkind (N) /= N_Subprogram_Renaming_Declaration
1215 and then Nkind (N) /= N_Task_Body
1216 and then Nkind (N) /= N_Task_Type_Declaration
1217 and then Nkind (N) not in N_Formal_Subprogram_Declaration
1218 and then Nkind (N) not in N_Generic_Renaming_Declaration
1222 -- We don't use Assert here, because that causes an infinite loop
1223 -- when assertions are turned off. Better to crash.
1226 raise Program_Error;
1231 end Unit_Declaration_Node;