Implement -mmemcpy-strategy= and -mmemset-strategy= options
[official-gcc.git] / gcc / ada / sem_aux.adb
blob3c5d2af59baa8f9c6c719c1a65883bcf1b971f30
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-2013, 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 -- 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. --
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 ------------------------------------------------------------------------------
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
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.
50 if Is_First_Subtype (Typ) or else Is_Base_Type (Typ) then
51 return Empty;
52 end if;
54 declare
55 D : constant Node_Id := Declaration_Node (Typ);
57 begin
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)));
63 else
64 return Entity (Subtype_Indication (D));
65 end if;
67 -- If not, then no subtype indication is available
69 else
70 return Empty;
71 end if;
72 end;
73 end Ancestor_Subtype;
75 --------------------
76 -- Available_View --
77 --------------------
79 function Available_View (Typ : Entity_Id) return Entity_Id is
80 begin
81 if Is_Incomplete_Type (Typ)
82 and then Present (Non_Limited_View (Typ))
83 then
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 -- If it is class_wide, check whether the specific type comes from
90 -- A limited_with.
92 elsif Is_Class_Wide_Type (Typ)
93 and then Is_Incomplete_Type (Etype (Typ))
94 and then From_With_Type (Etype (Typ))
95 and then Present (Non_Limited_View (Etype (Typ)))
96 then
97 return Class_Wide_Type (Non_Limited_View (Etype (Typ)));
99 else
100 return Typ;
101 end if;
102 end Available_View;
104 --------------------
105 -- Constant_Value --
106 --------------------
108 function Constant_Value (Ent : Entity_Id) return Node_Id is
109 D : constant Node_Id := Declaration_Node (Ent);
110 Full_D : Node_Id;
112 begin
113 -- If we have no declaration node, then return no constant value. Not
114 -- clear how this can happen, but it does sometimes and this is the
115 -- safest approach.
117 if No (D) then
118 return Empty;
120 -- Normal case where a declaration node is present
122 elsif Nkind (D) = N_Object_Renaming_Declaration then
123 return Renamed_Object (Ent);
125 -- If this is a component declaration whose entity is a constant, it is
126 -- a prival within a protected function (and so has no constant value).
128 elsif Nkind (D) = N_Component_Declaration then
129 return Empty;
131 -- If there is an expression, return it
133 elsif Present (Expression (D)) then
134 return (Expression (D));
136 -- For a constant, see if we have a full view
138 elsif Ekind (Ent) = E_Constant
139 and then Present (Full_View (Ent))
140 then
141 Full_D := Parent (Full_View (Ent));
143 -- The full view may have been rewritten as an object renaming
145 if Nkind (Full_D) = N_Object_Renaming_Declaration then
146 return Name (Full_D);
147 else
148 return Expression (Full_D);
149 end if;
151 -- Otherwise we have no expression to return
153 else
154 return Empty;
155 end if;
156 end Constant_Value;
158 -----------------------------
159 -- Enclosing_Dynamic_Scope --
160 -----------------------------
162 function Enclosing_Dynamic_Scope (Ent : Entity_Id) return Entity_Id is
163 S : Entity_Id;
165 begin
166 -- The following test is an error defense against some syntax errors
167 -- that can leave scopes very messed up.
169 if Ent = Standard_Standard then
170 return Ent;
171 end if;
173 -- Normal case, search enclosing scopes
175 -- Note: the test for Present (S) should not be required, it defends
176 -- against an ill-formed tree.
178 S := Scope (Ent);
179 loop
180 -- If we somehow got an empty value for Scope, the tree must be
181 -- malformed. Rather than blow up we return Standard in this case.
183 if No (S) then
184 return Standard_Standard;
186 -- Quit if we get to standard or a dynamic scope. We must also
187 -- handle enclosing scopes that have a full view; required to
188 -- locate enclosing scopes that are synchronized private types
189 -- whose full view is a task type.
191 elsif S = Standard_Standard
192 or else Is_Dynamic_Scope (S)
193 or else (Is_Private_Type (S)
194 and then Present (Full_View (S))
195 and then Is_Dynamic_Scope (Full_View (S)))
196 then
197 return S;
199 -- Otherwise keep climbing
201 else
202 S := Scope (S);
203 end if;
204 end loop;
205 end Enclosing_Dynamic_Scope;
207 ------------------------
208 -- First_Discriminant --
209 ------------------------
211 function First_Discriminant (Typ : Entity_Id) return Entity_Id is
212 Ent : Entity_Id;
214 begin
215 pragma Assert
216 (Has_Discriminants (Typ) or else Has_Unknown_Discriminants (Typ));
218 Ent := First_Entity (Typ);
220 -- The discriminants are not necessarily contiguous, because access
221 -- discriminants will generate itypes. They are not the first entities
222 -- either because the tag must be ahead of them.
224 if Chars (Ent) = Name_uTag then
225 Ent := Next_Entity (Ent);
226 end if;
228 -- Skip all hidden stored discriminants if any
230 while Present (Ent) loop
231 exit when Ekind (Ent) = E_Discriminant
232 and then not Is_Completely_Hidden (Ent);
234 Ent := Next_Entity (Ent);
235 end loop;
237 pragma Assert (Ekind (Ent) = E_Discriminant);
239 return Ent;
240 end First_Discriminant;
242 -------------------------------
243 -- First_Stored_Discriminant --
244 -------------------------------
246 function First_Stored_Discriminant (Typ : Entity_Id) return Entity_Id is
247 Ent : Entity_Id;
249 function Has_Completely_Hidden_Discriminant
250 (Typ : Entity_Id) return Boolean;
251 -- Scans the Discriminants to see whether any are Completely_Hidden
252 -- (the mechanism for describing non-specified stored discriminants)
254 ----------------------------------------
255 -- Has_Completely_Hidden_Discriminant --
256 ----------------------------------------
258 function Has_Completely_Hidden_Discriminant
259 (Typ : Entity_Id) return Boolean
261 Ent : Entity_Id;
263 begin
264 pragma Assert (Ekind (Typ) = E_Discriminant);
266 Ent := Typ;
267 while Present (Ent) and then Ekind (Ent) = E_Discriminant loop
268 if Is_Completely_Hidden (Ent) then
269 return True;
270 end if;
272 Ent := Next_Entity (Ent);
273 end loop;
275 return False;
276 end Has_Completely_Hidden_Discriminant;
278 -- Start of processing for First_Stored_Discriminant
280 begin
281 pragma Assert
282 (Has_Discriminants (Typ)
283 or else Has_Unknown_Discriminants (Typ));
285 Ent := First_Entity (Typ);
287 if Chars (Ent) = Name_uTag then
288 Ent := Next_Entity (Ent);
289 end if;
291 if Has_Completely_Hidden_Discriminant (Ent) then
292 while Present (Ent) loop
293 exit when Is_Completely_Hidden (Ent);
294 Ent := Next_Entity (Ent);
295 end loop;
296 end if;
298 pragma Assert (Ekind (Ent) = E_Discriminant);
300 return Ent;
301 end First_Stored_Discriminant;
303 -------------------
304 -- First_Subtype --
305 -------------------
307 function First_Subtype (Typ : Entity_Id) return Entity_Id is
308 B : constant Entity_Id := Base_Type (Typ);
309 F : constant Node_Id := Freeze_Node (B);
310 Ent : Entity_Id;
312 begin
313 -- If the base type has no freeze node, it is a type in Standard, and
314 -- always acts as its own first subtype, except where it is one of the
315 -- predefined integer types. If the type is formal, it is also a first
316 -- subtype, and its base type has no freeze node. On the other hand, a
317 -- subtype of a generic formal is not its own first subtype. Its base
318 -- type, if anonymous, is attached to the formal type decl. from which
319 -- the first subtype is obtained.
321 if No (F) then
322 if B = Base_Type (Standard_Integer) then
323 return Standard_Integer;
325 elsif B = Base_Type (Standard_Long_Integer) then
326 return Standard_Long_Integer;
328 elsif B = Base_Type (Standard_Short_Short_Integer) then
329 return Standard_Short_Short_Integer;
331 elsif B = Base_Type (Standard_Short_Integer) then
332 return Standard_Short_Integer;
334 elsif B = Base_Type (Standard_Long_Long_Integer) then
335 return Standard_Long_Long_Integer;
337 elsif Is_Generic_Type (Typ) then
338 if Present (Parent (B)) then
339 return Defining_Identifier (Parent (B));
340 else
341 return Defining_Identifier (Associated_Node_For_Itype (B));
342 end if;
344 else
345 return B;
346 end if;
348 -- Otherwise we check the freeze node, if it has a First_Subtype_Link
349 -- then we use that link, otherwise (happens with some Itypes), we use
350 -- the base type itself.
352 else
353 Ent := First_Subtype_Link (F);
355 if Present (Ent) then
356 return Ent;
357 else
358 return B;
359 end if;
360 end if;
361 end First_Subtype;
363 -------------------------
364 -- First_Tag_Component --
365 -------------------------
367 function First_Tag_Component (Typ : Entity_Id) return Entity_Id is
368 Comp : Entity_Id;
369 Ctyp : Entity_Id;
371 begin
372 Ctyp := Typ;
373 pragma Assert (Is_Tagged_Type (Ctyp));
375 if Is_Class_Wide_Type (Ctyp) then
376 Ctyp := Root_Type (Ctyp);
377 end if;
379 if Is_Private_Type (Ctyp) then
380 Ctyp := Underlying_Type (Ctyp);
382 -- If the underlying type is missing then the source program has
383 -- errors and there is nothing else to do (the full-type declaration
384 -- associated with the private type declaration is missing).
386 if No (Ctyp) then
387 return Empty;
388 end if;
389 end if;
391 Comp := First_Entity (Ctyp);
392 while Present (Comp) loop
393 if Is_Tag (Comp) then
394 return Comp;
395 end if;
397 Comp := Next_Entity (Comp);
398 end loop;
400 -- No tag component found
402 return Empty;
403 end First_Tag_Component;
405 ------------------
406 -- Get_Rep_Item --
407 ------------------
409 function Get_Rep_Item
410 (E : Entity_Id;
411 Nam : Name_Id;
412 Check_Parents : Boolean := True) return Node_Id
414 N : Node_Id;
416 begin
417 N := First_Rep_Item (E);
418 while Present (N) loop
420 -- Only one of Priority / Interrupt_Priority can be specified, so
421 -- return whichever one is present to catch illegal duplication.
423 if Nkind (N) = N_Pragma
424 and then
425 (Pragma_Name (N) = Nam
426 or else (Nam = Name_Priority
427 and then Pragma_Name (N) = Name_Interrupt_Priority)
428 or else (Nam = Name_Interrupt_Priority
429 and then Pragma_Name (N) = Name_Priority))
430 then
431 if Check_Parents then
432 return N;
434 -- If Check_Parents is False, return N if the pragma doesn't
435 -- appear in the Rep_Item chain of the parent.
437 else
438 declare
439 Par : constant Entity_Id := Nearest_Ancestor (E);
440 -- This node represents the parent type of type E (if any)
442 begin
443 if No (Par) then
444 return N;
446 elsif not Present_In_Rep_Item (Par, N) then
447 return N;
448 end if;
449 end;
450 end if;
452 elsif Nkind (N) = N_Attribute_Definition_Clause
453 and then
454 (Chars (N) = Nam
455 or else (Nam = Name_Priority
456 and then Chars (N) = Name_Interrupt_Priority))
457 then
458 if Check_Parents or else Entity (N) = E then
459 return N;
460 end if;
462 elsif Nkind (N) = N_Aspect_Specification
463 and then
464 (Chars (Identifier (N)) = Nam
465 or else
466 (Nam = Name_Priority
467 and then Chars (Identifier (N)) = Name_Interrupt_Priority))
468 then
469 if Check_Parents then
470 return N;
472 elsif Entity (N) = E then
473 return N;
474 end if;
475 end if;
477 Next_Rep_Item (N);
478 end loop;
480 return Empty;
481 end Get_Rep_Item;
483 function Get_Rep_Item
484 (E : Entity_Id;
485 Nam1 : Name_Id;
486 Nam2 : Name_Id;
487 Check_Parents : Boolean := True) return Node_Id
489 Nam1_Item : constant Node_Id := Get_Rep_Item (E, Nam1, Check_Parents);
490 Nam2_Item : constant Node_Id := Get_Rep_Item (E, Nam2, Check_Parents);
492 N : Node_Id;
494 begin
495 -- Check both Nam1_Item and Nam2_Item are present
497 if No (Nam1_Item) then
498 return Nam2_Item;
499 elsif No (Nam2_Item) then
500 return Nam1_Item;
501 end if;
503 -- Return the first node encountered in the list
505 N := First_Rep_Item (E);
506 while Present (N) loop
507 if N = Nam1_Item or else N = Nam2_Item then
508 return N;
509 end if;
511 Next_Rep_Item (N);
512 end loop;
514 return Empty;
515 end Get_Rep_Item;
517 --------------------
518 -- Get_Rep_Pragma --
519 --------------------
521 function Get_Rep_Pragma
522 (E : Entity_Id;
523 Nam : Name_Id;
524 Check_Parents : Boolean := True) return Node_Id
526 N : Node_Id;
528 begin
529 N := Get_Rep_Item (E, Nam, Check_Parents);
531 if Present (N) and then Nkind (N) = N_Pragma then
532 return N;
533 end if;
535 return Empty;
536 end Get_Rep_Pragma;
538 function Get_Rep_Pragma
539 (E : Entity_Id;
540 Nam1 : Name_Id;
541 Nam2 : Name_Id;
542 Check_Parents : Boolean := True) return Node_Id
544 Nam1_Item : constant Node_Id := Get_Rep_Pragma (E, Nam1, Check_Parents);
545 Nam2_Item : constant Node_Id := Get_Rep_Pragma (E, Nam2, Check_Parents);
547 N : Node_Id;
549 begin
550 -- Check both Nam1_Item and Nam2_Item are present
552 if No (Nam1_Item) then
553 return Nam2_Item;
554 elsif No (Nam2_Item) then
555 return Nam1_Item;
556 end if;
558 -- Return the first node encountered in the list
560 N := First_Rep_Item (E);
561 while Present (N) loop
562 if N = Nam1_Item or else N = Nam2_Item then
563 return N;
564 end if;
566 Next_Rep_Item (N);
567 end loop;
569 return Empty;
570 end Get_Rep_Pragma;
572 ------------------
573 -- Has_Rep_Item --
574 ------------------
576 function Has_Rep_Item
577 (E : Entity_Id;
578 Nam : Name_Id;
579 Check_Parents : Boolean := True) return Boolean
581 begin
582 return Present (Get_Rep_Item (E, Nam, Check_Parents));
583 end Has_Rep_Item;
585 function Has_Rep_Item
586 (E : Entity_Id;
587 Nam1 : Name_Id;
588 Nam2 : Name_Id;
589 Check_Parents : Boolean := True) return Boolean
591 begin
592 return Present (Get_Rep_Item (E, Nam1, Nam2, Check_Parents));
593 end Has_Rep_Item;
595 --------------------
596 -- Has_Rep_Pragma --
597 --------------------
599 function Has_Rep_Pragma
600 (E : Entity_Id;
601 Nam : Name_Id;
602 Check_Parents : Boolean := True) return Boolean
604 begin
605 return Present (Get_Rep_Pragma (E, Nam, Check_Parents));
606 end Has_Rep_Pragma;
608 function Has_Rep_Pragma
609 (E : Entity_Id;
610 Nam1 : Name_Id;
611 Nam2 : Name_Id;
612 Check_Parents : Boolean := True) return Boolean
614 begin
615 return Present (Get_Rep_Pragma (E, Nam1, Nam2, Check_Parents));
616 end Has_Rep_Pragma;
618 ---------------------
619 -- In_Generic_Body --
620 ---------------------
622 function In_Generic_Body (Id : Entity_Id) return Boolean is
623 S : Entity_Id;
625 begin
626 -- Climb scopes looking for generic body
628 S := Id;
629 while Present (S) and then S /= Standard_Standard loop
631 -- Generic package body
633 if Ekind (S) = E_Generic_Package
634 and then In_Package_Body (S)
635 then
636 return True;
638 -- Generic subprogram body
640 elsif Is_Subprogram (S)
641 and then Nkind (Unit_Declaration_Node (S))
642 = N_Generic_Subprogram_Declaration
643 then
644 return True;
645 end if;
647 S := Scope (S);
648 end loop;
650 -- False if top of scope stack without finding a generic body
652 return False;
653 end In_Generic_Body;
655 -------------------------------
656 -- Initialization_Suppressed --
657 -------------------------------
659 function Initialization_Suppressed (Typ : Entity_Id) return Boolean is
660 begin
661 return Suppress_Initialization (Typ)
662 or else Suppress_Initialization (Base_Type (Typ));
663 end Initialization_Suppressed;
665 ----------------
666 -- Initialize --
667 ----------------
669 procedure Initialize is
670 begin
671 Obsolescent_Warnings.Init;
672 end Initialize;
674 ---------------------
675 -- Is_By_Copy_Type --
676 ---------------------
678 function Is_By_Copy_Type (Ent : Entity_Id) return Boolean is
679 begin
680 -- If Id is a private type whose full declaration has not been seen,
681 -- we assume for now that it is not a By_Copy type. Clearly this
682 -- attribute should not be used before the type is frozen, but it is
683 -- needed to build the associated record of a protected type. Another
684 -- place where some lookahead for a full view is needed ???
686 return
687 Is_Elementary_Type (Ent)
688 or else (Is_Private_Type (Ent)
689 and then Present (Underlying_Type (Ent))
690 and then Is_Elementary_Type (Underlying_Type (Ent)));
691 end Is_By_Copy_Type;
693 --------------------------
694 -- Is_By_Reference_Type --
695 --------------------------
697 function Is_By_Reference_Type (Ent : Entity_Id) return Boolean is
698 Btype : constant Entity_Id := Base_Type (Ent);
700 begin
701 if Error_Posted (Ent) or else Error_Posted (Btype) then
702 return False;
704 elsif Is_Private_Type (Btype) then
705 declare
706 Utyp : constant Entity_Id := Underlying_Type (Btype);
707 begin
708 if No (Utyp) then
709 return False;
710 else
711 return Is_By_Reference_Type (Utyp);
712 end if;
713 end;
715 elsif Is_Incomplete_Type (Btype) then
716 declare
717 Ftyp : constant Entity_Id := Full_View (Btype);
718 begin
719 if No (Ftyp) then
720 return False;
721 else
722 return Is_By_Reference_Type (Ftyp);
723 end if;
724 end;
726 elsif Is_Concurrent_Type (Btype) then
727 return True;
729 elsif Is_Record_Type (Btype) then
730 if Is_Limited_Record (Btype)
731 or else Is_Tagged_Type (Btype)
732 or else Is_Volatile (Btype)
733 then
734 return True;
736 else
737 declare
738 C : Entity_Id;
740 begin
741 C := First_Component (Btype);
742 while Present (C) loop
743 if Is_By_Reference_Type (Etype (C))
744 or else Is_Volatile (Etype (C))
745 then
746 return True;
747 end if;
749 C := Next_Component (C);
750 end loop;
751 end;
753 return False;
754 end if;
756 elsif Is_Array_Type (Btype) then
757 return
758 Is_Volatile (Btype)
759 or else Is_By_Reference_Type (Component_Type (Btype))
760 or else Is_Volatile (Component_Type (Btype))
761 or else Has_Volatile_Components (Btype);
763 else
764 return False;
765 end if;
766 end Is_By_Reference_Type;
768 ---------------------
769 -- Is_Derived_Type --
770 ---------------------
772 function Is_Derived_Type (Ent : E) return B is
773 Par : Node_Id;
775 begin
776 if Is_Type (Ent)
777 and then Base_Type (Ent) /= Root_Type (Ent)
778 and then not Is_Class_Wide_Type (Ent)
779 then
780 if not Is_Numeric_Type (Root_Type (Ent)) then
781 return True;
783 else
784 Par := Parent (First_Subtype (Ent));
786 return Present (Par)
787 and then Nkind (Par) = N_Full_Type_Declaration
788 and then Nkind (Type_Definition (Par)) =
789 N_Derived_Type_Definition;
790 end if;
792 else
793 return False;
794 end if;
795 end Is_Derived_Type;
797 -----------------------
798 -- Is_Generic_Formal --
799 -----------------------
801 function Is_Generic_Formal (E : Entity_Id) return Boolean is
802 Kind : Node_Kind;
803 begin
804 if No (E) then
805 return False;
806 else
807 Kind := Nkind (Parent (E));
808 return
809 Nkind_In (Kind, N_Formal_Object_Declaration,
810 N_Formal_Package_Declaration,
811 N_Formal_Type_Declaration)
812 or else Is_Formal_Subprogram (E);
813 end if;
814 end Is_Generic_Formal;
816 -------------------------------
817 -- Is_Immutably_Limited_Type --
818 -------------------------------
820 function Is_Immutably_Limited_Type (Ent : Entity_Id) return Boolean is
821 Btype : constant Entity_Id := Available_View (Base_Type (Ent));
823 begin
824 if Is_Limited_Record (Btype) then
825 return True;
827 elsif Ekind (Btype) = E_Limited_Private_Type
828 and then Nkind (Parent (Btype)) = N_Formal_Type_Declaration
829 then
830 return not In_Package_Body (Scope ((Btype)));
832 elsif Is_Private_Type (Btype) then
834 -- AI05-0063: A type derived from a limited private formal type is
835 -- not immutably limited in a generic body.
837 if Is_Derived_Type (Btype)
838 and then Is_Generic_Type (Etype (Btype))
839 then
840 if not Is_Limited_Type (Etype (Btype)) then
841 return False;
843 -- A descendant of a limited formal type is not immutably limited
844 -- in the generic body, or in the body of a generic child.
846 elsif Ekind (Scope (Etype (Btype))) = E_Generic_Package then
847 return not In_Package_Body (Scope (Btype));
849 else
850 return False;
851 end if;
853 else
854 declare
855 Utyp : constant Entity_Id := Underlying_Type (Btype);
856 begin
857 if No (Utyp) then
858 return False;
859 else
860 return Is_Immutably_Limited_Type (Utyp);
861 end if;
862 end;
863 end if;
865 elsif Is_Concurrent_Type (Btype) then
866 return True;
868 elsif Is_Record_Type (Btype) then
870 -- Note that we return True for all limited interfaces, even though
871 -- (unsynchronized) limited interfaces can have descendants that are
872 -- nonlimited, because this is a predicate on the type itself, and
873 -- things like functions with limited interface results need to be
874 -- handled as build in place even though they might return objects
875 -- of a type that is not inherently limited.
877 if Is_Class_Wide_Type (Btype) then
878 return Is_Immutably_Limited_Type (Root_Type (Btype));
880 else
881 declare
882 C : Entity_Id;
884 begin
885 C := First_Component (Btype);
886 while Present (C) loop
888 -- Don't consider components with interface types (which can
889 -- only occur in the case of a _parent component anyway).
890 -- They don't have any components, plus it would cause this
891 -- function to return true for nonlimited types derived from
892 -- limited interfaces.
894 if not Is_Interface (Etype (C))
895 and then Is_Immutably_Limited_Type (Etype (C))
896 then
897 return True;
898 end if;
900 C := Next_Component (C);
901 end loop;
902 end;
904 return False;
905 end if;
907 elsif Is_Array_Type (Btype) then
908 return Is_Immutably_Limited_Type (Component_Type (Btype));
910 else
911 return False;
912 end if;
913 end Is_Immutably_Limited_Type;
915 ---------------------------
916 -- Is_Indefinite_Subtype --
917 ---------------------------
919 function Is_Indefinite_Subtype (Ent : Entity_Id) return Boolean is
920 K : constant Entity_Kind := Ekind (Ent);
922 begin
923 if Is_Constrained (Ent) then
924 return False;
926 elsif K in Array_Kind
927 or else K in Class_Wide_Kind
928 or else Has_Unknown_Discriminants (Ent)
929 then
930 return True;
932 -- Known discriminants: indefinite if there are no default values
934 elsif K in Record_Kind
935 or else Is_Incomplete_Or_Private_Type (Ent)
936 or else Is_Concurrent_Type (Ent)
937 then
938 return (Has_Discriminants (Ent)
939 and then
940 No (Discriminant_Default_Value (First_Discriminant (Ent))));
942 else
943 return False;
944 end if;
945 end Is_Indefinite_Subtype;
947 ---------------------
948 -- Is_Limited_Type --
949 ---------------------
951 function Is_Limited_Type (Ent : Entity_Id) return Boolean is
952 Btype : constant E := Base_Type (Ent);
953 Rtype : constant E := Root_Type (Btype);
955 begin
956 if not Is_Type (Ent) then
957 return False;
959 elsif Ekind (Btype) = E_Limited_Private_Type
960 or else Is_Limited_Composite (Btype)
961 then
962 return True;
964 elsif Is_Concurrent_Type (Btype) then
965 return True;
967 -- The Is_Limited_Record flag normally indicates that the type is
968 -- limited. The exception is that a type does not inherit limitedness
969 -- from its interface ancestor. So the type may be derived from a
970 -- limited interface, but is not limited.
972 elsif Is_Limited_Record (Ent)
973 and then not Is_Interface (Ent)
974 then
975 return True;
977 -- Otherwise we will look around to see if there is some other reason
978 -- for it to be limited, except that if an error was posted on the
979 -- entity, then just assume it is non-limited, because it can cause
980 -- trouble to recurse into a murky erroneous entity!
982 elsif Error_Posted (Ent) then
983 return False;
985 elsif Is_Record_Type (Btype) then
987 if Is_Limited_Interface (Ent) then
988 return True;
990 -- AI-419: limitedness is not inherited from a limited interface
992 elsif Is_Limited_Record (Rtype) then
993 return not Is_Interface (Rtype)
994 or else Is_Protected_Interface (Rtype)
995 or else Is_Synchronized_Interface (Rtype)
996 or else Is_Task_Interface (Rtype);
998 elsif Is_Class_Wide_Type (Btype) then
999 return Is_Limited_Type (Rtype);
1001 else
1002 declare
1003 C : E;
1005 begin
1006 C := First_Component (Btype);
1007 while Present (C) loop
1008 if Is_Limited_Type (Etype (C)) then
1009 return True;
1010 end if;
1012 C := Next_Component (C);
1013 end loop;
1014 end;
1016 return False;
1017 end if;
1019 elsif Is_Array_Type (Btype) then
1020 return Is_Limited_Type (Component_Type (Btype));
1022 else
1023 return False;
1024 end if;
1025 end Is_Limited_Type;
1027 ----------------------
1028 -- Nearest_Ancestor --
1029 ----------------------
1031 function Nearest_Ancestor (Typ : Entity_Id) return Entity_Id is
1032 D : constant Node_Id := Declaration_Node (Typ);
1034 begin
1035 -- If we have a subtype declaration, get the ancestor subtype
1037 if Nkind (D) = N_Subtype_Declaration then
1038 if Nkind (Subtype_Indication (D)) = N_Subtype_Indication then
1039 return Entity (Subtype_Mark (Subtype_Indication (D)));
1040 else
1041 return Entity (Subtype_Indication (D));
1042 end if;
1044 -- If derived type declaration, find who we are derived from
1046 elsif Nkind (D) = N_Full_Type_Declaration
1047 and then Nkind (Type_Definition (D)) = N_Derived_Type_Definition
1048 then
1049 declare
1050 DTD : constant Entity_Id := Type_Definition (D);
1051 SI : constant Entity_Id := Subtype_Indication (DTD);
1052 begin
1053 if Is_Entity_Name (SI) then
1054 return Entity (SI);
1055 else
1056 return Entity (Subtype_Mark (SI));
1057 end if;
1058 end;
1060 -- If derived type and private type, get the full view to find who we
1061 -- are derived from.
1063 elsif Is_Derived_Type (Typ)
1064 and then Is_Private_Type (Typ)
1065 and then Present (Full_View (Typ))
1066 then
1067 return Nearest_Ancestor (Full_View (Typ));
1069 -- Otherwise, nothing useful to return, return Empty
1071 else
1072 return Empty;
1073 end if;
1074 end Nearest_Ancestor;
1076 ---------------------------
1077 -- Nearest_Dynamic_Scope --
1078 ---------------------------
1080 function Nearest_Dynamic_Scope (Ent : Entity_Id) return Entity_Id is
1081 begin
1082 if Is_Dynamic_Scope (Ent) then
1083 return Ent;
1084 else
1085 return Enclosing_Dynamic_Scope (Ent);
1086 end if;
1087 end Nearest_Dynamic_Scope;
1089 ------------------------
1090 -- Next_Tag_Component --
1091 ------------------------
1093 function Next_Tag_Component (Tag : Entity_Id) return Entity_Id is
1094 Comp : Entity_Id;
1096 begin
1097 pragma Assert (Is_Tag (Tag));
1099 -- Loop to look for next tag component
1101 Comp := Next_Entity (Tag);
1102 while Present (Comp) loop
1103 if Is_Tag (Comp) then
1104 pragma Assert (Chars (Comp) /= Name_uTag);
1105 return Comp;
1106 end if;
1108 Comp := Next_Entity (Comp);
1109 end loop;
1111 -- No tag component found
1113 return Empty;
1114 end Next_Tag_Component;
1116 --------------------------
1117 -- Number_Discriminants --
1118 --------------------------
1120 function Number_Discriminants (Typ : Entity_Id) return Pos is
1121 N : Int;
1122 Discr : Entity_Id;
1124 begin
1125 N := 0;
1126 Discr := First_Discriminant (Typ);
1127 while Present (Discr) loop
1128 N := N + 1;
1129 Discr := Next_Discriminant (Discr);
1130 end loop;
1132 return N;
1133 end Number_Discriminants;
1135 ----------------------------------------------
1136 -- Object_Type_Has_Constrained_Partial_View --
1137 ----------------------------------------------
1139 function Object_Type_Has_Constrained_Partial_View
1140 (Typ : Entity_Id;
1141 Scop : Entity_Id) return Boolean
1143 begin
1144 return Has_Constrained_Partial_View (Typ)
1145 or else (In_Generic_Body (Scop)
1146 and then Is_Generic_Type (Base_Type (Typ))
1147 and then Is_Private_Type (Base_Type (Typ))
1148 and then not Is_Tagged_Type (Typ)
1149 and then not (Is_Array_Type (Typ)
1150 and then not Is_Constrained (Typ))
1151 and then Has_Discriminants (Typ));
1152 end Object_Type_Has_Constrained_Partial_View;
1154 ---------------
1155 -- Tree_Read --
1156 ---------------
1158 procedure Tree_Read is
1159 begin
1160 Obsolescent_Warnings.Tree_Read;
1161 end Tree_Read;
1163 ----------------
1164 -- Tree_Write --
1165 ----------------
1167 procedure Tree_Write is
1168 begin
1169 Obsolescent_Warnings.Tree_Write;
1170 end Tree_Write;
1172 --------------------
1173 -- Ultimate_Alias --
1174 --------------------
1176 function Ultimate_Alias (Prim : Entity_Id) return Entity_Id is
1177 E : Entity_Id := Prim;
1179 begin
1180 while Present (Alias (E)) loop
1181 pragma Assert (Alias (E) /= E);
1182 E := Alias (E);
1183 end loop;
1185 return E;
1186 end Ultimate_Alias;
1188 --------------------------
1189 -- Unit_Declaration_Node --
1190 --------------------------
1192 function Unit_Declaration_Node (Unit_Id : Entity_Id) return Node_Id is
1193 N : Node_Id := Parent (Unit_Id);
1195 begin
1196 -- Predefined operators do not have a full function declaration
1198 if Ekind (Unit_Id) = E_Operator then
1199 return N;
1200 end if;
1202 -- Isn't there some better way to express the following ???
1204 while Nkind (N) /= N_Abstract_Subprogram_Declaration
1205 and then Nkind (N) /= N_Formal_Package_Declaration
1206 and then Nkind (N) /= N_Function_Instantiation
1207 and then Nkind (N) /= N_Generic_Package_Declaration
1208 and then Nkind (N) /= N_Generic_Subprogram_Declaration
1209 and then Nkind (N) /= N_Package_Declaration
1210 and then Nkind (N) /= N_Package_Body
1211 and then Nkind (N) /= N_Package_Instantiation
1212 and then Nkind (N) /= N_Package_Renaming_Declaration
1213 and then Nkind (N) /= N_Procedure_Instantiation
1214 and then Nkind (N) /= N_Protected_Body
1215 and then Nkind (N) /= N_Subprogram_Declaration
1216 and then Nkind (N) /= N_Subprogram_Body
1217 and then Nkind (N) /= N_Subprogram_Body_Stub
1218 and then Nkind (N) /= N_Subprogram_Renaming_Declaration
1219 and then Nkind (N) /= N_Task_Body
1220 and then Nkind (N) /= N_Task_Type_Declaration
1221 and then Nkind (N) not in N_Formal_Subprogram_Declaration
1222 and then Nkind (N) not in N_Generic_Renaming_Declaration
1223 loop
1224 N := Parent (N);
1226 -- We don't use Assert here, because that causes an infinite loop
1227 -- when assertions are turned off. Better to crash.
1229 if No (N) then
1230 raise Program_Error;
1231 end if;
1232 end loop;
1234 return N;
1235 end Unit_Declaration_Node;
1237 end Sem_Aux;