File : sem_aux.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- S E M _ A U X --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
10 -- --
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. --
20 -- --
21 -- --
22 -- --
23 -- --
24 -- --
25 -- --
26 -- --
27 -- --
28 -- GNAT was originally developed by the GNAT team at New York University. --
29 -- Extensive contributions were provided by Ada Core Technologies Inc. --
30 -- --
31 ------------------------------------------------------------------------------
32
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;
38
39 package body Sem_Aux is
40
41 ----------------------
42 -- Ancestor_Subtype --
43 ----------------------
44
45 function Ancestor_Subtype (Typ : Entity_Id) return Entity_Id is
46 begin
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.
49
50 if Is_First_Subtype (Typ) or else Is_Base_Type (Typ) then
51 return Empty;
52 end if;
53
54 declare
55 D : constant Node_Id := Declaration_Node (Typ);
56
57 begin
58 -- If we have a subtype declaration, get the ancestor subtype
59
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)));
63 else
64 return Entity (Subtype_Indication (D));
65 end if;
66
67 -- If not, then no subtype indication is available
68
69 else
70 return Empty;
71 end if;
72 end;
73 end Ancestor_Subtype;
74
75 --------------------
76 -- Available_View --
77 --------------------
78
79 function Available_View (Ent : Entity_Id) return Entity_Id is
80 begin
81 -- Obtain the non-limited view (if available)
82
83 if Has_Non_Limited_View (Ent) then
84 return Get_Full_View (Non_Limited_View (Ent));
85
86 -- In all other cases, return entity unchanged
87
88 else
89 return Ent;
90 end if;
91 end Available_View;
92
93 --------------------
94 -- Constant_Value --
95 --------------------
96
97 function Constant_Value (Ent : Entity_Id) return Node_Id is
98 D : constant Node_Id := Declaration_Node (Ent);
99 Full_D : Node_Id;
100
101 begin
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
104 -- safest approach.
105
106 if No (D) then
107 return Empty;
108
109 -- Normal case where a declaration node is present
110
111 elsif Nkind (D) = N_Object_Renaming_Declaration then
112 return Renamed_Object (Ent);
113
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).
116
117 elsif Nkind (D) = N_Component_Declaration then
118 return Empty;
119
120 -- If there is an expression, return it
121
122 elsif Present (Expression (D)) then
123 return Expression (D);
124
125 -- For a constant, see if we have a full view
126
127 elsif Ekind (Ent) = E_Constant
128 and then Present (Full_View (Ent))
129 then
130 Full_D := Parent (Full_View (Ent));
131
132 -- The full view may have been rewritten as an object renaming
133
134 if Nkind (Full_D) = N_Object_Renaming_Declaration then
135 return Name (Full_D);
136 else
137 return Expression (Full_D);
138 end if;
139
140 -- Otherwise we have no expression to return
141
142 else
143 return Empty;
144 end if;
145 end Constant_Value;
146
147 ---------------------------------
148 -- Corresponding_Unsigned_Type --
149 ---------------------------------
150
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));
154 begin
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;
165 else
166 raise Program_Error;
167 end if;
168 end Corresponding_Unsigned_Type;
169
170 -----------------------------
171 -- Enclosing_Dynamic_Scope --
172 -----------------------------
173
174 function Enclosing_Dynamic_Scope (Ent : Entity_Id) return Entity_Id is
175 S : Entity_Id;
176
177 begin
178 -- The following test is an error defense against some syntax errors
179 -- that can leave scopes very messed up.
180
181 if Ent = Standard_Standard then
182 return Ent;
183 end if;
184
185 -- Normal case, search enclosing scopes
186
187 -- Note: the test for Present (S) should not be required, it defends
188 -- against an ill-formed tree.
189
190 S := Scope (Ent);
191 loop
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.
194
195 if No (S) then
196 return Standard_Standard;
197
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.
202
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)))
208 then
209 return S;
210
211 -- Otherwise keep climbing
212
213 else
214 S := Scope (S);
215 end if;
216 end loop;
217 end Enclosing_Dynamic_Scope;
218
219 ------------------------
220 -- First_Discriminant --
221 ------------------------
222
223 function First_Discriminant (Typ : Entity_Id) return Entity_Id is
224 Ent : Entity_Id;
225
226 begin
227 pragma Assert
228 (Has_Discriminants (Typ) or else Has_Unknown_Discriminants (Typ));
229
230 Ent := First_Entity (Typ);
231
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.
235
236 if Chars (Ent) = Name_uTag then
237 Ent := Next_Entity (Ent);
238 end if;
239
240 -- Skip all hidden stored discriminants if any
241
242 while Present (Ent) loop
243 exit when Ekind (Ent) = E_Discriminant
244 and then not Is_Completely_Hidden (Ent);
245
246 Ent := Next_Entity (Ent);
247 end loop;
248
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.
251
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.
255
256 return Ent;
257 end First_Discriminant;
258
259 -------------------------------
260 -- First_Stored_Discriminant --
261 -------------------------------
262
263 function First_Stored_Discriminant (Typ : Entity_Id) return Entity_Id is
264 Ent : Entity_Id;
265
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.
272
273 ----------------------------------------
274 -- Has_Completely_Hidden_Discriminant --
275 ----------------------------------------
276
277 function Has_Completely_Hidden_Discriminant
278 (Typ : Entity_Id) return Boolean
279 is
280 Ent : Entity_Id;
281
282 begin
283 pragma Assert (Ekind (Typ) = E_Discriminant);
284
285 Ent := Typ;
286 while Present (Ent) loop
287
288 -- Skip anonymous types that may be created by expressions
289 -- used as discriminant constraints on inherited discriminants.
290
291 if Is_Itype (Ent) then
292 null;
293
294 elsif Ekind (Ent) = E_Discriminant
295 and then Is_Completely_Hidden (Ent)
296 then
297 return True;
298 end if;
299
300 Ent := Next_Entity (Ent);
301 end loop;
302
303 return False;
304 end Has_Completely_Hidden_Discriminant;
305
306 -- Start of processing for First_Stored_Discriminant
307
308 begin
309 pragma Assert
310 (Has_Discriminants (Typ)
311 or else Has_Unknown_Discriminants (Typ));
312
313 Ent := First_Entity (Typ);
314
315 if Chars (Ent) = Name_uTag then
316 Ent := Next_Entity (Ent);
317 end if;
318
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);
324 end loop;
325 end if;
326
327 pragma Assert (Ekind (Ent) = E_Discriminant);
328
329 return Ent;
330 end First_Stored_Discriminant;
331
332 -------------------
333 -- First_Subtype --
334 -------------------
335
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);
339 Ent : Entity_Id;
340
341 begin
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.
349
350 if No (F) then
351 if B = Base_Type (Standard_Integer) then
352 return Standard_Integer;
353
354 elsif B = Base_Type (Standard_Long_Integer) then
355 return Standard_Long_Integer;
356
357 elsif B = Base_Type (Standard_Short_Short_Integer) then
358 return Standard_Short_Short_Integer;
359
360 elsif B = Base_Type (Standard_Short_Integer) then
361 return Standard_Short_Integer;
362
363 elsif B = Base_Type (Standard_Long_Long_Integer) then
364 return Standard_Long_Long_Integer;
365
366 elsif Is_Generic_Type (Typ) then
367 if Present (Parent (B)) then
368 return Defining_Identifier (Parent (B));
369 else
370 return Defining_Identifier (Associated_Node_For_Itype (B));
371 end if;
372
373 else
374 return B;
375 end if;
376
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.
380
381 else
382 Ent := First_Subtype_Link (F);
383
384 if Present (Ent) then
385 return Ent;
386 else
387 return B;
388 end if;
389 end if;
390 end First_Subtype;
391
392 -------------------------
393 -- First_Tag_Component --
394 -------------------------
395
396 function First_Tag_Component (Typ : Entity_Id) return Entity_Id is
397 Comp : Entity_Id;
398 Ctyp : Entity_Id;
399
400 begin
401 Ctyp := Typ;
402 pragma Assert (Is_Tagged_Type (Ctyp));
403
404 if Is_Class_Wide_Type (Ctyp) then
405 Ctyp := Root_Type (Ctyp);
406 end if;
407
408 if Is_Private_Type (Ctyp) then
409 Ctyp := Underlying_Type (Ctyp);
410
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).
414
415 if No (Ctyp) then
416 return Empty;
417 end if;
418 end if;
419
420 Comp := First_Entity (Ctyp);
421 while Present (Comp) loop
422 if Is_Tag (Comp) then
423 return Comp;
424 end if;
425
426 Comp := Next_Entity (Comp);
427 end loop;
428
429 -- No tag component found
430
431 return Empty;
432 end First_Tag_Component;
433
434 ---------------------
435 -- Get_Binary_Nkind --
436 ---------------------
437
438 function Get_Binary_Nkind (Op : Entity_Id) return Node_Kind is
439 begin
440 case Chars (Op) is
441 when Name_Op_Add =>
442 return N_Op_Add;
443 when Name_Op_Concat =>
444 return N_Op_Concat;
445 when Name_Op_Expon =>
446 return N_Op_Expon;
447 when Name_Op_Subtract =>
448 return N_Op_Subtract;
449 when Name_Op_Mod =>
450 return N_Op_Mod;
451 when Name_Op_Multiply =>
452 return N_Op_Multiply;
453 when Name_Op_Divide =>
454 return N_Op_Divide;
455 when Name_Op_Rem =>
456 return N_Op_Rem;
457 when Name_Op_And =>
458 return N_Op_And;
459 when Name_Op_Eq =>
460 return N_Op_Eq;
461 when Name_Op_Ge =>
462 return N_Op_Ge;
463 when Name_Op_Gt =>
464 return N_Op_Gt;
465 when Name_Op_Le =>
466 return N_Op_Le;
467 when Name_Op_Lt =>
468 return N_Op_Lt;
469 when Name_Op_Ne =>
470 return N_Op_Ne;
471 when Name_Op_Or =>
472 return N_Op_Or;
473 when Name_Op_Xor =>
474 return N_Op_Xor;
475 when others =>
476 raise Program_Error;
477 end case;
478 end Get_Binary_Nkind;
479
480 -------------------
481 -- Get_Low_Bound --
482 -------------------
483
484 function Get_Low_Bound (E : Entity_Id) return Node_Id is
485 begin
486 if Ekind (E) = E_String_Literal_Subtype then
487 return String_Literal_Low_Bound (E);
488 else
489 return Type_Low_Bound (E);
490 end if;
491 end Get_Low_Bound;
492
493 ------------------
494 -- Get_Rep_Item --
495 ------------------
496
497 function Get_Rep_Item
498 (E : Entity_Id;
499 Nam : Name_Id;
500 Check_Parents : Boolean := True) return Node_Id
501 is
502 N : Node_Id;
503
504 begin
505 N := First_Rep_Item (E);
506 while Present (N) loop
507
508 -- Only one of Priority / Interrupt_Priority can be specified, so
509 -- return whichever one is present to catch illegal duplication.
510
511 if Nkind (N) = N_Pragma
512 and then
513 (Pragma_Name (N) = Nam
514 or else (Nam = Name_Priority
515 and then Pragma_Name (N) = Name_Interrupt_Priority)
516 or else (Nam = Name_Interrupt_Priority
517 and then Pragma_Name (N) = Name_Priority))
518 then
519 if Check_Parents then
520 return N;
521
522 -- If Check_Parents is False, return N if the pragma doesn't
523 -- appear in the Rep_Item chain of the parent.
524
525 else
526 declare
527 Par : constant Entity_Id := Nearest_Ancestor (E);
528 -- This node represents the parent type of type E (if any)
529
530 begin
531 if No (Par) then
532 return N;
533
534 elsif not Present_In_Rep_Item (Par, N) then
535 return N;
536 end if;
537 end;
538 end if;
539
540 elsif Nkind (N) = N_Attribute_Definition_Clause
541 and then
542 (Chars (N) = Nam
543 or else (Nam = Name_Priority
544 and then Chars (N) = Name_Interrupt_Priority))
545 then
546 if Check_Parents or else Entity (N) = E then
547 return N;
548 end if;
549
550 elsif Nkind (N) = N_Aspect_Specification
551 and then
552 (Chars (Identifier (N)) = Nam
553 or else
554 (Nam = Name_Priority
555 and then Chars (Identifier (N)) = Name_Interrupt_Priority))
556 then
557 if Check_Parents then
558 return N;
559
560 elsif Entity (N) = E then
561 return N;
562 end if;
563 end if;
564
565 Next_Rep_Item (N);
566 end loop;
567
568 return Empty;
569 end Get_Rep_Item;
570
571 function Get_Rep_Item
572 (E : Entity_Id;
573 Nam1 : Name_Id;
574 Nam2 : Name_Id;
575 Check_Parents : Boolean := True) return Node_Id
576 is
577 Nam1_Item : constant Node_Id := Get_Rep_Item (E, Nam1, Check_Parents);
578 Nam2_Item : constant Node_Id := Get_Rep_Item (E, Nam2, Check_Parents);
579
580 N : Node_Id;
581
582 begin
583 -- Check both Nam1_Item and Nam2_Item are present
584
585 if No (Nam1_Item) then
586 return Nam2_Item;
587 elsif No (Nam2_Item) then
588 return Nam1_Item;
589 end if;
590
591 -- Return the first node encountered in the list
592
593 N := First_Rep_Item (E);
594 while Present (N) loop
595 if N = Nam1_Item or else N = Nam2_Item then
596 return N;
597 end if;
598
599 Next_Rep_Item (N);
600 end loop;
601
602 return Empty;
603 end Get_Rep_Item;
604
605 --------------------
606 -- Get_Rep_Pragma --
607 --------------------
608
609 function Get_Rep_Pragma
610 (E : Entity_Id;
611 Nam : Name_Id;
612 Check_Parents : Boolean := True) return Node_Id
613 is
614 N : constant Node_Id := Get_Rep_Item (E, Nam, Check_Parents);
615
616 begin
617 if Present (N) and then Nkind (N) = N_Pragma then
618 return N;
619 end if;
620
621 return Empty;
622 end Get_Rep_Pragma;
623
624 function Get_Rep_Pragma
625 (E : Entity_Id;
626 Nam1 : Name_Id;
627 Nam2 : Name_Id;
628 Check_Parents : Boolean := True) return Node_Id
629 is
630 Nam1_Item : constant Node_Id := Get_Rep_Pragma (E, Nam1, Check_Parents);
631 Nam2_Item : constant Node_Id := Get_Rep_Pragma (E, Nam2, Check_Parents);
632
633 N : Node_Id;
634
635 begin
636 -- Check both Nam1_Item and Nam2_Item are present
637
638 if No (Nam1_Item) then
639 return Nam2_Item;
640 elsif No (Nam2_Item) then
641 return Nam1_Item;
642 end if;
643
644 -- Return the first node encountered in the list
645
646 N := First_Rep_Item (E);
647 while Present (N) loop
648 if N = Nam1_Item or else N = Nam2_Item then
649 return N;
650 end if;
651
652 Next_Rep_Item (N);
653 end loop;
654
655 return Empty;
656 end Get_Rep_Pragma;
657
658 ---------------------
659 -- Get_Unary_Nkind --
660 ---------------------
661
662 function Get_Unary_Nkind (Op : Entity_Id) return Node_Kind is
663 begin
664 case Chars (Op) is
665 when Name_Op_Abs =>
666 return N_Op_Abs;
667 when Name_Op_Subtract =>
668 return N_Op_Minus;
669 when Name_Op_Not =>
670 return N_Op_Not;
671 when Name_Op_Add =>
672 return N_Op_Plus;
673 when others =>
674 raise Program_Error;
675 end case;
676 end Get_Unary_Nkind;
677
678 ---------------------------------
679 -- Has_External_Tag_Rep_Clause --
680 ---------------------------------
681
682 function Has_External_Tag_Rep_Clause (T : Entity_Id) return Boolean is
683 begin
684 pragma Assert (Is_Tagged_Type (T));
685 return Has_Rep_Item (T, Name_External_Tag, Check_Parents => False);
686 end Has_External_Tag_Rep_Clause;
687
688 ------------------
689 -- Has_Rep_Item --
690 ------------------
691
692 function Has_Rep_Item
693 (E : Entity_Id;
694 Nam : Name_Id;
695 Check_Parents : Boolean := True) return Boolean
696 is
697 begin
698 return Present (Get_Rep_Item (E, Nam, Check_Parents));
699 end Has_Rep_Item;
700
701 function Has_Rep_Item
702 (E : Entity_Id;
703 Nam1 : Name_Id;
704 Nam2 : Name_Id;
705 Check_Parents : Boolean := True) return Boolean
706 is
707 begin
708 return Present (Get_Rep_Item (E, Nam1, Nam2, Check_Parents));
709 end Has_Rep_Item;
710
711 function Has_Rep_Item (E : Entity_Id; N : Node_Id) return Boolean is
712 Item : Node_Id;
713
714 begin
715 pragma Assert
716 (Nkind_In (N, N_Aspect_Specification,
717 N_Attribute_Definition_Clause,
718 N_Enumeration_Representation_Clause,
719 N_Pragma,
720 N_Record_Representation_Clause));
721
722 Item := First_Rep_Item (E);
723 while Present (Item) loop
724 if Item = N then
725 return True;
726 end if;
727
728 Item := Next_Rep_Item (Item);
729 end loop;
730
731 return False;
732 end Has_Rep_Item;
733
734 --------------------
735 -- Has_Rep_Pragma --
736 --------------------
737
738 function Has_Rep_Pragma
739 (E : Entity_Id;
740 Nam : Name_Id;
741 Check_Parents : Boolean := True) return Boolean
742 is
743 begin
744 return Present (Get_Rep_Pragma (E, Nam, Check_Parents));
745 end Has_Rep_Pragma;
746
747 function Has_Rep_Pragma
748 (E : Entity_Id;
749 Nam1 : Name_Id;
750 Nam2 : Name_Id;
751 Check_Parents : Boolean := True) return Boolean
752 is
753 begin
754 return Present (Get_Rep_Pragma (E, Nam1, Nam2, Check_Parents));
755 end Has_Rep_Pragma;
756
757 --------------------------------
758 -- Has_Unconstrained_Elements --
759 --------------------------------
760
761 function Has_Unconstrained_Elements (T : Entity_Id) return Boolean is
762 U_T : constant Entity_Id := Underlying_Type (T);
763 begin
764 if No (U_T) then
765 return False;
766 elsif Is_Record_Type (U_T) then
767 return Has_Discriminants (U_T) and then not Is_Constrained (U_T);
768 elsif Is_Array_Type (U_T) then
769 return Has_Unconstrained_Elements (Component_Type (U_T));
770 else
771 return False;
772 end if;
773 end Has_Unconstrained_Elements;
774
775 ----------------------
776 -- Has_Variant_Part --
777 ----------------------
778
779 function Has_Variant_Part (Typ : Entity_Id) return Boolean is
780 FSTyp : Entity_Id;
781 Decl : Node_Id;
782 TDef : Node_Id;
783 CList : Node_Id;
784
785 begin
786 if not Is_Type (Typ) then
787 return False;
788 end if;
789
790 FSTyp := First_Subtype (Typ);
791
792 if not Has_Discriminants (FSTyp) then
793 return False;
794 end if;
795
796 -- Proceed with cautious checks here, return False if tree is not
797 -- as expected (may be caused by prior errors).
798
799 Decl := Declaration_Node (FSTyp);
800
801 if Nkind (Decl) /= N_Full_Type_Declaration then
802 return False;
803 end if;
804
805 TDef := Type_Definition (Decl);
806
807 if Nkind (TDef) /= N_Record_Definition then
808 return False;
809 end if;
810
811 CList := Component_List (TDef);
812
813 if Nkind (CList) /= N_Component_List then
814 return False;
815 else
816 return Present (Variant_Part (CList));
817 end if;
818 end Has_Variant_Part;
819
820 ---------------------
821 -- In_Generic_Body --
822 ---------------------
823
824 function In_Generic_Body (Id : Entity_Id) return Boolean is
825 S : Entity_Id;
826
827 begin
828 -- Climb scopes looking for generic body
829
830 S := Id;
831 while Present (S) and then S /= Standard_Standard loop
832
833 -- Generic package body
834
835 if Ekind (S) = E_Generic_Package
836 and then In_Package_Body (S)
837 then
838 return True;
839
840 -- Generic subprogram body
841
842 elsif Is_Subprogram (S)
843 and then Nkind (Unit_Declaration_Node (S)) =
844 N_Generic_Subprogram_Declaration
845 then
846 return True;
847 end if;
848
849 S := Scope (S);
850 end loop;
851
852 -- False if top of scope stack without finding a generic body
853
854 return False;
855 end In_Generic_Body;
856
857 -------------------------------
858 -- Initialization_Suppressed --
859 -------------------------------
860
861 function Initialization_Suppressed (Typ : Entity_Id) return Boolean is
862 begin
863 return Suppress_Initialization (Typ)
864 or else Suppress_Initialization (Base_Type (Typ));
865 end Initialization_Suppressed;
866
867 ----------------
868 -- Initialize --
869 ----------------
870
871 procedure Initialize is
872 begin
873 Obsolescent_Warnings.Init;
874 end Initialize;
875
876 -------------
877 -- Is_Body --
878 -------------
879
880 function Is_Body (N : Node_Id) return Boolean is
881 begin
882 return
883 Nkind (N) in N_Body_Stub
884 or else Nkind_In (N, N_Entry_Body,
885 N_Package_Body,
886 N_Protected_Body,
887 N_Subprogram_Body,
888 N_Task_Body);
889 end Is_Body;
890
891 ---------------------
892 -- Is_By_Copy_Type --
893 ---------------------
894
895 function Is_By_Copy_Type (Ent : Entity_Id) return Boolean is
896 begin
897 -- If Id is a private type whose full declaration has not been seen,
898 -- we assume for now that it is not a By_Copy type. Clearly this
899 -- attribute should not be used before the type is frozen, but it is
900 -- needed to build the associated record of a protected type. Another
901 -- place where some lookahead for a full view is needed ???
902
903 return
904 Is_Elementary_Type (Ent)
905 or else (Is_Private_Type (Ent)
906 and then Present (Underlying_Type (Ent))
907 and then Is_Elementary_Type (Underlying_Type (Ent)));
908 end Is_By_Copy_Type;
909
910 --------------------------
911 -- Is_By_Reference_Type --
912 --------------------------
913
914 function Is_By_Reference_Type (Ent : Entity_Id) return Boolean is
915 Btype : constant Entity_Id := Base_Type (Ent);
916
917 begin
918 if Error_Posted (Ent) or else Error_Posted (Btype) then
919 return False;
920
921 elsif Is_Private_Type (Btype) then
922 declare
923 Utyp : constant Entity_Id := Underlying_Type (Btype);
924 begin
925 if No (Utyp) then
926 return False;
927 else
928 return Is_By_Reference_Type (Utyp);
929 end if;
930 end;
931
932 elsif Is_Incomplete_Type (Btype) then
933 declare
934 Ftyp : constant Entity_Id := Full_View (Btype);
935 begin
936 -- Return true for a tagged incomplete type built as a shadow
937 -- entity in Build_Limited_Views. It can appear in the profile
938 -- of a thunk and the back end needs to know how it is passed.
939
940 if No (Ftyp) then
941 return Is_Tagged_Type (Btype);
942 else
943 return Is_By_Reference_Type (Ftyp);
944 end if;
945 end;
946
947 elsif Is_Concurrent_Type (Btype) then
948 return True;
949
950 elsif Is_Record_Type (Btype) then
951 if Is_Limited_Record (Btype)
952 or else Is_Tagged_Type (Btype)
953 or else Is_Volatile (Btype)
954 then
955 return True;
956
957 else
958 declare
959 C : Entity_Id;
960
961 begin
962 C := First_Component (Btype);
963 while Present (C) loop
964
965 -- For each component, test if its type is a by reference
966 -- type and if its type is volatile. Also test the component
967 -- itself for being volatile. This happens for example when
968 -- a Volatile aspect is added to a component.
969
970 if Is_By_Reference_Type (Etype (C))
971 or else Is_Volatile (Etype (C))
972 or else Is_Volatile (C)
973 then
974 return True;
975 end if;
976
977 C := Next_Component (C);
978 end loop;
979 end;
980
981 return False;
982 end if;
983
984 elsif Is_Array_Type (Btype) then
985 return
986 Is_Volatile (Btype)
987 or else Is_By_Reference_Type (Component_Type (Btype))
988 or else Is_Volatile (Component_Type (Btype))
989 or else Has_Volatile_Components (Btype);
990
991 else
992 return False;
993 end if;
994 end Is_By_Reference_Type;
995
996 -------------------------
997 -- Is_Definite_Subtype --
998 -------------------------
999
1000 function Is_Definite_Subtype (T : Entity_Id) return Boolean is
1001 pragma Assert (Is_Type (T));
1002 K : constant Entity_Kind := Ekind (T);
1003
1004 begin
1005 if Is_Constrained (T) then
1006 return True;
1007
1008 elsif K in Array_Kind
1009 or else K in Class_Wide_Kind
1010 or else Has_Unknown_Discriminants (T)
1011 then
1012 return False;
1013
1014 -- Known discriminants: definite if there are default values. Note that
1015 -- if any discriminant has a default, they all do.
1016
1017 elsif Has_Discriminants (T) then
1018 return Present (Discriminant_Default_Value (First_Discriminant (T)));
1019
1020 else
1021 return True;
1022 end if;
1023 end Is_Definite_Subtype;
1024
1025 ---------------------
1026 -- Is_Derived_Type --
1027 ---------------------
1028
1029 function Is_Derived_Type (Ent : E) return B is
1030 Par : Node_Id;
1031
1032 begin
1033 if Is_Type (Ent)
1034 and then Base_Type (Ent) /= Root_Type (Ent)
1035 and then not Is_Class_Wide_Type (Ent)
1036
1037 -- An access_to_subprogram whose result type is a limited view can
1038 -- appear in a return statement, without the full view of the result
1039 -- type being available. Do not interpret this as a derived type.
1040
1041 and then Ekind (Ent) /= E_Subprogram_Type
1042 then
1043 if not Is_Numeric_Type (Root_Type (Ent)) then
1044 return True;
1045
1046 else
1047 Par := Parent (First_Subtype (Ent));
1048
1049 return Present (Par)
1050 and then Nkind (Par) = N_Full_Type_Declaration
1051 and then Nkind (Type_Definition (Par)) =
1052 N_Derived_Type_Definition;
1053 end if;
1054
1055 else
1056 return False;
1057 end if;
1058 end Is_Derived_Type;
1059
1060 -----------------------
1061 -- Is_Generic_Formal --
1062 -----------------------
1063
1064 function Is_Generic_Formal (E : Entity_Id) return Boolean is
1065 Kind : Node_Kind;
1066 begin
1067 if No (E) then
1068 return False;
1069 else
1070 Kind := Nkind (Parent (E));
1071 return
1072 Nkind_In (Kind, N_Formal_Object_Declaration,
1073 N_Formal_Package_Declaration,
1074 N_Formal_Type_Declaration)
1075 or else Is_Formal_Subprogram (E);
1076 end if;
1077 end Is_Generic_Formal;
1078
1079 -------------------------------
1080 -- Is_Immutably_Limited_Type --
1081 -------------------------------
1082
1083 function Is_Immutably_Limited_Type (Ent : Entity_Id) return Boolean is
1084 Btype : constant Entity_Id := Available_View (Base_Type (Ent));
1085
1086 begin
1087 if Is_Limited_Record (Btype) then
1088 return True;
1089
1090 elsif Ekind (Btype) = E_Limited_Private_Type
1091 and then Nkind (Parent (Btype)) = N_Formal_Type_Declaration
1092 then
1093 return not In_Package_Body (Scope ((Btype)));
1094
1095 elsif Is_Private_Type (Btype) then
1096
1097 -- AI05-0063: A type derived from a limited private formal type is
1098 -- not immutably limited in a generic body.
1099
1100 if Is_Derived_Type (Btype)
1101 and then Is_Generic_Type (Etype (Btype))
1102 then
1103 if not Is_Limited_Type (Etype (Btype)) then
1104 return False;
1105
1106 -- A descendant of a limited formal type is not immutably limited
1107 -- in the generic body, or in the body of a generic child.
1108
1109 elsif Ekind (Scope (Etype (Btype))) = E_Generic_Package then
1110 return not In_Package_Body (Scope (Btype));
1111
1112 else
1113 return False;
1114 end if;
1115
1116 else
1117 declare
1118 Utyp : constant Entity_Id := Underlying_Type (Btype);
1119 begin
1120 if No (Utyp) then
1121 return False;
1122 else
1123 return Is_Immutably_Limited_Type (Utyp);
1124 end if;
1125 end;
1126 end if;
1127
1128 elsif Is_Concurrent_Type (Btype) then
1129 return True;
1130
1131 else
1132 return False;
1133 end if;
1134 end Is_Immutably_Limited_Type;
1135
1136 ---------------------
1137 -- Is_Limited_Type --
1138 ---------------------
1139
1140 function Is_Limited_Type (Ent : Entity_Id) return Boolean is
1141 Btype : constant E := Base_Type (Ent);
1142 Rtype : constant E := Root_Type (Btype);
1143
1144 begin
1145 if not Is_Type (Ent) then
1146 return False;
1147
1148 elsif Ekind (Btype) = E_Limited_Private_Type
1149 or else Is_Limited_Composite (Btype)
1150 then
1151 return True;
1152
1153 elsif Is_Concurrent_Type (Btype) then
1154 return True;
1155
1156 -- The Is_Limited_Record flag normally indicates that the type is
1157 -- limited. The exception is that a type does not inherit limitedness
1158 -- from its interface ancestor. So the type may be derived from a
1159 -- limited interface, but is not limited.
1160
1161 elsif Is_Limited_Record (Ent)
1162 and then not Is_Interface (Ent)
1163 then
1164 return True;
1165
1166 -- Otherwise we will look around to see if there is some other reason
1167 -- for it to be limited, except that if an error was posted on the
1168 -- entity, then just assume it is non-limited, because it can cause
1169 -- trouble to recurse into a murky entity resulting from other errors.
1170
1171 elsif Error_Posted (Ent) then
1172 return False;
1173
1174 elsif Is_Record_Type (Btype) then
1175
1176 if Is_Limited_Interface (Ent) then
1177 return True;
1178
1179 -- AI-419: limitedness is not inherited from a limited interface
1180
1181 elsif Is_Limited_Record (Rtype) then
1182 return not Is_Interface (Rtype)
1183 or else Is_Protected_Interface (Rtype)
1184 or else Is_Synchronized_Interface (Rtype)
1185 or else Is_Task_Interface (Rtype);
1186
1187 elsif Is_Class_Wide_Type (Btype) then
1188 return Is_Limited_Type (Rtype);
1189
1190 else
1191 declare
1192 C : E;
1193
1194 begin
1195 C := First_Component (Btype);
1196 while Present (C) loop
1197 if Is_Limited_Type (Etype (C)) then
1198 return True;
1199 end if;
1200
1201 C := Next_Component (C);
1202 end loop;
1203 end;
1204
1205 return False;
1206 end if;
1207
1208 elsif Is_Array_Type (Btype) then
1209 return Is_Limited_Type (Component_Type (Btype));
1210
1211 else
1212 return False;
1213 end if;
1214 end Is_Limited_Type;
1215
1216 ---------------------
1217 -- Is_Limited_View --
1218 ---------------------
1219
1220 function Is_Limited_View (Ent : Entity_Id) return Boolean is
1221 Btype : constant Entity_Id := Available_View (Base_Type (Ent));
1222
1223 begin
1224 if Is_Limited_Record (Btype) then
1225 return True;
1226
1227 elsif Ekind (Btype) = E_Limited_Private_Type
1228 and then Nkind (Parent (Btype)) = N_Formal_Type_Declaration
1229 then
1230 return not In_Package_Body (Scope ((Btype)));
1231
1232 elsif Is_Private_Type (Btype) then
1233
1234 -- AI05-0063: A type derived from a limited private formal type is
1235 -- not immutably limited in a generic body.
1236
1237 if Is_Derived_Type (Btype)
1238 and then Is_Generic_Type (Etype (Btype))
1239 then
1240 if not Is_Limited_Type (Etype (Btype)) then
1241 return False;
1242
1243 -- A descendant of a limited formal type is not immutably limited
1244 -- in the generic body, or in the body of a generic child.
1245
1246 elsif Ekind (Scope (Etype (Btype))) = E_Generic_Package then
1247 return not In_Package_Body (Scope (Btype));
1248
1249 else
1250 return False;
1251 end if;
1252
1253 else
1254 declare
1255 Utyp : constant Entity_Id := Underlying_Type (Btype);
1256 begin
1257 if No (Utyp) then
1258 return False;
1259 else
1260 return Is_Limited_View (Utyp);
1261 end if;
1262 end;
1263 end if;
1264
1265 elsif Is_Concurrent_Type (Btype) then
1266 return True;
1267
1268 elsif Is_Record_Type (Btype) then
1269
1270 -- Note that we return True for all limited interfaces, even though
1271 -- (unsynchronized) limited interfaces can have descendants that are
1272 -- nonlimited, because this is a predicate on the type itself, and
1273 -- things like functions with limited interface results need to be
1274 -- handled as build in place even though they might return objects
1275 -- of a type that is not inherently limited.
1276
1277 if Is_Class_Wide_Type (Btype) then
1278 return Is_Limited_View (Root_Type (Btype));
1279
1280 else
1281 declare
1282 C : Entity_Id;
1283
1284 begin
1285 C := First_Component (Btype);
1286 while Present (C) loop
1287
1288 -- Don't consider components with interface types (which can
1289 -- only occur in the case of a _parent component anyway).
1290 -- They don't have any components, plus it would cause this
1291 -- function to return true for nonlimited types derived from
1292 -- limited interfaces.
1293
1294 if not Is_Interface (Etype (C))
1295 and then Is_Limited_View (Etype (C))
1296 then
1297 return True;
1298 end if;
1299
1300 C := Next_Component (C);
1301 end loop;
1302 end;
1303
1304 return False;
1305 end if;
1306
1307 elsif Is_Array_Type (Btype) then
1308 return Is_Limited_View (Component_Type (Btype));
1309
1310 else
1311 return False;
1312 end if;
1313 end Is_Limited_View;
1314
1315 ----------------------
1316 -- Nearest_Ancestor --
1317 ----------------------
1318
1319 function Nearest_Ancestor (Typ : Entity_Id) return Entity_Id is
1320 D : constant Node_Id := Declaration_Node (Typ);
1321
1322 begin
1323 -- If we have a subtype declaration, get the ancestor subtype
1324
1325 if Nkind (D) = N_Subtype_Declaration then
1326 if Nkind (Subtype_Indication (D)) = N_Subtype_Indication then
1327 return Entity (Subtype_Mark (Subtype_Indication (D)));
1328 else
1329 return Entity (Subtype_Indication (D));
1330 end if;
1331
1332 -- If derived type declaration, find who we are derived from
1333
1334 elsif Nkind (D) = N_Full_Type_Declaration
1335 and then Nkind (Type_Definition (D)) = N_Derived_Type_Definition
1336 then
1337 declare
1338 DTD : constant Entity_Id := Type_Definition (D);
1339 SI : constant Entity_Id := Subtype_Indication (DTD);
1340 begin
1341 if Is_Entity_Name (SI) then
1342 return Entity (SI);
1343 else
1344 return Entity (Subtype_Mark (SI));
1345 end if;
1346 end;
1347
1348 -- If derived type and private type, get the full view to find who we
1349 -- are derived from.
1350
1351 elsif Is_Derived_Type (Typ)
1352 and then Is_Private_Type (Typ)
1353 and then Present (Full_View (Typ))
1354 then
1355 return Nearest_Ancestor (Full_View (Typ));
1356
1357 -- Otherwise, nothing useful to return, return Empty
1358
1359 else
1360 return Empty;
1361 end if;
1362 end Nearest_Ancestor;
1363
1364 ---------------------------
1365 -- Nearest_Dynamic_Scope --
1366 ---------------------------
1367
1368 function Nearest_Dynamic_Scope (Ent : Entity_Id) return Entity_Id is
1369 begin
1370 if Is_Dynamic_Scope (Ent) then
1371 return Ent;
1372 else
1373 return Enclosing_Dynamic_Scope (Ent);
1374 end if;
1375 end Nearest_Dynamic_Scope;
1376
1377 ------------------------
1378 -- Next_Tag_Component --
1379 ------------------------
1380
1381 function Next_Tag_Component (Tag : Entity_Id) return Entity_Id is
1382 Comp : Entity_Id;
1383
1384 begin
1385 pragma Assert (Is_Tag (Tag));
1386
1387 -- Loop to look for next tag component
1388
1389 Comp := Next_Entity (Tag);
1390 while Present (Comp) loop
1391 if Is_Tag (Comp) then
1392 pragma Assert (Chars (Comp) /= Name_uTag);
1393 return Comp;
1394 end if;
1395
1396 Comp := Next_Entity (Comp);
1397 end loop;
1398
1399 -- No tag component found
1400
1401 return Empty;
1402 end Next_Tag_Component;
1403
1404 -----------------------
1405 -- Number_Components --
1406 -----------------------
1407
1408 function Number_Components (Typ : Entity_Id) return Nat is
1409 N : Nat := 0;
1410 Comp : Entity_Id;
1411
1412 begin
1413 -- We do not call Einfo.First_Component_Or_Discriminant, as this
1414 -- function does not skip completely hidden discriminants, which we
1415 -- want to skip here.
1416
1417 if Has_Discriminants (Typ) then
1418 Comp := First_Discriminant (Typ);
1419 else
1420 Comp := First_Component (Typ);
1421 end if;
1422
1423 while Present (Comp) loop
1424 N := N + 1;
1425 Comp := Next_Component_Or_Discriminant (Comp);
1426 end loop;
1427
1428 return N;
1429 end Number_Components;
1430
1431 --------------------------
1432 -- Number_Discriminants --
1433 --------------------------
1434
1435 function Number_Discriminants (Typ : Entity_Id) return Pos is
1436 N : Nat := 0;
1437 Discr : Entity_Id := First_Discriminant (Typ);
1438
1439 begin
1440 while Present (Discr) loop
1441 N := N + 1;
1442 Discr := Next_Discriminant (Discr);
1443 end loop;
1444
1445 return N;
1446 end Number_Discriminants;
1447
1448 ----------------------------------------------
1449 -- Object_Type_Has_Constrained_Partial_View --
1450 ----------------------------------------------
1451
1452 function Object_Type_Has_Constrained_Partial_View
1453 (Typ : Entity_Id;
1454 Scop : Entity_Id) return Boolean
1455 is
1456 begin
1457 return Has_Constrained_Partial_View (Typ)
1458 or else (In_Generic_Body (Scop)
1459 and then Is_Generic_Type (Base_Type (Typ))
1460 and then Is_Private_Type (Base_Type (Typ))
1461 and then not Is_Tagged_Type (Typ)
1462 and then not (Is_Array_Type (Typ)
1463 and then not Is_Constrained (Typ))
1464 and then Has_Discriminants (Typ));
1465 end Object_Type_Has_Constrained_Partial_View;
1466
1467 ------------------
1468 -- Package_Body --
1469 ------------------
1470
1471 function Package_Body (E : Entity_Id) return Node_Id is
1472 N : Node_Id;
1473
1474 begin
1475 if Ekind (E) = E_Package_Body then
1476 N := Parent (E);
1477
1478 if Nkind (N) = N_Defining_Program_Unit_Name then
1479 N := Parent (N);
1480 end if;
1481
1482 else
1483 N := Package_Spec (E);
1484
1485 if Present (Corresponding_Body (N)) then
1486 N := Parent (Corresponding_Body (N));
1487
1488 if Nkind (N) = N_Defining_Program_Unit_Name then
1489 N := Parent (N);
1490 end if;
1491 else
1492 N := Empty;
1493 end if;
1494 end if;
1495
1496 return N;
1497 end Package_Body;
1498
1499 ------------------
1500 -- Package_Spec --
1501 ------------------
1502
1503 function Package_Spec (E : Entity_Id) return Node_Id is
1504 begin
1505 return Parent (Package_Specification (E));
1506 end Package_Spec;
1507
1508 ---------------------------
1509 -- Package_Specification --
1510 ---------------------------
1511
1512 function Package_Specification (E : Entity_Id) return Node_Id is
1513 N : Node_Id;
1514
1515 begin
1516 N := Parent (E);
1517
1518 if Nkind (N) = N_Defining_Program_Unit_Name then
1519 N := Parent (N);
1520 end if;
1521
1522 return N;
1523 end Package_Specification;
1524
1525 ---------------------
1526 -- Subprogram_Body --
1527 ---------------------
1528
1529 function Subprogram_Body (E : Entity_Id) return Node_Id is
1530 Body_E : constant Entity_Id := Subprogram_Body_Entity (E);
1531
1532 begin
1533 if No (Body_E) then
1534 return Empty;
1535 else
1536 return Parent (Subprogram_Specification (Body_E));
1537 end if;
1538 end Subprogram_Body;
1539
1540 ----------------------------
1541 -- Subprogram_Body_Entity --
1542 ----------------------------
1543
1544 function Subprogram_Body_Entity (E : Entity_Id) return Entity_Id is
1545 N : constant Node_Id := Parent (Subprogram_Specification (E));
1546 -- Declaration for E
1547
1548 begin
1549 -- If this declaration is not a subprogram body, then it must be a
1550 -- subprogram declaration or body stub, from which we can retrieve the
1551 -- entity for the corresponding subprogram body if any, or an abstract
1552 -- subprogram declaration, for which we return Empty.
1553
1554 case Nkind (N) is
1555 when N_Subprogram_Body =>
1556 return E;
1557
1558 when N_Subprogram_Declaration | N_Subprogram_Body_Stub =>
1559 return Corresponding_Body (N);
1560
1561 when others =>
1562 return Empty;
1563 end case;
1564 end Subprogram_Body_Entity;
1565
1566 ---------------------
1567 -- Subprogram_Spec --
1568 ---------------------
1569
1570 function Subprogram_Spec (E : Entity_Id) return Node_Id is
1571 N : constant Node_Id := Parent (Subprogram_Specification (E));
1572 -- Declaration for E
1573
1574 begin
1575 -- This declaration is either subprogram declaration or a subprogram
1576 -- body, in which case return Empty.
1577
1578 if Nkind (N) = N_Subprogram_Declaration then
1579 return N;
1580 else
1581 return Empty;
1582 end if;
1583 end Subprogram_Spec;
1584
1585 ------------------------------
1586 -- Subprogram_Specification --
1587 ------------------------------
1588
1589 function Subprogram_Specification (E : Entity_Id) return Node_Id is
1590 N : Node_Id;
1591
1592 begin
1593 N := Parent (E);
1594
1595 if Nkind (N) = N_Defining_Program_Unit_Name then
1596 N := Parent (N);
1597 end if;
1598
1599 -- If the Parent pointer of E is not a subprogram specification node
1600 -- (going through an intermediate N_Defining_Program_Unit_Name node
1601 -- for subprogram units), then E is an inherited operation. Its parent
1602 -- points to the type derivation that produces the inheritance: that's
1603 -- the node that generates the subprogram specification. Its alias
1604 -- is the parent subprogram, and that one points to a subprogram
1605 -- declaration, or to another type declaration if this is a hierarchy
1606 -- of derivations.
1607
1608 if Nkind (N) not in N_Subprogram_Specification then
1609 pragma Assert (Present (Alias (E)));
1610 N := Subprogram_Specification (Alias (E));
1611 end if;
1612
1613 return N;
1614 end Subprogram_Specification;
1615
1616 ---------------
1617 -- Tree_Read --
1618 ---------------
1619
1620 procedure Tree_Read is
1621 begin
1622 Obsolescent_Warnings.Tree_Read;
1623 end Tree_Read;
1624
1625 ----------------
1626 -- Tree_Write --
1627 ----------------
1628
1629 procedure Tree_Write is
1630 begin
1631 Obsolescent_Warnings.Tree_Write;
1632 end Tree_Write;
1633
1634 --------------------
1635 -- Ultimate_Alias --
1636 --------------------
1637
1638 function Ultimate_Alias (Prim : Entity_Id) return Entity_Id is
1639 E : Entity_Id := Prim;
1640
1641 begin
1642 while Present (Alias (E)) loop
1643 pragma Assert (Alias (E) /= E);
1644 E := Alias (E);
1645 end loop;
1646
1647 return E;
1648 end Ultimate_Alias;
1649
1650 --------------------------
1651 -- Unit_Declaration_Node --
1652 --------------------------
1653
1654 function Unit_Declaration_Node (Unit_Id : Entity_Id) return Node_Id is
1655 N : Node_Id := Parent (Unit_Id);
1656
1657 begin
1658 -- Predefined operators do not have a full function declaration
1659
1660 if Ekind (Unit_Id) = E_Operator then
1661 return N;
1662 end if;
1663
1664 -- Isn't there some better way to express the following ???
1665
1666 while Nkind (N) /= N_Abstract_Subprogram_Declaration
1667 and then Nkind (N) /= N_Entry_Body
1668 and then Nkind (N) /= N_Entry_Declaration
1669 and then Nkind (N) /= N_Formal_Package_Declaration
1670 and then Nkind (N) /= N_Function_Instantiation
1671 and then Nkind (N) /= N_Generic_Package_Declaration
1672 and then Nkind (N) /= N_Generic_Subprogram_Declaration
1673 and then Nkind (N) /= N_Package_Declaration
1674 and then Nkind (N) /= N_Package_Body
1675 and then Nkind (N) /= N_Package_Instantiation
1676 and then Nkind (N) /= N_Package_Renaming_Declaration
1677 and then Nkind (N) /= N_Procedure_Instantiation
1678 and then Nkind (N) /= N_Protected_Body
1679 and then Nkind (N) /= N_Subprogram_Declaration
1680 and then Nkind (N) /= N_Subprogram_Body
1681 and then Nkind (N) /= N_Subprogram_Body_Stub
1682 and then Nkind (N) /= N_Subprogram_Renaming_Declaration
1683 and then Nkind (N) /= N_Task_Body
1684 and then Nkind (N) /= N_Task_Type_Declaration
1685 and then Nkind (N) not in N_Formal_Subprogram_Declaration
1686 and then Nkind (N) not in N_Generic_Renaming_Declaration
1687 loop
1688 N := Parent (N);
1689
1690 -- We don't use Assert here, because that causes an infinite loop
1691 -- when assertions are turned off. Better to crash.
1692
1693 if No (N) then
1694 raise Program_Error;
1695 end if;
1696 end loop;
1697
1698 return N;
1699 end Unit_Declaration_Node;
1700
1701 end Sem_Aux;