1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2013, 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 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Atree; use Atree;
27 with Casing; use Casing;
28 with Checks; use Checks;
29 with Debug; use Debug;
30 with Elists; use Elists;
31 with Errout; use Errout;
32 with Exp_Ch11; use Exp_Ch11;
33 with Exp_Disp; use Exp_Disp;
34 with Exp_Util; use Exp_Util;
35 with Fname; use Fname;
36 with Freeze; use Freeze;
38 with Lib.Xref; use Lib.Xref;
39 with Namet.Sp; use Namet.Sp;
40 with Nlists; use Nlists;
41 with Nmake; use Nmake;
42 with Output; use Output;
44 with Restrict; use Restrict;
45 with Rident; use Rident;
46 with Rtsfind; use Rtsfind;
48 with Sem_Aux; use Sem_Aux;
49 with Sem_Attr; use Sem_Attr;
50 with Sem_Ch8; use Sem_Ch8;
51 with Sem_Disp; use Sem_Disp;
52 with Sem_Eval; use Sem_Eval;
53 with Sem_Res; use Sem_Res;
54 with Sem_Type; use Sem_Type;
55 with Sinfo; use Sinfo;
56 with Sinput; use Sinput;
57 with Stand; use Stand;
59 with Stringt; use Stringt;
60 with Targparm; use Targparm;
61 with Tbuild; use Tbuild;
62 with Ttypes; use Ttypes;
63 with Uname; use Uname;
65 with GNAT.HTable; use GNAT.HTable;
67 package body Sem_Util is
69 ----------------------------------------
70 -- Global_Variables for New_Copy_Tree --
71 ----------------------------------------
73 -- These global variables are used by New_Copy_Tree. See description
74 -- of the body of this subprogram for details. Global variables can be
75 -- safely used by New_Copy_Tree, since there is no case of a recursive
76 -- call from the processing inside New_Copy_Tree.
78 NCT_Hash_Threshold : constant := 20;
79 -- If there are more than this number of pairs of entries in the
80 -- map, then Hash_Tables_Used will be set, and the hash tables will
81 -- be initialized and used for the searches.
83 NCT_Hash_Tables_Used : Boolean := False;
84 -- Set to True if hash tables are in use
86 NCT_Table_Entries : Nat := 0;
87 -- Count entries in table to see if threshold is reached
89 NCT_Hash_Table_Setup : Boolean := False;
90 -- Set to True if hash table contains data. We set this True if we
91 -- setup the hash table with data, and leave it set permanently
92 -- from then on, this is a signal that second and subsequent users
93 -- of the hash table must clear the old entries before reuse.
95 subtype NCT_Header_Num is Int range 0 .. 511;
96 -- Defines range of headers in hash tables (512 headers)
98 -----------------------
99 -- Local Subprograms --
100 -----------------------
102 function Build_Component_Subtype
105 T : Entity_Id) return Node_Id;
106 -- This function builds the subtype for Build_Actual_Subtype_Of_Component
107 -- and Build_Discriminal_Subtype_Of_Component. C is a list of constraints,
108 -- Loc is the source location, T is the original subtype.
110 function Is_Fully_Initialized_Variant (Typ : Entity_Id) return Boolean;
111 -- Subsidiary to Is_Fully_Initialized_Type. For an unconstrained type
112 -- with discriminants whose default values are static, examine only the
113 -- components in the selected variant to determine whether all of them
116 function Has_Enabled_Property
118 Prop_Nam : Name_Id) return Boolean;
119 -- Subsidiary to routines Async_xxx_Enabled and Effective_xxx_Enabled.
120 -- Given pragma External, determine whether it contains a property denoted
121 -- by its name Prop_Nam and if it does, whether its expression is True.
123 function Has_Null_Extension (T : Entity_Id) return Boolean;
124 -- T is a derived tagged type. Check whether the type extension is null.
125 -- If the parent type is fully initialized, T can be treated as such.
127 ------------------------------
128 -- Abstract_Interface_List --
129 ------------------------------
131 function Abstract_Interface_List (Typ : Entity_Id) return List_Id is
135 if Is_Concurrent_Type (Typ) then
137 -- If we are dealing with a synchronized subtype, go to the base
138 -- type, whose declaration has the interface list.
140 -- Shouldn't this be Declaration_Node???
142 Nod := Parent (Base_Type (Typ));
144 if Nkind (Nod) = N_Full_Type_Declaration then
148 elsif Ekind (Typ) = E_Record_Type_With_Private then
149 if Nkind (Parent (Typ)) = N_Full_Type_Declaration then
150 Nod := Type_Definition (Parent (Typ));
152 elsif Nkind (Parent (Typ)) = N_Private_Type_Declaration then
153 if Present (Full_View (Typ))
154 and then Nkind (Parent (Full_View (Typ)))
155 = N_Full_Type_Declaration
157 Nod := Type_Definition (Parent (Full_View (Typ)));
159 -- If the full-view is not available we cannot do anything else
160 -- here (the source has errors).
166 -- Support for generic formals with interfaces is still missing ???
168 elsif Nkind (Parent (Typ)) = N_Formal_Type_Declaration then
173 (Nkind (Parent (Typ)) = N_Private_Extension_Declaration);
177 elsif Ekind (Typ) = E_Record_Subtype then
178 Nod := Type_Definition (Parent (Etype (Typ)));
180 elsif Ekind (Typ) = E_Record_Subtype_With_Private then
182 -- Recurse, because parent may still be a private extension. Also
183 -- note that the full view of the subtype or the full view of its
184 -- base type may (both) be unavailable.
186 return Abstract_Interface_List (Etype (Typ));
188 else pragma Assert ((Ekind (Typ)) = E_Record_Type);
189 if Nkind (Parent (Typ)) = N_Formal_Type_Declaration then
190 Nod := Formal_Type_Definition (Parent (Typ));
192 Nod := Type_Definition (Parent (Typ));
196 return Interface_List (Nod);
197 end Abstract_Interface_List;
199 --------------------------------
200 -- Add_Access_Type_To_Process --
201 --------------------------------
203 procedure Add_Access_Type_To_Process (E : Entity_Id; A : Entity_Id) is
207 Ensure_Freeze_Node (E);
208 L := Access_Types_To_Process (Freeze_Node (E));
212 Set_Access_Types_To_Process (Freeze_Node (E), L);
216 end Add_Access_Type_To_Process;
218 -----------------------
219 -- Add_Contract_Item --
220 -----------------------
222 procedure Add_Contract_Item (Prag : Node_Id; Id : Entity_Id) is
223 Items : constant Node_Id := Contract (Id);
228 -- The related context must have a contract and the item to be added
231 pragma Assert (Present (Items));
232 pragma Assert (Nkind (Prag) = N_Pragma);
234 Nam := Original_Aspect_Name (Prag);
236 -- Contract items related to [generic] packages. The applicable pragmas
242 if Ekind_In (Id, E_Generic_Package, E_Package) then
243 if Nam_In (Nam, Name_Abstract_State,
244 Name_Initial_Condition,
247 Set_Next_Pragma (Prag, Classifications (Items));
248 Set_Classifications (Items, Prag);
250 -- The pragma is not a proper contract item
256 -- Contract items related to package bodies. The applicable pragmas are:
259 elsif Ekind (Id) = E_Package_Body then
260 if Nam = Name_Refined_State then
261 Set_Next_Pragma (Prag, Classifications (Items));
262 Set_Classifications (Items, Prag);
264 -- The pragma is not a proper contract item
270 -- Contract items related to subprogram or entry declarations. The
271 -- applicable pragmas are:
281 elsif Ekind_In (Id, E_Entry, E_Entry_Family)
282 or else Is_Generic_Subprogram (Id)
283 or else Is_Subprogram (Id)
285 if Nam_In (Nam, Name_Precondition,
292 -- Before we add a precondition or postcondition to the list,
293 -- make sure we do not have a disallowed duplicate, which can
294 -- happen if we use a pragma for Pre[_Class] or Post[_Class]
295 -- instead of the corresponding aspect.
297 if not From_Aspect_Specification (Prag)
298 and then Nam_In (Nam, Name_Pre_Class,
305 N := Pre_Post_Conditions (Items);
306 while Present (N) loop
308 and then Original_Aspect_Name (N) = Nam
310 Error_Msg_Sloc := Sloc (N);
312 ("duplication of aspect for & given#", Prag, Id);
315 N := Next_Pragma (N);
320 Set_Next_Pragma (Prag, Pre_Post_Conditions (Items));
321 Set_Pre_Post_Conditions (Items, Prag);
323 elsif Nam_In (Nam, Name_Contract_Cases, Name_Test_Case) then
324 Set_Next_Pragma (Prag, Contract_Test_Cases (Items));
325 Set_Contract_Test_Cases (Items, Prag);
327 elsif Nam_In (Nam, Name_Depends, Name_Global) then
328 Set_Next_Pragma (Prag, Classifications (Items));
329 Set_Classifications (Items, Prag);
331 -- The pragma is not a proper contract item
337 -- Contract items related to subprogram bodies. The applicable pragmas
342 elsif Ekind (Id) = E_Subprogram_Body then
343 if Nam_In (Nam, Name_Refined_Depends, Name_Refined_Global) then
344 Set_Next_Pragma (Prag, Classifications (Items));
345 Set_Classifications (Items, Prag);
347 -- The pragma is not a proper contract item
353 -- Contract items related to variables. The applicable pragmas are:
359 elsif Ekind (Id) = E_Variable then
360 if Nam_In (Nam, Name_Async_Readers,
362 Name_Effective_Reads,
363 Name_Effective_Writes)
365 Set_Next_Pragma (Prag, Classifications (Items));
366 Set_Classifications (Items, Prag);
368 -- The pragma is not a proper contract item
374 end Add_Contract_Item;
376 ----------------------------
377 -- Add_Global_Declaration --
378 ----------------------------
380 procedure Add_Global_Declaration (N : Node_Id) is
381 Aux_Node : constant Node_Id := Aux_Decls_Node (Cunit (Current_Sem_Unit));
384 if No (Declarations (Aux_Node)) then
385 Set_Declarations (Aux_Node, New_List);
388 Append_To (Declarations (Aux_Node), N);
390 end Add_Global_Declaration;
392 --------------------------------
393 -- Address_Integer_Convert_OK --
394 --------------------------------
396 function Address_Integer_Convert_OK (T1, T2 : Entity_Id) return Boolean is
398 if Allow_Integer_Address
399 and then ((Is_Descendent_Of_Address (T1)
400 and then Is_Private_Type (T1)
401 and then Is_Integer_Type (T2))
403 (Is_Descendent_Of_Address (T2)
404 and then Is_Private_Type (T2)
405 and then Is_Integer_Type (T1)))
411 end Address_Integer_Convert_OK;
417 -- For now, just 8/16/32/64. but analyze later if AAMP is special???
419 function Addressable (V : Uint) return Boolean is
421 return V = Uint_8 or else
427 function Addressable (V : Int) return Boolean is
435 -----------------------
436 -- Alignment_In_Bits --
437 -----------------------
439 function Alignment_In_Bits (E : Entity_Id) return Uint is
441 return Alignment (E) * System_Storage_Unit;
442 end Alignment_In_Bits;
444 ---------------------------------
445 -- Append_Inherited_Subprogram --
446 ---------------------------------
448 procedure Append_Inherited_Subprogram (S : Entity_Id) is
449 Par : constant Entity_Id := Alias (S);
450 -- The parent subprogram
452 Scop : constant Entity_Id := Scope (Par);
453 -- The scope of definition of the parent subprogram
455 Typ : constant Entity_Id := Defining_Entity (Parent (S));
456 -- The derived type of which S is a primitive operation
462 if Ekind (Current_Scope) = E_Package
463 and then In_Private_Part (Current_Scope)
464 and then Has_Private_Declaration (Typ)
465 and then Is_Tagged_Type (Typ)
466 and then Scop = Current_Scope
468 -- The inherited operation is available at the earliest place after
469 -- the derived type declaration ( RM 7.3.1 (6/1)). This is only
470 -- relevant for type extensions. If the parent operation appears
471 -- after the type extension, the operation is not visible.
474 (Visible_Declarations
475 (Package_Specification (Current_Scope)));
476 while Present (Decl) loop
477 if Nkind (Decl) = N_Private_Extension_Declaration
478 and then Defining_Entity (Decl) = Typ
480 if Sloc (Decl) > Sloc (Par) then
481 Next_E := Next_Entity (Par);
482 Set_Next_Entity (Par, S);
483 Set_Next_Entity (S, Next_E);
495 -- If partial view is not a type extension, or it appears before the
496 -- subprogram declaration, insert normally at end of entity list.
498 Append_Entity (S, Current_Scope);
499 end Append_Inherited_Subprogram;
501 -----------------------------------------
502 -- Apply_Compile_Time_Constraint_Error --
503 -----------------------------------------
505 procedure Apply_Compile_Time_Constraint_Error
508 Reason : RT_Exception_Code;
509 Ent : Entity_Id := Empty;
510 Typ : Entity_Id := Empty;
511 Loc : Source_Ptr := No_Location;
512 Rep : Boolean := True;
513 Warn : Boolean := False)
515 Stat : constant Boolean := Is_Static_Expression (N);
516 R_Stat : constant Node_Id :=
517 Make_Raise_Constraint_Error (Sloc (N), Reason => Reason);
528 (Compile_Time_Constraint_Error (N, Msg, Ent, Loc, Warn => Warn));
534 -- Now we replace the node by an N_Raise_Constraint_Error node
535 -- This does not need reanalyzing, so set it as analyzed now.
538 Set_Analyzed (N, True);
541 Set_Raises_Constraint_Error (N);
543 -- Now deal with possible local raise handling
545 Possible_Local_Raise (N, Standard_Constraint_Error);
547 -- If the original expression was marked as static, the result is
548 -- still marked as static, but the Raises_Constraint_Error flag is
549 -- always set so that further static evaluation is not attempted.
552 Set_Is_Static_Expression (N);
554 end Apply_Compile_Time_Constraint_Error;
556 ---------------------------
557 -- Async_Readers_Enabled --
558 ---------------------------
560 function Async_Readers_Enabled (Id : Entity_Id) return Boolean is
562 if Ekind (Id) = E_Abstract_State then
565 (Extern => Get_Pragma (Id, Pragma_External),
566 Prop_Nam => Name_Async_Readers);
568 else pragma Assert (Ekind (Id) = E_Variable);
569 return Present (Get_Pragma (Id, Pragma_Async_Readers));
571 end Async_Readers_Enabled;
573 ---------------------------
574 -- Async_Writers_Enabled --
575 ---------------------------
577 function Async_Writers_Enabled (Id : Entity_Id) return Boolean is
579 if Ekind (Id) = E_Abstract_State then
582 (Extern => Get_Pragma (Id, Pragma_External),
583 Prop_Nam => Name_Async_Writers);
585 else pragma Assert (Ekind (Id) = E_Variable);
586 return Present (Get_Pragma (Id, Pragma_Async_Writers));
588 end Async_Writers_Enabled;
590 --------------------------------------
591 -- Available_Full_View_Of_Component --
592 --------------------------------------
594 function Available_Full_View_Of_Component (T : Entity_Id) return Boolean is
595 ST : constant Entity_Id := Scope (T);
596 SCT : constant Entity_Id := Scope (Component_Type (T));
598 return In_Open_Scopes (ST)
599 and then In_Open_Scopes (SCT)
600 and then Scope_Depth (ST) >= Scope_Depth (SCT);
601 end Available_Full_View_Of_Component;
607 procedure Bad_Attribute
610 Warn : Boolean := False)
613 Error_Msg_Warn := Warn;
614 Error_Msg_N ("unrecognized attribute&<", N);
616 -- Check for possible misspelling
618 Error_Msg_Name_1 := First_Attribute_Name;
619 while Error_Msg_Name_1 <= Last_Attribute_Name loop
620 if Is_Bad_Spelling_Of (Nam, Error_Msg_Name_1) then
621 Error_Msg_N -- CODEFIX
622 ("\possible misspelling of %<", N);
626 Error_Msg_Name_1 := Error_Msg_Name_1 + 1;
630 --------------------------------
631 -- Bad_Predicated_Subtype_Use --
632 --------------------------------
634 procedure Bad_Predicated_Subtype_Use
638 Suggest_Static : Boolean := False)
641 if Has_Predicates (Typ) then
642 if Is_Generic_Actual_Type (Typ) then
643 Error_Msg_Warn := SPARK_Mode /= On;
644 Error_Msg_FE (Msg & "<<", N, Typ);
645 Error_Msg_F ("\Program_Error [<<", N);
647 Make_Raise_Program_Error (Sloc (N),
648 Reason => PE_Bad_Predicated_Generic_Type));
651 Error_Msg_FE (Msg, N, Typ);
654 -- Emit an optional suggestion on how to remedy the error if the
655 -- context warrants it.
657 if Suggest_Static and then Present (Static_Predicate (Typ)) then
658 Error_Msg_FE ("\predicate of & should be marked static", N, Typ);
661 end Bad_Predicated_Subtype_Use;
663 --------------------------
664 -- Build_Actual_Subtype --
665 --------------------------
667 function Build_Actual_Subtype
669 N : Node_Or_Entity_Id) return Node_Id
672 -- Normally Sloc (N), but may point to corresponding body in some cases
674 Constraints : List_Id;
680 Disc_Type : Entity_Id;
686 if Nkind (N) = N_Defining_Identifier then
687 Obj := New_Reference_To (N, Loc);
689 -- If this is a formal parameter of a subprogram declaration, and
690 -- we are compiling the body, we want the declaration for the
691 -- actual subtype to carry the source position of the body, to
692 -- prevent anomalies in gdb when stepping through the code.
694 if Is_Formal (N) then
696 Decl : constant Node_Id := Unit_Declaration_Node (Scope (N));
698 if Nkind (Decl) = N_Subprogram_Declaration
699 and then Present (Corresponding_Body (Decl))
701 Loc := Sloc (Corresponding_Body (Decl));
710 if Is_Array_Type (T) then
711 Constraints := New_List;
712 for J in 1 .. Number_Dimensions (T) loop
714 -- Build an array subtype declaration with the nominal subtype and
715 -- the bounds of the actual. Add the declaration in front of the
716 -- local declarations for the subprogram, for analysis before any
717 -- reference to the formal in the body.
720 Make_Attribute_Reference (Loc,
722 Duplicate_Subexpr_No_Checks (Obj, Name_Req => True),
723 Attribute_Name => Name_First,
724 Expressions => New_List (
725 Make_Integer_Literal (Loc, J)));
728 Make_Attribute_Reference (Loc,
730 Duplicate_Subexpr_No_Checks (Obj, Name_Req => True),
731 Attribute_Name => Name_Last,
732 Expressions => New_List (
733 Make_Integer_Literal (Loc, J)));
735 Append (Make_Range (Loc, Lo, Hi), Constraints);
738 -- If the type has unknown discriminants there is no constrained
739 -- subtype to build. This is never called for a formal or for a
740 -- lhs, so returning the type is ok ???
742 elsif Has_Unknown_Discriminants (T) then
746 Constraints := New_List;
748 -- Type T is a generic derived type, inherit the discriminants from
751 if Is_Private_Type (T)
752 and then No (Full_View (T))
754 -- T was flagged as an error if it was declared as a formal
755 -- derived type with known discriminants. In this case there
756 -- is no need to look at the parent type since T already carries
757 -- its own discriminants.
759 and then not Error_Posted (T)
761 Disc_Type := Etype (Base_Type (T));
766 Discr := First_Discriminant (Disc_Type);
767 while Present (Discr) loop
768 Append_To (Constraints,
769 Make_Selected_Component (Loc,
771 Duplicate_Subexpr_No_Checks (Obj),
772 Selector_Name => New_Occurrence_Of (Discr, Loc)));
773 Next_Discriminant (Discr);
777 Subt := Make_Temporary (Loc, 'S', Related_Node => N);
778 Set_Is_Internal (Subt);
781 Make_Subtype_Declaration (Loc,
782 Defining_Identifier => Subt,
783 Subtype_Indication =>
784 Make_Subtype_Indication (Loc,
785 Subtype_Mark => New_Reference_To (T, Loc),
787 Make_Index_Or_Discriminant_Constraint (Loc,
788 Constraints => Constraints)));
790 Mark_Rewrite_Insertion (Decl);
792 end Build_Actual_Subtype;
794 ---------------------------------------
795 -- Build_Actual_Subtype_Of_Component --
796 ---------------------------------------
798 function Build_Actual_Subtype_Of_Component
800 N : Node_Id) return Node_Id
802 Loc : constant Source_Ptr := Sloc (N);
803 P : constant Node_Id := Prefix (N);
806 Index_Typ : Entity_Id;
808 Desig_Typ : Entity_Id;
809 -- This is either a copy of T, or if T is an access type, then it is
810 -- the directly designated type of this access type.
812 function Build_Actual_Array_Constraint return List_Id;
813 -- If one or more of the bounds of the component depends on
814 -- discriminants, build actual constraint using the discriminants
817 function Build_Actual_Record_Constraint return List_Id;
818 -- Similar to previous one, for discriminated components constrained
819 -- by the discriminant of the enclosing object.
821 -----------------------------------
822 -- Build_Actual_Array_Constraint --
823 -----------------------------------
825 function Build_Actual_Array_Constraint return List_Id is
826 Constraints : constant List_Id := New_List;
834 Indx := First_Index (Desig_Typ);
835 while Present (Indx) loop
836 Old_Lo := Type_Low_Bound (Etype (Indx));
837 Old_Hi := Type_High_Bound (Etype (Indx));
839 if Denotes_Discriminant (Old_Lo) then
841 Make_Selected_Component (Loc,
842 Prefix => New_Copy_Tree (P),
843 Selector_Name => New_Occurrence_Of (Entity (Old_Lo), Loc));
846 Lo := New_Copy_Tree (Old_Lo);
848 -- The new bound will be reanalyzed in the enclosing
849 -- declaration. For literal bounds that come from a type
850 -- declaration, the type of the context must be imposed, so
851 -- insure that analysis will take place. For non-universal
852 -- types this is not strictly necessary.
854 Set_Analyzed (Lo, False);
857 if Denotes_Discriminant (Old_Hi) then
859 Make_Selected_Component (Loc,
860 Prefix => New_Copy_Tree (P),
861 Selector_Name => New_Occurrence_Of (Entity (Old_Hi), Loc));
864 Hi := New_Copy_Tree (Old_Hi);
865 Set_Analyzed (Hi, False);
868 Append (Make_Range (Loc, Lo, Hi), Constraints);
873 end Build_Actual_Array_Constraint;
875 ------------------------------------
876 -- Build_Actual_Record_Constraint --
877 ------------------------------------
879 function Build_Actual_Record_Constraint return List_Id is
880 Constraints : constant List_Id := New_List;
885 D := First_Elmt (Discriminant_Constraint (Desig_Typ));
886 while Present (D) loop
887 if Denotes_Discriminant (Node (D)) then
888 D_Val := Make_Selected_Component (Loc,
889 Prefix => New_Copy_Tree (P),
890 Selector_Name => New_Occurrence_Of (Entity (Node (D)), Loc));
893 D_Val := New_Copy_Tree (Node (D));
896 Append (D_Val, Constraints);
901 end Build_Actual_Record_Constraint;
903 -- Start of processing for Build_Actual_Subtype_Of_Component
906 -- Why the test for Spec_Expression mode here???
908 if In_Spec_Expression then
911 -- More comments for the rest of this body would be good ???
913 elsif Nkind (N) = N_Explicit_Dereference then
914 if Is_Composite_Type (T)
915 and then not Is_Constrained (T)
916 and then not (Is_Class_Wide_Type (T)
917 and then Is_Constrained (Root_Type (T)))
918 and then not Has_Unknown_Discriminants (T)
920 -- If the type of the dereference is already constrained, it is an
923 if Is_Array_Type (Etype (N))
924 and then Is_Constrained (Etype (N))
928 Remove_Side_Effects (P);
929 return Build_Actual_Subtype (T, N);
936 if Ekind (T) = E_Access_Subtype then
937 Desig_Typ := Designated_Type (T);
942 if Ekind (Desig_Typ) = E_Array_Subtype then
943 Id := First_Index (Desig_Typ);
944 while Present (Id) loop
945 Index_Typ := Underlying_Type (Etype (Id));
947 if Denotes_Discriminant (Type_Low_Bound (Index_Typ))
949 Denotes_Discriminant (Type_High_Bound (Index_Typ))
951 Remove_Side_Effects (P);
953 Build_Component_Subtype
954 (Build_Actual_Array_Constraint, Loc, Base_Type (T));
960 elsif Is_Composite_Type (Desig_Typ)
961 and then Has_Discriminants (Desig_Typ)
962 and then not Has_Unknown_Discriminants (Desig_Typ)
964 if Is_Private_Type (Desig_Typ)
965 and then No (Discriminant_Constraint (Desig_Typ))
967 Desig_Typ := Full_View (Desig_Typ);
970 D := First_Elmt (Discriminant_Constraint (Desig_Typ));
971 while Present (D) loop
972 if Denotes_Discriminant (Node (D)) then
973 Remove_Side_Effects (P);
975 Build_Component_Subtype (
976 Build_Actual_Record_Constraint, Loc, Base_Type (T));
983 -- If none of the above, the actual and nominal subtypes are the same
986 end Build_Actual_Subtype_Of_Component;
988 -----------------------------
989 -- Build_Component_Subtype --
990 -----------------------------
992 function Build_Component_Subtype
995 T : Entity_Id) return Node_Id
1001 -- Unchecked_Union components do not require component subtypes
1003 if Is_Unchecked_Union (T) then
1007 Subt := Make_Temporary (Loc, 'S');
1008 Set_Is_Internal (Subt);
1011 Make_Subtype_Declaration (Loc,
1012 Defining_Identifier => Subt,
1013 Subtype_Indication =>
1014 Make_Subtype_Indication (Loc,
1015 Subtype_Mark => New_Reference_To (Base_Type (T), Loc),
1017 Make_Index_Or_Discriminant_Constraint (Loc,
1018 Constraints => C)));
1020 Mark_Rewrite_Insertion (Decl);
1022 end Build_Component_Subtype;
1024 ---------------------------
1025 -- Build_Default_Subtype --
1026 ---------------------------
1028 function Build_Default_Subtype
1030 N : Node_Id) return Entity_Id
1032 Loc : constant Source_Ptr := Sloc (N);
1036 -- The base type that is to be constrained by the defaults
1039 if not Has_Discriminants (T) or else Is_Constrained (T) then
1043 Bas := Base_Type (T);
1045 -- If T is non-private but its base type is private, this is the
1046 -- completion of a subtype declaration whose parent type is private
1047 -- (see Complete_Private_Subtype in Sem_Ch3). The proper discriminants
1048 -- are to be found in the full view of the base.
1050 if Is_Private_Type (Bas) and then Present (Full_View (Bas)) then
1051 Bas := Full_View (Bas);
1054 Disc := First_Discriminant (T);
1056 if No (Discriminant_Default_Value (Disc)) then
1061 Act : constant Entity_Id := Make_Temporary (Loc, 'S');
1062 Constraints : constant List_Id := New_List;
1066 while Present (Disc) loop
1067 Append_To (Constraints,
1068 New_Copy_Tree (Discriminant_Default_Value (Disc)));
1069 Next_Discriminant (Disc);
1073 Make_Subtype_Declaration (Loc,
1074 Defining_Identifier => Act,
1075 Subtype_Indication =>
1076 Make_Subtype_Indication (Loc,
1077 Subtype_Mark => New_Occurrence_Of (Bas, Loc),
1079 Make_Index_Or_Discriminant_Constraint (Loc,
1080 Constraints => Constraints)));
1082 Insert_Action (N, Decl);
1086 end Build_Default_Subtype;
1088 --------------------------------------------
1089 -- Build_Discriminal_Subtype_Of_Component --
1090 --------------------------------------------
1092 function Build_Discriminal_Subtype_Of_Component
1093 (T : Entity_Id) return Node_Id
1095 Loc : constant Source_Ptr := Sloc (T);
1099 function Build_Discriminal_Array_Constraint return List_Id;
1100 -- If one or more of the bounds of the component depends on
1101 -- discriminants, build actual constraint using the discriminants
1104 function Build_Discriminal_Record_Constraint return List_Id;
1105 -- Similar to previous one, for discriminated components constrained by
1106 -- the discriminant of the enclosing object.
1108 ----------------------------------------
1109 -- Build_Discriminal_Array_Constraint --
1110 ----------------------------------------
1112 function Build_Discriminal_Array_Constraint return List_Id is
1113 Constraints : constant List_Id := New_List;
1121 Indx := First_Index (T);
1122 while Present (Indx) loop
1123 Old_Lo := Type_Low_Bound (Etype (Indx));
1124 Old_Hi := Type_High_Bound (Etype (Indx));
1126 if Denotes_Discriminant (Old_Lo) then
1127 Lo := New_Occurrence_Of (Discriminal (Entity (Old_Lo)), Loc);
1130 Lo := New_Copy_Tree (Old_Lo);
1133 if Denotes_Discriminant (Old_Hi) then
1134 Hi := New_Occurrence_Of (Discriminal (Entity (Old_Hi)), Loc);
1137 Hi := New_Copy_Tree (Old_Hi);
1140 Append (Make_Range (Loc, Lo, Hi), Constraints);
1145 end Build_Discriminal_Array_Constraint;
1147 -----------------------------------------
1148 -- Build_Discriminal_Record_Constraint --
1149 -----------------------------------------
1151 function Build_Discriminal_Record_Constraint return List_Id is
1152 Constraints : constant List_Id := New_List;
1157 D := First_Elmt (Discriminant_Constraint (T));
1158 while Present (D) loop
1159 if Denotes_Discriminant (Node (D)) then
1161 New_Occurrence_Of (Discriminal (Entity (Node (D))), Loc);
1164 D_Val := New_Copy_Tree (Node (D));
1167 Append (D_Val, Constraints);
1172 end Build_Discriminal_Record_Constraint;
1174 -- Start of processing for Build_Discriminal_Subtype_Of_Component
1177 if Ekind (T) = E_Array_Subtype then
1178 Id := First_Index (T);
1179 while Present (Id) loop
1180 if Denotes_Discriminant (Type_Low_Bound (Etype (Id))) or else
1181 Denotes_Discriminant (Type_High_Bound (Etype (Id)))
1183 return Build_Component_Subtype
1184 (Build_Discriminal_Array_Constraint, Loc, T);
1190 elsif Ekind (T) = E_Record_Subtype
1191 and then Has_Discriminants (T)
1192 and then not Has_Unknown_Discriminants (T)
1194 D := First_Elmt (Discriminant_Constraint (T));
1195 while Present (D) loop
1196 if Denotes_Discriminant (Node (D)) then
1197 return Build_Component_Subtype
1198 (Build_Discriminal_Record_Constraint, Loc, T);
1205 -- If none of the above, the actual and nominal subtypes are the same
1208 end Build_Discriminal_Subtype_Of_Component;
1210 ------------------------------
1211 -- Build_Elaboration_Entity --
1212 ------------------------------
1214 procedure Build_Elaboration_Entity (N : Node_Id; Spec_Id : Entity_Id) is
1215 Loc : constant Source_Ptr := Sloc (N);
1217 Elab_Ent : Entity_Id;
1219 procedure Set_Package_Name (Ent : Entity_Id);
1220 -- Given an entity, sets the fully qualified name of the entity in
1221 -- Name_Buffer, with components separated by double underscores. This
1222 -- is a recursive routine that climbs the scope chain to Standard.
1224 ----------------------
1225 -- Set_Package_Name --
1226 ----------------------
1228 procedure Set_Package_Name (Ent : Entity_Id) is
1230 if Scope (Ent) /= Standard_Standard then
1231 Set_Package_Name (Scope (Ent));
1234 Nam : constant String := Get_Name_String (Chars (Ent));
1236 Name_Buffer (Name_Len + 1) := '_';
1237 Name_Buffer (Name_Len + 2) := '_';
1238 Name_Buffer (Name_Len + 3 .. Name_Len + Nam'Length + 2) := Nam;
1239 Name_Len := Name_Len + Nam'Length + 2;
1243 Get_Name_String (Chars (Ent));
1245 end Set_Package_Name;
1247 -- Start of processing for Build_Elaboration_Entity
1250 -- Ignore if already constructed
1252 if Present (Elaboration_Entity (Spec_Id)) then
1256 -- Ignore in ASIS mode, elaboration entity is not in source and plays
1257 -- no role in analysis.
1263 -- Construct name of elaboration entity as xxx_E, where xxx is the unit
1264 -- name with dots replaced by double underscore. We have to manually
1265 -- construct this name, since it will be elaborated in the outer scope,
1266 -- and thus will not have the unit name automatically prepended.
1268 Set_Package_Name (Spec_Id);
1269 Add_Str_To_Name_Buffer ("_E");
1271 -- Create elaboration counter
1273 Elab_Ent := Make_Defining_Identifier (Loc, Chars => Name_Find);
1274 Set_Elaboration_Entity (Spec_Id, Elab_Ent);
1277 Make_Object_Declaration (Loc,
1278 Defining_Identifier => Elab_Ent,
1279 Object_Definition =>
1280 New_Occurrence_Of (Standard_Short_Integer, Loc),
1281 Expression => Make_Integer_Literal (Loc, Uint_0));
1283 Push_Scope (Standard_Standard);
1284 Add_Global_Declaration (Decl);
1287 -- Reset True_Constant indication, since we will indeed assign a value
1288 -- to the variable in the binder main. We also kill the Current_Value
1289 -- and Last_Assignment fields for the same reason.
1291 Set_Is_True_Constant (Elab_Ent, False);
1292 Set_Current_Value (Elab_Ent, Empty);
1293 Set_Last_Assignment (Elab_Ent, Empty);
1295 -- We do not want any further qualification of the name (if we did not
1296 -- do this, we would pick up the name of the generic package in the case
1297 -- of a library level generic instantiation).
1299 Set_Has_Qualified_Name (Elab_Ent);
1300 Set_Has_Fully_Qualified_Name (Elab_Ent);
1301 end Build_Elaboration_Entity;
1303 --------------------------------
1304 -- Build_Explicit_Dereference --
1305 --------------------------------
1307 procedure Build_Explicit_Dereference
1311 Loc : constant Source_Ptr := Sloc (Expr);
1314 -- An entity of a type with a reference aspect is overloaded with
1315 -- both interpretations: with and without the dereference. Now that
1316 -- the dereference is made explicit, set the type of the node properly,
1317 -- to prevent anomalies in the backend. Same if the expression is an
1318 -- overloaded function call whose return type has a reference aspect.
1320 if Is_Entity_Name (Expr) then
1321 Set_Etype (Expr, Etype (Entity (Expr)));
1323 elsif Nkind (Expr) = N_Function_Call then
1324 Set_Etype (Expr, Etype (Name (Expr)));
1327 Set_Is_Overloaded (Expr, False);
1329 Make_Explicit_Dereference (Loc,
1331 Make_Selected_Component (Loc,
1332 Prefix => Relocate_Node (Expr),
1333 Selector_Name => New_Occurrence_Of (Disc, Loc))));
1334 Set_Etype (Prefix (Expr), Etype (Disc));
1335 Set_Etype (Expr, Designated_Type (Etype (Disc)));
1336 end Build_Explicit_Dereference;
1338 -----------------------------------
1339 -- Cannot_Raise_Constraint_Error --
1340 -----------------------------------
1342 function Cannot_Raise_Constraint_Error (Expr : Node_Id) return Boolean is
1344 if Compile_Time_Known_Value (Expr) then
1347 elsif Do_Range_Check (Expr) then
1350 elsif Raises_Constraint_Error (Expr) then
1354 case Nkind (Expr) is
1355 when N_Identifier =>
1358 when N_Expanded_Name =>
1361 when N_Selected_Component =>
1362 return not Do_Discriminant_Check (Expr);
1364 when N_Attribute_Reference =>
1365 if Do_Overflow_Check (Expr) then
1368 elsif No (Expressions (Expr)) then
1376 N := First (Expressions (Expr));
1377 while Present (N) loop
1378 if Cannot_Raise_Constraint_Error (N) then
1389 when N_Type_Conversion =>
1390 if Do_Overflow_Check (Expr)
1391 or else Do_Length_Check (Expr)
1392 or else Do_Tag_Check (Expr)
1396 return Cannot_Raise_Constraint_Error (Expression (Expr));
1399 when N_Unchecked_Type_Conversion =>
1400 return Cannot_Raise_Constraint_Error (Expression (Expr));
1403 if Do_Overflow_Check (Expr) then
1406 return Cannot_Raise_Constraint_Error (Right_Opnd (Expr));
1413 if Do_Division_Check (Expr)
1414 or else Do_Overflow_Check (Expr)
1419 Cannot_Raise_Constraint_Error (Left_Opnd (Expr))
1421 Cannot_Raise_Constraint_Error (Right_Opnd (Expr));
1440 N_Op_Shift_Right_Arithmetic |
1444 if Do_Overflow_Check (Expr) then
1448 Cannot_Raise_Constraint_Error (Left_Opnd (Expr))
1450 Cannot_Raise_Constraint_Error (Right_Opnd (Expr));
1457 end Cannot_Raise_Constraint_Error;
1459 -----------------------------------------
1460 -- Check_Dynamically_Tagged_Expression --
1461 -----------------------------------------
1463 procedure Check_Dynamically_Tagged_Expression
1466 Related_Nod : Node_Id)
1469 pragma Assert (Is_Tagged_Type (Typ));
1471 -- In order to avoid spurious errors when analyzing the expanded code,
1472 -- this check is done only for nodes that come from source and for
1473 -- actuals of generic instantiations.
1475 if (Comes_From_Source (Related_Nod)
1476 or else In_Generic_Actual (Expr))
1477 and then (Is_Class_Wide_Type (Etype (Expr))
1478 or else Is_Dynamically_Tagged (Expr))
1479 and then Is_Tagged_Type (Typ)
1480 and then not Is_Class_Wide_Type (Typ)
1482 Error_Msg_N ("dynamically tagged expression not allowed!", Expr);
1484 end Check_Dynamically_Tagged_Expression;
1486 -----------------------------------------------
1487 -- Check_Expression_Against_Static_Predicate --
1488 -----------------------------------------------
1490 procedure Check_Expression_Against_Static_Predicate
1495 -- When the predicate is static and the value of the expression is known
1496 -- at compile time, evaluate the predicate check. A type is non-static
1497 -- when it has aspect Dynamic_Predicate.
1499 if Compile_Time_Known_Value (Expr)
1500 and then Has_Predicates (Typ)
1501 and then Present (Static_Predicate (Typ))
1502 and then not Has_Dynamic_Predicate_Aspect (Typ)
1504 -- Either -gnatc is enabled or the expression is ok
1506 if Operating_Mode < Generate_Code
1507 or else Eval_Static_Predicate_Check (Expr, Typ)
1511 -- The expression is prohibited by the static predicate
1515 ("?static expression fails static predicate check on &",
1519 end Check_Expression_Against_Static_Predicate;
1521 --------------------------
1522 -- Check_Fully_Declared --
1523 --------------------------
1525 procedure Check_Fully_Declared (T : Entity_Id; N : Node_Id) is
1527 if Ekind (T) = E_Incomplete_Type then
1529 -- Ada 2005 (AI-50217): If the type is available through a limited
1530 -- with_clause, verify that its full view has been analyzed.
1532 if From_Limited_With (T)
1533 and then Present (Non_Limited_View (T))
1534 and then Ekind (Non_Limited_View (T)) /= E_Incomplete_Type
1536 -- The non-limited view is fully declared
1541 ("premature usage of incomplete}", N, First_Subtype (T));
1544 -- Need comments for these tests ???
1546 elsif Has_Private_Component (T)
1547 and then not Is_Generic_Type (Root_Type (T))
1548 and then not In_Spec_Expression
1550 -- Special case: if T is the anonymous type created for a single
1551 -- task or protected object, use the name of the source object.
1553 if Is_Concurrent_Type (T)
1554 and then not Comes_From_Source (T)
1555 and then Nkind (N) = N_Object_Declaration
1557 Error_Msg_NE ("type of& has incomplete component", N,
1558 Defining_Identifier (N));
1562 ("premature usage of incomplete}", N, First_Subtype (T));
1565 end Check_Fully_Declared;
1567 -------------------------------------
1568 -- Check_Function_Writable_Actuals --
1569 -------------------------------------
1571 procedure Check_Function_Writable_Actuals (N : Node_Id) is
1572 Writable_Actuals_List : Elist_Id := No_Elist;
1573 Identifiers_List : Elist_Id := No_Elist;
1574 Error_Node : Node_Id := Empty;
1576 procedure Collect_Identifiers (N : Node_Id);
1577 -- In a single traversal of subtree N collect in Writable_Actuals_List
1578 -- all the actuals of functions with writable actuals, and in the list
1579 -- Identifiers_List collect all the identifiers that are not actuals of
1580 -- functions with writable actuals. If a writable actual is referenced
1581 -- twice as writable actual then Error_Node is set to reference its
1582 -- second occurrence, the error is reported, and the tree traversal
1585 function Get_Function_Id (Call : Node_Id) return Entity_Id;
1586 -- Return the entity associated with the function call
1588 procedure Preanalyze_Without_Errors (N : Node_Id);
1589 -- Preanalyze N without reporting errors. Very dubious, you can't just
1590 -- go analyzing things more than once???
1592 -------------------------
1593 -- Collect_Identifiers --
1594 -------------------------
1596 procedure Collect_Identifiers (N : Node_Id) is
1598 function Check_Node (N : Node_Id) return Traverse_Result;
1599 -- Process a single node during the tree traversal to collect the
1600 -- writable actuals of functions and all the identifiers which are
1601 -- not writable actuals of functions.
1603 function Contains (List : Elist_Id; N : Node_Id) return Boolean;
1604 -- Returns True if List has a node whose Entity is Entity (N)
1606 -------------------------
1607 -- Check_Function_Call --
1608 -------------------------
1610 function Check_Node (N : Node_Id) return Traverse_Result is
1611 Is_Writable_Actual : Boolean := False;
1615 if Nkind (N) = N_Identifier then
1617 -- No analysis possible if the entity is not decorated
1619 if No (Entity (N)) then
1622 -- Don't collect identifiers of packages, called functions, etc
1624 elsif Ekind_In (Entity (N), E_Package,
1631 -- Analyze if N is a writable actual of a function
1633 elsif Nkind (Parent (N)) = N_Function_Call then
1635 Call : constant Node_Id := Parent (N);
1640 Id := Get_Function_Id (Call);
1642 Formal := First_Formal (Id);
1643 Actual := First_Actual (Call);
1644 while Present (Actual) and then Present (Formal) loop
1646 if Ekind_In (Formal, E_Out_Parameter,
1649 Is_Writable_Actual := True;
1655 Next_Formal (Formal);
1656 Next_Actual (Actual);
1661 if Is_Writable_Actual then
1662 if Contains (Writable_Actuals_List, N) then
1664 ("value may be affected by call to& "
1665 & "because order of evaluation is arbitrary", N, Id);
1670 if Writable_Actuals_List = No_Elist then
1671 Writable_Actuals_List := New_Elmt_List;
1674 Append_Elmt (N, Writable_Actuals_List);
1676 if Identifiers_List = No_Elist then
1677 Identifiers_List := New_Elmt_List;
1680 Append_Unique_Elmt (N, Identifiers_List);
1693 N : Node_Id) return Boolean
1695 pragma Assert (Nkind (N) in N_Has_Entity);
1700 if List = No_Elist then
1704 Elmt := First_Elmt (List);
1705 while Present (Elmt) loop
1706 if Entity (Node (Elmt)) = Entity (N) then
1720 procedure Do_Traversal is new Traverse_Proc (Check_Node);
1721 -- The traversal procedure
1723 -- Start of processing for Collect_Identifiers
1726 if Present (Error_Node) then
1730 if Nkind (N) in N_Subexpr
1731 and then Is_Static_Expression (N)
1737 end Collect_Identifiers;
1739 ---------------------
1740 -- Get_Function_Id --
1741 ---------------------
1743 function Get_Function_Id (Call : Node_Id) return Entity_Id is
1744 Nam : constant Node_Id := Name (Call);
1748 if Nkind (Nam) = N_Explicit_Dereference then
1750 pragma Assert (Ekind (Id) = E_Subprogram_Type);
1752 elsif Nkind (Nam) = N_Selected_Component then
1753 Id := Entity (Selector_Name (Nam));
1755 elsif Nkind (Nam) = N_Indexed_Component then
1756 Id := Entity (Selector_Name (Prefix (Nam)));
1763 end Get_Function_Id;
1765 ---------------------------
1766 -- Preanalyze_Expression --
1767 ---------------------------
1769 procedure Preanalyze_Without_Errors (N : Node_Id) is
1770 Status : constant Boolean := Get_Ignore_Errors;
1772 Set_Ignore_Errors (True);
1774 Set_Ignore_Errors (Status);
1775 end Preanalyze_Without_Errors;
1777 -- Start of processing for Check_Function_Writable_Actuals
1780 -- The check only applies to Ada 2012 code, and only to constructs that
1781 -- have multiple constituents whose order of evaluation is not specified
1784 if Ada_Version < Ada_2012
1785 or else (not (Nkind (N) in N_Op)
1786 and then not (Nkind (N) in N_Membership_Test)
1787 and then not Nkind_In (N, N_Range,
1789 N_Extension_Aggregate,
1790 N_Full_Type_Declaration,
1792 N_Procedure_Call_Statement,
1793 N_Entry_Call_Statement))
1794 or else (Nkind (N) = N_Full_Type_Declaration
1795 and then not Is_Record_Type (Defining_Identifier (N)))
1797 -- In addition, this check only applies to source code, not to code
1798 -- generated by constraint checks.
1800 or else not Comes_From_Source (N)
1805 -- If a construct C has two or more direct constituents that are names
1806 -- or expressions whose evaluation may occur in an arbitrary order, at
1807 -- least one of which contains a function call with an in out or out
1808 -- parameter, then the construct is legal only if: for each name N that
1809 -- is passed as a parameter of mode in out or out to some inner function
1810 -- call C2 (not including the construct C itself), there is no other
1811 -- name anywhere within a direct constituent of the construct C other
1812 -- than the one containing C2, that is known to refer to the same
1813 -- object (RM 6.4.1(6.17/3)).
1817 Collect_Identifiers (Low_Bound (N));
1818 Collect_Identifiers (High_Bound (N));
1820 when N_Op | N_Membership_Test =>
1824 Collect_Identifiers (Left_Opnd (N));
1826 if Present (Right_Opnd (N)) then
1827 Collect_Identifiers (Right_Opnd (N));
1830 if Nkind_In (N, N_In, N_Not_In)
1831 and then Present (Alternatives (N))
1833 Expr := First (Alternatives (N));
1834 while Present (Expr) loop
1835 Collect_Identifiers (Expr);
1842 when N_Full_Type_Declaration =>
1844 function Get_Record_Part (N : Node_Id) return Node_Id;
1845 -- Return the record part of this record type definition
1847 function Get_Record_Part (N : Node_Id) return Node_Id is
1848 Type_Def : constant Node_Id := Type_Definition (N);
1850 if Nkind (Type_Def) = N_Derived_Type_Definition then
1851 return Record_Extension_Part (Type_Def);
1855 end Get_Record_Part;
1858 Def_Id : Entity_Id := Defining_Identifier (N);
1859 Rec : Node_Id := Get_Record_Part (N);
1862 -- No need to perform any analysis if the record has no
1865 if No (Rec) or else No (Component_List (Rec)) then
1869 -- Collect the identifiers starting from the deepest
1870 -- derivation. Done to report the error in the deepest
1874 if Present (Component_List (Rec)) then
1875 Comp := First (Component_Items (Component_List (Rec)));
1876 while Present (Comp) loop
1877 if Nkind (Comp) = N_Component_Declaration
1878 and then Present (Expression (Comp))
1880 Collect_Identifiers (Expression (Comp));
1887 exit when No (Underlying_Type (Etype (Def_Id)))
1888 or else Base_Type (Underlying_Type (Etype (Def_Id)))
1891 Def_Id := Base_Type (Underlying_Type (Etype (Def_Id)));
1892 Rec := Get_Record_Part (Parent (Def_Id));
1896 when N_Subprogram_Call |
1897 N_Entry_Call_Statement =>
1899 Id : constant Entity_Id := Get_Function_Id (N);
1904 Formal := First_Formal (Id);
1905 Actual := First_Actual (N);
1906 while Present (Actual) and then Present (Formal) loop
1907 if Ekind_In (Formal, E_Out_Parameter,
1910 Collect_Identifiers (Actual);
1913 Next_Formal (Formal);
1914 Next_Actual (Actual);
1919 N_Extension_Aggregate =>
1923 Comp_Expr : Node_Id;
1926 -- Handle the N_Others_Choice of array aggregates with static
1927 -- bounds. There is no need to perform this analysis in
1928 -- aggregates without static bounds since we cannot evaluate
1929 -- if the N_Others_Choice covers several elements. There is
1930 -- no need to handle the N_Others choice of record aggregates
1931 -- since at this stage it has been already expanded by
1932 -- Resolve_Record_Aggregate.
1934 if Is_Array_Type (Etype (N))
1935 and then Nkind (N) = N_Aggregate
1936 and then Present (Aggregate_Bounds (N))
1937 and then Compile_Time_Known_Bounds (Etype (N))
1938 and then Expr_Value (High_Bound (Aggregate_Bounds (N)))
1939 > Expr_Value (Low_Bound (Aggregate_Bounds (N)))
1942 Count_Components : Uint := Uint_0;
1943 Num_Components : Uint;
1944 Others_Assoc : Node_Id;
1945 Others_Choice : Node_Id := Empty;
1946 Others_Box_Present : Boolean := False;
1949 -- Count positional associations
1951 if Present (Expressions (N)) then
1952 Comp_Expr := First (Expressions (N));
1953 while Present (Comp_Expr) loop
1954 Count_Components := Count_Components + 1;
1959 -- Count the rest of elements and locate the N_Others
1962 Assoc := First (Component_Associations (N));
1963 while Present (Assoc) loop
1964 Choice := First (Choices (Assoc));
1965 while Present (Choice) loop
1966 if Nkind (Choice) = N_Others_Choice then
1967 Others_Assoc := Assoc;
1968 Others_Choice := Choice;
1969 Others_Box_Present := Box_Present (Assoc);
1971 -- Count several components
1973 elsif Nkind_In (Choice, N_Range,
1974 N_Subtype_Indication)
1975 or else (Is_Entity_Name (Choice)
1976 and then Is_Type (Entity (Choice)))
1981 Get_Index_Bounds (Choice, L, H);
1983 (Compile_Time_Known_Value (L)
1984 and then Compile_Time_Known_Value (H));
1987 + Expr_Value (H) - Expr_Value (L) + 1;
1990 -- Count single component. No other case available
1991 -- since we are handling an aggregate with static
1995 pragma Assert (Is_Static_Expression (Choice)
1996 or else Nkind (Choice) = N_Identifier
1997 or else Nkind (Choice) = N_Integer_Literal);
1999 Count_Components := Count_Components + 1;
2009 Expr_Value (High_Bound (Aggregate_Bounds (N))) -
2010 Expr_Value (Low_Bound (Aggregate_Bounds (N))) + 1;
2012 pragma Assert (Count_Components <= Num_Components);
2014 -- Handle the N_Others choice if it covers several
2017 if Present (Others_Choice)
2018 and then (Num_Components - Count_Components) > 1
2020 if not Others_Box_Present then
2022 -- At this stage, if expansion is active, the
2023 -- expression of the others choice has not been
2024 -- analyzed. Hence we generate a duplicate and
2025 -- we analyze it silently to have available the
2026 -- minimum decoration required to collect the
2029 if not Expander_Active then
2030 Comp_Expr := Expression (Others_Assoc);
2033 New_Copy_Tree (Expression (Others_Assoc));
2034 Preanalyze_Without_Errors (Comp_Expr);
2037 Collect_Identifiers (Comp_Expr);
2039 if Writable_Actuals_List /= No_Elist then
2041 -- As suggested by Robert, at current stage we
2042 -- report occurrences of this case as warnings.
2045 ("writable function parameter may affect "
2046 & "value in other component because order "
2047 & "of evaluation is unspecified?",
2048 Node (First_Elmt (Writable_Actuals_List)));
2055 -- Handle ancestor part of extension aggregates
2057 if Nkind (N) = N_Extension_Aggregate then
2058 Collect_Identifiers (Ancestor_Part (N));
2061 -- Handle positional associations
2063 if Present (Expressions (N)) then
2064 Comp_Expr := First (Expressions (N));
2065 while Present (Comp_Expr) loop
2066 if not Is_Static_Expression (Comp_Expr) then
2067 Collect_Identifiers (Comp_Expr);
2074 -- Handle discrete associations
2076 if Present (Component_Associations (N)) then
2077 Assoc := First (Component_Associations (N));
2078 while Present (Assoc) loop
2080 if not Box_Present (Assoc) then
2081 Choice := First (Choices (Assoc));
2082 while Present (Choice) loop
2084 -- For now we skip discriminants since it requires
2085 -- performing the analysis in two phases: first one
2086 -- analyzing discriminants and second one analyzing
2087 -- the rest of components since discriminants are
2088 -- evaluated prior to components: too much extra
2089 -- work to detect a corner case???
2091 if Nkind (Choice) in N_Has_Entity
2092 and then Present (Entity (Choice))
2093 and then Ekind (Entity (Choice)) = E_Discriminant
2097 elsif Box_Present (Assoc) then
2101 if not Analyzed (Expression (Assoc)) then
2103 New_Copy_Tree (Expression (Assoc));
2104 Set_Parent (Comp_Expr, Parent (N));
2105 Preanalyze_Without_Errors (Comp_Expr);
2107 Comp_Expr := Expression (Assoc);
2110 Collect_Identifiers (Comp_Expr);
2126 -- No further action needed if we already reported an error
2128 if Present (Error_Node) then
2132 -- Check if some writable argument of a function is referenced
2134 if Writable_Actuals_List /= No_Elist
2135 and then Identifiers_List /= No_Elist
2142 Elmt_1 := First_Elmt (Writable_Actuals_List);
2143 while Present (Elmt_1) loop
2144 Elmt_2 := First_Elmt (Identifiers_List);
2145 while Present (Elmt_2) loop
2146 if Entity (Node (Elmt_1)) = Entity (Node (Elmt_2)) then
2147 case Nkind (Parent (Node (Elmt_2))) is
2149 N_Component_Association |
2150 N_Component_Declaration =>
2152 ("value may be affected by call in other "
2153 & "component because they are evaluated "
2154 & "in unspecified order",
2157 when N_In | N_Not_In =>
2159 ("value may be affected by call in other "
2160 & "alternative because they are evaluated "
2161 & "in unspecified order",
2166 ("value of actual may be affected by call in "
2167 & "other actual because they are evaluated "
2168 & "in unspecified order",
2180 end Check_Function_Writable_Actuals;
2182 --------------------------------
2183 -- Check_Implicit_Dereference --
2184 --------------------------------
2186 procedure Check_Implicit_Dereference (Nam : Node_Id; Typ : Entity_Id) is
2191 if Ada_Version < Ada_2012
2192 or else not Has_Implicit_Dereference (Base_Type (Typ))
2196 elsif not Comes_From_Source (Nam) then
2199 elsif Is_Entity_Name (Nam)
2200 and then Is_Type (Entity (Nam))
2205 Disc := First_Discriminant (Typ);
2206 while Present (Disc) loop
2207 if Has_Implicit_Dereference (Disc) then
2208 Desig := Designated_Type (Etype (Disc));
2209 Add_One_Interp (Nam, Disc, Desig);
2213 Next_Discriminant (Disc);
2216 end Check_Implicit_Dereference;
2218 ----------------------------------
2219 -- Check_Internal_Protected_Use --
2220 ----------------------------------
2222 procedure Check_Internal_Protected_Use (N : Node_Id; Nam : Entity_Id) is
2228 while Present (S) loop
2229 if S = Standard_Standard then
2232 elsif Ekind (S) = E_Function
2233 and then Ekind (Scope (S)) = E_Protected_Type
2242 if Scope (Nam) = Prot and then Ekind (Nam) /= E_Function then
2243 if Nkind (N) = N_Subprogram_Renaming_Declaration then
2245 ("within protected function cannot use protected "
2246 & "procedure in renaming or as generic actual", N);
2248 elsif Nkind (N) = N_Attribute_Reference then
2250 ("within protected function cannot take access of "
2251 & " protected procedure", N);
2255 ("within protected function, protected object is constant", N);
2257 ("\cannot call operation that may modify it", N);
2260 end Check_Internal_Protected_Use;
2262 ---------------------------------------
2263 -- Check_Later_Vs_Basic_Declarations --
2264 ---------------------------------------
2266 procedure Check_Later_Vs_Basic_Declarations
2268 During_Parsing : Boolean)
2270 Body_Sloc : Source_Ptr;
2273 function Is_Later_Declarative_Item (Decl : Node_Id) return Boolean;
2274 -- Return whether Decl is considered as a declarative item.
2275 -- When During_Parsing is True, the semantics of Ada 83 is followed.
2276 -- When During_Parsing is False, the semantics of SPARK is followed.
2278 -------------------------------
2279 -- Is_Later_Declarative_Item --
2280 -------------------------------
2282 function Is_Later_Declarative_Item (Decl : Node_Id) return Boolean is
2284 if Nkind (Decl) in N_Later_Decl_Item then
2287 elsif Nkind (Decl) = N_Pragma then
2290 elsif During_Parsing then
2293 -- In SPARK, a package declaration is not considered as a later
2294 -- declarative item.
2296 elsif Nkind (Decl) = N_Package_Declaration then
2299 -- In SPARK, a renaming is considered as a later declarative item
2301 elsif Nkind (Decl) in N_Renaming_Declaration then
2307 end Is_Later_Declarative_Item;
2309 -- Start of Check_Later_Vs_Basic_Declarations
2312 Decl := First (Decls);
2314 -- Loop through sequence of basic declarative items
2316 Outer : while Present (Decl) loop
2317 if not Nkind_In (Decl, N_Subprogram_Body, N_Package_Body, N_Task_Body)
2318 and then Nkind (Decl) not in N_Body_Stub
2322 -- Once a body is encountered, we only allow later declarative
2323 -- items. The inner loop checks the rest of the list.
2326 Body_Sloc := Sloc (Decl);
2328 Inner : while Present (Decl) loop
2329 if not Is_Later_Declarative_Item (Decl) then
2330 if During_Parsing then
2331 if Ada_Version = Ada_83 then
2332 Error_Msg_Sloc := Body_Sloc;
2334 ("(Ada 83) decl cannot appear after body#", Decl);
2337 Error_Msg_Sloc := Body_Sloc;
2338 Check_SPARK_Restriction
2339 ("decl cannot appear after body#", Decl);
2347 end Check_Later_Vs_Basic_Declarations;
2349 -------------------------
2350 -- Check_Nested_Access --
2351 -------------------------
2353 procedure Check_Nested_Access (Ent : Entity_Id) is
2354 Scop : constant Entity_Id := Current_Scope;
2355 Current_Subp : Entity_Id;
2356 Enclosing : Entity_Id;
2359 -- Currently only enabled for VM back-ends for efficiency, should we
2360 -- enable it more systematically ???
2362 -- Check for Is_Imported needs commenting below ???
2364 if VM_Target /= No_VM
2365 and then (Ekind (Ent) = E_Variable
2367 Ekind (Ent) = E_Constant
2369 Ekind (Ent) = E_Loop_Parameter)
2370 and then Scope (Ent) /= Empty
2371 and then not Is_Library_Level_Entity (Ent)
2372 and then not Is_Imported (Ent)
2374 if Is_Subprogram (Scop)
2375 or else Is_Generic_Subprogram (Scop)
2376 or else Is_Entry (Scop)
2378 Current_Subp := Scop;
2380 Current_Subp := Current_Subprogram;
2383 Enclosing := Enclosing_Subprogram (Ent);
2385 if Enclosing /= Empty
2386 and then Enclosing /= Current_Subp
2388 Set_Has_Up_Level_Access (Ent, True);
2391 end Check_Nested_Access;
2393 ---------------------------
2394 -- Check_No_Hidden_State --
2395 ---------------------------
2397 procedure Check_No_Hidden_State (Id : Entity_Id) is
2398 function Has_Null_Abstract_State (Pkg : Entity_Id) return Boolean;
2399 -- Determine whether the entity of a package denoted by Pkg has a null
2402 -----------------------------
2403 -- Has_Null_Abstract_State --
2404 -----------------------------
2406 function Has_Null_Abstract_State (Pkg : Entity_Id) return Boolean is
2407 States : constant Elist_Id := Abstract_States (Pkg);
2410 -- Check first available state of related package. A null abstract
2411 -- state always appears as the sole element of the state list.
2415 and then Is_Null_State (Node (First_Elmt (States)));
2416 end Has_Null_Abstract_State;
2420 Context : Entity_Id := Empty;
2421 Not_Visible : Boolean := False;
2424 -- Start of processing for Check_No_Hidden_State
2427 pragma Assert (Ekind_In (Id, E_Abstract_State, E_Variable));
2429 -- Find the proper context where the object or state appears
2432 while Present (Scop) loop
2435 -- Keep track of the context's visibility
2437 Not_Visible := Not_Visible or else In_Private_Part (Context);
2439 -- Prevent the search from going too far
2441 if Context = Standard_Standard then
2444 -- Objects and states that appear immediately within a subprogram or
2445 -- inside a construct nested within a subprogram do not introduce a
2446 -- hidden state. They behave as local variable declarations.
2448 elsif Is_Subprogram (Context) then
2451 -- When examining a package body, use the entity of the spec as it
2452 -- carries the abstract state declarations.
2454 elsif Ekind (Context) = E_Package_Body then
2455 Context := Spec_Entity (Context);
2458 -- Stop the traversal when a package subject to a null abstract state
2461 if Ekind_In (Context, E_Generic_Package, E_Package)
2462 and then Has_Null_Abstract_State (Context)
2467 Scop := Scope (Scop);
2470 -- At this point we know that there is at least one package with a null
2471 -- abstract state in visibility. Emit an error message unconditionally
2472 -- if the entity being processed is a state because the placement of the
2473 -- related package is irrelevant. This is not the case for objects as
2474 -- the intermediate context matters.
2476 if Present (Context)
2477 and then (Ekind (Id) = E_Abstract_State or else Not_Visible)
2479 Error_Msg_N ("cannot introduce hidden state &", Id);
2480 Error_Msg_NE ("\package & has null abstract state", Id, Context);
2482 end Check_No_Hidden_State;
2484 ------------------------------------------
2485 -- Check_Potentially_Blocking_Operation --
2486 ------------------------------------------
2488 procedure Check_Potentially_Blocking_Operation (N : Node_Id) is
2492 -- N is one of the potentially blocking operations listed in 9.5.1(8).
2493 -- When pragma Detect_Blocking is active, the run time will raise
2494 -- Program_Error. Here we only issue a warning, since we generally
2495 -- support the use of potentially blocking operations in the absence
2498 -- Indirect blocking through a subprogram call cannot be diagnosed
2499 -- statically without interprocedural analysis, so we do not attempt
2502 S := Scope (Current_Scope);
2503 while Present (S) and then S /= Standard_Standard loop
2504 if Is_Protected_Type (S) then
2506 ("potentially blocking operation in protected operation??", N);
2512 end Check_Potentially_Blocking_Operation;
2514 ---------------------------------
2515 -- Check_Result_And_Post_State --
2516 ---------------------------------
2518 procedure Check_Result_And_Post_State
2520 Result_Seen : in out Boolean)
2522 procedure Check_Expression (Expr : Node_Id);
2523 -- Perform the 'Result and post-state checks on a given expression
2525 function Is_Function_Result (N : Node_Id) return Traverse_Result;
2526 -- Attempt to find attribute 'Result in a subtree denoted by N
2528 function Is_Trivial_Boolean (N : Node_Id) return Boolean;
2529 -- Determine whether source node N denotes "True" or "False"
2531 function Mentions_Post_State (N : Node_Id) return Boolean;
2532 -- Determine whether a subtree denoted by N mentions any construct that
2533 -- denotes a post-state.
2535 procedure Check_Function_Result is
2536 new Traverse_Proc (Is_Function_Result);
2538 ----------------------
2539 -- Check_Expression --
2540 ----------------------
2542 procedure Check_Expression (Expr : Node_Id) is
2544 if not Is_Trivial_Boolean (Expr) then
2545 Check_Function_Result (Expr);
2547 if not Mentions_Post_State (Expr) then
2548 if Pragma_Name (Prag) = Name_Contract_Cases then
2550 ("contract case refers only to pre-state?T?", Expr);
2552 elsif Pragma_Name (Prag) = Name_Refined_Post then
2554 ("refined postcondition refers only to pre-state?T?",
2559 ("postcondition refers only to pre-state?T?", Prag);
2563 end Check_Expression;
2565 ------------------------
2566 -- Is_Function_Result --
2567 ------------------------
2569 function Is_Function_Result (N : Node_Id) return Traverse_Result is
2571 if Is_Attribute_Result (N) then
2572 Result_Seen := True;
2575 -- Continue the traversal
2580 end Is_Function_Result;
2582 ------------------------
2583 -- Is_Trivial_Boolean --
2584 ------------------------
2586 function Is_Trivial_Boolean (N : Node_Id) return Boolean is
2589 Comes_From_Source (N)
2590 and then Is_Entity_Name (N)
2591 and then (Entity (N) = Standard_True
2592 or else Entity (N) = Standard_False);
2593 end Is_Trivial_Boolean;
2595 -------------------------
2596 -- Mentions_Post_State --
2597 -------------------------
2599 function Mentions_Post_State (N : Node_Id) return Boolean is
2600 Post_State_Seen : Boolean := False;
2602 function Is_Post_State (N : Node_Id) return Traverse_Result;
2603 -- Attempt to find a construct that denotes a post-state. If this is
2604 -- the case, set flag Post_State_Seen.
2610 function Is_Post_State (N : Node_Id) return Traverse_Result is
2614 if Nkind_In (N, N_Explicit_Dereference, N_Function_Call) then
2615 Post_State_Seen := True;
2618 elsif Nkind_In (N, N_Expanded_Name, N_Identifier) then
2621 if No (Ent) or else Ekind (Ent) in Assignable_Kind then
2622 Post_State_Seen := True;
2626 elsif Nkind (N) = N_Attribute_Reference then
2627 if Attribute_Name (N) = Name_Old then
2630 elsif Attribute_Name (N) = Name_Result then
2631 Post_State_Seen := True;
2639 procedure Find_Post_State is new Traverse_Proc (Is_Post_State);
2641 -- Start of processing for Mentions_Post_State
2644 Find_Post_State (N);
2646 return Post_State_Seen;
2647 end Mentions_Post_State;
2651 Expr : constant Node_Id :=
2652 Get_Pragma_Arg (First (Pragma_Argument_Associations (Prag)));
2653 Nam : constant Name_Id := Pragma_Name (Prag);
2656 -- Start of processing for Check_Result_And_Post_State
2659 -- Examine all consequences
2661 if Nam = Name_Contract_Cases then
2662 CCase := First (Component_Associations (Expr));
2663 while Present (CCase) loop
2664 Check_Expression (Expression (CCase));
2669 -- Examine the expression of a postcondition
2671 else pragma Assert (Nam_In (Nam, Name_Postcondition, Name_Refined_Post));
2672 Check_Expression (Expr);
2674 end Check_Result_And_Post_State;
2676 ------------------------------
2677 -- Check_Unprotected_Access --
2678 ------------------------------
2680 procedure Check_Unprotected_Access
2684 Cont_Encl_Typ : Entity_Id;
2685 Pref_Encl_Typ : Entity_Id;
2687 function Enclosing_Protected_Type (Obj : Node_Id) return Entity_Id;
2688 -- Check whether Obj is a private component of a protected object.
2689 -- Return the protected type where the component resides, Empty
2692 function Is_Public_Operation return Boolean;
2693 -- Verify that the enclosing operation is callable from outside the
2694 -- protected object, to minimize false positives.
2696 ------------------------------
2697 -- Enclosing_Protected_Type --
2698 ------------------------------
2700 function Enclosing_Protected_Type (Obj : Node_Id) return Entity_Id is
2702 if Is_Entity_Name (Obj) then
2704 Ent : Entity_Id := Entity (Obj);
2707 -- The object can be a renaming of a private component, use
2708 -- the original record component.
2710 if Is_Prival (Ent) then
2711 Ent := Prival_Link (Ent);
2714 if Is_Protected_Type (Scope (Ent)) then
2720 -- For indexed and selected components, recursively check the prefix
2722 if Nkind_In (Obj, N_Indexed_Component, N_Selected_Component) then
2723 return Enclosing_Protected_Type (Prefix (Obj));
2725 -- The object does not denote a protected component
2730 end Enclosing_Protected_Type;
2732 -------------------------
2733 -- Is_Public_Operation --
2734 -------------------------
2736 function Is_Public_Operation return Boolean is
2743 and then S /= Pref_Encl_Typ
2745 if Scope (S) = Pref_Encl_Typ then
2746 E := First_Entity (Pref_Encl_Typ);
2748 and then E /= First_Private_Entity (Pref_Encl_Typ)
2761 end Is_Public_Operation;
2763 -- Start of processing for Check_Unprotected_Access
2766 if Nkind (Expr) = N_Attribute_Reference
2767 and then Attribute_Name (Expr) = Name_Unchecked_Access
2769 Cont_Encl_Typ := Enclosing_Protected_Type (Context);
2770 Pref_Encl_Typ := Enclosing_Protected_Type (Prefix (Expr));
2772 -- Check whether we are trying to export a protected component to a
2773 -- context with an equal or lower access level.
2775 if Present (Pref_Encl_Typ)
2776 and then No (Cont_Encl_Typ)
2777 and then Is_Public_Operation
2778 and then Scope_Depth (Pref_Encl_Typ) >=
2779 Object_Access_Level (Context)
2782 ("??possible unprotected access to protected data", Expr);
2785 end Check_Unprotected_Access;
2791 procedure Check_VMS (Construct : Node_Id) is
2793 if not OpenVMS_On_Target then
2795 ("this construct is allowed only in Open'V'M'S", Construct);
2799 ------------------------
2800 -- Collect_Interfaces --
2801 ------------------------
2803 procedure Collect_Interfaces
2805 Ifaces_List : out Elist_Id;
2806 Exclude_Parents : Boolean := False;
2807 Use_Full_View : Boolean := True)
2809 procedure Collect (Typ : Entity_Id);
2810 -- Subsidiary subprogram used to traverse the whole list
2811 -- of directly and indirectly implemented interfaces
2817 procedure Collect (Typ : Entity_Id) is
2818 Ancestor : Entity_Id;
2826 -- Handle private types
2829 and then Is_Private_Type (Typ)
2830 and then Present (Full_View (Typ))
2832 Full_T := Full_View (Typ);
2835 -- Include the ancestor if we are generating the whole list of
2836 -- abstract interfaces.
2838 if Etype (Full_T) /= Typ
2840 -- Protect the frontend against wrong sources. For example:
2843 -- type A is tagged null record;
2844 -- type B is new A with private;
2845 -- type C is new A with private;
2847 -- type B is new C with null record;
2848 -- type C is new B with null record;
2851 and then Etype (Full_T) /= T
2853 Ancestor := Etype (Full_T);
2856 if Is_Interface (Ancestor)
2857 and then not Exclude_Parents
2859 Append_Unique_Elmt (Ancestor, Ifaces_List);
2863 -- Traverse the graph of ancestor interfaces
2865 if Is_Non_Empty_List (Abstract_Interface_List (Full_T)) then
2866 Id := First (Abstract_Interface_List (Full_T));
2867 while Present (Id) loop
2868 Iface := Etype (Id);
2870 -- Protect against wrong uses. For example:
2871 -- type I is interface;
2872 -- type O is tagged null record;
2873 -- type Wrong is new I and O with null record; -- ERROR
2875 if Is_Interface (Iface) then
2877 and then Etype (T) /= T
2878 and then Interface_Present_In_Ancestor (Etype (T), Iface)
2883 Append_Unique_Elmt (Iface, Ifaces_List);
2892 -- Start of processing for Collect_Interfaces
2895 pragma Assert (Is_Tagged_Type (T) or else Is_Concurrent_Type (T));
2896 Ifaces_List := New_Elmt_List;
2898 end Collect_Interfaces;
2900 ----------------------------------
2901 -- Collect_Interface_Components --
2902 ----------------------------------
2904 procedure Collect_Interface_Components
2905 (Tagged_Type : Entity_Id;
2906 Components_List : out Elist_Id)
2908 procedure Collect (Typ : Entity_Id);
2909 -- Subsidiary subprogram used to climb to the parents
2915 procedure Collect (Typ : Entity_Id) is
2916 Tag_Comp : Entity_Id;
2917 Parent_Typ : Entity_Id;
2920 -- Handle private types
2922 if Present (Full_View (Etype (Typ))) then
2923 Parent_Typ := Full_View (Etype (Typ));
2925 Parent_Typ := Etype (Typ);
2928 if Parent_Typ /= Typ
2930 -- Protect the frontend against wrong sources. For example:
2933 -- type A is tagged null record;
2934 -- type B is new A with private;
2935 -- type C is new A with private;
2937 -- type B is new C with null record;
2938 -- type C is new B with null record;
2941 and then Parent_Typ /= Tagged_Type
2943 Collect (Parent_Typ);
2946 -- Collect the components containing tags of secondary dispatch
2949 Tag_Comp := Next_Tag_Component (First_Tag_Component (Typ));
2950 while Present (Tag_Comp) loop
2951 pragma Assert (Present (Related_Type (Tag_Comp)));
2952 Append_Elmt (Tag_Comp, Components_List);
2954 Tag_Comp := Next_Tag_Component (Tag_Comp);
2958 -- Start of processing for Collect_Interface_Components
2961 pragma Assert (Ekind (Tagged_Type) = E_Record_Type
2962 and then Is_Tagged_Type (Tagged_Type));
2964 Components_List := New_Elmt_List;
2965 Collect (Tagged_Type);
2966 end Collect_Interface_Components;
2968 -----------------------------
2969 -- Collect_Interfaces_Info --
2970 -----------------------------
2972 procedure Collect_Interfaces_Info
2974 Ifaces_List : out Elist_Id;
2975 Components_List : out Elist_Id;
2976 Tags_List : out Elist_Id)
2978 Comps_List : Elist_Id;
2979 Comp_Elmt : Elmt_Id;
2980 Comp_Iface : Entity_Id;
2981 Iface_Elmt : Elmt_Id;
2984 function Search_Tag (Iface : Entity_Id) return Entity_Id;
2985 -- Search for the secondary tag associated with the interface type
2986 -- Iface that is implemented by T.
2992 function Search_Tag (Iface : Entity_Id) return Entity_Id is
2995 if not Is_CPP_Class (T) then
2996 ADT := Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (T))));
2998 ADT := Next_Elmt (First_Elmt (Access_Disp_Table (T)));
3002 and then Is_Tag (Node (ADT))
3003 and then Related_Type (Node (ADT)) /= Iface
3005 -- Skip secondary dispatch table referencing thunks to user
3006 -- defined primitives covered by this interface.
3008 pragma Assert (Has_Suffix (Node (ADT), 'P'));
3011 -- Skip secondary dispatch tables of Ada types
3013 if not Is_CPP_Class (T) then
3015 -- Skip secondary dispatch table referencing thunks to
3016 -- predefined primitives.
3018 pragma Assert (Has_Suffix (Node (ADT), 'Y'));
3021 -- Skip secondary dispatch table referencing user-defined
3022 -- primitives covered by this interface.
3024 pragma Assert (Has_Suffix (Node (ADT), 'D'));
3027 -- Skip secondary dispatch table referencing predefined
3030 pragma Assert (Has_Suffix (Node (ADT), 'Z'));
3035 pragma Assert (Is_Tag (Node (ADT)));
3039 -- Start of processing for Collect_Interfaces_Info
3042 Collect_Interfaces (T, Ifaces_List);
3043 Collect_Interface_Components (T, Comps_List);
3045 -- Search for the record component and tag associated with each
3046 -- interface type of T.
3048 Components_List := New_Elmt_List;
3049 Tags_List := New_Elmt_List;
3051 Iface_Elmt := First_Elmt (Ifaces_List);
3052 while Present (Iface_Elmt) loop
3053 Iface := Node (Iface_Elmt);
3055 -- Associate the primary tag component and the primary dispatch table
3056 -- with all the interfaces that are parents of T
3058 if Is_Ancestor (Iface, T, Use_Full_View => True) then
3059 Append_Elmt (First_Tag_Component (T), Components_List);
3060 Append_Elmt (Node (First_Elmt (Access_Disp_Table (T))), Tags_List);
3062 -- Otherwise search for the tag component and secondary dispatch
3066 Comp_Elmt := First_Elmt (Comps_List);
3067 while Present (Comp_Elmt) loop
3068 Comp_Iface := Related_Type (Node (Comp_Elmt));
3070 if Comp_Iface = Iface
3071 or else Is_Ancestor (Iface, Comp_Iface, Use_Full_View => True)
3073 Append_Elmt (Node (Comp_Elmt), Components_List);
3074 Append_Elmt (Search_Tag (Comp_Iface), Tags_List);
3078 Next_Elmt (Comp_Elmt);
3080 pragma Assert (Present (Comp_Elmt));
3083 Next_Elmt (Iface_Elmt);
3085 end Collect_Interfaces_Info;
3087 ---------------------
3088 -- Collect_Parents --
3089 ---------------------
3091 procedure Collect_Parents
3093 List : out Elist_Id;
3094 Use_Full_View : Boolean := True)
3096 Current_Typ : Entity_Id := T;
3097 Parent_Typ : Entity_Id;
3100 List := New_Elmt_List;
3102 -- No action if the if the type has no parents
3104 if T = Etype (T) then
3109 Parent_Typ := Etype (Current_Typ);
3111 if Is_Private_Type (Parent_Typ)
3112 and then Present (Full_View (Parent_Typ))
3113 and then Use_Full_View
3115 Parent_Typ := Full_View (Base_Type (Parent_Typ));
3118 Append_Elmt (Parent_Typ, List);
3120 exit when Parent_Typ = Current_Typ;
3121 Current_Typ := Parent_Typ;
3123 end Collect_Parents;
3125 ----------------------------------
3126 -- Collect_Primitive_Operations --
3127 ----------------------------------
3129 function Collect_Primitive_Operations (T : Entity_Id) return Elist_Id is
3130 B_Type : constant Entity_Id := Base_Type (T);
3131 B_Decl : constant Node_Id := Original_Node (Parent (B_Type));
3132 B_Scope : Entity_Id := Scope (B_Type);
3136 Is_Type_In_Pkg : Boolean;
3137 Formal_Derived : Boolean := False;
3140 function Match (E : Entity_Id) return Boolean;
3141 -- True if E's base type is B_Type, or E is of an anonymous access type
3142 -- and the base type of its designated type is B_Type.
3148 function Match (E : Entity_Id) return Boolean is
3149 Etyp : Entity_Id := Etype (E);
3152 if Ekind (Etyp) = E_Anonymous_Access_Type then
3153 Etyp := Designated_Type (Etyp);
3156 return Base_Type (Etyp) = B_Type;
3159 -- Start of processing for Collect_Primitive_Operations
3162 -- For tagged types, the primitive operations are collected as they
3163 -- are declared, and held in an explicit list which is simply returned.
3165 if Is_Tagged_Type (B_Type) then
3166 return Primitive_Operations (B_Type);
3168 -- An untagged generic type that is a derived type inherits the
3169 -- primitive operations of its parent type. Other formal types only
3170 -- have predefined operators, which are not explicitly represented.
3172 elsif Is_Generic_Type (B_Type) then
3173 if Nkind (B_Decl) = N_Formal_Type_Declaration
3174 and then Nkind (Formal_Type_Definition (B_Decl))
3175 = N_Formal_Derived_Type_Definition
3177 Formal_Derived := True;
3179 return New_Elmt_List;
3183 Op_List := New_Elmt_List;
3185 if B_Scope = Standard_Standard then
3186 if B_Type = Standard_String then
3187 Append_Elmt (Standard_Op_Concat, Op_List);
3189 elsif B_Type = Standard_Wide_String then
3190 Append_Elmt (Standard_Op_Concatw, Op_List);
3196 -- Locate the primitive subprograms of the type
3199 -- The primitive operations appear after the base type, except
3200 -- if the derivation happens within the private part of B_Scope
3201 -- and the type is a private type, in which case both the type
3202 -- and some primitive operations may appear before the base
3203 -- type, and the list of candidates starts after the type.
3205 if In_Open_Scopes (B_Scope)
3206 and then Scope (T) = B_Scope
3207 and then In_Private_Part (B_Scope)
3209 Id := Next_Entity (T);
3211 Id := Next_Entity (B_Type);
3214 -- Set flag if this is a type in a package spec
3217 Is_Package_Or_Generic_Package (B_Scope)
3219 Nkind (Parent (Declaration_Node (First_Subtype (T)))) /=
3222 while Present (Id) loop
3224 -- Test whether the result type or any of the parameter types of
3225 -- each subprogram following the type match that type when the
3226 -- type is declared in a package spec, is a derived type, or the
3227 -- subprogram is marked as primitive. (The Is_Primitive test is
3228 -- needed to find primitives of nonderived types in declarative
3229 -- parts that happen to override the predefined "=" operator.)
3231 -- Note that generic formal subprograms are not considered to be
3232 -- primitive operations and thus are never inherited.
3234 if Is_Overloadable (Id)
3235 and then (Is_Type_In_Pkg
3236 or else Is_Derived_Type (B_Type)
3237 or else Is_Primitive (Id))
3238 and then Nkind (Parent (Parent (Id)))
3239 not in N_Formal_Subprogram_Declaration
3247 Formal := First_Formal (Id);
3248 while Present (Formal) loop
3249 if Match (Formal) then
3254 Next_Formal (Formal);
3258 -- For a formal derived type, the only primitives are the ones
3259 -- inherited from the parent type. Operations appearing in the
3260 -- package declaration are not primitive for it.
3263 and then (not Formal_Derived
3264 or else Present (Alias (Id)))
3266 -- In the special case of an equality operator aliased to
3267 -- an overriding dispatching equality belonging to the same
3268 -- type, we don't include it in the list of primitives.
3269 -- This avoids inheriting multiple equality operators when
3270 -- deriving from untagged private types whose full type is
3271 -- tagged, which can otherwise cause ambiguities. Note that
3272 -- this should only happen for this kind of untagged parent
3273 -- type, since normally dispatching operations are inherited
3274 -- using the type's Primitive_Operations list.
3276 if Chars (Id) = Name_Op_Eq
3277 and then Is_Dispatching_Operation (Id)
3278 and then Present (Alias (Id))
3279 and then Present (Overridden_Operation (Alias (Id)))
3280 and then Base_Type (Etype (First_Entity (Id))) =
3281 Base_Type (Etype (First_Entity (Alias (Id))))
3285 -- Include the subprogram in the list of primitives
3288 Append_Elmt (Id, Op_List);
3295 -- For a type declared in System, some of its operations may
3296 -- appear in the target-specific extension to System.
3299 and then B_Scope = RTU_Entity (System)
3300 and then Present_System_Aux
3302 B_Scope := System_Aux_Id;
3303 Id := First_Entity (System_Aux_Id);
3309 end Collect_Primitive_Operations;
3311 -----------------------------------
3312 -- Compile_Time_Constraint_Error --
3313 -----------------------------------
3315 function Compile_Time_Constraint_Error
3318 Ent : Entity_Id := Empty;
3319 Loc : Source_Ptr := No_Location;
3320 Warn : Boolean := False) return Node_Id
3322 Msgc : String (1 .. Msg'Length + 3);
3323 -- Copy of message, with room for possible ?? or << and ! at end
3333 -- If this is a warning, convert it into an error if we are in code
3334 -- subject to SPARK_Mode being set ON.
3336 Error_Msg_Warn := SPARK_Mode /= On;
3338 -- A static constraint error in an instance body is not a fatal error.
3339 -- we choose to inhibit the message altogether, because there is no
3340 -- obvious node (for now) on which to post it. On the other hand the
3341 -- offending node must be replaced with a constraint_error in any case.
3343 -- No messages are generated if we already posted an error on this node
3345 if not Error_Posted (N) then
3346 if Loc /= No_Location then
3352 -- Copy message to Msgc, converting any ? in the message into
3353 -- < instead, so that we have an error in GNATprove mode.
3357 for J in 1 .. Msgl loop
3358 if Msg (J) = '?' and then (J = 1 or else Msg (J) /= ''') then
3361 Msgc (J) := Msg (J);
3365 -- Message is a warning, even in Ada 95 case
3367 if Msg (Msg'Last) = '?' or else Msg (Msg'Last) = '<' then
3370 -- In Ada 83, all messages are warnings. In the private part and
3371 -- the body of an instance, constraint_checks are only warnings.
3372 -- We also make this a warning if the Warn parameter is set.
3375 or else (Ada_Version = Ada_83 and then Comes_From_Source (N))
3383 elsif In_Instance_Not_Visible then
3390 -- Otherwise we have a real error message (Ada 95 static case)
3391 -- and we make this an unconditional message. Note that in the
3392 -- warning case we do not make the message unconditional, it seems
3393 -- quite reasonable to delete messages like this (about exceptions
3394 -- that will be raised) in dead code.
3402 -- Should we generate a warning? The answer is not quite yes. The
3403 -- very annoying exception occurs in the case of a short circuit
3404 -- operator where the left operand is static and decisive. Climb
3405 -- parents to see if that is the case we have here. Conditional
3406 -- expressions with decisive conditions are a similar situation.
3414 -- And then with False as left operand
3416 if Nkind (P) = N_And_Then
3417 and then Compile_Time_Known_Value (Left_Opnd (P))
3418 and then Is_False (Expr_Value (Left_Opnd (P)))
3423 -- OR ELSE with True as left operand
3425 elsif Nkind (P) = N_Or_Else
3426 and then Compile_Time_Known_Value (Left_Opnd (P))
3427 and then Is_True (Expr_Value (Left_Opnd (P)))
3434 elsif Nkind (P) = N_If_Expression then
3436 Cond : constant Node_Id := First (Expressions (P));
3437 Texp : constant Node_Id := Next (Cond);
3438 Fexp : constant Node_Id := Next (Texp);
3441 if Compile_Time_Known_Value (Cond) then
3443 -- Condition is True and we are in the right operand
3445 if Is_True (Expr_Value (Cond))
3446 and then OldP = Fexp
3451 -- Condition is False and we are in the left operand
3453 elsif Is_False (Expr_Value (Cond))
3454 and then OldP = Texp
3462 -- Special case for component association in aggregates, where
3463 -- we want to keep climbing up to the parent aggregate.
3465 elsif Nkind (P) = N_Component_Association
3466 and then Nkind (Parent (P)) = N_Aggregate
3470 -- Keep going if within subexpression
3473 exit when Nkind (P) not in N_Subexpr;
3478 Error_Msg_Warn := SPARK_Mode /= On;
3480 if Present (Ent) then
3481 Error_Msg_NEL (Msgc (1 .. Msgl), N, Ent, Eloc);
3483 Error_Msg_NEL (Msgc (1 .. Msgl), N, Etype (N), Eloc);
3488 -- Check whether the context is an Init_Proc
3490 if Inside_Init_Proc then
3492 Conc_Typ : constant Entity_Id :=
3493 Corresponding_Concurrent_Type
3494 (Entity (Parameter_Type (First
3495 (Parameter_Specifications
3496 (Parent (Current_Scope))))));
3499 -- Don't complain if the corresponding concurrent type
3500 -- doesn't come from source (i.e. a single task/protected
3503 if Present (Conc_Typ)
3504 and then not Comes_From_Source (Conc_Typ)
3507 ("\& [<<", N, Standard_Constraint_Error, Eloc);
3510 if GNATprove_Mode then
3512 ("\& would have been raised for objects of this "
3513 & "type", N, Standard_Constraint_Error, Eloc);
3516 ("\& will be raised for objects of this type??",
3517 N, Standard_Constraint_Error, Eloc);
3523 Error_Msg_NEL ("\& [<<", N, Standard_Constraint_Error, Eloc);
3527 Error_Msg ("\static expression fails Constraint_Check", Eloc);
3528 Set_Error_Posted (N);
3534 end Compile_Time_Constraint_Error;
3536 -----------------------
3537 -- Conditional_Delay --
3538 -----------------------
3540 procedure Conditional_Delay (New_Ent, Old_Ent : Entity_Id) is
3542 if Has_Delayed_Freeze (Old_Ent) and then not Is_Frozen (Old_Ent) then
3543 Set_Has_Delayed_Freeze (New_Ent);
3545 end Conditional_Delay;
3547 ----------------------------
3548 -- Contains_Refined_State --
3549 ----------------------------
3551 function Contains_Refined_State (Prag : Node_Id) return Boolean is
3552 function Has_State_In_Dependency (List : Node_Id) return Boolean;
3553 -- Determine whether a dependency list mentions a state with a visible
3556 function Has_State_In_Global (List : Node_Id) return Boolean;
3557 -- Determine whether a global list mentions a state with a visible
3560 function Is_Refined_State (Item : Node_Id) return Boolean;
3561 -- Determine whether Item is a reference to an abstract state with a
3562 -- visible refinement.
3564 -----------------------------
3565 -- Has_State_In_Dependency --
3566 -----------------------------
3568 function Has_State_In_Dependency (List : Node_Id) return Boolean is
3573 -- A null dependency list does not mention any states
3575 if Nkind (List) = N_Null then
3578 -- Dependency clauses appear as component associations of an
3581 elsif Nkind (List) = N_Aggregate
3582 and then Present (Component_Associations (List))
3584 Clause := First (Component_Associations (List));
3585 while Present (Clause) loop
3587 -- Inspect the outputs of a dependency clause
3589 Output := First (Choices (Clause));
3590 while Present (Output) loop
3591 if Is_Refined_State (Output) then
3598 -- Inspect the outputs of a dependency clause
3600 if Is_Refined_State (Expression (Clause)) then
3607 -- If we get here, then none of the dependency clauses mention a
3608 -- state with visible refinement.
3612 -- An illegal pragma managed to sneak in
3615 raise Program_Error;
3617 end Has_State_In_Dependency;
3619 -------------------------
3620 -- Has_State_In_Global --
3621 -------------------------
3623 function Has_State_In_Global (List : Node_Id) return Boolean is
3627 -- A null global list does not mention any states
3629 if Nkind (List) = N_Null then
3632 -- Simple global list or moded global list declaration
3634 elsif Nkind (List) = N_Aggregate then
3636 -- The declaration of a simple global list appear as a collection
3639 if Present (Expressions (List)) then
3640 Item := First (Expressions (List));
3641 while Present (Item) loop
3642 if Is_Refined_State (Item) then
3649 -- The declaration of a moded global list appears as a collection
3650 -- of component associations where individual choices denote
3654 Item := First (Component_Associations (List));
3655 while Present (Item) loop
3656 if Has_State_In_Global (Expression (Item)) then
3664 -- If we get here, then the simple/moded global list did not
3665 -- mention any states with a visible refinement.
3669 -- Single global item declaration
3671 elsif Is_Entity_Name (List) then
3672 return Is_Refined_State (List);
3674 -- An illegal pragma managed to sneak in
3677 raise Program_Error;
3679 end Has_State_In_Global;
3681 ----------------------
3682 -- Is_Refined_State --
3683 ----------------------
3685 function Is_Refined_State (Item : Node_Id) return Boolean is
3687 Item_Id : Entity_Id;
3690 if Nkind (Item) = N_Null then
3693 -- States cannot be subject to attribute 'Result. This case arises
3694 -- in dependency relations.
3696 elsif Nkind (Item) = N_Attribute_Reference
3697 and then Attribute_Name (Item) = Name_Result
3701 -- Multiple items appear as an aggregate. This case arises in
3702 -- dependency relations.
3704 elsif Nkind (Item) = N_Aggregate
3705 and then Present (Expressions (Item))
3707 Elmt := First (Expressions (Item));
3708 while Present (Elmt) loop
3709 if Is_Refined_State (Elmt) then
3716 -- If we get here, then none of the inputs or outputs reference a
3717 -- state with visible refinement.
3724 Item_Id := Entity_Of (Item);
3727 Ekind (Item_Id) = E_Abstract_State
3728 and then Has_Visible_Refinement (Item_Id);
3730 end Is_Refined_State;
3734 Arg : constant Node_Id :=
3735 Get_Pragma_Arg (First (Pragma_Argument_Associations (Prag)));
3736 Nam : constant Name_Id := Pragma_Name (Prag);
3738 -- Start of processing for Contains_Refined_State
3741 if Nam = Name_Depends then
3742 return Has_State_In_Dependency (Arg);
3744 else pragma Assert (Nam = Name_Global);
3745 return Has_State_In_Global (Arg);
3747 end Contains_Refined_State;
3749 -------------------------
3750 -- Copy_Component_List --
3751 -------------------------
3753 function Copy_Component_List
3755 Loc : Source_Ptr) return List_Id
3758 Comps : constant List_Id := New_List;
3761 Comp := First_Component (Underlying_Type (R_Typ));
3762 while Present (Comp) loop
3763 if Comes_From_Source (Comp) then
3765 Comp_Decl : constant Node_Id := Declaration_Node (Comp);
3768 Make_Component_Declaration (Loc,
3769 Defining_Identifier =>
3770 Make_Defining_Identifier (Loc, Chars (Comp)),
3771 Component_Definition =>
3773 (Component_Definition (Comp_Decl), New_Sloc => Loc)));
3777 Next_Component (Comp);
3781 end Copy_Component_List;
3783 -------------------------
3784 -- Copy_Parameter_List --
3785 -------------------------
3787 function Copy_Parameter_List (Subp_Id : Entity_Id) return List_Id is
3788 Loc : constant Source_Ptr := Sloc (Subp_Id);
3793 if No (First_Formal (Subp_Id)) then
3797 Formal := First_Formal (Subp_Id);
3798 while Present (Formal) loop
3800 (Make_Parameter_Specification (Loc,
3801 Defining_Identifier =>
3802 Make_Defining_Identifier (Sloc (Formal),
3803 Chars => Chars (Formal)),
3804 In_Present => In_Present (Parent (Formal)),
3805 Out_Present => Out_Present (Parent (Formal)),
3807 New_Reference_To (Etype (Formal), Loc),
3809 New_Copy_Tree (Expression (Parent (Formal)))),
3812 Next_Formal (Formal);
3817 end Copy_Parameter_List;
3819 --------------------------------
3820 -- Corresponding_Generic_Type --
3821 --------------------------------
3823 function Corresponding_Generic_Type (T : Entity_Id) return Entity_Id is
3829 if not Is_Generic_Actual_Type (T) then
3832 -- If the actual is the actual of an enclosing instance, resolution
3833 -- was correct in the generic.
3835 elsif Nkind (Parent (T)) = N_Subtype_Declaration
3836 and then Is_Entity_Name (Subtype_Indication (Parent (T)))
3838 Is_Generic_Actual_Type (Entity (Subtype_Indication (Parent (T))))
3845 if Is_Wrapper_Package (Inst) then
3846 Inst := Related_Instance (Inst);
3851 (Specification (Unit_Declaration_Node (Inst)));
3853 -- Generic actual has the same name as the corresponding formal
3855 Typ := First_Entity (Gen);
3856 while Present (Typ) loop
3857 if Chars (Typ) = Chars (T) then
3866 end Corresponding_Generic_Type;
3868 --------------------
3869 -- Current_Entity --
3870 --------------------
3872 -- The currently visible definition for a given identifier is the
3873 -- one most chained at the start of the visibility chain, i.e. the
3874 -- one that is referenced by the Node_Id value of the name of the
3875 -- given identifier.
3877 function Current_Entity (N : Node_Id) return Entity_Id is
3879 return Get_Name_Entity_Id (Chars (N));
3882 -----------------------------
3883 -- Current_Entity_In_Scope --
3884 -----------------------------
3886 function Current_Entity_In_Scope (N : Node_Id) return Entity_Id is
3888 CS : constant Entity_Id := Current_Scope;
3890 Transient_Case : constant Boolean := Scope_Is_Transient;
3893 E := Get_Name_Entity_Id (Chars (N));
3895 and then Scope (E) /= CS
3896 and then (not Transient_Case or else Scope (E) /= Scope (CS))
3902 end Current_Entity_In_Scope;
3908 function Current_Scope return Entity_Id is
3910 if Scope_Stack.Last = -1 then
3911 return Standard_Standard;
3914 C : constant Entity_Id :=
3915 Scope_Stack.Table (Scope_Stack.Last).Entity;
3920 return Standard_Standard;
3926 ------------------------
3927 -- Current_Subprogram --
3928 ------------------------
3930 function Current_Subprogram return Entity_Id is
3931 Scop : constant Entity_Id := Current_Scope;
3933 if Is_Subprogram (Scop) or else Is_Generic_Subprogram (Scop) then
3936 return Enclosing_Subprogram (Scop);
3938 end Current_Subprogram;
3940 ----------------------------------
3941 -- Deepest_Type_Access_Level --
3942 ----------------------------------
3944 function Deepest_Type_Access_Level (Typ : Entity_Id) return Uint is
3946 if Ekind (Typ) = E_Anonymous_Access_Type
3947 and then not Is_Local_Anonymous_Access (Typ)
3948 and then Nkind (Associated_Node_For_Itype (Typ)) = N_Object_Declaration
3950 -- Typ is the type of an Ada 2012 stand-alone object of an anonymous
3954 Scope_Depth (Enclosing_Dynamic_Scope
3955 (Defining_Identifier
3956 (Associated_Node_For_Itype (Typ))));
3958 -- For generic formal type, return Int'Last (infinite).
3959 -- See comment preceding Is_Generic_Type call in Type_Access_Level.
3961 elsif Is_Generic_Type (Root_Type (Typ)) then
3962 return UI_From_Int (Int'Last);
3965 return Type_Access_Level (Typ);
3967 end Deepest_Type_Access_Level;
3969 ----------------------------
3970 -- Default_Initialization --
3971 ----------------------------
3973 function Default_Initialization
3974 (Typ : Entity_Id) return Default_Initialization_Kind
3977 Init : Default_Initialization_Kind;
3979 FDI : Boolean := False;
3980 NDI : Boolean := False;
3981 -- Two flags used to designate whether a record type has at least one
3982 -- fully default initialized component and/or one not fully default
3983 -- initialized component.
3986 -- Access types are always fully default initialized
3988 if Is_Access_Type (Typ) then
3989 return Full_Default_Initialization;
3991 -- An array type subject to aspect/pragma Default_Component_Value is
3992 -- fully default initialized. Otherwise its initialization status is
3993 -- that of its component type.
3995 elsif Is_Array_Type (Typ) then
3996 if Present (Default_Aspect_Component_Value (Base_Type (Typ))) then
3997 return Full_Default_Initialization;
3999 return Default_Initialization (Component_Type (Typ));
4002 -- The initialization status of a private type depends on its full view
4004 elsif Is_Private_Type (Typ) and then Present (Full_View (Typ)) then
4005 return Default_Initialization (Full_View (Typ));
4007 -- Record and protected types offer several initialization options
4008 -- depending on their components (if any).
4010 elsif Is_Record_Type (Typ) or else Is_Protected_Type (Typ) then
4011 Comp := First_Component (Typ);
4013 -- Inspect all components
4015 if Present (Comp) then
4016 while Present (Comp) loop
4018 -- Do not process internally generated components except for
4019 -- _parent which represents the ancestor portion of a derived
4022 if Comes_From_Source (Comp)
4023 or else Chars (Comp) = Name_uParent
4025 Init := Default_Initialization (Base_Type (Etype (Comp)));
4027 -- A component with mixed initialization renders the whole
4028 -- record/protected type mixed.
4030 if Init = Mixed_Initialization then
4031 return Mixed_Initialization;
4033 -- The component is fully default initialized when its type
4034 -- is fully default initialized or when the component has an
4035 -- initialization expression. Note that this has precedence
4036 -- given that the component type may lack initialization.
4038 elsif Init = Full_Default_Initialization
4039 or else Present (Expression (Parent (Comp)))
4043 -- Components with no possible initialization are ignored
4045 elsif Init = No_Possible_Initialization then
4048 -- The component has no full default initialization
4055 Next_Component (Comp);
4058 -- Detect a mixed case of initialization
4061 return Mixed_Initialization;
4064 return Full_Default_Initialization;
4067 return No_Default_Initialization;
4069 -- The type either has no components or they are all internally
4073 return No_Possible_Initialization;
4076 -- The record type is null, there is nothing to initialize
4079 return No_Possible_Initialization;
4082 -- A scalar type subject to aspect/pragma Default_Value is fully default
4085 elsif Is_Scalar_Type (Typ)
4086 and then Present (Default_Aspect_Value (Base_Type (Typ)))
4088 return Full_Default_Initialization;
4090 -- Task types are always fully default initialized
4092 elsif Is_Task_Type (Typ) then
4093 return Full_Default_Initialization;
4096 -- The type has no full default initialization
4098 return No_Default_Initialization;
4099 end Default_Initialization;
4101 ---------------------
4102 -- Defining_Entity --
4103 ---------------------
4105 function Defining_Entity (N : Node_Id) return Entity_Id is
4106 K : constant Node_Kind := Nkind (N);
4107 Err : Entity_Id := Empty;
4112 N_Subprogram_Declaration |
4113 N_Abstract_Subprogram_Declaration |
4115 N_Package_Declaration |
4116 N_Subprogram_Renaming_Declaration |
4117 N_Subprogram_Body_Stub |
4118 N_Generic_Subprogram_Declaration |
4119 N_Generic_Package_Declaration |
4120 N_Formal_Subprogram_Declaration |
4121 N_Expression_Function
4123 return Defining_Entity (Specification (N));
4126 N_Component_Declaration |
4127 N_Defining_Program_Unit_Name |
4128 N_Discriminant_Specification |
4130 N_Entry_Declaration |
4131 N_Entry_Index_Specification |
4132 N_Exception_Declaration |
4133 N_Exception_Renaming_Declaration |
4134 N_Formal_Object_Declaration |
4135 N_Formal_Package_Declaration |
4136 N_Formal_Type_Declaration |
4137 N_Full_Type_Declaration |
4138 N_Implicit_Label_Declaration |
4139 N_Incomplete_Type_Declaration |
4140 N_Loop_Parameter_Specification |
4141 N_Number_Declaration |
4142 N_Object_Declaration |
4143 N_Object_Renaming_Declaration |
4144 N_Package_Body_Stub |
4145 N_Parameter_Specification |
4146 N_Private_Extension_Declaration |
4147 N_Private_Type_Declaration |
4149 N_Protected_Body_Stub |
4150 N_Protected_Type_Declaration |
4151 N_Single_Protected_Declaration |
4152 N_Single_Task_Declaration |
4153 N_Subtype_Declaration |
4156 N_Task_Type_Declaration
4158 return Defining_Identifier (N);
4161 return Defining_Entity (Proper_Body (N));
4164 N_Function_Instantiation |
4165 N_Function_Specification |
4166 N_Generic_Function_Renaming_Declaration |
4167 N_Generic_Package_Renaming_Declaration |
4168 N_Generic_Procedure_Renaming_Declaration |
4170 N_Package_Instantiation |
4171 N_Package_Renaming_Declaration |
4172 N_Package_Specification |
4173 N_Procedure_Instantiation |
4174 N_Procedure_Specification
4177 Nam : constant Node_Id := Defining_Unit_Name (N);
4180 if Nkind (Nam) in N_Entity then
4183 -- For Error, make up a name and attach to declaration
4184 -- so we can continue semantic analysis
4186 elsif Nam = Error then
4187 Err := Make_Temporary (Sloc (N), 'T');
4188 Set_Defining_Unit_Name (N, Err);
4191 -- If not an entity, get defining identifier
4194 return Defining_Identifier (Nam);
4198 when N_Block_Statement =>
4199 return Entity (Identifier (N));
4202 raise Program_Error;
4205 end Defining_Entity;
4207 --------------------------
4208 -- Denotes_Discriminant --
4209 --------------------------
4211 function Denotes_Discriminant
4213 Check_Concurrent : Boolean := False) return Boolean
4217 if not Is_Entity_Name (N)
4218 or else No (Entity (N))
4225 -- If we are checking for a protected type, the discriminant may have
4226 -- been rewritten as the corresponding discriminal of the original type
4227 -- or of the corresponding concurrent record, depending on whether we
4228 -- are in the spec or body of the protected type.
4230 return Ekind (E) = E_Discriminant
4233 and then Ekind (E) = E_In_Parameter
4234 and then Present (Discriminal_Link (E))
4236 (Is_Concurrent_Type (Scope (Discriminal_Link (E)))
4238 Is_Concurrent_Record_Type (Scope (Discriminal_Link (E)))));
4240 end Denotes_Discriminant;
4242 -------------------------
4243 -- Denotes_Same_Object --
4244 -------------------------
4246 function Denotes_Same_Object (A1, A2 : Node_Id) return Boolean is
4247 Obj1 : Node_Id := A1;
4248 Obj2 : Node_Id := A2;
4250 function Has_Prefix (N : Node_Id) return Boolean;
4251 -- Return True if N has attribute Prefix
4253 function Is_Renaming (N : Node_Id) return Boolean;
4254 -- Return true if N names a renaming entity
4256 function Is_Valid_Renaming (N : Node_Id) return Boolean;
4257 -- For renamings, return False if the prefix of any dereference within
4258 -- the renamed object_name is a variable, or any expression within the
4259 -- renamed object_name contains references to variables or calls on
4260 -- nonstatic functions; otherwise return True (RM 6.4.1(6.10/3))
4266 function Has_Prefix (N : Node_Id) return Boolean is
4270 N_Attribute_Reference,
4272 N_Explicit_Dereference,
4273 N_Indexed_Component,
4275 N_Selected_Component,
4283 function Is_Renaming (N : Node_Id) return Boolean is
4285 return Is_Entity_Name (N)
4286 and then Present (Renamed_Entity (Entity (N)));
4289 -----------------------
4290 -- Is_Valid_Renaming --
4291 -----------------------
4293 function Is_Valid_Renaming (N : Node_Id) return Boolean is
4295 function Check_Renaming (N : Node_Id) return Boolean;
4296 -- Recursive function used to traverse all the prefixes of N
4298 function Check_Renaming (N : Node_Id) return Boolean is
4301 and then not Check_Renaming (Renamed_Entity (Entity (N)))
4306 if Nkind (N) = N_Indexed_Component then
4311 Indx := First (Expressions (N));
4312 while Present (Indx) loop
4313 if not Is_OK_Static_Expression (Indx) then
4322 if Has_Prefix (N) then
4324 P : constant Node_Id := Prefix (N);
4327 if Nkind (N) = N_Explicit_Dereference
4328 and then Is_Variable (P)
4332 elsif Is_Entity_Name (P)
4333 and then Ekind (Entity (P)) = E_Function
4337 elsif Nkind (P) = N_Function_Call then
4341 -- Recursion to continue traversing the prefix of the
4342 -- renaming expression
4344 return Check_Renaming (P);
4351 -- Start of processing for Is_Valid_Renaming
4354 return Check_Renaming (N);
4355 end Is_Valid_Renaming;
4357 -- Start of processing for Denotes_Same_Object
4360 -- Both names statically denote the same stand-alone object or parameter
4361 -- (RM 6.4.1(6.5/3))
4363 if Is_Entity_Name (Obj1)
4364 and then Is_Entity_Name (Obj2)
4365 and then Entity (Obj1) = Entity (Obj2)
4370 -- For renamings, the prefix of any dereference within the renamed
4371 -- object_name is not a variable, and any expression within the
4372 -- renamed object_name contains no references to variables nor
4373 -- calls on nonstatic functions (RM 6.4.1(6.10/3)).
4375 if Is_Renaming (Obj1) then
4376 if Is_Valid_Renaming (Obj1) then
4377 Obj1 := Renamed_Entity (Entity (Obj1));
4383 if Is_Renaming (Obj2) then
4384 if Is_Valid_Renaming (Obj2) then
4385 Obj2 := Renamed_Entity (Entity (Obj2));
4391 -- No match if not same node kind (such cases are handled by
4392 -- Denotes_Same_Prefix)
4394 if Nkind (Obj1) /= Nkind (Obj2) then
4397 -- After handling valid renamings, one of the two names statically
4398 -- denoted a renaming declaration whose renamed object_name is known
4399 -- to denote the same object as the other (RM 6.4.1(6.10/3))
4401 elsif Is_Entity_Name (Obj1) then
4402 if Is_Entity_Name (Obj2) then
4403 return Entity (Obj1) = Entity (Obj2);
4408 -- Both names are selected_components, their prefixes are known to
4409 -- denote the same object, and their selector_names denote the same
4410 -- component (RM 6.4.1(6.6/3)
4412 elsif Nkind (Obj1) = N_Selected_Component then
4413 return Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2))
4415 Entity (Selector_Name (Obj1)) = Entity (Selector_Name (Obj2));
4417 -- Both names are dereferences and the dereferenced names are known to
4418 -- denote the same object (RM 6.4.1(6.7/3))
4420 elsif Nkind (Obj1) = N_Explicit_Dereference then
4421 return Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2));
4423 -- Both names are indexed_components, their prefixes are known to denote
4424 -- the same object, and each of the pairs of corresponding index values
4425 -- are either both static expressions with the same static value or both
4426 -- names that are known to denote the same object (RM 6.4.1(6.8/3))
4428 elsif Nkind (Obj1) = N_Indexed_Component then
4429 if not Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2)) then
4437 Indx1 := First (Expressions (Obj1));
4438 Indx2 := First (Expressions (Obj2));
4439 while Present (Indx1) loop
4441 -- Indexes must denote the same static value or same object
4443 if Is_OK_Static_Expression (Indx1) then
4444 if not Is_OK_Static_Expression (Indx2) then
4447 elsif Expr_Value (Indx1) /= Expr_Value (Indx2) then
4451 elsif not Denotes_Same_Object (Indx1, Indx2) then
4463 -- Both names are slices, their prefixes are known to denote the same
4464 -- object, and the two slices have statically matching index constraints
4465 -- (RM 6.4.1(6.9/3))
4467 elsif Nkind (Obj1) = N_Slice
4468 and then Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2))
4471 Lo1, Lo2, Hi1, Hi2 : Node_Id;
4474 Get_Index_Bounds (Etype (Obj1), Lo1, Hi1);
4475 Get_Index_Bounds (Etype (Obj2), Lo2, Hi2);
4477 -- Check whether bounds are statically identical. There is no
4478 -- attempt to detect partial overlap of slices.
4480 return Denotes_Same_Object (Lo1, Lo2)
4481 and then Denotes_Same_Object (Hi1, Hi2);
4484 -- In the recursion, literals appear as indexes.
4486 elsif Nkind (Obj1) = N_Integer_Literal
4487 and then Nkind (Obj2) = N_Integer_Literal
4489 return Intval (Obj1) = Intval (Obj2);
4494 end Denotes_Same_Object;
4496 -------------------------
4497 -- Denotes_Same_Prefix --
4498 -------------------------
4500 function Denotes_Same_Prefix (A1, A2 : Node_Id) return Boolean is
4503 if Is_Entity_Name (A1) then
4504 if Nkind_In (A2, N_Selected_Component, N_Indexed_Component)
4505 and then not Is_Access_Type (Etype (A1))
4507 return Denotes_Same_Object (A1, Prefix (A2))
4508 or else Denotes_Same_Prefix (A1, Prefix (A2));
4513 elsif Is_Entity_Name (A2) then
4514 return Denotes_Same_Prefix (A1 => A2, A2 => A1);
4516 elsif Nkind_In (A1, N_Selected_Component, N_Indexed_Component, N_Slice)
4518 Nkind_In (A2, N_Selected_Component, N_Indexed_Component, N_Slice)
4521 Root1, Root2 : Node_Id;
4522 Depth1, Depth2 : Int := 0;
4525 Root1 := Prefix (A1);
4526 while not Is_Entity_Name (Root1) loop
4528 (Root1, N_Selected_Component, N_Indexed_Component)
4532 Root1 := Prefix (Root1);
4535 Depth1 := Depth1 + 1;
4538 Root2 := Prefix (A2);
4539 while not Is_Entity_Name (Root2) loop
4541 (Root2, N_Selected_Component, N_Indexed_Component)
4545 Root2 := Prefix (Root2);
4548 Depth2 := Depth2 + 1;
4551 -- If both have the same depth and they do not denote the same
4552 -- object, they are disjoint and no warning is needed.
4554 if Depth1 = Depth2 then
4557 elsif Depth1 > Depth2 then
4558 Root1 := Prefix (A1);
4559 for I in 1 .. Depth1 - Depth2 - 1 loop
4560 Root1 := Prefix (Root1);
4563 return Denotes_Same_Object (Root1, A2);
4566 Root2 := Prefix (A2);
4567 for I in 1 .. Depth2 - Depth1 - 1 loop
4568 Root2 := Prefix (Root2);
4571 return Denotes_Same_Object (A1, Root2);
4578 end Denotes_Same_Prefix;
4580 ----------------------
4581 -- Denotes_Variable --
4582 ----------------------
4584 function Denotes_Variable (N : Node_Id) return Boolean is
4586 return Is_Variable (N) and then Paren_Count (N) = 0;
4587 end Denotes_Variable;
4589 -----------------------------
4590 -- Depends_On_Discriminant --
4591 -----------------------------
4593 function Depends_On_Discriminant (N : Node_Id) return Boolean is
4598 Get_Index_Bounds (N, L, H);
4599 return Denotes_Discriminant (L) or else Denotes_Discriminant (H);
4600 end Depends_On_Discriminant;
4602 -------------------------
4603 -- Designate_Same_Unit --
4604 -------------------------
4606 function Designate_Same_Unit
4608 Name2 : Node_Id) return Boolean
4610 K1 : constant Node_Kind := Nkind (Name1);
4611 K2 : constant Node_Kind := Nkind (Name2);
4613 function Prefix_Node (N : Node_Id) return Node_Id;
4614 -- Returns the parent unit name node of a defining program unit name
4615 -- or the prefix if N is a selected component or an expanded name.
4617 function Select_Node (N : Node_Id) return Node_Id;
4618 -- Returns the defining identifier node of a defining program unit
4619 -- name or the selector node if N is a selected component or an
4626 function Prefix_Node (N : Node_Id) return Node_Id is
4628 if Nkind (N) = N_Defining_Program_Unit_Name then
4640 function Select_Node (N : Node_Id) return Node_Id is
4642 if Nkind (N) = N_Defining_Program_Unit_Name then
4643 return Defining_Identifier (N);
4646 return Selector_Name (N);
4650 -- Start of processing for Designate_Next_Unit
4653 if (K1 = N_Identifier or else
4654 K1 = N_Defining_Identifier)
4656 (K2 = N_Identifier or else
4657 K2 = N_Defining_Identifier)
4659 return Chars (Name1) = Chars (Name2);
4662 (K1 = N_Expanded_Name or else
4663 K1 = N_Selected_Component or else
4664 K1 = N_Defining_Program_Unit_Name)
4666 (K2 = N_Expanded_Name or else
4667 K2 = N_Selected_Component or else
4668 K2 = N_Defining_Program_Unit_Name)
4671 (Chars (Select_Node (Name1)) = Chars (Select_Node (Name2)))
4673 Designate_Same_Unit (Prefix_Node (Name1), Prefix_Node (Name2));
4678 end Designate_Same_Unit;
4680 ------------------------------------------
4681 -- function Dynamic_Accessibility_Level --
4682 ------------------------------------------
4684 function Dynamic_Accessibility_Level (Expr : Node_Id) return Node_Id is
4686 Loc : constant Source_Ptr := Sloc (Expr);
4688 function Make_Level_Literal (Level : Uint) return Node_Id;
4689 -- Construct an integer literal representing an accessibility level
4690 -- with its type set to Natural.
4692 ------------------------
4693 -- Make_Level_Literal --
4694 ------------------------
4696 function Make_Level_Literal (Level : Uint) return Node_Id is
4697 Result : constant Node_Id := Make_Integer_Literal (Loc, Level);
4699 Set_Etype (Result, Standard_Natural);
4701 end Make_Level_Literal;
4703 -- Start of processing for Dynamic_Accessibility_Level
4706 if Is_Entity_Name (Expr) then
4709 if Present (Renamed_Object (E)) then
4710 return Dynamic_Accessibility_Level (Renamed_Object (E));
4713 if Is_Formal (E) or else Ekind_In (E, E_Variable, E_Constant) then
4714 if Present (Extra_Accessibility (E)) then
4715 return New_Occurrence_Of (Extra_Accessibility (E), Loc);
4720 -- Unimplemented: Ptr.all'Access, where Ptr has Extra_Accessibility ???
4722 case Nkind (Expr) is
4724 -- For access discriminant, the level of the enclosing object
4726 when N_Selected_Component =>
4727 if Ekind (Entity (Selector_Name (Expr))) = E_Discriminant
4728 and then Ekind (Etype (Entity (Selector_Name (Expr)))) =
4729 E_Anonymous_Access_Type
4731 return Make_Level_Literal (Object_Access_Level (Expr));
4734 when N_Attribute_Reference =>
4735 case Get_Attribute_Id (Attribute_Name (Expr)) is
4737 -- For X'Access, the level of the prefix X
4739 when Attribute_Access =>
4740 return Make_Level_Literal
4741 (Object_Access_Level (Prefix (Expr)));
4743 -- Treat the unchecked attributes as library-level
4745 when Attribute_Unchecked_Access |
4746 Attribute_Unrestricted_Access =>
4747 return Make_Level_Literal (Scope_Depth (Standard_Standard));
4749 -- No other access-valued attributes
4752 raise Program_Error;
4757 -- Unimplemented: depends on context. As an actual parameter where
4758 -- formal type is anonymous, use
4759 -- Scope_Depth (Current_Scope) + 1.
4760 -- For other cases, see 3.10.2(14/3) and following. ???
4764 when N_Type_Conversion =>
4765 if not Is_Local_Anonymous_Access (Etype (Expr)) then
4767 -- Handle type conversions introduced for a rename of an
4768 -- Ada 2012 stand-alone object of an anonymous access type.
4770 return Dynamic_Accessibility_Level (Expression (Expr));
4777 return Make_Level_Literal (Type_Access_Level (Etype (Expr)));
4778 end Dynamic_Accessibility_Level;
4780 -----------------------------------
4781 -- Effective_Extra_Accessibility --
4782 -----------------------------------
4784 function Effective_Extra_Accessibility (Id : Entity_Id) return Entity_Id is
4786 if Present (Renamed_Object (Id))
4787 and then Is_Entity_Name (Renamed_Object (Id))
4789 return Effective_Extra_Accessibility (Entity (Renamed_Object (Id)));
4791 return Extra_Accessibility (Id);
4793 end Effective_Extra_Accessibility;
4795 -----------------------------
4796 -- Effective_Reads_Enabled --
4797 -----------------------------
4799 function Effective_Reads_Enabled (Id : Entity_Id) return Boolean is
4801 if Ekind (Id) = E_Abstract_State then
4803 Has_Enabled_Property
4804 (Extern => Get_Pragma (Id, Pragma_External),
4805 Prop_Nam => Name_Effective_Reads);
4807 else pragma Assert (Ekind (Id) = E_Variable);
4808 return Present (Get_Pragma (Id, Pragma_Effective_Reads));
4810 end Effective_Reads_Enabled;
4812 ------------------------------
4813 -- Effective_Writes_Enabled --
4814 ------------------------------
4816 function Effective_Writes_Enabled (Id : Entity_Id) return Boolean is
4818 if Ekind (Id) = E_Abstract_State then
4820 Has_Enabled_Property
4821 (Extern => Get_Pragma (Id, Pragma_External),
4822 Prop_Nam => Name_Effective_Writes);
4824 else pragma Assert (Ekind (Id) = E_Variable);
4825 return Present (Get_Pragma (Id, Pragma_Effective_Writes));
4827 end Effective_Writes_Enabled;
4829 ------------------------------
4830 -- Enclosing_Comp_Unit_Node --
4831 ------------------------------
4833 function Enclosing_Comp_Unit_Node (N : Node_Id) return Node_Id is
4834 Current_Node : Node_Id;
4838 while Present (Current_Node)
4839 and then Nkind (Current_Node) /= N_Compilation_Unit
4841 Current_Node := Parent (Current_Node);
4844 if Nkind (Current_Node) /= N_Compilation_Unit then
4847 return Current_Node;
4849 end Enclosing_Comp_Unit_Node;
4851 --------------------------
4852 -- Enclosing_CPP_Parent --
4853 --------------------------
4855 function Enclosing_CPP_Parent (Typ : Entity_Id) return Entity_Id is
4856 Parent_Typ : Entity_Id := Typ;
4859 while not Is_CPP_Class (Parent_Typ)
4860 and then Etype (Parent_Typ) /= Parent_Typ
4862 Parent_Typ := Etype (Parent_Typ);
4864 if Is_Private_Type (Parent_Typ) then
4865 Parent_Typ := Full_View (Base_Type (Parent_Typ));
4869 pragma Assert (Is_CPP_Class (Parent_Typ));
4871 end Enclosing_CPP_Parent;
4873 ----------------------------
4874 -- Enclosing_Generic_Body --
4875 ----------------------------
4877 function Enclosing_Generic_Body
4878 (N : Node_Id) return Node_Id
4886 while Present (P) loop
4887 if Nkind (P) = N_Package_Body
4888 or else Nkind (P) = N_Subprogram_Body
4890 Spec := Corresponding_Spec (P);
4892 if Present (Spec) then
4893 Decl := Unit_Declaration_Node (Spec);
4895 if Nkind (Decl) = N_Generic_Package_Declaration
4896 or else Nkind (Decl) = N_Generic_Subprogram_Declaration
4907 end Enclosing_Generic_Body;
4909 ----------------------------
4910 -- Enclosing_Generic_Unit --
4911 ----------------------------
4913 function Enclosing_Generic_Unit
4914 (N : Node_Id) return Node_Id
4922 while Present (P) loop
4923 if Nkind (P) = N_Generic_Package_Declaration
4924 or else Nkind (P) = N_Generic_Subprogram_Declaration
4928 elsif Nkind (P) = N_Package_Body
4929 or else Nkind (P) = N_Subprogram_Body
4931 Spec := Corresponding_Spec (P);
4933 if Present (Spec) then
4934 Decl := Unit_Declaration_Node (Spec);
4936 if Nkind (Decl) = N_Generic_Package_Declaration
4937 or else Nkind (Decl) = N_Generic_Subprogram_Declaration
4948 end Enclosing_Generic_Unit;
4950 -------------------------------
4951 -- Enclosing_Lib_Unit_Entity --
4952 -------------------------------
4954 function Enclosing_Lib_Unit_Entity
4955 (E : Entity_Id := Current_Scope) return Entity_Id
4957 Unit_Entity : Entity_Id;
4960 -- Look for enclosing library unit entity by following scope links.
4961 -- Equivalent to, but faster than indexing through the scope stack.
4964 while (Present (Scope (Unit_Entity))
4965 and then Scope (Unit_Entity) /= Standard_Standard)
4966 and not Is_Child_Unit (Unit_Entity)
4968 Unit_Entity := Scope (Unit_Entity);
4972 end Enclosing_Lib_Unit_Entity;
4974 -----------------------
4975 -- Enclosing_Package --
4976 -----------------------
4978 function Enclosing_Package (E : Entity_Id) return Entity_Id is
4979 Dynamic_Scope : constant Entity_Id := Enclosing_Dynamic_Scope (E);
4982 if Dynamic_Scope = Standard_Standard then
4983 return Standard_Standard;
4985 elsif Dynamic_Scope = Empty then
4988 elsif Ekind_In (Dynamic_Scope, E_Package, E_Package_Body,
4991 return Dynamic_Scope;
4994 return Enclosing_Package (Dynamic_Scope);
4996 end Enclosing_Package;
4998 --------------------------
4999 -- Enclosing_Subprogram --
5000 --------------------------
5002 function Enclosing_Subprogram (E : Entity_Id) return Entity_Id is
5003 Dynamic_Scope : constant Entity_Id := Enclosing_Dynamic_Scope (E);
5006 if Dynamic_Scope = Standard_Standard then
5009 elsif Dynamic_Scope = Empty then
5012 elsif Ekind (Dynamic_Scope) = E_Subprogram_Body then
5013 return Corresponding_Spec (Parent (Parent (Dynamic_Scope)));
5015 elsif Ekind (Dynamic_Scope) = E_Block
5016 or else Ekind (Dynamic_Scope) = E_Return_Statement
5018 return Enclosing_Subprogram (Dynamic_Scope);
5020 elsif Ekind (Dynamic_Scope) = E_Task_Type then
5021 return Get_Task_Body_Procedure (Dynamic_Scope);
5023 elsif Ekind (Dynamic_Scope) = E_Limited_Private_Type
5024 and then Present (Full_View (Dynamic_Scope))
5025 and then Ekind (Full_View (Dynamic_Scope)) = E_Task_Type
5027 return Get_Task_Body_Procedure (Full_View (Dynamic_Scope));
5029 -- No body is generated if the protected operation is eliminated
5031 elsif Convention (Dynamic_Scope) = Convention_Protected
5032 and then not Is_Eliminated (Dynamic_Scope)
5033 and then Present (Protected_Body_Subprogram (Dynamic_Scope))
5035 return Protected_Body_Subprogram (Dynamic_Scope);
5038 return Dynamic_Scope;
5040 end Enclosing_Subprogram;
5042 ------------------------
5043 -- Ensure_Freeze_Node --
5044 ------------------------
5046 procedure Ensure_Freeze_Node (E : Entity_Id) is
5049 if No (Freeze_Node (E)) then
5050 FN := Make_Freeze_Entity (Sloc (E));
5051 Set_Has_Delayed_Freeze (E);
5052 Set_Freeze_Node (E, FN);
5053 Set_Access_Types_To_Process (FN, No_Elist);
5054 Set_TSS_Elist (FN, No_Elist);
5057 end Ensure_Freeze_Node;
5063 procedure Enter_Name (Def_Id : Entity_Id) is
5064 C : constant Entity_Id := Current_Entity (Def_Id);
5065 E : constant Entity_Id := Current_Entity_In_Scope (Def_Id);
5066 S : constant Entity_Id := Current_Scope;
5069 Generate_Definition (Def_Id);
5071 -- Add new name to current scope declarations. Check for duplicate
5072 -- declaration, which may or may not be a genuine error.
5076 -- Case of previous entity entered because of a missing declaration
5077 -- or else a bad subtype indication. Best is to use the new entity,
5078 -- and make the previous one invisible.
5080 if Etype (E) = Any_Type then
5081 Set_Is_Immediately_Visible (E, False);
5083 -- Case of renaming declaration constructed for package instances.
5084 -- if there is an explicit declaration with the same identifier,
5085 -- the renaming is not immediately visible any longer, but remains
5086 -- visible through selected component notation.
5088 elsif Nkind (Parent (E)) = N_Package_Renaming_Declaration
5089 and then not Comes_From_Source (E)
5091 Set_Is_Immediately_Visible (E, False);
5093 -- The new entity may be the package renaming, which has the same
5094 -- same name as a generic formal which has been seen already.
5096 elsif Nkind (Parent (Def_Id)) = N_Package_Renaming_Declaration
5097 and then not Comes_From_Source (Def_Id)
5099 Set_Is_Immediately_Visible (E, False);
5101 -- For a fat pointer corresponding to a remote access to subprogram,
5102 -- we use the same identifier as the RAS type, so that the proper
5103 -- name appears in the stub. This type is only retrieved through
5104 -- the RAS type and never by visibility, and is not added to the
5105 -- visibility list (see below).
5107 elsif Nkind (Parent (Def_Id)) = N_Full_Type_Declaration
5108 and then Present (Corresponding_Remote_Type (Def_Id))
5112 -- Case of an implicit operation or derived literal. The new entity
5113 -- hides the implicit one, which is removed from all visibility,
5114 -- i.e. the entity list of its scope, and homonym chain of its name.
5116 elsif (Is_Overloadable (E) and then Is_Inherited_Operation (E))
5117 or else Is_Internal (E)
5121 Prev_Vis : Entity_Id;
5122 Decl : constant Node_Id := Parent (E);
5125 -- If E is an implicit declaration, it cannot be the first
5126 -- entity in the scope.
5128 Prev := First_Entity (Current_Scope);
5129 while Present (Prev)
5130 and then Next_Entity (Prev) /= E
5137 -- If E is not on the entity chain of the current scope,
5138 -- it is an implicit declaration in the generic formal
5139 -- part of a generic subprogram. When analyzing the body,
5140 -- the generic formals are visible but not on the entity
5141 -- chain of the subprogram. The new entity will become
5142 -- the visible one in the body.
5145 (Nkind (Parent (Decl)) = N_Generic_Subprogram_Declaration);
5149 Set_Next_Entity (Prev, Next_Entity (E));
5151 if No (Next_Entity (Prev)) then
5152 Set_Last_Entity (Current_Scope, Prev);
5155 if E = Current_Entity (E) then
5159 Prev_Vis := Current_Entity (E);
5160 while Homonym (Prev_Vis) /= E loop
5161 Prev_Vis := Homonym (Prev_Vis);
5165 if Present (Prev_Vis) then
5167 -- Skip E in the visibility chain
5169 Set_Homonym (Prev_Vis, Homonym (E));
5172 Set_Name_Entity_Id (Chars (E), Homonym (E));
5177 -- This section of code could use a comment ???
5179 elsif Present (Etype (E))
5180 and then Is_Concurrent_Type (Etype (E))
5185 -- If the homograph is a protected component renaming, it should not
5186 -- be hiding the current entity. Such renamings are treated as weak
5189 elsif Is_Prival (E) then
5190 Set_Is_Immediately_Visible (E, False);
5192 -- In this case the current entity is a protected component renaming.
5193 -- Perform minimal decoration by setting the scope and return since
5194 -- the prival should not be hiding other visible entities.
5196 elsif Is_Prival (Def_Id) then
5197 Set_Scope (Def_Id, Current_Scope);
5200 -- Analogous to privals, the discriminal generated for an entry index
5201 -- parameter acts as a weak declaration. Perform minimal decoration
5202 -- to avoid bogus errors.
5204 elsif Is_Discriminal (Def_Id)
5205 and then Ekind (Discriminal_Link (Def_Id)) = E_Entry_Index_Parameter
5207 Set_Scope (Def_Id, Current_Scope);
5210 -- In the body or private part of an instance, a type extension may
5211 -- introduce a component with the same name as that of an actual. The
5212 -- legality rule is not enforced, but the semantics of the full type
5213 -- with two components of same name are not clear at this point???
5215 elsif In_Instance_Not_Visible then
5218 -- When compiling a package body, some child units may have become
5219 -- visible. They cannot conflict with local entities that hide them.
5221 elsif Is_Child_Unit (E)
5222 and then In_Open_Scopes (Scope (E))
5223 and then not Is_Immediately_Visible (E)
5227 -- Conversely, with front-end inlining we may compile the parent body
5228 -- first, and a child unit subsequently. The context is now the
5229 -- parent spec, and body entities are not visible.
5231 elsif Is_Child_Unit (Def_Id)
5232 and then Is_Package_Body_Entity (E)
5233 and then not In_Package_Body (Current_Scope)
5237 -- Case of genuine duplicate declaration
5240 Error_Msg_Sloc := Sloc (E);
5242 -- If the previous declaration is an incomplete type declaration
5243 -- this may be an attempt to complete it with a private type. The
5244 -- following avoids confusing cascaded errors.
5246 if Nkind (Parent (E)) = N_Incomplete_Type_Declaration
5247 and then Nkind (Parent (Def_Id)) = N_Private_Type_Declaration
5250 ("incomplete type cannot be completed with a private " &
5251 "declaration", Parent (Def_Id));
5252 Set_Is_Immediately_Visible (E, False);
5253 Set_Full_View (E, Def_Id);
5255 -- An inherited component of a record conflicts with a new
5256 -- discriminant. The discriminant is inserted first in the scope,
5257 -- but the error should be posted on it, not on the component.
5259 elsif Ekind (E) = E_Discriminant
5260 and then Present (Scope (Def_Id))
5261 and then Scope (Def_Id) /= Current_Scope
5263 Error_Msg_Sloc := Sloc (Def_Id);
5264 Error_Msg_N ("& conflicts with declaration#", E);
5267 -- If the name of the unit appears in its own context clause, a
5268 -- dummy package with the name has already been created, and the
5269 -- error emitted. Try to continue quietly.
5271 elsif Error_Posted (E)
5272 and then Sloc (E) = No_Location
5273 and then Nkind (Parent (E)) = N_Package_Specification
5274 and then Current_Scope = Standard_Standard
5276 Set_Scope (Def_Id, Current_Scope);
5280 Error_Msg_N ("& conflicts with declaration#", Def_Id);
5282 -- Avoid cascaded messages with duplicate components in
5285 if Ekind_In (E, E_Component, E_Discriminant) then
5290 if Nkind (Parent (Parent (Def_Id))) =
5291 N_Generic_Subprogram_Declaration
5293 Defining_Entity (Specification (Parent (Parent (Def_Id))))
5295 Error_Msg_N ("\generic units cannot be overloaded", Def_Id);
5298 -- If entity is in standard, then we are in trouble, because it
5299 -- means that we have a library package with a duplicated name.
5300 -- That's hard to recover from, so abort!
5302 if S = Standard_Standard then
5303 raise Unrecoverable_Error;
5305 -- Otherwise we continue with the declaration. Having two
5306 -- identical declarations should not cause us too much trouble!
5314 -- If we fall through, declaration is OK, at least OK enough to continue
5316 -- If Def_Id is a discriminant or a record component we are in the midst
5317 -- of inheriting components in a derived record definition. Preserve
5318 -- their Ekind and Etype.
5320 if Ekind_In (Def_Id, E_Discriminant, E_Component) then
5323 -- If a type is already set, leave it alone (happens when a type
5324 -- declaration is reanalyzed following a call to the optimizer).
5326 elsif Present (Etype (Def_Id)) then
5329 -- Otherwise, the kind E_Void insures that premature uses of the entity
5330 -- will be detected. Any_Type insures that no cascaded errors will occur
5333 Set_Ekind (Def_Id, E_Void);
5334 Set_Etype (Def_Id, Any_Type);
5337 -- Inherited discriminants and components in derived record types are
5338 -- immediately visible. Itypes are not.
5340 -- Unless the Itype is for a record type with a corresponding remote
5341 -- type (what is that about, it was not commented ???)
5343 if Ekind_In (Def_Id, E_Discriminant, E_Component)
5345 ((not Is_Record_Type (Def_Id)
5346 or else No (Corresponding_Remote_Type (Def_Id)))
5347 and then not Is_Itype (Def_Id))
5349 Set_Is_Immediately_Visible (Def_Id);
5350 Set_Current_Entity (Def_Id);
5353 Set_Homonym (Def_Id, C);
5354 Append_Entity (Def_Id, S);
5355 Set_Public_Status (Def_Id);
5357 -- Declaring a homonym is not allowed in SPARK ...
5360 and then Restriction_Check_Required (SPARK_05)
5363 Enclosing_Subp : constant Node_Id := Enclosing_Subprogram (Def_Id);
5364 Enclosing_Pack : constant Node_Id := Enclosing_Package (Def_Id);
5365 Other_Scope : constant Node_Id := Enclosing_Dynamic_Scope (C);
5368 -- ... unless the new declaration is in a subprogram, and the
5369 -- visible declaration is a variable declaration or a parameter
5370 -- specification outside that subprogram.
5372 if Present (Enclosing_Subp)
5373 and then Nkind_In (Parent (C), N_Object_Declaration,
5374 N_Parameter_Specification)
5375 and then not Scope_Within_Or_Same (Other_Scope, Enclosing_Subp)
5379 -- ... or the new declaration is in a package, and the visible
5380 -- declaration occurs outside that package.
5382 elsif Present (Enclosing_Pack)
5383 and then not Scope_Within_Or_Same (Other_Scope, Enclosing_Pack)
5387 -- ... or the new declaration is a component declaration in a
5388 -- record type definition.
5390 elsif Nkind (Parent (Def_Id)) = N_Component_Declaration then
5393 -- Don't issue error for non-source entities
5395 elsif Comes_From_Source (Def_Id)
5396 and then Comes_From_Source (C)
5398 Error_Msg_Sloc := Sloc (C);
5399 Check_SPARK_Restriction
5400 ("redeclaration of identifier &#", Def_Id);
5405 -- Warn if new entity hides an old one
5407 if Warn_On_Hiding and then Present (C)
5409 -- Don't warn for record components since they always have a well
5410 -- defined scope which does not confuse other uses. Note that in
5411 -- some cases, Ekind has not been set yet.
5413 and then Ekind (C) /= E_Component
5414 and then Ekind (C) /= E_Discriminant
5415 and then Nkind (Parent (C)) /= N_Component_Declaration
5416 and then Ekind (Def_Id) /= E_Component
5417 and then Ekind (Def_Id) /= E_Discriminant
5418 and then Nkind (Parent (Def_Id)) /= N_Component_Declaration
5420 -- Don't warn for one character variables. It is too common to use
5421 -- such variables as locals and will just cause too many false hits.
5423 and then Length_Of_Name (Chars (C)) /= 1
5425 -- Don't warn for non-source entities
5427 and then Comes_From_Source (C)
5428 and then Comes_From_Source (Def_Id)
5430 -- Don't warn unless entity in question is in extended main source
5432 and then In_Extended_Main_Source_Unit (Def_Id)
5434 -- Finally, the hidden entity must be either immediately visible or
5435 -- use visible (i.e. from a used package).
5438 (Is_Immediately_Visible (C)
5440 Is_Potentially_Use_Visible (C))
5442 Error_Msg_Sloc := Sloc (C);
5443 Error_Msg_N ("declaration hides &#?h?", Def_Id);
5451 function Entity_Of (N : Node_Id) return Entity_Id is
5457 if Is_Entity_Name (N) then
5460 -- Follow a possible chain of renamings to reach the root renamed
5463 while Present (Id) and then Present (Renamed_Object (Id)) loop
5464 if Is_Entity_Name (Renamed_Object (Id)) then
5465 Id := Entity (Renamed_Object (Id));
5476 --------------------------
5477 -- Explain_Limited_Type --
5478 --------------------------
5480 procedure Explain_Limited_Type (T : Entity_Id; N : Node_Id) is
5484 -- For array, component type must be limited
5486 if Is_Array_Type (T) then
5487 Error_Msg_Node_2 := T;
5489 ("\component type& of type& is limited", N, Component_Type (T));
5490 Explain_Limited_Type (Component_Type (T), N);
5492 elsif Is_Record_Type (T) then
5494 -- No need for extra messages if explicit limited record
5496 if Is_Limited_Record (Base_Type (T)) then
5500 -- Otherwise find a limited component. Check only components that
5501 -- come from source, or inherited components that appear in the
5502 -- source of the ancestor.
5504 C := First_Component (T);
5505 while Present (C) loop
5506 if Is_Limited_Type (Etype (C))
5508 (Comes_From_Source (C)
5510 (Present (Original_Record_Component (C))
5512 Comes_From_Source (Original_Record_Component (C))))
5514 Error_Msg_Node_2 := T;
5515 Error_Msg_NE ("\component& of type& has limited type", N, C);
5516 Explain_Limited_Type (Etype (C), N);
5523 -- The type may be declared explicitly limited, even if no component
5524 -- of it is limited, in which case we fall out of the loop.
5527 end Explain_Limited_Type;
5533 procedure Find_Actual
5535 Formal : out Entity_Id;
5538 Parnt : constant Node_Id := Parent (N);
5542 if (Nkind (Parnt) = N_Indexed_Component
5544 Nkind (Parnt) = N_Selected_Component)
5545 and then N = Prefix (Parnt)
5547 Find_Actual (Parnt, Formal, Call);
5550 elsif Nkind (Parnt) = N_Parameter_Association
5551 and then N = Explicit_Actual_Parameter (Parnt)
5553 Call := Parent (Parnt);
5555 elsif Nkind (Parnt) in N_Subprogram_Call then
5564 -- If we have a call to a subprogram look for the parameter. Note that
5565 -- we exclude overloaded calls, since we don't know enough to be sure
5566 -- of giving the right answer in this case.
5568 if Is_Entity_Name (Name (Call))
5569 and then Present (Entity (Name (Call)))
5570 and then Is_Overloadable (Entity (Name (Call)))
5571 and then not Is_Overloaded (Name (Call))
5573 -- Fall here if we are definitely a parameter
5575 Actual := First_Actual (Call);
5576 Formal := First_Formal (Entity (Name (Call)));
5577 while Present (Formal) and then Present (Actual) loop
5581 Actual := Next_Actual (Actual);
5582 Formal := Next_Formal (Formal);
5587 -- Fall through here if we did not find matching actual
5593 ---------------------------
5594 -- Find_Body_Discriminal --
5595 ---------------------------
5597 function Find_Body_Discriminal
5598 (Spec_Discriminant : Entity_Id) return Entity_Id
5604 -- If expansion is suppressed, then the scope can be the concurrent type
5605 -- itself rather than a corresponding concurrent record type.
5607 if Is_Concurrent_Type (Scope (Spec_Discriminant)) then
5608 Tsk := Scope (Spec_Discriminant);
5611 pragma Assert (Is_Concurrent_Record_Type (Scope (Spec_Discriminant)));
5613 Tsk := Corresponding_Concurrent_Type (Scope (Spec_Discriminant));
5616 -- Find discriminant of original concurrent type, and use its current
5617 -- discriminal, which is the renaming within the task/protected body.
5619 Disc := First_Discriminant (Tsk);
5620 while Present (Disc) loop
5621 if Chars (Disc) = Chars (Spec_Discriminant) then
5622 return Discriminal (Disc);
5625 Next_Discriminant (Disc);
5628 -- That loop should always succeed in finding a matching entry and
5629 -- returning. Fatal error if not.
5631 raise Program_Error;
5632 end Find_Body_Discriminal;
5634 -------------------------------------
5635 -- Find_Corresponding_Discriminant --
5636 -------------------------------------
5638 function Find_Corresponding_Discriminant
5640 Typ : Entity_Id) return Entity_Id
5642 Par_Disc : Entity_Id;
5643 Old_Disc : Entity_Id;
5644 New_Disc : Entity_Id;
5647 Par_Disc := Original_Record_Component (Original_Discriminant (Id));
5649 -- The original type may currently be private, and the discriminant
5650 -- only appear on its full view.
5652 if Is_Private_Type (Scope (Par_Disc))
5653 and then not Has_Discriminants (Scope (Par_Disc))
5654 and then Present (Full_View (Scope (Par_Disc)))
5656 Old_Disc := First_Discriminant (Full_View (Scope (Par_Disc)));
5658 Old_Disc := First_Discriminant (Scope (Par_Disc));
5661 if Is_Class_Wide_Type (Typ) then
5662 New_Disc := First_Discriminant (Root_Type (Typ));
5664 New_Disc := First_Discriminant (Typ);
5667 while Present (Old_Disc) and then Present (New_Disc) loop
5668 if Old_Disc = Par_Disc then
5671 Next_Discriminant (Old_Disc);
5672 Next_Discriminant (New_Disc);
5676 -- Should always find it
5678 raise Program_Error;
5679 end Find_Corresponding_Discriminant;
5681 ------------------------------------
5682 -- Find_Loop_In_Conditional_Block --
5683 ------------------------------------
5685 function Find_Loop_In_Conditional_Block (N : Node_Id) return Node_Id is
5691 if Nkind (Stmt) = N_If_Statement then
5692 Stmt := First (Then_Statements (Stmt));
5695 pragma Assert (Nkind (Stmt) = N_Block_Statement);
5697 -- Inspect the statements of the conditional block. In general the loop
5698 -- should be the first statement in the statement sequence of the block,
5699 -- but the finalization machinery may have introduced extra object
5702 Stmt := First (Statements (Handled_Statement_Sequence (Stmt)));
5703 while Present (Stmt) loop
5704 if Nkind (Stmt) = N_Loop_Statement then
5711 -- The expansion of attribute 'Loop_Entry produced a malformed block
5713 raise Program_Error;
5714 end Find_Loop_In_Conditional_Block;
5716 --------------------------
5717 -- Find_Overlaid_Entity --
5718 --------------------------
5720 procedure Find_Overlaid_Entity
5722 Ent : out Entity_Id;
5728 -- We are looking for one of the two following forms:
5730 -- for X'Address use Y'Address
5734 -- Const : constant Address := expr;
5736 -- for X'Address use Const;
5738 -- In the second case, the expr is either Y'Address, or recursively a
5739 -- constant that eventually references Y'Address.
5744 if Nkind (N) = N_Attribute_Definition_Clause
5745 and then Chars (N) = Name_Address
5747 Expr := Expression (N);
5749 -- This loop checks the form of the expression for Y'Address,
5750 -- using recursion to deal with intermediate constants.
5753 -- Check for Y'Address
5755 if Nkind (Expr) = N_Attribute_Reference
5756 and then Attribute_Name (Expr) = Name_Address
5758 Expr := Prefix (Expr);
5761 -- Check for Const where Const is a constant entity
5763 elsif Is_Entity_Name (Expr)
5764 and then Ekind (Entity (Expr)) = E_Constant
5766 Expr := Constant_Value (Entity (Expr));
5768 -- Anything else does not need checking
5775 -- This loop checks the form of the prefix for an entity, using
5776 -- recursion to deal with intermediate components.
5779 -- Check for Y where Y is an entity
5781 if Is_Entity_Name (Expr) then
5782 Ent := Entity (Expr);
5785 -- Check for components
5788 Nkind_In (Expr, N_Selected_Component, N_Indexed_Component)
5790 Expr := Prefix (Expr);
5793 -- Anything else does not need checking
5800 end Find_Overlaid_Entity;
5802 -------------------------
5803 -- Find_Parameter_Type --
5804 -------------------------
5806 function Find_Parameter_Type (Param : Node_Id) return Entity_Id is
5808 if Nkind (Param) /= N_Parameter_Specification then
5811 -- For an access parameter, obtain the type from the formal entity
5812 -- itself, because access to subprogram nodes do not carry a type.
5813 -- Shouldn't we always use the formal entity ???
5815 elsif Nkind (Parameter_Type (Param)) = N_Access_Definition then
5816 return Etype (Defining_Identifier (Param));
5819 return Etype (Parameter_Type (Param));
5821 end Find_Parameter_Type;
5823 -----------------------------
5824 -- Find_Static_Alternative --
5825 -----------------------------
5827 function Find_Static_Alternative (N : Node_Id) return Node_Id is
5828 Expr : constant Node_Id := Expression (N);
5829 Val : constant Uint := Expr_Value (Expr);
5834 Alt := First (Alternatives (N));
5837 if Nkind (Alt) /= N_Pragma then
5838 Choice := First (Discrete_Choices (Alt));
5839 while Present (Choice) loop
5841 -- Others choice, always matches
5843 if Nkind (Choice) = N_Others_Choice then
5846 -- Range, check if value is in the range
5848 elsif Nkind (Choice) = N_Range then
5850 Val >= Expr_Value (Low_Bound (Choice))
5852 Val <= Expr_Value (High_Bound (Choice));
5854 -- Choice is a subtype name. Note that we know it must
5855 -- be a static subtype, since otherwise it would have
5856 -- been diagnosed as illegal.
5858 elsif Is_Entity_Name (Choice)
5859 and then Is_Type (Entity (Choice))
5861 exit Search when Is_In_Range (Expr, Etype (Choice),
5862 Assume_Valid => False);
5864 -- Choice is a subtype indication
5866 elsif Nkind (Choice) = N_Subtype_Indication then
5868 C : constant Node_Id := Constraint (Choice);
5869 R : constant Node_Id := Range_Expression (C);
5873 Val >= Expr_Value (Low_Bound (R))
5875 Val <= Expr_Value (High_Bound (R));
5878 -- Choice is a simple expression
5881 exit Search when Val = Expr_Value (Choice);
5889 pragma Assert (Present (Alt));
5892 -- The above loop *must* terminate by finding a match, since
5893 -- we know the case statement is valid, and the value of the
5894 -- expression is known at compile time. When we fall out of
5895 -- the loop, Alt points to the alternative that we know will
5896 -- be selected at run time.
5899 end Find_Static_Alternative;
5905 function First_Actual (Node : Node_Id) return Node_Id is
5909 if No (Parameter_Associations (Node)) then
5913 N := First (Parameter_Associations (Node));
5915 if Nkind (N) = N_Parameter_Association then
5916 return First_Named_Actual (Node);
5922 -----------------------
5923 -- Gather_Components --
5924 -----------------------
5926 procedure Gather_Components
5928 Comp_List : Node_Id;
5929 Governed_By : List_Id;
5931 Report_Errors : out Boolean)
5935 Discrete_Choice : Node_Id;
5936 Comp_Item : Node_Id;
5938 Discrim : Entity_Id;
5939 Discrim_Name : Node_Id;
5940 Discrim_Value : Node_Id;
5943 Report_Errors := False;
5945 if No (Comp_List) or else Null_Present (Comp_List) then
5948 elsif Present (Component_Items (Comp_List)) then
5949 Comp_Item := First (Component_Items (Comp_List));
5955 while Present (Comp_Item) loop
5957 -- Skip the tag of a tagged record, the interface tags, as well
5958 -- as all items that are not user components (anonymous types,
5959 -- rep clauses, Parent field, controller field).
5961 if Nkind (Comp_Item) = N_Component_Declaration then
5963 Comp : constant Entity_Id := Defining_Identifier (Comp_Item);
5965 if not Is_Tag (Comp)
5966 and then Chars (Comp) /= Name_uParent
5968 Append_Elmt (Comp, Into);
5976 if No (Variant_Part (Comp_List)) then
5979 Discrim_Name := Name (Variant_Part (Comp_List));
5980 Variant := First_Non_Pragma (Variants (Variant_Part (Comp_List)));
5983 -- Look for the discriminant that governs this variant part.
5984 -- The discriminant *must* be in the Governed_By List
5986 Assoc := First (Governed_By);
5987 Find_Constraint : loop
5988 Discrim := First (Choices (Assoc));
5989 exit Find_Constraint when Chars (Discrim_Name) = Chars (Discrim)
5990 or else (Present (Corresponding_Discriminant (Entity (Discrim)))
5992 Chars (Corresponding_Discriminant (Entity (Discrim))) =
5993 Chars (Discrim_Name))
5994 or else Chars (Original_Record_Component (Entity (Discrim)))
5995 = Chars (Discrim_Name);
5997 if No (Next (Assoc)) then
5998 if not Is_Constrained (Typ)
5999 and then Is_Derived_Type (Typ)
6000 and then Present (Stored_Constraint (Typ))
6002 -- If the type is a tagged type with inherited discriminants,
6003 -- use the stored constraint on the parent in order to find
6004 -- the values of discriminants that are otherwise hidden by an
6005 -- explicit constraint. Renamed discriminants are handled in
6008 -- If several parent discriminants are renamed by a single
6009 -- discriminant of the derived type, the call to obtain the
6010 -- Corresponding_Discriminant field only retrieves the last
6011 -- of them. We recover the constraint on the others from the
6012 -- Stored_Constraint as well.
6019 D := First_Discriminant (Etype (Typ));
6020 C := First_Elmt (Stored_Constraint (Typ));
6021 while Present (D) and then Present (C) loop
6022 if Chars (Discrim_Name) = Chars (D) then
6023 if Is_Entity_Name (Node (C))
6024 and then Entity (Node (C)) = Entity (Discrim)
6026 -- D is renamed by Discrim, whose value is given in
6033 Make_Component_Association (Sloc (Typ),
6035 (New_Occurrence_Of (D, Sloc (Typ))),
6036 Duplicate_Subexpr_No_Checks (Node (C)));
6038 exit Find_Constraint;
6041 Next_Discriminant (D);
6048 if No (Next (Assoc)) then
6049 Error_Msg_NE (" missing value for discriminant&",
6050 First (Governed_By), Discrim_Name);
6051 Report_Errors := True;
6056 end loop Find_Constraint;
6058 Discrim_Value := Expression (Assoc);
6060 if not Is_OK_Static_Expression (Discrim_Value) then
6062 ("value for discriminant & must be static!",
6063 Discrim_Value, Discrim);
6064 Why_Not_Static (Discrim_Value);
6065 Report_Errors := True;
6069 Search_For_Discriminant_Value : declare
6075 UI_Discrim_Value : constant Uint := Expr_Value (Discrim_Value);
6078 Find_Discrete_Value : while Present (Variant) loop
6079 Discrete_Choice := First (Discrete_Choices (Variant));
6080 while Present (Discrete_Choice) loop
6081 exit Find_Discrete_Value when
6082 Nkind (Discrete_Choice) = N_Others_Choice;
6084 Get_Index_Bounds (Discrete_Choice, Low, High);
6086 UI_Low := Expr_Value (Low);
6087 UI_High := Expr_Value (High);
6089 exit Find_Discrete_Value when
6090 UI_Low <= UI_Discrim_Value
6092 UI_High >= UI_Discrim_Value;
6094 Next (Discrete_Choice);
6097 Next_Non_Pragma (Variant);
6098 end loop Find_Discrete_Value;
6099 end Search_For_Discriminant_Value;
6101 if No (Variant) then
6103 ("value of discriminant & is out of range", Discrim_Value, Discrim);
6104 Report_Errors := True;
6108 -- If we have found the corresponding choice, recursively add its
6109 -- components to the Into list.
6112 (Empty, Component_List (Variant), Governed_By, Into, Report_Errors);
6113 end Gather_Components;
6115 ------------------------
6116 -- Get_Actual_Subtype --
6117 ------------------------
6119 function Get_Actual_Subtype (N : Node_Id) return Entity_Id is
6120 Typ : constant Entity_Id := Etype (N);
6121 Utyp : Entity_Id := Underlying_Type (Typ);
6130 -- If what we have is an identifier that references a subprogram
6131 -- formal, or a variable or constant object, then we get the actual
6132 -- subtype from the referenced entity if one has been built.
6134 if Nkind (N) = N_Identifier
6136 (Is_Formal (Entity (N))
6137 or else Ekind (Entity (N)) = E_Constant
6138 or else Ekind (Entity (N)) = E_Variable)
6139 and then Present (Actual_Subtype (Entity (N)))
6141 return Actual_Subtype (Entity (N));
6143 -- Actual subtype of unchecked union is always itself. We never need
6144 -- the "real" actual subtype. If we did, we couldn't get it anyway
6145 -- because the discriminant is not available. The restrictions on
6146 -- Unchecked_Union are designed to make sure that this is OK.
6148 elsif Is_Unchecked_Union (Base_Type (Utyp)) then
6151 -- Here for the unconstrained case, we must find actual subtype
6152 -- No actual subtype is available, so we must build it on the fly.
6154 -- Checking the type, not the underlying type, for constrainedness
6155 -- seems to be necessary. Maybe all the tests should be on the type???
6157 elsif (not Is_Constrained (Typ))
6158 and then (Is_Array_Type (Utyp)
6159 or else (Is_Record_Type (Utyp)
6160 and then Has_Discriminants (Utyp)))
6161 and then not Has_Unknown_Discriminants (Utyp)
6162 and then not (Ekind (Utyp) = E_String_Literal_Subtype)
6164 -- Nothing to do if in spec expression (why not???)
6166 if In_Spec_Expression then
6169 elsif Is_Private_Type (Typ)
6170 and then not Has_Discriminants (Typ)
6172 -- If the type has no discriminants, there is no subtype to
6173 -- build, even if the underlying type is discriminated.
6177 -- Else build the actual subtype
6180 Decl := Build_Actual_Subtype (Typ, N);
6181 Atyp := Defining_Identifier (Decl);
6183 -- If Build_Actual_Subtype generated a new declaration then use it
6187 -- The actual subtype is an Itype, so analyze the declaration,
6188 -- but do not attach it to the tree, to get the type defined.
6190 Set_Parent (Decl, N);
6191 Set_Is_Itype (Atyp);
6192 Analyze (Decl, Suppress => All_Checks);
6193 Set_Associated_Node_For_Itype (Atyp, N);
6194 Set_Has_Delayed_Freeze (Atyp, False);
6196 -- We need to freeze the actual subtype immediately. This is
6197 -- needed, because otherwise this Itype will not get frozen
6198 -- at all, and it is always safe to freeze on creation because
6199 -- any associated types must be frozen at this point.
6201 Freeze_Itype (Atyp, N);
6204 -- Otherwise we did not build a declaration, so return original
6211 -- For all remaining cases, the actual subtype is the same as
6212 -- the nominal type.
6217 end Get_Actual_Subtype;
6219 -------------------------------------
6220 -- Get_Actual_Subtype_If_Available --
6221 -------------------------------------
6223 function Get_Actual_Subtype_If_Available (N : Node_Id) return Entity_Id is
6224 Typ : constant Entity_Id := Etype (N);
6227 -- If what we have is an identifier that references a subprogram
6228 -- formal, or a variable or constant object, then we get the actual
6229 -- subtype from the referenced entity if one has been built.
6231 if Nkind (N) = N_Identifier
6233 (Is_Formal (Entity (N))
6234 or else Ekind (Entity (N)) = E_Constant
6235 or else Ekind (Entity (N)) = E_Variable)
6236 and then Present (Actual_Subtype (Entity (N)))
6238 return Actual_Subtype (Entity (N));
6240 -- Otherwise the Etype of N is returned unchanged
6245 end Get_Actual_Subtype_If_Available;
6247 ------------------------
6248 -- Get_Body_From_Stub --
6249 ------------------------
6251 function Get_Body_From_Stub (N : Node_Id) return Node_Id is
6253 return Proper_Body (Unit (Library_Unit (N)));
6254 end Get_Body_From_Stub;
6256 -------------------------------
6257 -- Get_Default_External_Name --
6258 -------------------------------
6260 function Get_Default_External_Name (E : Node_Or_Entity_Id) return Node_Id is
6262 Get_Decoded_Name_String (Chars (E));
6264 if Opt.External_Name_Imp_Casing = Uppercase then
6265 Set_Casing (All_Upper_Case);
6267 Set_Casing (All_Lower_Case);
6271 Make_String_Literal (Sloc (E),
6272 Strval => String_From_Name_Buffer);
6273 end Get_Default_External_Name;
6275 --------------------------
6276 -- Get_Enclosing_Object --
6277 --------------------------
6279 function Get_Enclosing_Object (N : Node_Id) return Entity_Id is
6281 if Is_Entity_Name (N) then
6285 when N_Indexed_Component |
6287 N_Selected_Component =>
6289 -- If not generating code, a dereference may be left implicit.
6290 -- In thoses cases, return Empty.
6292 if Is_Access_Type (Etype (Prefix (N))) then
6295 return Get_Enclosing_Object (Prefix (N));
6298 when N_Type_Conversion =>
6299 return Get_Enclosing_Object (Expression (N));
6305 end Get_Enclosing_Object;
6307 ---------------------------
6308 -- Get_Enum_Lit_From_Pos --
6309 ---------------------------
6311 function Get_Enum_Lit_From_Pos
6314 Loc : Source_Ptr) return Node_Id
6316 Btyp : Entity_Id := Base_Type (T);
6320 -- In the case where the literal is of type Character, Wide_Character
6321 -- or Wide_Wide_Character or of a type derived from them, there needs
6322 -- to be some special handling since there is no explicit chain of
6323 -- literals to search. Instead, an N_Character_Literal node is created
6324 -- with the appropriate Char_Code and Chars fields.
6326 if Is_Standard_Character_Type (T) then
6327 Set_Character_Literal_Name (UI_To_CC (Pos));
6329 Make_Character_Literal (Loc,
6331 Char_Literal_Value => Pos);
6333 -- For all other cases, we have a complete table of literals, and
6334 -- we simply iterate through the chain of literal until the one
6335 -- with the desired position value is found.
6339 if Is_Private_Type (Btyp) and then Present (Full_View (Btyp)) then
6340 Btyp := Full_View (Btyp);
6343 Lit := First_Literal (Btyp);
6344 for J in 1 .. UI_To_Int (Pos) loop
6348 return New_Occurrence_Of (Lit, Loc);
6350 end Get_Enum_Lit_From_Pos;
6352 ---------------------------------
6353 -- Get_Ensures_From_CTC_Pragma --
6354 ---------------------------------
6356 function Get_Ensures_From_CTC_Pragma (N : Node_Id) return Node_Id is
6357 Args : constant List_Id := Pragma_Argument_Associations (N);
6361 if List_Length (Args) = 4 then
6362 Res := Pick (Args, 4);
6364 elsif List_Length (Args) = 3 then
6365 Res := Pick (Args, 3);
6367 if Chars (Res) /= Name_Ensures then
6376 end Get_Ensures_From_CTC_Pragma;
6378 ------------------------
6379 -- Get_Generic_Entity --
6380 ------------------------
6382 function Get_Generic_Entity (N : Node_Id) return Entity_Id is
6383 Ent : constant Entity_Id := Entity (Name (N));
6385 if Present (Renamed_Object (Ent)) then
6386 return Renamed_Object (Ent);
6390 end Get_Generic_Entity;
6392 -------------------------------------
6393 -- Get_Incomplete_View_Of_Ancestor --
6394 -------------------------------------
6396 function Get_Incomplete_View_Of_Ancestor (E : Entity_Id) return Entity_Id is
6397 Cur_Unit : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
6398 Par_Scope : Entity_Id;
6399 Par_Type : Entity_Id;
6402 -- The incomplete view of an ancestor is only relevant for private
6403 -- derived types in child units.
6405 if not Is_Derived_Type (E)
6406 or else not Is_Child_Unit (Cur_Unit)
6411 Par_Scope := Scope (Cur_Unit);
6412 if No (Par_Scope) then
6416 Par_Type := Etype (Base_Type (E));
6418 -- Traverse list of ancestor types until we find one declared in
6419 -- a parent or grandparent unit (two levels seem sufficient).
6421 while Present (Par_Type) loop
6422 if Scope (Par_Type) = Par_Scope
6423 or else Scope (Par_Type) = Scope (Par_Scope)
6427 elsif not Is_Derived_Type (Par_Type) then
6431 Par_Type := Etype (Base_Type (Par_Type));
6435 -- If none found, there is no relevant ancestor type.
6439 end Get_Incomplete_View_Of_Ancestor;
6441 ----------------------
6442 -- Get_Index_Bounds --
6443 ----------------------
6445 procedure Get_Index_Bounds (N : Node_Id; L, H : out Node_Id) is
6446 Kind : constant Node_Kind := Nkind (N);
6450 if Kind = N_Range then
6452 H := High_Bound (N);
6454 elsif Kind = N_Subtype_Indication then
6455 R := Range_Expression (Constraint (N));
6463 L := Low_Bound (Range_Expression (Constraint (N)));
6464 H := High_Bound (Range_Expression (Constraint (N)));
6467 elsif Is_Entity_Name (N) and then Is_Type (Entity (N)) then
6468 if Error_Posted (Scalar_Range (Entity (N))) then
6472 elsif Nkind (Scalar_Range (Entity (N))) = N_Subtype_Indication then
6473 Get_Index_Bounds (Scalar_Range (Entity (N)), L, H);
6476 L := Low_Bound (Scalar_Range (Entity (N)));
6477 H := High_Bound (Scalar_Range (Entity (N)));
6481 -- N is an expression, indicating a range with one value
6486 end Get_Index_Bounds;
6488 ----------------------------------
6489 -- Get_Library_Unit_Name_string --
6490 ----------------------------------
6492 procedure Get_Library_Unit_Name_String (Decl_Node : Node_Id) is
6493 Unit_Name_Id : constant Unit_Name_Type := Get_Unit_Name (Decl_Node);
6496 Get_Unit_Name_String (Unit_Name_Id);
6498 -- Remove seven last character (" (spec)" or " (body)")
6500 Name_Len := Name_Len - 7;
6501 pragma Assert (Name_Buffer (Name_Len + 1) = ' ');
6502 end Get_Library_Unit_Name_String;
6504 ------------------------
6505 -- Get_Name_Entity_Id --
6506 ------------------------
6508 function Get_Name_Entity_Id (Id : Name_Id) return Entity_Id is
6510 return Entity_Id (Get_Name_Table_Info (Id));
6511 end Get_Name_Entity_Id;
6513 ------------------------------
6514 -- Get_Name_From_CTC_Pragma --
6515 ------------------------------
6517 function Get_Name_From_CTC_Pragma (N : Node_Id) return String_Id is
6518 Arg : constant Node_Id :=
6519 Get_Pragma_Arg (First (Pragma_Argument_Associations (N)));
6521 return Strval (Expr_Value_S (Arg));
6522 end Get_Name_From_CTC_Pragma;
6528 function Get_Pragma_Id (N : Node_Id) return Pragma_Id is
6530 return Get_Pragma_Id (Pragma_Name (N));
6533 ---------------------------
6534 -- Get_Referenced_Object --
6535 ---------------------------
6537 function Get_Referenced_Object (N : Node_Id) return Node_Id is
6542 while Is_Entity_Name (R)
6543 and then Present (Renamed_Object (Entity (R)))
6545 R := Renamed_Object (Entity (R));
6549 end Get_Referenced_Object;
6551 ------------------------
6552 -- Get_Renamed_Entity --
6553 ------------------------
6555 function Get_Renamed_Entity (E : Entity_Id) return Entity_Id is
6560 while Present (Renamed_Entity (R)) loop
6561 R := Renamed_Entity (R);
6565 end Get_Renamed_Entity;
6567 ----------------------------------
6568 -- Get_Requires_From_CTC_Pragma --
6569 ----------------------------------
6571 function Get_Requires_From_CTC_Pragma (N : Node_Id) return Node_Id is
6572 Args : constant List_Id := Pragma_Argument_Associations (N);
6576 if List_Length (Args) >= 3 then
6577 Res := Pick (Args, 3);
6579 if Chars (Res) /= Name_Requires then
6588 end Get_Requires_From_CTC_Pragma;
6590 -------------------------
6591 -- Get_Subprogram_Body --
6592 -------------------------
6594 function Get_Subprogram_Body (E : Entity_Id) return Node_Id is
6598 Decl := Unit_Declaration_Node (E);
6600 if Nkind (Decl) = N_Subprogram_Body then
6603 -- The below comment is bad, because it is possible for
6604 -- Nkind (Decl) to be an N_Subprogram_Body_Stub ???
6606 else -- Nkind (Decl) = N_Subprogram_Declaration
6608 if Present (Corresponding_Body (Decl)) then
6609 return Unit_Declaration_Node (Corresponding_Body (Decl));
6611 -- Imported subprogram case
6617 end Get_Subprogram_Body;
6619 ---------------------------
6620 -- Get_Subprogram_Entity --
6621 ---------------------------
6623 function Get_Subprogram_Entity (Nod : Node_Id) return Entity_Id is
6625 Subp_Id : Entity_Id;
6628 if Nkind (Nod) = N_Accept_Statement then
6629 Subp := Entry_Direct_Name (Nod);
6631 elsif Nkind (Nod) = N_Slice then
6632 Subp := Prefix (Nod);
6638 -- Strip the subprogram call
6641 if Nkind_In (Subp, N_Explicit_Dereference,
6642 N_Indexed_Component,
6643 N_Selected_Component)
6645 Subp := Prefix (Subp);
6647 elsif Nkind_In (Subp, N_Type_Conversion,
6648 N_Unchecked_Type_Conversion)
6650 Subp := Expression (Subp);
6657 -- Extract the entity of the subprogram call
6659 if Is_Entity_Name (Subp) then
6660 Subp_Id := Entity (Subp);
6662 if Ekind (Subp_Id) = E_Access_Subprogram_Type then
6663 Subp_Id := Directly_Designated_Type (Subp_Id);
6666 if Is_Subprogram (Subp_Id) then
6672 -- The search did not find a construct that denotes a subprogram
6677 end Get_Subprogram_Entity;
6679 -----------------------------
6680 -- Get_Task_Body_Procedure --
6681 -----------------------------
6683 function Get_Task_Body_Procedure (E : Entity_Id) return Node_Id is
6685 -- Note: A task type may be the completion of a private type with
6686 -- discriminants. When performing elaboration checks on a task
6687 -- declaration, the current view of the type may be the private one,
6688 -- and the procedure that holds the body of the task is held in its
6691 -- This is an odd function, why not have Task_Body_Procedure do
6692 -- the following digging???
6694 return Task_Body_Procedure (Underlying_Type (Root_Type (E)));
6695 end Get_Task_Body_Procedure;
6697 -----------------------
6698 -- Has_Access_Values --
6699 -----------------------
6701 function Has_Access_Values (T : Entity_Id) return Boolean is
6702 Typ : constant Entity_Id := Underlying_Type (T);
6705 -- Case of a private type which is not completed yet. This can only
6706 -- happen in the case of a generic format type appearing directly, or
6707 -- as a component of the type to which this function is being applied
6708 -- at the top level. Return False in this case, since we certainly do
6709 -- not know that the type contains access types.
6714 elsif Is_Access_Type (Typ) then
6717 elsif Is_Array_Type (Typ) then
6718 return Has_Access_Values (Component_Type (Typ));
6720 elsif Is_Record_Type (Typ) then
6725 -- Loop to Check components
6727 Comp := First_Component_Or_Discriminant (Typ);
6728 while Present (Comp) loop
6730 -- Check for access component, tag field does not count, even
6731 -- though it is implemented internally using an access type.
6733 if Has_Access_Values (Etype (Comp))
6734 and then Chars (Comp) /= Name_uTag
6739 Next_Component_Or_Discriminant (Comp);
6748 end Has_Access_Values;
6750 ------------------------------
6751 -- Has_Compatible_Alignment --
6752 ------------------------------
6754 function Has_Compatible_Alignment
6756 Expr : Node_Id) return Alignment_Result
6758 function Has_Compatible_Alignment_Internal
6761 Default : Alignment_Result) return Alignment_Result;
6762 -- This is the internal recursive function that actually does the work.
6763 -- There is one additional parameter, which says what the result should
6764 -- be if no alignment information is found, and there is no definite
6765 -- indication of compatible alignments. At the outer level, this is set
6766 -- to Unknown, but for internal recursive calls in the case where types
6767 -- are known to be correct, it is set to Known_Compatible.
6769 ---------------------------------------
6770 -- Has_Compatible_Alignment_Internal --
6771 ---------------------------------------
6773 function Has_Compatible_Alignment_Internal
6776 Default : Alignment_Result) return Alignment_Result
6778 Result : Alignment_Result := Known_Compatible;
6779 -- Holds the current status of the result. Note that once a value of
6780 -- Known_Incompatible is set, it is sticky and does not get changed
6781 -- to Unknown (the value in Result only gets worse as we go along,
6784 Offs : Uint := No_Uint;
6785 -- Set to a factor of the offset from the base object when Expr is a
6786 -- selected or indexed component, based on Component_Bit_Offset and
6787 -- Component_Size respectively. A negative value is used to represent
6788 -- a value which is not known at compile time.
6790 procedure Check_Prefix;
6791 -- Checks the prefix recursively in the case where the expression
6792 -- is an indexed or selected component.
6794 procedure Set_Result (R : Alignment_Result);
6795 -- If R represents a worse outcome (unknown instead of known
6796 -- compatible, or known incompatible), then set Result to R.
6802 procedure Check_Prefix is
6804 -- The subtlety here is that in doing a recursive call to check
6805 -- the prefix, we have to decide what to do in the case where we
6806 -- don't find any specific indication of an alignment problem.
6808 -- At the outer level, we normally set Unknown as the result in
6809 -- this case, since we can only set Known_Compatible if we really
6810 -- know that the alignment value is OK, but for the recursive
6811 -- call, in the case where the types match, and we have not
6812 -- specified a peculiar alignment for the object, we are only
6813 -- concerned about suspicious rep clauses, the default case does
6814 -- not affect us, since the compiler will, in the absence of such
6815 -- rep clauses, ensure that the alignment is correct.
6817 if Default = Known_Compatible
6819 (Etype (Obj) = Etype (Expr)
6820 and then (Unknown_Alignment (Obj)
6822 Alignment (Obj) = Alignment (Etype (Obj))))
6825 (Has_Compatible_Alignment_Internal
6826 (Obj, Prefix (Expr), Known_Compatible));
6828 -- In all other cases, we need a full check on the prefix
6832 (Has_Compatible_Alignment_Internal
6833 (Obj, Prefix (Expr), Unknown));
6841 procedure Set_Result (R : Alignment_Result) is
6848 -- Start of processing for Has_Compatible_Alignment_Internal
6851 -- If Expr is a selected component, we must make sure there is no
6852 -- potentially troublesome component clause, and that the record is
6855 if Nkind (Expr) = N_Selected_Component then
6857 -- Packed record always generate unknown alignment
6859 if Is_Packed (Etype (Prefix (Expr))) then
6860 Set_Result (Unknown);
6863 -- Check prefix and component offset
6866 Offs := Component_Bit_Offset (Entity (Selector_Name (Expr)));
6868 -- If Expr is an indexed component, we must make sure there is no
6869 -- potentially troublesome Component_Size clause and that the array
6870 -- is not bit-packed.
6872 elsif Nkind (Expr) = N_Indexed_Component then
6874 Typ : constant Entity_Id := Etype (Prefix (Expr));
6875 Ind : constant Node_Id := First_Index (Typ);
6878 -- Bit packed array always generates unknown alignment
6880 if Is_Bit_Packed_Array (Typ) then
6881 Set_Result (Unknown);
6884 -- Check prefix and component offset
6887 Offs := Component_Size (Typ);
6889 -- Small optimization: compute the full offset when possible
6892 and then Offs > Uint_0
6893 and then Present (Ind)
6894 and then Nkind (Ind) = N_Range
6895 and then Compile_Time_Known_Value (Low_Bound (Ind))
6896 and then Compile_Time_Known_Value (First (Expressions (Expr)))
6898 Offs := Offs * (Expr_Value (First (Expressions (Expr)))
6899 - Expr_Value (Low_Bound ((Ind))));
6904 -- If we have a null offset, the result is entirely determined by
6905 -- the base object and has already been computed recursively.
6907 if Offs = Uint_0 then
6910 -- Case where we know the alignment of the object
6912 elsif Known_Alignment (Obj) then
6914 ObjA : constant Uint := Alignment (Obj);
6915 ExpA : Uint := No_Uint;
6916 SizA : Uint := No_Uint;
6919 -- If alignment of Obj is 1, then we are always OK
6922 Set_Result (Known_Compatible);
6924 -- Alignment of Obj is greater than 1, so we need to check
6927 -- If we have an offset, see if it is compatible
6929 if Offs /= No_Uint and Offs > Uint_0 then
6930 if Offs mod (System_Storage_Unit * ObjA) /= 0 then
6931 Set_Result (Known_Incompatible);
6934 -- See if Expr is an object with known alignment
6936 elsif Is_Entity_Name (Expr)
6937 and then Known_Alignment (Entity (Expr))
6939 ExpA := Alignment (Entity (Expr));
6941 -- Otherwise, we can use the alignment of the type of
6942 -- Expr given that we already checked for
6943 -- discombobulating rep clauses for the cases of indexed
6944 -- and selected components above.
6946 elsif Known_Alignment (Etype (Expr)) then
6947 ExpA := Alignment (Etype (Expr));
6949 -- Otherwise the alignment is unknown
6952 Set_Result (Default);
6955 -- If we got an alignment, see if it is acceptable
6957 if ExpA /= No_Uint and then ExpA < ObjA then
6958 Set_Result (Known_Incompatible);
6961 -- If Expr is not a piece of a larger object, see if size
6962 -- is given. If so, check that it is not too small for the
6963 -- required alignment.
6965 if Offs /= No_Uint then
6968 -- See if Expr is an object with known size
6970 elsif Is_Entity_Name (Expr)
6971 and then Known_Static_Esize (Entity (Expr))
6973 SizA := Esize (Entity (Expr));
6975 -- Otherwise, we check the object size of the Expr type
6977 elsif Known_Static_Esize (Etype (Expr)) then
6978 SizA := Esize (Etype (Expr));
6981 -- If we got a size, see if it is a multiple of the Obj
6982 -- alignment, if not, then the alignment cannot be
6983 -- acceptable, since the size is always a multiple of the
6986 if SizA /= No_Uint then
6987 if SizA mod (ObjA * Ttypes.System_Storage_Unit) /= 0 then
6988 Set_Result (Known_Incompatible);
6994 -- If we do not know required alignment, any non-zero offset is a
6995 -- potential problem (but certainly may be OK, so result is unknown).
6997 elsif Offs /= No_Uint then
6998 Set_Result (Unknown);
7000 -- If we can't find the result by direct comparison of alignment
7001 -- values, then there is still one case that we can determine known
7002 -- result, and that is when we can determine that the types are the
7003 -- same, and no alignments are specified. Then we known that the
7004 -- alignments are compatible, even if we don't know the alignment
7005 -- value in the front end.
7007 elsif Etype (Obj) = Etype (Expr) then
7009 -- Types are the same, but we have to check for possible size
7010 -- and alignments on the Expr object that may make the alignment
7011 -- different, even though the types are the same.
7013 if Is_Entity_Name (Expr) then
7015 -- First check alignment of the Expr object. Any alignment less
7016 -- than Maximum_Alignment is worrisome since this is the case
7017 -- where we do not know the alignment of Obj.
7019 if Known_Alignment (Entity (Expr))
7021 UI_To_Int (Alignment (Entity (Expr))) <
7022 Ttypes.Maximum_Alignment
7024 Set_Result (Unknown);
7026 -- Now check size of Expr object. Any size that is not an
7027 -- even multiple of Maximum_Alignment is also worrisome
7028 -- since it may cause the alignment of the object to be less
7029 -- than the alignment of the type.
7031 elsif Known_Static_Esize (Entity (Expr))
7033 (UI_To_Int (Esize (Entity (Expr))) mod
7034 (Ttypes.Maximum_Alignment * Ttypes.System_Storage_Unit))
7037 Set_Result (Unknown);
7039 -- Otherwise same type is decisive
7042 Set_Result (Known_Compatible);
7046 -- Another case to deal with is when there is an explicit size or
7047 -- alignment clause when the types are not the same. If so, then the
7048 -- result is Unknown. We don't need to do this test if the Default is
7049 -- Unknown, since that result will be set in any case.
7051 elsif Default /= Unknown
7052 and then (Has_Size_Clause (Etype (Expr))
7054 Has_Alignment_Clause (Etype (Expr)))
7056 Set_Result (Unknown);
7058 -- If no indication found, set default
7061 Set_Result (Default);
7064 -- Return worst result found
7067 end Has_Compatible_Alignment_Internal;
7069 -- Start of processing for Has_Compatible_Alignment
7072 -- If Obj has no specified alignment, then set alignment from the type
7073 -- alignment. Perhaps we should always do this, but for sure we should
7074 -- do it when there is an address clause since we can do more if the
7075 -- alignment is known.
7077 if Unknown_Alignment (Obj) then
7078 Set_Alignment (Obj, Alignment (Etype (Obj)));
7081 -- Now do the internal call that does all the work
7083 return Has_Compatible_Alignment_Internal (Obj, Expr, Unknown);
7084 end Has_Compatible_Alignment;
7086 ----------------------
7087 -- Has_Declarations --
7088 ----------------------
7090 function Has_Declarations (N : Node_Id) return Boolean is
7092 return Nkind_In (Nkind (N), N_Accept_Statement,
7094 N_Compilation_Unit_Aux,
7100 N_Package_Specification);
7101 end Has_Declarations;
7107 function Has_Denormals (E : Entity_Id) return Boolean is
7109 return Is_Floating_Point_Type (E)
7110 and then Denorm_On_Target
7111 and then not Vax_Float (E);
7114 -------------------------------------------
7115 -- Has_Discriminant_Dependent_Constraint --
7116 -------------------------------------------
7118 function Has_Discriminant_Dependent_Constraint
7119 (Comp : Entity_Id) return Boolean
7121 Comp_Decl : constant Node_Id := Parent (Comp);
7122 Subt_Indic : constant Node_Id :=
7123 Subtype_Indication (Component_Definition (Comp_Decl));
7128 if Nkind (Subt_Indic) = N_Subtype_Indication then
7129 Constr := Constraint (Subt_Indic);
7131 if Nkind (Constr) = N_Index_Or_Discriminant_Constraint then
7132 Assn := First (Constraints (Constr));
7133 while Present (Assn) loop
7134 case Nkind (Assn) is
7135 when N_Subtype_Indication |
7139 if Depends_On_Discriminant (Assn) then
7143 when N_Discriminant_Association =>
7144 if Depends_On_Discriminant (Expression (Assn)) then
7159 end Has_Discriminant_Dependent_Constraint;
7161 --------------------------
7162 -- Has_Enabled_Property --
7163 --------------------------
7165 function Has_Enabled_Property
7167 Prop_Nam : Name_Id) return Boolean
7170 Props : Node_Id := Empty;
7173 -- The related abstract state or variable do not have an Extern pragma,
7174 -- the property in question cannot be set.
7179 elsif Nkind (Extern) = N_Component_Association then
7180 Props := Expression (Extern);
7183 -- External state with properties
7185 if Present (Props) then
7187 -- Multiple properties appear as an aggregate
7189 if Nkind (Props) = N_Aggregate then
7191 -- Simple property form
7193 Prop := First (Expressions (Props));
7194 while Present (Prop) loop
7195 if Chars (Prop) = Prop_Nam then
7202 -- Property with expression form
7204 Prop := First (Component_Associations (Props));
7205 while Present (Prop) loop
7206 if Chars (Prop) = Prop_Nam then
7207 return Is_True (Expr_Value (Expression (Prop)));
7213 -- Pragma Extern contains properties, but not the one we want
7220 return Chars (Prop) = Prop_Nam;
7223 -- An external state defined without any properties defaults all
7224 -- properties to True;
7229 end Has_Enabled_Property;
7231 --------------------
7232 -- Has_Infinities --
7233 --------------------
7235 function Has_Infinities (E : Entity_Id) return Boolean is
7238 Is_Floating_Point_Type (E)
7239 and then Nkind (Scalar_Range (E)) = N_Range
7240 and then Includes_Infinities (Scalar_Range (E));
7243 --------------------
7244 -- Has_Interfaces --
7245 --------------------
7247 function Has_Interfaces
7249 Use_Full_View : Boolean := True) return Boolean
7251 Typ : Entity_Id := Base_Type (T);
7254 -- Handle concurrent types
7256 if Is_Concurrent_Type (Typ) then
7257 Typ := Corresponding_Record_Type (Typ);
7260 if not Present (Typ)
7261 or else not Is_Record_Type (Typ)
7262 or else not Is_Tagged_Type (Typ)
7267 -- Handle private types
7270 and then Present (Full_View (Typ))
7272 Typ := Full_View (Typ);
7275 -- Handle concurrent record types
7277 if Is_Concurrent_Record_Type (Typ)
7278 and then Is_Non_Empty_List (Abstract_Interface_List (Typ))
7284 if Is_Interface (Typ)
7286 (Is_Record_Type (Typ)
7287 and then Present (Interfaces (Typ))
7288 and then not Is_Empty_Elmt_List (Interfaces (Typ)))
7293 exit when Etype (Typ) = Typ
7295 -- Handle private types
7297 or else (Present (Full_View (Etype (Typ)))
7298 and then Full_View (Etype (Typ)) = Typ)
7300 -- Protect the frontend against wrong source with cyclic
7303 or else Etype (Typ) = T;
7305 -- Climb to the ancestor type handling private types
7307 if Present (Full_View (Etype (Typ))) then
7308 Typ := Full_View (Etype (Typ));
7317 ---------------------------------
7318 -- Has_No_Obvious_Side_Effects --
7319 ---------------------------------
7321 function Has_No_Obvious_Side_Effects (N : Node_Id) return Boolean is
7323 -- For now, just handle literals, constants, and non-volatile
7324 -- variables and expressions combining these with operators or
7325 -- short circuit forms.
7327 if Nkind (N) in N_Numeric_Or_String_Literal then
7330 elsif Nkind (N) = N_Character_Literal then
7333 elsif Nkind (N) in N_Unary_Op then
7334 return Has_No_Obvious_Side_Effects (Right_Opnd (N));
7336 elsif Nkind (N) in N_Binary_Op or else Nkind (N) in N_Short_Circuit then
7337 return Has_No_Obvious_Side_Effects (Left_Opnd (N))
7339 Has_No_Obvious_Side_Effects (Right_Opnd (N));
7341 elsif Nkind (N) = N_Expression_With_Actions
7343 Is_Empty_List (Actions (N))
7345 return Has_No_Obvious_Side_Effects (Expression (N));
7347 elsif Nkind (N) in N_Has_Entity then
7348 return Present (Entity (N))
7349 and then Ekind_In (Entity (N), E_Variable,
7351 E_Enumeration_Literal,
7355 and then not Is_Volatile (Entity (N));
7360 end Has_No_Obvious_Side_Effects;
7362 ------------------------
7363 -- Has_Null_Exclusion --
7364 ------------------------
7366 function Has_Null_Exclusion (N : Node_Id) return Boolean is
7369 when N_Access_Definition |
7370 N_Access_Function_Definition |
7371 N_Access_Procedure_Definition |
7372 N_Access_To_Object_Definition |
7374 N_Derived_Type_Definition |
7375 N_Function_Specification |
7376 N_Subtype_Declaration =>
7377 return Null_Exclusion_Present (N);
7379 when N_Component_Definition |
7380 N_Formal_Object_Declaration |
7381 N_Object_Renaming_Declaration =>
7382 if Present (Subtype_Mark (N)) then
7383 return Null_Exclusion_Present (N);
7384 else pragma Assert (Present (Access_Definition (N)));
7385 return Null_Exclusion_Present (Access_Definition (N));
7388 when N_Discriminant_Specification =>
7389 if Nkind (Discriminant_Type (N)) = N_Access_Definition then
7390 return Null_Exclusion_Present (Discriminant_Type (N));
7392 return Null_Exclusion_Present (N);
7395 when N_Object_Declaration =>
7396 if Nkind (Object_Definition (N)) = N_Access_Definition then
7397 return Null_Exclusion_Present (Object_Definition (N));
7399 return Null_Exclusion_Present (N);
7402 when N_Parameter_Specification =>
7403 if Nkind (Parameter_Type (N)) = N_Access_Definition then
7404 return Null_Exclusion_Present (Parameter_Type (N));
7406 return Null_Exclusion_Present (N);
7413 end Has_Null_Exclusion;
7415 ------------------------
7416 -- Has_Null_Extension --
7417 ------------------------
7419 function Has_Null_Extension (T : Entity_Id) return Boolean is
7420 B : constant Entity_Id := Base_Type (T);
7425 if Nkind (Parent (B)) = N_Full_Type_Declaration
7426 and then Present (Record_Extension_Part (Type_Definition (Parent (B))))
7428 Ext := Record_Extension_Part (Type_Definition (Parent (B)));
7430 if Present (Ext) then
7431 if Null_Present (Ext) then
7434 Comps := Component_List (Ext);
7436 -- The null component list is rewritten during analysis to
7437 -- include the parent component. Any other component indicates
7438 -- that the extension was not originally null.
7440 return Null_Present (Comps)
7441 or else No (Next (First (Component_Items (Comps))));
7450 end Has_Null_Extension;
7452 -------------------------------
7453 -- Has_Overriding_Initialize --
7454 -------------------------------
7456 function Has_Overriding_Initialize (T : Entity_Id) return Boolean is
7457 BT : constant Entity_Id := Base_Type (T);
7461 if Is_Controlled (BT) then
7462 if Is_RTU (Scope (BT), Ada_Finalization) then
7465 elsif Present (Primitive_Operations (BT)) then
7466 P := First_Elmt (Primitive_Operations (BT));
7467 while Present (P) loop
7469 Init : constant Entity_Id := Node (P);
7470 Formal : constant Entity_Id := First_Formal (Init);
7472 if Ekind (Init) = E_Procedure
7473 and then Chars (Init) = Name_Initialize
7474 and then Comes_From_Source (Init)
7475 and then Present (Formal)
7476 and then Etype (Formal) = BT
7477 and then No (Next_Formal (Formal))
7478 and then (Ada_Version < Ada_2012
7479 or else not Null_Present (Parent (Init)))
7489 -- Here if type itself does not have a non-null Initialize operation:
7490 -- check immediate ancestor.
7492 if Is_Derived_Type (BT)
7493 and then Has_Overriding_Initialize (Etype (BT))
7500 end Has_Overriding_Initialize;
7502 --------------------------------------
7503 -- Has_Preelaborable_Initialization --
7504 --------------------------------------
7506 function Has_Preelaborable_Initialization (E : Entity_Id) return Boolean is
7509 procedure Check_Components (E : Entity_Id);
7510 -- Check component/discriminant chain, sets Has_PE False if a component
7511 -- or discriminant does not meet the preelaborable initialization rules.
7513 ----------------------
7514 -- Check_Components --
7515 ----------------------
7517 procedure Check_Components (E : Entity_Id) is
7521 function Is_Preelaborable_Expression (N : Node_Id) return Boolean;
7522 -- Returns True if and only if the expression denoted by N does not
7523 -- violate restrictions on preelaborable constructs (RM-10.2.1(5-9)).
7525 ---------------------------------
7526 -- Is_Preelaborable_Expression --
7527 ---------------------------------
7529 function Is_Preelaborable_Expression (N : Node_Id) return Boolean is
7533 Comp_Type : Entity_Id;
7534 Is_Array_Aggr : Boolean;
7537 if Is_Static_Expression (N) then
7540 elsif Nkind (N) = N_Null then
7543 -- Attributes are allowed in general, even if their prefix is a
7544 -- formal type. (It seems that certain attributes known not to be
7545 -- static might not be allowed, but there are no rules to prevent
7548 elsif Nkind (N) = N_Attribute_Reference then
7551 -- The name of a discriminant evaluated within its parent type is
7552 -- defined to be preelaborable (10.2.1(8)). Note that we test for
7553 -- names that denote discriminals as well as discriminants to
7554 -- catch references occurring within init procs.
7556 elsif Is_Entity_Name (N)
7558 (Ekind (Entity (N)) = E_Discriminant
7560 ((Ekind (Entity (N)) = E_Constant
7561 or else Ekind (Entity (N)) = E_In_Parameter)
7562 and then Present (Discriminal_Link (Entity (N)))))
7566 elsif Nkind (N) = N_Qualified_Expression then
7567 return Is_Preelaborable_Expression (Expression (N));
7569 -- For aggregates we have to check that each of the associations
7570 -- is preelaborable.
7572 elsif Nkind (N) = N_Aggregate
7573 or else Nkind (N) = N_Extension_Aggregate
7575 Is_Array_Aggr := Is_Array_Type (Etype (N));
7577 if Is_Array_Aggr then
7578 Comp_Type := Component_Type (Etype (N));
7581 -- Check the ancestor part of extension aggregates, which must
7582 -- be either the name of a type that has preelaborable init or
7583 -- an expression that is preelaborable.
7585 if Nkind (N) = N_Extension_Aggregate then
7587 Anc_Part : constant Node_Id := Ancestor_Part (N);
7590 if Is_Entity_Name (Anc_Part)
7591 and then Is_Type (Entity (Anc_Part))
7593 if not Has_Preelaborable_Initialization
7599 elsif not Is_Preelaborable_Expression (Anc_Part) then
7605 -- Check positional associations
7607 Exp := First (Expressions (N));
7608 while Present (Exp) loop
7609 if not Is_Preelaborable_Expression (Exp) then
7616 -- Check named associations
7618 Assn := First (Component_Associations (N));
7619 while Present (Assn) loop
7620 Choice := First (Choices (Assn));
7621 while Present (Choice) loop
7622 if Is_Array_Aggr then
7623 if Nkind (Choice) = N_Others_Choice then
7626 elsif Nkind (Choice) = N_Range then
7627 if not Is_Static_Range (Choice) then
7631 elsif not Is_Static_Expression (Choice) then
7636 Comp_Type := Etype (Choice);
7642 -- If the association has a <> at this point, then we have
7643 -- to check whether the component's type has preelaborable
7644 -- initialization. Note that this only occurs when the
7645 -- association's corresponding component does not have a
7646 -- default expression, the latter case having already been
7647 -- expanded as an expression for the association.
7649 if Box_Present (Assn) then
7650 if not Has_Preelaborable_Initialization (Comp_Type) then
7654 -- In the expression case we check whether the expression
7655 -- is preelaborable.
7658 not Is_Preelaborable_Expression (Expression (Assn))
7666 -- If we get here then aggregate as a whole is preelaborable
7670 -- All other cases are not preelaborable
7675 end Is_Preelaborable_Expression;
7677 -- Start of processing for Check_Components
7680 -- Loop through entities of record or protected type
7683 while Present (Ent) loop
7685 -- We are interested only in components and discriminants
7692 -- Get default expression if any. If there is no declaration
7693 -- node, it means we have an internal entity. The parent and
7694 -- tag fields are examples of such entities. For such cases,
7695 -- we just test the type of the entity.
7697 if Present (Declaration_Node (Ent)) then
7698 Exp := Expression (Declaration_Node (Ent));
7701 when E_Discriminant =>
7703 -- Note: for a renamed discriminant, the Declaration_Node
7704 -- may point to the one from the ancestor, and have a
7705 -- different expression, so use the proper attribute to
7706 -- retrieve the expression from the derived constraint.
7708 Exp := Discriminant_Default_Value (Ent);
7711 goto Check_Next_Entity;
7714 -- A component has PI if it has no default expression and the
7715 -- component type has PI.
7718 if not Has_Preelaborable_Initialization (Etype (Ent)) then
7723 -- Require the default expression to be preelaborable
7725 elsif not Is_Preelaborable_Expression (Exp) then
7730 <<Check_Next_Entity>>
7733 end Check_Components;
7735 -- Start of processing for Has_Preelaborable_Initialization
7738 -- Immediate return if already marked as known preelaborable init. This
7739 -- covers types for which this function has already been called once
7740 -- and returned True (in which case the result is cached), and also
7741 -- types to which a pragma Preelaborable_Initialization applies.
7743 if Known_To_Have_Preelab_Init (E) then
7747 -- If the type is a subtype representing a generic actual type, then
7748 -- test whether its base type has preelaborable initialization since
7749 -- the subtype representing the actual does not inherit this attribute
7750 -- from the actual or formal. (but maybe it should???)
7752 if Is_Generic_Actual_Type (E) then
7753 return Has_Preelaborable_Initialization (Base_Type (E));
7756 -- All elementary types have preelaborable initialization
7758 if Is_Elementary_Type (E) then
7761 -- Array types have PI if the component type has PI
7763 elsif Is_Array_Type (E) then
7764 Has_PE := Has_Preelaborable_Initialization (Component_Type (E));
7766 -- A derived type has preelaborable initialization if its parent type
7767 -- has preelaborable initialization and (in the case of a derived record
7768 -- extension) if the non-inherited components all have preelaborable
7769 -- initialization. However, a user-defined controlled type with an
7770 -- overriding Initialize procedure does not have preelaborable
7773 elsif Is_Derived_Type (E) then
7775 -- If the derived type is a private extension then it doesn't have
7776 -- preelaborable initialization.
7778 if Ekind (Base_Type (E)) = E_Record_Type_With_Private then
7782 -- First check whether ancestor type has preelaborable initialization
7784 Has_PE := Has_Preelaborable_Initialization (Etype (Base_Type (E)));
7786 -- If OK, check extension components (if any)
7788 if Has_PE and then Is_Record_Type (E) then
7789 Check_Components (First_Entity (E));
7792 -- Check specifically for 10.2.1(11.4/2) exception: a controlled type
7793 -- with a user defined Initialize procedure does not have PI.
7796 and then Is_Controlled (E)
7797 and then Has_Overriding_Initialize (E)
7802 -- Private types not derived from a type having preelaborable init and
7803 -- that are not marked with pragma Preelaborable_Initialization do not
7804 -- have preelaborable initialization.
7806 elsif Is_Private_Type (E) then
7809 -- Record type has PI if it is non private and all components have PI
7811 elsif Is_Record_Type (E) then
7813 Check_Components (First_Entity (E));
7815 -- Protected types must not have entries, and components must meet
7816 -- same set of rules as for record components.
7818 elsif Is_Protected_Type (E) then
7819 if Has_Entries (E) then
7823 Check_Components (First_Entity (E));
7824 Check_Components (First_Private_Entity (E));
7827 -- Type System.Address always has preelaborable initialization
7829 elsif Is_RTE (E, RE_Address) then
7832 -- In all other cases, type does not have preelaborable initialization
7838 -- If type has preelaborable initialization, cache result
7841 Set_Known_To_Have_Preelab_Init (E);
7845 end Has_Preelaborable_Initialization;
7847 ---------------------------
7848 -- Has_Private_Component --
7849 ---------------------------
7851 function Has_Private_Component (Type_Id : Entity_Id) return Boolean is
7852 Btype : Entity_Id := Base_Type (Type_Id);
7853 Component : Entity_Id;
7856 if Error_Posted (Type_Id)
7857 or else Error_Posted (Btype)
7862 if Is_Class_Wide_Type (Btype) then
7863 Btype := Root_Type (Btype);
7866 if Is_Private_Type (Btype) then
7868 UT : constant Entity_Id := Underlying_Type (Btype);
7871 if No (Full_View (Btype)) then
7872 return not Is_Generic_Type (Btype)
7873 and then not Is_Generic_Type (Root_Type (Btype));
7875 return not Is_Generic_Type (Root_Type (Full_View (Btype)));
7878 return not Is_Frozen (UT) and then Has_Private_Component (UT);
7882 elsif Is_Array_Type (Btype) then
7883 return Has_Private_Component (Component_Type (Btype));
7885 elsif Is_Record_Type (Btype) then
7886 Component := First_Component (Btype);
7887 while Present (Component) loop
7888 if Has_Private_Component (Etype (Component)) then
7892 Next_Component (Component);
7897 elsif Is_Protected_Type (Btype)
7898 and then Present (Corresponding_Record_Type (Btype))
7900 return Has_Private_Component (Corresponding_Record_Type (Btype));
7905 end Has_Private_Component;
7907 ----------------------
7908 -- Has_Signed_Zeros --
7909 ----------------------
7911 function Has_Signed_Zeros (E : Entity_Id) return Boolean is
7913 return Is_Floating_Point_Type (E)
7914 and then Signed_Zeros_On_Target
7915 and then not Vax_Float (E);
7916 end Has_Signed_Zeros;
7918 -----------------------------
7919 -- Has_Static_Array_Bounds --
7920 -----------------------------
7922 function Has_Static_Array_Bounds (Typ : Node_Id) return Boolean is
7923 Ndims : constant Nat := Number_Dimensions (Typ);
7930 -- Unconstrained types do not have static bounds
7932 if not Is_Constrained (Typ) then
7936 -- First treat string literals specially, as the lower bound and length
7937 -- of string literals are not stored like those of arrays.
7939 -- A string literal always has static bounds
7941 if Ekind (Typ) = E_String_Literal_Subtype then
7945 -- Treat all dimensions in turn
7947 Index := First_Index (Typ);
7948 for Indx in 1 .. Ndims loop
7950 -- In case of an erroneous index which is not a discrete type, return
7951 -- that the type is not static.
7953 if not Is_Discrete_Type (Etype (Index))
7954 or else Etype (Index) = Any_Type
7959 Get_Index_Bounds (Index, Low, High);
7961 if Error_Posted (Low) or else Error_Posted (High) then
7965 if Is_OK_Static_Expression (Low)
7967 Is_OK_Static_Expression (High)
7977 -- If we fall through the loop, all indexes matched
7980 end Has_Static_Array_Bounds;
7986 function Has_Stream (T : Entity_Id) return Boolean is
7993 elsif Is_RTE (Root_Type (T), RE_Root_Stream_Type) then
7996 elsif Is_Array_Type (T) then
7997 return Has_Stream (Component_Type (T));
7999 elsif Is_Record_Type (T) then
8000 E := First_Component (T);
8001 while Present (E) loop
8002 if Has_Stream (Etype (E)) then
8011 elsif Is_Private_Type (T) then
8012 return Has_Stream (Underlying_Type (T));
8023 function Has_Suffix (E : Entity_Id; Suffix : Character) return Boolean is
8025 Get_Name_String (Chars (E));
8026 return Name_Buffer (Name_Len) = Suffix;
8033 function Add_Suffix (E : Entity_Id; Suffix : Character) return Name_Id is
8035 Get_Name_String (Chars (E));
8036 Add_Char_To_Name_Buffer (Suffix);
8044 function Remove_Suffix (E : Entity_Id; Suffix : Character) return Name_Id is
8046 pragma Assert (Has_Suffix (E, Suffix));
8047 Get_Name_String (Chars (E));
8048 Name_Len := Name_Len - 1;
8052 --------------------------
8053 -- Has_Tagged_Component --
8054 --------------------------
8056 function Has_Tagged_Component (Typ : Entity_Id) return Boolean is
8060 if Is_Private_Type (Typ)
8061 and then Present (Underlying_Type (Typ))
8063 return Has_Tagged_Component (Underlying_Type (Typ));
8065 elsif Is_Array_Type (Typ) then
8066 return Has_Tagged_Component (Component_Type (Typ));
8068 elsif Is_Tagged_Type (Typ) then
8071 elsif Is_Record_Type (Typ) then
8072 Comp := First_Component (Typ);
8073 while Present (Comp) loop
8074 if Has_Tagged_Component (Etype (Comp)) then
8078 Next_Component (Comp);
8086 end Has_Tagged_Component;
8088 -------------------------
8089 -- Implementation_Kind --
8090 -------------------------
8092 function Implementation_Kind (Subp : Entity_Id) return Name_Id is
8093 Impl_Prag : constant Node_Id := Get_Rep_Pragma (Subp, Name_Implemented);
8096 pragma Assert (Present (Impl_Prag));
8097 Arg := Last (Pragma_Argument_Associations (Impl_Prag));
8098 return Chars (Get_Pragma_Arg (Arg));
8099 end Implementation_Kind;
8101 --------------------------
8102 -- Implements_Interface --
8103 --------------------------
8105 function Implements_Interface
8106 (Typ_Ent : Entity_Id;
8107 Iface_Ent : Entity_Id;
8108 Exclude_Parents : Boolean := False) return Boolean
8110 Ifaces_List : Elist_Id;
8112 Iface : Entity_Id := Base_Type (Iface_Ent);
8113 Typ : Entity_Id := Base_Type (Typ_Ent);
8116 if Is_Class_Wide_Type (Typ) then
8117 Typ := Root_Type (Typ);
8120 if not Has_Interfaces (Typ) then
8124 if Is_Class_Wide_Type (Iface) then
8125 Iface := Root_Type (Iface);
8128 Collect_Interfaces (Typ, Ifaces_List);
8130 Elmt := First_Elmt (Ifaces_List);
8131 while Present (Elmt) loop
8132 if Is_Ancestor (Node (Elmt), Typ, Use_Full_View => True)
8133 and then Exclude_Parents
8137 elsif Node (Elmt) = Iface then
8145 end Implements_Interface;
8151 function In_Instance return Boolean is
8152 Curr_Unit : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
8158 and then S /= Standard_Standard
8160 if (Ekind (S) = E_Function
8161 or else Ekind (S) = E_Package
8162 or else Ekind (S) = E_Procedure)
8163 and then Is_Generic_Instance (S)
8165 -- A child instance is always compiled in the context of a parent
8166 -- instance. Nevertheless, the actuals are not analyzed in an
8167 -- instance context. We detect this case by examining the current
8168 -- compilation unit, which must be a child instance, and checking
8169 -- that it is not currently on the scope stack.
8171 if Is_Child_Unit (Curr_Unit)
8173 Nkind (Unit (Cunit (Current_Sem_Unit)))
8174 = N_Package_Instantiation
8175 and then not In_Open_Scopes (Curr_Unit)
8189 ----------------------
8190 -- In_Instance_Body --
8191 ----------------------
8193 function In_Instance_Body return Boolean is
8199 and then S /= Standard_Standard
8201 if (Ekind (S) = E_Function
8202 or else Ekind (S) = E_Procedure)
8203 and then Is_Generic_Instance (S)
8207 elsif Ekind (S) = E_Package
8208 and then In_Package_Body (S)
8209 and then Is_Generic_Instance (S)
8218 end In_Instance_Body;
8220 -----------------------------
8221 -- In_Instance_Not_Visible --
8222 -----------------------------
8224 function In_Instance_Not_Visible return Boolean is
8230 and then S /= Standard_Standard
8232 if (Ekind (S) = E_Function
8233 or else Ekind (S) = E_Procedure)
8234 and then Is_Generic_Instance (S)
8238 elsif Ekind (S) = E_Package
8239 and then (In_Package_Body (S) or else In_Private_Part (S))
8240 and then Is_Generic_Instance (S)
8249 end In_Instance_Not_Visible;
8251 ------------------------------
8252 -- In_Instance_Visible_Part --
8253 ------------------------------
8255 function In_Instance_Visible_Part return Boolean is
8261 and then S /= Standard_Standard
8263 if Ekind (S) = E_Package
8264 and then Is_Generic_Instance (S)
8265 and then not In_Package_Body (S)
8266 and then not In_Private_Part (S)
8275 end In_Instance_Visible_Part;
8277 ---------------------
8278 -- In_Package_Body --
8279 ---------------------
8281 function In_Package_Body return Boolean is
8287 and then S /= Standard_Standard
8289 if Ekind (S) = E_Package
8290 and then In_Package_Body (S)
8299 end In_Package_Body;
8301 --------------------------------
8302 -- In_Parameter_Specification --
8303 --------------------------------
8305 function In_Parameter_Specification (N : Node_Id) return Boolean is
8310 while Present (PN) loop
8311 if Nkind (PN) = N_Parameter_Specification then
8319 end In_Parameter_Specification;
8321 -------------------------------------
8322 -- In_Reverse_Storage_Order_Object --
8323 -------------------------------------
8325 function In_Reverse_Storage_Order_Object (N : Node_Id) return Boolean is
8327 Btyp : Entity_Id := Empty;
8330 -- Climb up indexed components
8334 case Nkind (Pref) is
8335 when N_Selected_Component =>
8336 Pref := Prefix (Pref);
8339 when N_Indexed_Component =>
8340 Pref := Prefix (Pref);
8348 if Present (Pref) then
8349 Btyp := Base_Type (Etype (Pref));
8354 and then (Is_Record_Type (Btyp) or else Is_Array_Type (Btyp))
8355 and then Reverse_Storage_Order (Btyp);
8356 end In_Reverse_Storage_Order_Object;
8358 --------------------------------------
8359 -- In_Subprogram_Or_Concurrent_Unit --
8360 --------------------------------------
8362 function In_Subprogram_Or_Concurrent_Unit return Boolean is
8367 -- Use scope chain to check successively outer scopes
8373 if K in Subprogram_Kind
8374 or else K in Concurrent_Kind
8375 or else K in Generic_Subprogram_Kind
8379 elsif E = Standard_Standard then
8385 end In_Subprogram_Or_Concurrent_Unit;
8387 ---------------------
8388 -- In_Visible_Part --
8389 ---------------------
8391 function In_Visible_Part (Scope_Id : Entity_Id) return Boolean is
8394 Is_Package_Or_Generic_Package (Scope_Id)
8395 and then In_Open_Scopes (Scope_Id)
8396 and then not In_Package_Body (Scope_Id)
8397 and then not In_Private_Part (Scope_Id);
8398 end In_Visible_Part;
8400 --------------------------------
8401 -- Incomplete_Or_Private_View --
8402 --------------------------------
8404 function Incomplete_Or_Private_View (Typ : Entity_Id) return Entity_Id is
8405 function Inspect_Decls
8407 Taft : Boolean := False) return Entity_Id;
8408 -- Check whether a declarative region contains the incomplete or private
8415 function Inspect_Decls
8417 Taft : Boolean := False) return Entity_Id
8423 Decl := First (Decls);
8424 while Present (Decl) loop
8428 if Nkind (Decl) = N_Incomplete_Type_Declaration then
8429 Match := Defining_Identifier (Decl);
8433 if Nkind_In (Decl, N_Private_Extension_Declaration,
8434 N_Private_Type_Declaration)
8436 Match := Defining_Identifier (Decl);
8441 and then Present (Full_View (Match))
8442 and then Full_View (Match) = Typ
8457 -- Start of processing for Incomplete_Or_Partial_View
8460 -- Incomplete type case
8462 Prev := Current_Entity_In_Scope (Typ);
8465 and then Is_Incomplete_Type (Prev)
8466 and then Present (Full_View (Prev))
8467 and then Full_View (Prev) = Typ
8472 -- Private or Taft amendment type case
8475 Pkg : constant Entity_Id := Scope (Typ);
8476 Pkg_Decl : Node_Id := Pkg;
8479 if Ekind (Pkg) = E_Package then
8480 while Nkind (Pkg_Decl) /= N_Package_Specification loop
8481 Pkg_Decl := Parent (Pkg_Decl);
8484 -- It is knows that Typ has a private view, look for it in the
8485 -- visible declarations of the enclosing scope. A special case
8486 -- of this is when the two views have been exchanged - the full
8487 -- appears earlier than the private.
8489 if Has_Private_Declaration (Typ) then
8490 Prev := Inspect_Decls (Visible_Declarations (Pkg_Decl));
8492 -- Exchanged view case, look in the private declarations
8495 Prev := Inspect_Decls (Private_Declarations (Pkg_Decl));
8500 -- Otherwise if this is the package body, then Typ is a potential
8501 -- Taft amendment type. The incomplete view should be located in
8502 -- the private declarations of the enclosing scope.
8504 elsif In_Package_Body (Pkg) then
8505 return Inspect_Decls (Private_Declarations (Pkg_Decl), True);
8510 -- The type has no incomplete or private view
8513 end Incomplete_Or_Private_View;
8515 ---------------------------------
8516 -- Insert_Explicit_Dereference --
8517 ---------------------------------
8519 procedure Insert_Explicit_Dereference (N : Node_Id) is
8520 New_Prefix : constant Node_Id := Relocate_Node (N);
8521 Ent : Entity_Id := Empty;
8528 Save_Interps (N, New_Prefix);
8531 Make_Explicit_Dereference (Sloc (Parent (N)),
8532 Prefix => New_Prefix));
8534 Set_Etype (N, Designated_Type (Etype (New_Prefix)));
8536 if Is_Overloaded (New_Prefix) then
8538 -- The dereference is also overloaded, and its interpretations are
8539 -- the designated types of the interpretations of the original node.
8541 Set_Etype (N, Any_Type);
8543 Get_First_Interp (New_Prefix, I, It);
8544 while Present (It.Nam) loop
8547 if Is_Access_Type (T) then
8548 Add_One_Interp (N, Designated_Type (T), Designated_Type (T));
8551 Get_Next_Interp (I, It);
8557 -- Prefix is unambiguous: mark the original prefix (which might
8558 -- Come_From_Source) as a reference, since the new (relocated) one
8559 -- won't be taken into account.
8561 if Is_Entity_Name (New_Prefix) then
8562 Ent := Entity (New_Prefix);
8565 -- For a retrieval of a subcomponent of some composite object,
8566 -- retrieve the ultimate entity if there is one.
8568 elsif Nkind (New_Prefix) = N_Selected_Component
8569 or else Nkind (New_Prefix) = N_Indexed_Component
8571 Pref := Prefix (New_Prefix);
8572 while Present (Pref)
8574 (Nkind (Pref) = N_Selected_Component
8575 or else Nkind (Pref) = N_Indexed_Component)
8577 Pref := Prefix (Pref);
8580 if Present (Pref) and then Is_Entity_Name (Pref) then
8581 Ent := Entity (Pref);
8585 -- Place the reference on the entity node
8587 if Present (Ent) then
8588 Generate_Reference (Ent, Pref);
8591 end Insert_Explicit_Dereference;
8593 ------------------------------------------
8594 -- Inspect_Deferred_Constant_Completion --
8595 ------------------------------------------
8597 procedure Inspect_Deferred_Constant_Completion (Decls : List_Id) is
8601 Decl := First (Decls);
8602 while Present (Decl) loop
8604 -- Deferred constant signature
8606 if Nkind (Decl) = N_Object_Declaration
8607 and then Constant_Present (Decl)
8608 and then No (Expression (Decl))
8610 -- No need to check internally generated constants
8612 and then Comes_From_Source (Decl)
8614 -- The constant is not completed. A full object declaration or a
8615 -- pragma Import complete a deferred constant.
8617 and then not Has_Completion (Defining_Identifier (Decl))
8620 ("constant declaration requires initialization expression",
8621 Defining_Identifier (Decl));
8624 Decl := Next (Decl);
8626 end Inspect_Deferred_Constant_Completion;
8628 -----------------------------
8629 -- Is_Actual_Out_Parameter --
8630 -----------------------------
8632 function Is_Actual_Out_Parameter (N : Node_Id) return Boolean is
8636 Find_Actual (N, Formal, Call);
8637 return Present (Formal) and then Ekind (Formal) = E_Out_Parameter;
8638 end Is_Actual_Out_Parameter;
8640 -------------------------
8641 -- Is_Actual_Parameter --
8642 -------------------------
8644 function Is_Actual_Parameter (N : Node_Id) return Boolean is
8645 PK : constant Node_Kind := Nkind (Parent (N));
8649 when N_Parameter_Association =>
8650 return N = Explicit_Actual_Parameter (Parent (N));
8652 when N_Subprogram_Call =>
8653 return Is_List_Member (N)
8655 List_Containing (N) = Parameter_Associations (Parent (N));
8660 end Is_Actual_Parameter;
8662 --------------------------------
8663 -- Is_Actual_Tagged_Parameter --
8664 --------------------------------
8666 function Is_Actual_Tagged_Parameter (N : Node_Id) return Boolean is
8670 Find_Actual (N, Formal, Call);
8671 return Present (Formal) and then Is_Tagged_Type (Etype (Formal));
8672 end Is_Actual_Tagged_Parameter;
8674 ---------------------
8675 -- Is_Aliased_View --
8676 ---------------------
8678 function Is_Aliased_View (Obj : Node_Id) return Boolean is
8682 if Is_Entity_Name (Obj) then
8689 or else (Present (Renamed_Object (E))
8690 and then Is_Aliased_View (Renamed_Object (E)))))
8692 or else ((Is_Formal (E)
8693 or else Ekind (E) = E_Generic_In_Out_Parameter
8694 or else Ekind (E) = E_Generic_In_Parameter)
8695 and then Is_Tagged_Type (Etype (E)))
8697 or else (Is_Concurrent_Type (E) and then In_Open_Scopes (E))
8699 -- Current instance of type, either directly or as rewritten
8700 -- reference to the current object.
8702 or else (Is_Entity_Name (Original_Node (Obj))
8703 and then Present (Entity (Original_Node (Obj)))
8704 and then Is_Type (Entity (Original_Node (Obj))))
8706 or else (Is_Type (E) and then E = Current_Scope)
8708 or else (Is_Incomplete_Or_Private_Type (E)
8709 and then Full_View (E) = Current_Scope)
8711 -- Ada 2012 AI05-0053: the return object of an extended return
8712 -- statement is aliased if its type is immutably limited.
8714 or else (Is_Return_Object (E)
8715 and then Is_Limited_View (Etype (E)));
8717 elsif Nkind (Obj) = N_Selected_Component then
8718 return Is_Aliased (Entity (Selector_Name (Obj)));
8720 elsif Nkind (Obj) = N_Indexed_Component then
8721 return Has_Aliased_Components (Etype (Prefix (Obj)))
8723 (Is_Access_Type (Etype (Prefix (Obj)))
8724 and then Has_Aliased_Components
8725 (Designated_Type (Etype (Prefix (Obj)))));
8727 elsif Nkind_In (Obj, N_Unchecked_Type_Conversion, N_Type_Conversion) then
8728 return Is_Tagged_Type (Etype (Obj))
8729 and then Is_Aliased_View (Expression (Obj));
8731 elsif Nkind (Obj) = N_Explicit_Dereference then
8732 return Nkind (Original_Node (Obj)) /= N_Function_Call;
8737 end Is_Aliased_View;
8739 -------------------------
8740 -- Is_Ancestor_Package --
8741 -------------------------
8743 function Is_Ancestor_Package
8745 E2 : Entity_Id) return Boolean
8752 and then Par /= Standard_Standard
8762 end Is_Ancestor_Package;
8764 ----------------------
8765 -- Is_Atomic_Object --
8766 ----------------------
8768 function Is_Atomic_Object (N : Node_Id) return Boolean is
8770 function Object_Has_Atomic_Components (N : Node_Id) return Boolean;
8771 -- Determines if given object has atomic components
8773 function Is_Atomic_Prefix (N : Node_Id) return Boolean;
8774 -- If prefix is an implicit dereference, examine designated type
8776 ----------------------
8777 -- Is_Atomic_Prefix --
8778 ----------------------
8780 function Is_Atomic_Prefix (N : Node_Id) return Boolean is
8782 if Is_Access_Type (Etype (N)) then
8784 Has_Atomic_Components (Designated_Type (Etype (N)));
8786 return Object_Has_Atomic_Components (N);
8788 end Is_Atomic_Prefix;
8790 ----------------------------------
8791 -- Object_Has_Atomic_Components --
8792 ----------------------------------
8794 function Object_Has_Atomic_Components (N : Node_Id) return Boolean is
8796 if Has_Atomic_Components (Etype (N))
8797 or else Is_Atomic (Etype (N))
8801 elsif Is_Entity_Name (N)
8802 and then (Has_Atomic_Components (Entity (N))
8803 or else Is_Atomic (Entity (N)))
8807 elsif Nkind (N) = N_Selected_Component
8808 and then Is_Atomic (Entity (Selector_Name (N)))
8812 elsif Nkind (N) = N_Indexed_Component
8813 or else Nkind (N) = N_Selected_Component
8815 return Is_Atomic_Prefix (Prefix (N));
8820 end Object_Has_Atomic_Components;
8822 -- Start of processing for Is_Atomic_Object
8825 -- Predicate is not relevant to subprograms
8827 if Is_Entity_Name (N) and then Is_Overloadable (Entity (N)) then
8830 elsif Is_Atomic (Etype (N))
8831 or else (Is_Entity_Name (N) and then Is_Atomic (Entity (N)))
8835 elsif Nkind (N) = N_Selected_Component
8836 and then Is_Atomic (Entity (Selector_Name (N)))
8840 elsif Nkind (N) = N_Indexed_Component
8841 or else Nkind (N) = N_Selected_Component
8843 return Is_Atomic_Prefix (Prefix (N));
8848 end Is_Atomic_Object;
8850 -------------------------
8851 -- Is_Attribute_Result --
8852 -------------------------
8854 function Is_Attribute_Result (N : Node_Id) return Boolean is
8857 Nkind (N) = N_Attribute_Reference
8858 and then Attribute_Name (N) = Name_Result;
8859 end Is_Attribute_Result;
8861 ------------------------------------
8862 -- Is_Body_Or_Package_Declaration --
8863 ------------------------------------
8865 function Is_Body_Or_Package_Declaration (N : Node_Id) return Boolean is
8867 return Nkind_In (N, N_Entry_Body,
8869 N_Package_Declaration,
8873 end Is_Body_Or_Package_Declaration;
8875 -----------------------
8876 -- Is_Bounded_String --
8877 -----------------------
8879 function Is_Bounded_String (T : Entity_Id) return Boolean is
8880 Under : constant Entity_Id := Underlying_Type (Root_Type (T));
8883 -- Check whether T is ultimately derived from Ada.Strings.Superbounded.
8884 -- Super_String, or one of the [Wide_]Wide_ versions. This will
8885 -- be True for all the Bounded_String types in instances of the
8886 -- Generic_Bounded_Length generics, and for types derived from those.
8888 return Present (Under)
8889 and then (Is_RTE (Root_Type (Under), RO_SU_Super_String) or else
8890 Is_RTE (Root_Type (Under), RO_WI_Super_String) or else
8891 Is_RTE (Root_Type (Under), RO_WW_Super_String));
8892 end Is_Bounded_String;
8894 -------------------------
8895 -- Is_Child_Or_Sibling --
8896 -------------------------
8898 function Is_Child_Or_Sibling
8899 (Pack_1 : Entity_Id;
8901 Private_Child : Boolean) return Boolean
8903 function Distance_From_Standard (Pack : Entity_Id) return Nat;
8904 -- Given an arbitrary package, return the number of "climbs" necessary
8905 -- to reach scope Standard_Standard.
8907 procedure Equalize_Depths
8908 (Pack : in out Entity_Id;
8910 Depth_To_Reach : Nat);
8911 -- Given an arbitrary package, its depth and a target depth to reach,
8912 -- climb the scope chain until the said depth is reached. The pointer
8913 -- to the package and its depth a modified during the climb.
8915 function Is_Child (Pack : Entity_Id) return Boolean;
8916 -- Given a package Pack, determine whether it is a child package that
8917 -- satisfies the privacy requirement (if set).
8919 ----------------------------
8920 -- Distance_From_Standard --
8921 ----------------------------
8923 function Distance_From_Standard (Pack : Entity_Id) return Nat is
8930 while Present (Scop) and then Scop /= Standard_Standard loop
8932 Scop := Scope (Scop);
8936 end Distance_From_Standard;
8938 ---------------------
8939 -- Equalize_Depths --
8940 ---------------------
8942 procedure Equalize_Depths
8943 (Pack : in out Entity_Id;
8945 Depth_To_Reach : Nat)
8948 -- The package must be at a greater or equal depth
8950 if Depth < Depth_To_Reach then
8951 raise Program_Error;
8954 -- Climb the scope chain until the desired depth is reached
8956 while Present (Pack) and then Depth /= Depth_To_Reach loop
8957 Pack := Scope (Pack);
8960 end Equalize_Depths;
8966 function Is_Child (Pack : Entity_Id) return Boolean is
8968 if Is_Child_Unit (Pack) then
8969 if Private_Child then
8970 return Is_Private_Descendant (Pack);
8975 -- The package is nested, it cannot act a child or a sibling
8984 P_1 : Entity_Id := Pack_1;
8985 P_1_Child : Boolean := False;
8986 P_1_Depth : Nat := Distance_From_Standard (P_1);
8987 P_2 : Entity_Id := Pack_2;
8988 P_2_Child : Boolean := False;
8989 P_2_Depth : Nat := Distance_From_Standard (P_2);
8991 -- Start of processing for Is_Child_Or_Sibling
8995 (Ekind (Pack_1) = E_Package and then Ekind (Pack_2) = E_Package);
8997 -- Both packages denote the same entity, therefore they cannot be
8998 -- children or siblings.
9003 -- One of the packages is at a deeper level than the other. Note that
9004 -- both may still come from differen hierarchies.
9012 elsif P_1_Depth > P_2_Depth then
9013 Equalize_Depths (P_1, P_1_Depth, P_2_Depth);
9022 elsif P_2_Depth > P_1_Depth then
9023 Equalize_Depths (P_2, P_2_Depth, P_1_Depth);
9027 -- At this stage the package pointers have been elevated to the same
9028 -- depth. If the related entities are the same, then one package is a
9029 -- potential child of the other:
9033 -- X became P_1 P_2 or vica versa
9039 return Is_Child (Pack_1);
9040 else pragma Assert (P_2_Child);
9041 return Is_Child (Pack_2);
9044 -- The packages may come from the same package chain or from entirely
9045 -- different hierarcies. To determine this, climb the scope stack until
9046 -- a common root is found.
9048 -- (root) (root 1) (root 2)
9053 while Present (P_1) and then Present (P_2) loop
9055 -- The two packages may be siblings
9058 return Is_Child (Pack_1) and then Is_Child (Pack_2);
9067 end Is_Child_Or_Sibling;
9069 -----------------------------
9070 -- Is_Concurrent_Interface --
9071 -----------------------------
9073 function Is_Concurrent_Interface (T : Entity_Id) return Boolean is
9078 (Is_Protected_Interface (T)
9079 or else Is_Synchronized_Interface (T)
9080 or else Is_Task_Interface (T));
9081 end Is_Concurrent_Interface;
9083 -----------------------
9084 -- Is_Constant_Bound --
9085 -----------------------
9087 function Is_Constant_Bound (Exp : Node_Id) return Boolean is
9089 if Compile_Time_Known_Value (Exp) then
9092 elsif Is_Entity_Name (Exp) and then Present (Entity (Exp)) then
9093 return Is_Constant_Object (Entity (Exp))
9094 or else Ekind (Entity (Exp)) = E_Enumeration_Literal;
9096 elsif Nkind (Exp) in N_Binary_Op then
9097 return Is_Constant_Bound (Left_Opnd (Exp))
9098 and then Is_Constant_Bound (Right_Opnd (Exp))
9099 and then Scope (Entity (Exp)) = Standard_Standard;
9104 end Is_Constant_Bound;
9106 --------------------------------------
9107 -- Is_Controlling_Limited_Procedure --
9108 --------------------------------------
9110 function Is_Controlling_Limited_Procedure
9111 (Proc_Nam : Entity_Id) return Boolean
9113 Param_Typ : Entity_Id := Empty;
9116 if Ekind (Proc_Nam) = E_Procedure
9117 and then Present (Parameter_Specifications (Parent (Proc_Nam)))
9119 Param_Typ := Etype (Parameter_Type (First (
9120 Parameter_Specifications (Parent (Proc_Nam)))));
9122 -- In this case where an Itype was created, the procedure call has been
9125 elsif Present (Associated_Node_For_Itype (Proc_Nam))
9126 and then Present (Original_Node (Associated_Node_For_Itype (Proc_Nam)))
9128 Present (Parameter_Associations
9129 (Associated_Node_For_Itype (Proc_Nam)))
9132 Etype (First (Parameter_Associations
9133 (Associated_Node_For_Itype (Proc_Nam))));
9136 if Present (Param_Typ) then
9138 Is_Interface (Param_Typ)
9139 and then Is_Limited_Record (Param_Typ);
9143 end Is_Controlling_Limited_Procedure;
9145 -----------------------------
9146 -- Is_CPP_Constructor_Call --
9147 -----------------------------
9149 function Is_CPP_Constructor_Call (N : Node_Id) return Boolean is
9151 return Nkind (N) = N_Function_Call
9152 and then Is_CPP_Class (Etype (Etype (N)))
9153 and then Is_Constructor (Entity (Name (N)))
9154 and then Is_Imported (Entity (Name (N)));
9155 end Is_CPP_Constructor_Call;
9161 function Is_Delegate (T : Entity_Id) return Boolean is
9162 Desig_Type : Entity_Id;
9165 if VM_Target /= CLI_Target then
9169 -- Access-to-subprograms are delegates in CIL
9171 if Ekind (T) = E_Access_Subprogram_Type then
9175 if Ekind (T) not in Access_Kind then
9177 -- A delegate is a managed pointer. If no designated type is defined
9178 -- it means that it's not a delegate.
9183 Desig_Type := Etype (Directly_Designated_Type (T));
9185 if not Is_Tagged_Type (Desig_Type) then
9189 -- Test if the type is inherited from [mscorlib]System.Delegate
9191 while Etype (Desig_Type) /= Desig_Type loop
9192 if Chars (Scope (Desig_Type)) /= No_Name
9193 and then Is_Imported (Scope (Desig_Type))
9194 and then Get_Name_String (Chars (Scope (Desig_Type))) = "delegate"
9199 Desig_Type := Etype (Desig_Type);
9205 ----------------------------------------------
9206 -- Is_Dependent_Component_Of_Mutable_Object --
9207 ----------------------------------------------
9209 function Is_Dependent_Component_Of_Mutable_Object
9210 (Object : Node_Id) return Boolean
9213 Prefix_Type : Entity_Id;
9214 P_Aliased : Boolean := False;
9217 function Is_Declared_Within_Variant (Comp : Entity_Id) return Boolean;
9218 -- Returns True if and only if Comp is declared within a variant part
9220 --------------------------------
9221 -- Is_Declared_Within_Variant --
9222 --------------------------------
9224 function Is_Declared_Within_Variant (Comp : Entity_Id) return Boolean is
9225 Comp_Decl : constant Node_Id := Parent (Comp);
9226 Comp_List : constant Node_Id := Parent (Comp_Decl);
9228 return Nkind (Parent (Comp_List)) = N_Variant;
9229 end Is_Declared_Within_Variant;
9231 -- Start of processing for Is_Dependent_Component_Of_Mutable_Object
9234 if Is_Variable (Object) then
9236 if Nkind (Object) = N_Selected_Component then
9237 P := Prefix (Object);
9238 Prefix_Type := Etype (P);
9240 if Is_Entity_Name (P) then
9242 if Ekind (Entity (P)) = E_Generic_In_Out_Parameter then
9243 Prefix_Type := Base_Type (Prefix_Type);
9246 if Is_Aliased (Entity (P)) then
9250 -- A discriminant check on a selected component may be expanded
9251 -- into a dereference when removing side-effects. Recover the
9252 -- original node and its type, which may be unconstrained.
9254 elsif Nkind (P) = N_Explicit_Dereference
9255 and then not (Comes_From_Source (P))
9257 P := Original_Node (P);
9258 Prefix_Type := Etype (P);
9261 -- Check for prefix being an aliased component???
9267 -- A heap object is constrained by its initial value
9269 -- Ada 2005 (AI-363): Always assume the object could be mutable in
9270 -- the dereferenced case, since the access value might denote an
9271 -- unconstrained aliased object, whereas in Ada 95 the designated
9272 -- object is guaranteed to be constrained. A worst-case assumption
9273 -- has to apply in Ada 2005 because we can't tell at compile time
9274 -- whether the object is "constrained by its initial value"
9275 -- (despite the fact that 3.10.2(26/2) and 8.5.1(5/2) are
9276 -- semantic rules -- these rules are acknowledged to need fixing).
9278 if Ada_Version < Ada_2005 then
9279 if Is_Access_Type (Prefix_Type)
9280 or else Nkind (P) = N_Explicit_Dereference
9285 elsif Ada_Version >= Ada_2005 then
9286 if Is_Access_Type (Prefix_Type) then
9288 -- If the access type is pool-specific, and there is no
9289 -- constrained partial view of the designated type, then the
9290 -- designated object is known to be constrained.
9292 if Ekind (Prefix_Type) = E_Access_Type
9293 and then not Object_Type_Has_Constrained_Partial_View
9294 (Typ => Designated_Type (Prefix_Type),
9295 Scop => Current_Scope)
9299 -- Otherwise (general access type, or there is a constrained
9300 -- partial view of the designated type), we need to check
9301 -- based on the designated type.
9304 Prefix_Type := Designated_Type (Prefix_Type);
9310 Original_Record_Component (Entity (Selector_Name (Object)));
9312 -- As per AI-0017, the renaming is illegal in a generic body, even
9313 -- if the subtype is indefinite.
9315 -- Ada 2005 (AI-363): In Ada 2005 an aliased object can be mutable
9317 if not Is_Constrained (Prefix_Type)
9318 and then (not Is_Indefinite_Subtype (Prefix_Type)
9320 (Is_Generic_Type (Prefix_Type)
9321 and then Ekind (Current_Scope) = E_Generic_Package
9322 and then In_Package_Body (Current_Scope)))
9324 and then (Is_Declared_Within_Variant (Comp)
9325 or else Has_Discriminant_Dependent_Constraint (Comp))
9326 and then (not P_Aliased or else Ada_Version >= Ada_2005)
9330 -- If the prefix is of an access type at this point, then we want
9331 -- to return False, rather than calling this function recursively
9332 -- on the access object (which itself might be a discriminant-
9333 -- dependent component of some other object, but that isn't
9334 -- relevant to checking the object passed to us). This avoids
9335 -- issuing wrong errors when compiling with -gnatc, where there
9336 -- can be implicit dereferences that have not been expanded.
9338 elsif Is_Access_Type (Etype (Prefix (Object))) then
9343 Is_Dependent_Component_Of_Mutable_Object (Prefix (Object));
9346 elsif Nkind (Object) = N_Indexed_Component
9347 or else Nkind (Object) = N_Slice
9349 return Is_Dependent_Component_Of_Mutable_Object (Prefix (Object));
9351 -- A type conversion that Is_Variable is a view conversion:
9352 -- go back to the denoted object.
9354 elsif Nkind (Object) = N_Type_Conversion then
9356 Is_Dependent_Component_Of_Mutable_Object (Expression (Object));
9361 end Is_Dependent_Component_Of_Mutable_Object;
9363 ---------------------
9364 -- Is_Dereferenced --
9365 ---------------------
9367 function Is_Dereferenced (N : Node_Id) return Boolean is
9368 P : constant Node_Id := Parent (N);
9371 (Nkind (P) = N_Selected_Component
9373 Nkind (P) = N_Explicit_Dereference
9375 Nkind (P) = N_Indexed_Component
9377 Nkind (P) = N_Slice)
9378 and then Prefix (P) = N;
9379 end Is_Dereferenced;
9381 ----------------------
9382 -- Is_Descendent_Of --
9383 ----------------------
9385 function Is_Descendent_Of (T1 : Entity_Id; T2 : Entity_Id) return Boolean is
9390 pragma Assert (Nkind (T1) in N_Entity);
9391 pragma Assert (Nkind (T2) in N_Entity);
9393 T := Base_Type (T1);
9395 -- Immediate return if the types match
9400 -- Comment needed here ???
9402 elsif Ekind (T) = E_Class_Wide_Type then
9403 return Etype (T) = T2;
9411 -- Done if we found the type we are looking for
9416 -- Done if no more derivations to check
9423 -- Following test catches error cases resulting from prev errors
9425 elsif No (Etyp) then
9428 elsif Is_Private_Type (T) and then Etyp = Full_View (T) then
9431 elsif Is_Private_Type (Etyp) and then Full_View (Etyp) = T then
9435 T := Base_Type (Etyp);
9438 end Is_Descendent_Of;
9440 ----------------------------
9441 -- Is_Expression_Function --
9442 ----------------------------
9444 function Is_Expression_Function (Subp : Entity_Id) return Boolean is
9448 if Ekind (Subp) /= E_Function then
9452 Decl := Unit_Declaration_Node (Subp);
9453 return Nkind (Decl) = N_Subprogram_Declaration
9455 (Nkind (Original_Node (Decl)) = N_Expression_Function
9457 (Present (Corresponding_Body (Decl))
9459 Nkind (Original_Node
9460 (Unit_Declaration_Node
9461 (Corresponding_Body (Decl)))) =
9462 N_Expression_Function));
9464 end Is_Expression_Function;
9470 function Is_False (U : Uint) return Boolean is
9475 ---------------------------
9476 -- Is_Fixed_Model_Number --
9477 ---------------------------
9479 function Is_Fixed_Model_Number (U : Ureal; T : Entity_Id) return Boolean is
9480 S : constant Ureal := Small_Value (T);
9481 M : Urealp.Save_Mark;
9485 R := (U = UR_Trunc (U / S) * S);
9488 end Is_Fixed_Model_Number;
9490 -------------------------------
9491 -- Is_Fully_Initialized_Type --
9492 -------------------------------
9494 function Is_Fully_Initialized_Type (Typ : Entity_Id) return Boolean is
9496 -- In Ada2012, a scalar type with an aspect Default_Value
9497 -- is fully initialized.
9499 if Is_Scalar_Type (Typ) then
9500 return Ada_Version >= Ada_2012 and then Has_Default_Aspect (Typ);
9502 elsif Is_Access_Type (Typ) then
9505 elsif Is_Array_Type (Typ) then
9506 if Is_Fully_Initialized_Type (Component_Type (Typ))
9507 or else (Ada_Version >= Ada_2012 and then Has_Default_Aspect (Typ))
9512 -- An interesting case, if we have a constrained type one of whose
9513 -- bounds is known to be null, then there are no elements to be
9514 -- initialized, so all the elements are initialized!
9516 if Is_Constrained (Typ) then
9519 Indx_Typ : Entity_Id;
9523 Indx := First_Index (Typ);
9524 while Present (Indx) loop
9525 if Etype (Indx) = Any_Type then
9528 -- If index is a range, use directly
9530 elsif Nkind (Indx) = N_Range then
9531 Lbd := Low_Bound (Indx);
9532 Hbd := High_Bound (Indx);
9535 Indx_Typ := Etype (Indx);
9537 if Is_Private_Type (Indx_Typ) then
9538 Indx_Typ := Full_View (Indx_Typ);
9541 if No (Indx_Typ) or else Etype (Indx_Typ) = Any_Type then
9544 Lbd := Type_Low_Bound (Indx_Typ);
9545 Hbd := Type_High_Bound (Indx_Typ);
9549 if Compile_Time_Known_Value (Lbd)
9550 and then Compile_Time_Known_Value (Hbd)
9552 if Expr_Value (Hbd) < Expr_Value (Lbd) then
9562 -- If no null indexes, then type is not fully initialized
9568 elsif Is_Record_Type (Typ) then
9569 if Has_Discriminants (Typ)
9571 Present (Discriminant_Default_Value (First_Discriminant (Typ)))
9572 and then Is_Fully_Initialized_Variant (Typ)
9577 -- We consider bounded string types to be fully initialized, because
9578 -- otherwise we get false alarms when the Data component is not
9579 -- default-initialized.
9581 if Is_Bounded_String (Typ) then
9585 -- Controlled records are considered to be fully initialized if
9586 -- there is a user defined Initialize routine. This may not be
9587 -- entirely correct, but as the spec notes, we are guessing here
9588 -- what is best from the point of view of issuing warnings.
9590 if Is_Controlled (Typ) then
9592 Utyp : constant Entity_Id := Underlying_Type (Typ);
9595 if Present (Utyp) then
9597 Init : constant Entity_Id :=
9599 (Underlying_Type (Typ), Name_Initialize));
9603 and then Comes_From_Source (Init)
9605 Is_Predefined_File_Name
9606 (File_Name (Get_Source_File_Index (Sloc (Init))))
9610 elsif Has_Null_Extension (Typ)
9612 Is_Fully_Initialized_Type
9613 (Etype (Base_Type (Typ)))
9622 -- Otherwise see if all record components are initialized
9628 Ent := First_Entity (Typ);
9629 while Present (Ent) loop
9630 if Ekind (Ent) = E_Component
9631 and then (No (Parent (Ent))
9632 or else No (Expression (Parent (Ent))))
9633 and then not Is_Fully_Initialized_Type (Etype (Ent))
9635 -- Special VM case for tag components, which need to be
9636 -- defined in this case, but are never initialized as VMs
9637 -- are using other dispatching mechanisms. Ignore this
9638 -- uninitialized case. Note that this applies both to the
9639 -- uTag entry and the main vtable pointer (CPP_Class case).
9641 and then (Tagged_Type_Expansion or else not Is_Tag (Ent))
9650 -- No uninitialized components, so type is fully initialized.
9651 -- Note that this catches the case of no components as well.
9655 elsif Is_Concurrent_Type (Typ) then
9658 elsif Is_Private_Type (Typ) then
9660 U : constant Entity_Id := Underlying_Type (Typ);
9666 return Is_Fully_Initialized_Type (U);
9673 end Is_Fully_Initialized_Type;
9675 ----------------------------------
9676 -- Is_Fully_Initialized_Variant --
9677 ----------------------------------
9679 function Is_Fully_Initialized_Variant (Typ : Entity_Id) return Boolean is
9680 Loc : constant Source_Ptr := Sloc (Typ);
9681 Constraints : constant List_Id := New_List;
9682 Components : constant Elist_Id := New_Elmt_List;
9683 Comp_Elmt : Elmt_Id;
9685 Comp_List : Node_Id;
9687 Discr_Val : Node_Id;
9689 Report_Errors : Boolean;
9690 pragma Warnings (Off, Report_Errors);
9693 if Serious_Errors_Detected > 0 then
9697 if Is_Record_Type (Typ)
9698 and then Nkind (Parent (Typ)) = N_Full_Type_Declaration
9699 and then Nkind (Type_Definition (Parent (Typ))) = N_Record_Definition
9701 Comp_List := Component_List (Type_Definition (Parent (Typ)));
9703 Discr := First_Discriminant (Typ);
9704 while Present (Discr) loop
9705 if Nkind (Parent (Discr)) = N_Discriminant_Specification then
9706 Discr_Val := Expression (Parent (Discr));
9708 if Present (Discr_Val)
9709 and then Is_OK_Static_Expression (Discr_Val)
9711 Append_To (Constraints,
9712 Make_Component_Association (Loc,
9713 Choices => New_List (New_Occurrence_Of (Discr, Loc)),
9714 Expression => New_Copy (Discr_Val)));
9722 Next_Discriminant (Discr);
9727 Comp_List => Comp_List,
9728 Governed_By => Constraints,
9730 Report_Errors => Report_Errors);
9732 -- Check that each component present is fully initialized
9734 Comp_Elmt := First_Elmt (Components);
9735 while Present (Comp_Elmt) loop
9736 Comp_Id := Node (Comp_Elmt);
9738 if Ekind (Comp_Id) = E_Component
9739 and then (No (Parent (Comp_Id))
9740 or else No (Expression (Parent (Comp_Id))))
9741 and then not Is_Fully_Initialized_Type (Etype (Comp_Id))
9746 Next_Elmt (Comp_Elmt);
9751 elsif Is_Private_Type (Typ) then
9753 U : constant Entity_Id := Underlying_Type (Typ);
9759 return Is_Fully_Initialized_Variant (U);
9766 end Is_Fully_Initialized_Variant;
9768 ----------------------------
9769 -- Is_Inherited_Operation --
9770 ----------------------------
9772 function Is_Inherited_Operation (E : Entity_Id) return Boolean is
9773 pragma Assert (Is_Overloadable (E));
9774 Kind : constant Node_Kind := Nkind (Parent (E));
9776 return Kind = N_Full_Type_Declaration
9777 or else Kind = N_Private_Extension_Declaration
9778 or else Kind = N_Subtype_Declaration
9779 or else (Ekind (E) = E_Enumeration_Literal
9780 and then Is_Derived_Type (Etype (E)));
9781 end Is_Inherited_Operation;
9783 -------------------------------------
9784 -- Is_Inherited_Operation_For_Type --
9785 -------------------------------------
9787 function Is_Inherited_Operation_For_Type
9789 Typ : Entity_Id) return Boolean
9792 -- Check that the operation has been created by the type declaration
9794 return Is_Inherited_Operation (E)
9795 and then Defining_Identifier (Parent (E)) = Typ;
9796 end Is_Inherited_Operation_For_Type;
9802 function Is_Iterator (Typ : Entity_Id) return Boolean is
9803 Ifaces_List : Elist_Id;
9804 Iface_Elmt : Elmt_Id;
9808 if Is_Class_Wide_Type (Typ)
9810 Nam_In (Chars (Etype (Typ)), Name_Forward_Iterator,
9811 Name_Reversible_Iterator)
9813 Is_Predefined_File_Name
9814 (Unit_File_Name (Get_Source_Unit (Etype (Typ))))
9818 elsif not Is_Tagged_Type (Typ) or else not Is_Derived_Type (Typ) then
9822 Collect_Interfaces (Typ, Ifaces_List);
9824 Iface_Elmt := First_Elmt (Ifaces_List);
9825 while Present (Iface_Elmt) loop
9826 Iface := Node (Iface_Elmt);
9827 if Chars (Iface) = Name_Forward_Iterator
9829 Is_Predefined_File_Name
9830 (Unit_File_Name (Get_Source_Unit (Iface)))
9835 Next_Elmt (Iface_Elmt);
9846 -- We seem to have a lot of overlapping functions that do similar things
9847 -- (testing for left hand sides or lvalues???). Anyway, since this one is
9848 -- purely syntactic, it should be in Sem_Aux I would think???
9850 function Is_LHS (N : Node_Id) return Boolean is
9851 P : constant Node_Id := Parent (N);
9854 if Nkind (P) = N_Assignment_Statement then
9855 return Name (P) = N;
9858 Nkind_In (P, N_Indexed_Component, N_Selected_Component, N_Slice)
9860 return N = Prefix (P) and then Is_LHS (P);
9867 -----------------------------
9868 -- Is_Library_Level_Entity --
9869 -----------------------------
9871 function Is_Library_Level_Entity (E : Entity_Id) return Boolean is
9873 -- The following is a small optimization, and it also properly handles
9874 -- discriminals, which in task bodies might appear in expressions before
9875 -- the corresponding procedure has been created, and which therefore do
9876 -- not have an assigned scope.
9878 if Is_Formal (E) then
9882 -- Normal test is simply that the enclosing dynamic scope is Standard
9884 return Enclosing_Dynamic_Scope (E) = Standard_Standard;
9885 end Is_Library_Level_Entity;
9887 --------------------------------
9888 -- Is_Limited_Class_Wide_Type --
9889 --------------------------------
9891 function Is_Limited_Class_Wide_Type (Typ : Entity_Id) return Boolean is
9894 Is_Class_Wide_Type (Typ)
9895 and then (Is_Limited_Type (Typ) or else From_Limited_With (Typ));
9896 end Is_Limited_Class_Wide_Type;
9898 ---------------------------------
9899 -- Is_Local_Variable_Reference --
9900 ---------------------------------
9902 function Is_Local_Variable_Reference (Expr : Node_Id) return Boolean is
9904 if not Is_Entity_Name (Expr) then
9909 Ent : constant Entity_Id := Entity (Expr);
9910 Sub : constant Entity_Id := Enclosing_Subprogram (Ent);
9912 if not Ekind_In (Ent, E_Variable, E_In_Out_Parameter) then
9915 return Present (Sub) and then Sub = Current_Subprogram;
9919 end Is_Local_Variable_Reference;
9921 -------------------------
9922 -- Is_Object_Reference --
9923 -------------------------
9925 function Is_Object_Reference (N : Node_Id) return Boolean is
9927 function Is_Internally_Generated_Renaming (N : Node_Id) return Boolean;
9928 -- Determine whether N is the name of an internally-generated renaming
9930 --------------------------------------
9931 -- Is_Internally_Generated_Renaming --
9932 --------------------------------------
9934 function Is_Internally_Generated_Renaming (N : Node_Id) return Boolean is
9939 while Present (P) loop
9940 if Nkind (P) = N_Object_Renaming_Declaration then
9941 return not Comes_From_Source (P);
9942 elsif Is_List_Member (P) then
9950 end Is_Internally_Generated_Renaming;
9952 -- Start of processing for Is_Object_Reference
9955 if Is_Entity_Name (N) then
9956 return Present (Entity (N)) and then Is_Object (Entity (N));
9960 when N_Indexed_Component | N_Slice =>
9962 Is_Object_Reference (Prefix (N))
9963 or else Is_Access_Type (Etype (Prefix (N)));
9965 -- In Ada 95, a function call is a constant object; a procedure
9968 when N_Function_Call =>
9969 return Etype (N) /= Standard_Void_Type;
9971 -- Attributes 'Input, 'Old and 'Result produce objects
9973 when N_Attribute_Reference =>
9976 (Attribute_Name (N), Name_Input, Name_Old, Name_Result);
9978 when N_Selected_Component =>
9980 Is_Object_Reference (Selector_Name (N))
9982 (Is_Object_Reference (Prefix (N))
9983 or else Is_Access_Type (Etype (Prefix (N))));
9985 when N_Explicit_Dereference =>
9988 -- A view conversion of a tagged object is an object reference
9990 when N_Type_Conversion =>
9991 return Is_Tagged_Type (Etype (Subtype_Mark (N)))
9992 and then Is_Tagged_Type (Etype (Expression (N)))
9993 and then Is_Object_Reference (Expression (N));
9995 -- An unchecked type conversion is considered to be an object if
9996 -- the operand is an object (this construction arises only as a
9997 -- result of expansion activities).
9999 when N_Unchecked_Type_Conversion =>
10002 -- Allow string literals to act as objects as long as they appear
10003 -- in internally-generated renamings. The expansion of iterators
10004 -- may generate such renamings when the range involves a string
10007 when N_String_Literal =>
10008 return Is_Internally_Generated_Renaming (Parent (N));
10010 -- AI05-0003: In Ada 2012 a qualified expression is a name.
10011 -- This allows disambiguation of function calls and the use
10012 -- of aggregates in more contexts.
10014 when N_Qualified_Expression =>
10015 if Ada_Version < Ada_2012 then
10018 return Is_Object_Reference (Expression (N))
10019 or else Nkind (Expression (N)) = N_Aggregate;
10026 end Is_Object_Reference;
10028 -----------------------------------
10029 -- Is_OK_Variable_For_Out_Formal --
10030 -----------------------------------
10032 function Is_OK_Variable_For_Out_Formal (AV : Node_Id) return Boolean is
10034 Note_Possible_Modification (AV, Sure => True);
10036 -- We must reject parenthesized variable names. Comes_From_Source is
10037 -- checked because there are currently cases where the compiler violates
10038 -- this rule (e.g. passing a task object to its controlled Initialize
10039 -- routine). This should be properly documented in sinfo???
10041 if Paren_Count (AV) > 0 and then Comes_From_Source (AV) then
10044 -- A variable is always allowed
10046 elsif Is_Variable (AV) then
10049 -- Unchecked conversions are allowed only if they come from the
10050 -- generated code, which sometimes uses unchecked conversions for out
10051 -- parameters in cases where code generation is unaffected. We tell
10052 -- source unchecked conversions by seeing if they are rewrites of
10053 -- an original Unchecked_Conversion function call, or of an explicit
10054 -- conversion of a function call or an aggregate (as may happen in the
10055 -- expansion of a packed array aggregate).
10057 elsif Nkind (AV) = N_Unchecked_Type_Conversion then
10058 if Nkind_In (Original_Node (AV), N_Function_Call, N_Aggregate) then
10061 elsif Comes_From_Source (AV)
10062 and then Nkind (Original_Node (Expression (AV))) = N_Function_Call
10066 elsif Nkind (Original_Node (AV)) = N_Type_Conversion then
10067 return Is_OK_Variable_For_Out_Formal (Expression (AV));
10073 -- Normal type conversions are allowed if argument is a variable
10075 elsif Nkind (AV) = N_Type_Conversion then
10076 if Is_Variable (Expression (AV))
10077 and then Paren_Count (Expression (AV)) = 0
10079 Note_Possible_Modification (Expression (AV), Sure => True);
10082 -- We also allow a non-parenthesized expression that raises
10083 -- constraint error if it rewrites what used to be a variable
10085 elsif Raises_Constraint_Error (Expression (AV))
10086 and then Paren_Count (Expression (AV)) = 0
10087 and then Is_Variable (Original_Node (Expression (AV)))
10091 -- Type conversion of something other than a variable
10097 -- If this node is rewritten, then test the original form, if that is
10098 -- OK, then we consider the rewritten node OK (for example, if the
10099 -- original node is a conversion, then Is_Variable will not be true
10100 -- but we still want to allow the conversion if it converts a variable).
10102 elsif Original_Node (AV) /= AV then
10104 -- In Ada 2012, the explicit dereference may be a rewritten call to a
10105 -- Reference function.
10107 if Ada_Version >= Ada_2012
10108 and then Nkind (Original_Node (AV)) = N_Function_Call
10110 Has_Implicit_Dereference (Etype (Name (Original_Node (AV))))
10115 return Is_OK_Variable_For_Out_Formal (Original_Node (AV));
10118 -- All other non-variables are rejected
10123 end Is_OK_Variable_For_Out_Formal;
10125 -----------------------------------
10126 -- Is_Partially_Initialized_Type --
10127 -----------------------------------
10129 function Is_Partially_Initialized_Type
10131 Include_Implicit : Boolean := True) return Boolean
10134 if Is_Scalar_Type (Typ) then
10137 elsif Is_Access_Type (Typ) then
10138 return Include_Implicit;
10140 elsif Is_Array_Type (Typ) then
10142 -- If component type is partially initialized, so is array type
10144 if Is_Partially_Initialized_Type
10145 (Component_Type (Typ), Include_Implicit)
10149 -- Otherwise we are only partially initialized if we are fully
10150 -- initialized (this is the empty array case, no point in us
10151 -- duplicating that code here).
10154 return Is_Fully_Initialized_Type (Typ);
10157 elsif Is_Record_Type (Typ) then
10159 -- A discriminated type is always partially initialized if in
10162 if Has_Discriminants (Typ) and then Include_Implicit then
10165 -- A tagged type is always partially initialized
10167 elsif Is_Tagged_Type (Typ) then
10170 -- Case of non-discriminated record
10176 Component_Present : Boolean := False;
10177 -- Set True if at least one component is present. If no
10178 -- components are present, then record type is fully
10179 -- initialized (another odd case, like the null array).
10182 -- Loop through components
10184 Ent := First_Entity (Typ);
10185 while Present (Ent) loop
10186 if Ekind (Ent) = E_Component then
10187 Component_Present := True;
10189 -- If a component has an initialization expression then
10190 -- the enclosing record type is partially initialized
10192 if Present (Parent (Ent))
10193 and then Present (Expression (Parent (Ent)))
10197 -- If a component is of a type which is itself partially
10198 -- initialized, then the enclosing record type is also.
10200 elsif Is_Partially_Initialized_Type
10201 (Etype (Ent), Include_Implicit)
10210 -- No initialized components found. If we found any components
10211 -- they were all uninitialized so the result is false.
10213 if Component_Present then
10216 -- But if we found no components, then all the components are
10217 -- initialized so we consider the type to be initialized.
10225 -- Concurrent types are always fully initialized
10227 elsif Is_Concurrent_Type (Typ) then
10230 -- For a private type, go to underlying type. If there is no underlying
10231 -- type then just assume this partially initialized. Not clear if this
10232 -- can happen in a non-error case, but no harm in testing for this.
10234 elsif Is_Private_Type (Typ) then
10236 U : constant Entity_Id := Underlying_Type (Typ);
10241 return Is_Partially_Initialized_Type (U, Include_Implicit);
10245 -- For any other type (are there any?) assume partially initialized
10250 end Is_Partially_Initialized_Type;
10252 --------------------------------
10253 -- Is_Potentially_Unevaluated --
10254 --------------------------------
10256 function Is_Potentially_Unevaluated (N : Node_Id) return Boolean is
10263 while not Nkind_In (Par, N_If_Expression,
10271 Par := Parent (Par);
10272 if Nkind (Par) not in N_Subexpr then
10277 if Nkind (Par) = N_If_Expression then
10278 return Is_Elsif (Par) or else Expr /= First (Expressions (Par));
10280 elsif Nkind (Par) = N_Case_Expression then
10281 return Expr /= Expression (Par);
10283 elsif Nkind_In (Par, N_And_Then, N_Or_Else) then
10284 return Expr = Right_Opnd (Par);
10286 elsif Nkind_In (Par, N_In, N_Not_In) then
10287 return Expr /= Left_Opnd (Par);
10292 end Is_Potentially_Unevaluated;
10294 ------------------------------------
10295 -- Is_Potentially_Persistent_Type --
10296 ------------------------------------
10298 function Is_Potentially_Persistent_Type (T : Entity_Id) return Boolean is
10303 -- For private type, test corresponding full type
10305 if Is_Private_Type (T) then
10306 return Is_Potentially_Persistent_Type (Full_View (T));
10308 -- Scalar types are potentially persistent
10310 elsif Is_Scalar_Type (T) then
10313 -- Record type is potentially persistent if not tagged and the types of
10314 -- all it components are potentially persistent, and no component has
10315 -- an initialization expression.
10317 elsif Is_Record_Type (T)
10318 and then not Is_Tagged_Type (T)
10319 and then not Is_Partially_Initialized_Type (T)
10321 Comp := First_Component (T);
10322 while Present (Comp) loop
10323 if not Is_Potentially_Persistent_Type (Etype (Comp)) then
10326 Next_Entity (Comp);
10332 -- Array type is potentially persistent if its component type is
10333 -- potentially persistent and if all its constraints are static.
10335 elsif Is_Array_Type (T) then
10336 if not Is_Potentially_Persistent_Type (Component_Type (T)) then
10340 Indx := First_Index (T);
10341 while Present (Indx) loop
10342 if not Is_OK_Static_Subtype (Etype (Indx)) then
10351 -- All other types are not potentially persistent
10356 end Is_Potentially_Persistent_Type;
10358 ---------------------------------
10359 -- Is_Protected_Self_Reference --
10360 ---------------------------------
10362 function Is_Protected_Self_Reference (N : Node_Id) return Boolean is
10364 function In_Access_Definition (N : Node_Id) return Boolean;
10365 -- Returns true if N belongs to an access definition
10367 --------------------------
10368 -- In_Access_Definition --
10369 --------------------------
10371 function In_Access_Definition (N : Node_Id) return Boolean is
10376 while Present (P) loop
10377 if Nkind (P) = N_Access_Definition then
10385 end In_Access_Definition;
10387 -- Start of processing for Is_Protected_Self_Reference
10390 -- Verify that prefix is analyzed and has the proper form. Note that
10391 -- the attributes Elab_Spec, Elab_Body, Elab_Subp_Body and UET_Address,
10392 -- which also produce the address of an entity, do not analyze their
10393 -- prefix because they denote entities that are not necessarily visible.
10394 -- Neither of them can apply to a protected type.
10396 return Ada_Version >= Ada_2005
10397 and then Is_Entity_Name (N)
10398 and then Present (Entity (N))
10399 and then Is_Protected_Type (Entity (N))
10400 and then In_Open_Scopes (Entity (N))
10401 and then not In_Access_Definition (N);
10402 end Is_Protected_Self_Reference;
10404 -----------------------------
10405 -- Is_RCI_Pkg_Spec_Or_Body --
10406 -----------------------------
10408 function Is_RCI_Pkg_Spec_Or_Body (Cunit : Node_Id) return Boolean is
10410 function Is_RCI_Pkg_Decl_Cunit (Cunit : Node_Id) return Boolean;
10411 -- Return True if the unit of Cunit is an RCI package declaration
10413 ---------------------------
10414 -- Is_RCI_Pkg_Decl_Cunit --
10415 ---------------------------
10417 function Is_RCI_Pkg_Decl_Cunit (Cunit : Node_Id) return Boolean is
10418 The_Unit : constant Node_Id := Unit (Cunit);
10421 if Nkind (The_Unit) /= N_Package_Declaration then
10425 return Is_Remote_Call_Interface (Defining_Entity (The_Unit));
10426 end Is_RCI_Pkg_Decl_Cunit;
10428 -- Start of processing for Is_RCI_Pkg_Spec_Or_Body
10431 return Is_RCI_Pkg_Decl_Cunit (Cunit)
10433 (Nkind (Unit (Cunit)) = N_Package_Body
10434 and then Is_RCI_Pkg_Decl_Cunit (Library_Unit (Cunit)));
10435 end Is_RCI_Pkg_Spec_Or_Body;
10437 -----------------------------------------
10438 -- Is_Remote_Access_To_Class_Wide_Type --
10439 -----------------------------------------
10441 function Is_Remote_Access_To_Class_Wide_Type
10442 (E : Entity_Id) return Boolean
10445 -- A remote access to class-wide type is a general access to object type
10446 -- declared in the visible part of a Remote_Types or Remote_Call_
10449 return Ekind (E) = E_General_Access_Type
10450 and then (Is_Remote_Call_Interface (E) or else Is_Remote_Types (E));
10451 end Is_Remote_Access_To_Class_Wide_Type;
10453 -----------------------------------------
10454 -- Is_Remote_Access_To_Subprogram_Type --
10455 -----------------------------------------
10457 function Is_Remote_Access_To_Subprogram_Type
10458 (E : Entity_Id) return Boolean
10461 return (Ekind (E) = E_Access_Subprogram_Type
10462 or else (Ekind (E) = E_Record_Type
10463 and then Present (Corresponding_Remote_Type (E))))
10464 and then (Is_Remote_Call_Interface (E) or else Is_Remote_Types (E));
10465 end Is_Remote_Access_To_Subprogram_Type;
10467 --------------------
10468 -- Is_Remote_Call --
10469 --------------------
10471 function Is_Remote_Call (N : Node_Id) return Boolean is
10473 if Nkind (N) not in N_Subprogram_Call then
10475 -- An entry call cannot be remote
10479 elsif Nkind (Name (N)) in N_Has_Entity
10480 and then Is_Remote_Call_Interface (Entity (Name (N)))
10482 -- A subprogram declared in the spec of a RCI package is remote
10486 elsif Nkind (Name (N)) = N_Explicit_Dereference
10487 and then Is_Remote_Access_To_Subprogram_Type
10488 (Etype (Prefix (Name (N))))
10490 -- The dereference of a RAS is a remote call
10494 elsif Present (Controlling_Argument (N))
10495 and then Is_Remote_Access_To_Class_Wide_Type
10496 (Etype (Controlling_Argument (N)))
10498 -- Any primitive operation call with a controlling argument of
10499 -- a RACW type is a remote call.
10504 -- All other calls are local calls
10507 end Is_Remote_Call;
10509 ----------------------
10510 -- Is_Renamed_Entry --
10511 ----------------------
10513 function Is_Renamed_Entry (Proc_Nam : Entity_Id) return Boolean is
10514 Orig_Node : Node_Id := Empty;
10515 Subp_Decl : Node_Id := Parent (Parent (Proc_Nam));
10517 function Is_Entry (Nam : Node_Id) return Boolean;
10518 -- Determine whether Nam is an entry. Traverse selectors if there are
10519 -- nested selected components.
10525 function Is_Entry (Nam : Node_Id) return Boolean is
10527 if Nkind (Nam) = N_Selected_Component then
10528 return Is_Entry (Selector_Name (Nam));
10531 return Ekind (Entity (Nam)) = E_Entry;
10534 -- Start of processing for Is_Renamed_Entry
10537 if Present (Alias (Proc_Nam)) then
10538 Subp_Decl := Parent (Parent (Alias (Proc_Nam)));
10541 -- Look for a rewritten subprogram renaming declaration
10543 if Nkind (Subp_Decl) = N_Subprogram_Declaration
10544 and then Present (Original_Node (Subp_Decl))
10546 Orig_Node := Original_Node (Subp_Decl);
10549 -- The rewritten subprogram is actually an entry
10551 if Present (Orig_Node)
10552 and then Nkind (Orig_Node) = N_Subprogram_Renaming_Declaration
10553 and then Is_Entry (Name (Orig_Node))
10559 end Is_Renamed_Entry;
10561 ----------------------------
10562 -- Is_Reversible_Iterator --
10563 ----------------------------
10565 function Is_Reversible_Iterator (Typ : Entity_Id) return Boolean is
10566 Ifaces_List : Elist_Id;
10567 Iface_Elmt : Elmt_Id;
10571 if Is_Class_Wide_Type (Typ)
10572 and then Chars (Etype (Typ)) = Name_Reversible_Iterator
10574 Is_Predefined_File_Name
10575 (Unit_File_Name (Get_Source_Unit (Etype (Typ))))
10579 elsif not Is_Tagged_Type (Typ)
10580 or else not Is_Derived_Type (Typ)
10585 Collect_Interfaces (Typ, Ifaces_List);
10587 Iface_Elmt := First_Elmt (Ifaces_List);
10588 while Present (Iface_Elmt) loop
10589 Iface := Node (Iface_Elmt);
10590 if Chars (Iface) = Name_Reversible_Iterator
10592 Is_Predefined_File_Name
10593 (Unit_File_Name (Get_Source_Unit (Iface)))
10598 Next_Elmt (Iface_Elmt);
10603 end Is_Reversible_Iterator;
10605 ----------------------
10606 -- Is_Selector_Name --
10607 ----------------------
10609 function Is_Selector_Name (N : Node_Id) return Boolean is
10611 if not Is_List_Member (N) then
10613 P : constant Node_Id := Parent (N);
10614 K : constant Node_Kind := Nkind (P);
10617 (K = N_Expanded_Name or else
10618 K = N_Generic_Association or else
10619 K = N_Parameter_Association or else
10620 K = N_Selected_Component)
10621 and then Selector_Name (P) = N;
10626 L : constant List_Id := List_Containing (N);
10627 P : constant Node_Id := Parent (L);
10629 return (Nkind (P) = N_Discriminant_Association
10630 and then Selector_Names (P) = L)
10632 (Nkind (P) = N_Component_Association
10633 and then Choices (P) = L);
10636 end Is_Selector_Name;
10638 ----------------------------------
10639 -- Is_SPARK_Initialization_Expr --
10640 ----------------------------------
10642 function Is_SPARK_Initialization_Expr (N : Node_Id) return Boolean is
10645 Comp_Assn : Node_Id;
10646 Orig_N : constant Node_Id := Original_Node (N);
10651 if not Comes_From_Source (Orig_N) then
10655 pragma Assert (Nkind (Orig_N) in N_Subexpr);
10657 case Nkind (Orig_N) is
10658 when N_Character_Literal |
10659 N_Integer_Literal |
10661 N_String_Literal =>
10664 when N_Identifier |
10666 if Is_Entity_Name (Orig_N)
10667 and then Present (Entity (Orig_N)) -- needed in some cases
10669 case Ekind (Entity (Orig_N)) is
10671 E_Enumeration_Literal |
10676 if Is_Type (Entity (Orig_N)) then
10684 when N_Qualified_Expression |
10685 N_Type_Conversion =>
10686 Is_Ok := Is_SPARK_Initialization_Expr (Expression (Orig_N));
10689 Is_Ok := Is_SPARK_Initialization_Expr (Right_Opnd (Orig_N));
10693 N_Membership_Test =>
10694 Is_Ok := Is_SPARK_Initialization_Expr (Left_Opnd (Orig_N))
10695 and then Is_SPARK_Initialization_Expr (Right_Opnd (Orig_N));
10698 N_Extension_Aggregate =>
10699 if Nkind (Orig_N) = N_Extension_Aggregate then
10700 Is_Ok := Is_SPARK_Initialization_Expr (Ancestor_Part (Orig_N));
10703 Expr := First (Expressions (Orig_N));
10704 while Present (Expr) loop
10705 if not Is_SPARK_Initialization_Expr (Expr) then
10713 Comp_Assn := First (Component_Associations (Orig_N));
10714 while Present (Comp_Assn) loop
10715 Expr := Expression (Comp_Assn);
10716 if Present (Expr) -- needed for box association
10717 and then not Is_SPARK_Initialization_Expr (Expr)
10726 when N_Attribute_Reference =>
10727 if Nkind (Prefix (Orig_N)) in N_Subexpr then
10728 Is_Ok := Is_SPARK_Initialization_Expr (Prefix (Orig_N));
10731 Expr := First (Expressions (Orig_N));
10732 while Present (Expr) loop
10733 if not Is_SPARK_Initialization_Expr (Expr) then
10741 -- Selected components might be expanded named not yet resolved, so
10742 -- default on the safe side. (Eg on sparklex.ads)
10744 when N_Selected_Component =>
10753 end Is_SPARK_Initialization_Expr;
10755 -------------------------------
10756 -- Is_SPARK_Object_Reference --
10757 -------------------------------
10759 function Is_SPARK_Object_Reference (N : Node_Id) return Boolean is
10761 if Is_Entity_Name (N) then
10762 return Present (Entity (N))
10764 (Ekind_In (Entity (N), E_Constant, E_Variable)
10765 or else Ekind (Entity (N)) in Formal_Kind);
10769 when N_Selected_Component =>
10770 return Is_SPARK_Object_Reference (Prefix (N));
10776 end Is_SPARK_Object_Reference;
10782 function Is_Statement (N : Node_Id) return Boolean is
10785 Nkind (N) in N_Statement_Other_Than_Procedure_Call
10786 or else Nkind (N) = N_Procedure_Call_Statement;
10789 --------------------------------------------------
10790 -- Is_Subprogram_Stub_Without_Prior_Declaration --
10791 --------------------------------------------------
10793 function Is_Subprogram_Stub_Without_Prior_Declaration
10794 (N : Node_Id) return Boolean
10797 -- A subprogram stub without prior declaration serves as declaration for
10798 -- the actual subprogram body. As such, it has an attached defining
10799 -- entity of E_[Generic_]Function or E_[Generic_]Procedure.
10801 return Nkind (N) = N_Subprogram_Body_Stub
10802 and then Ekind (Defining_Entity (N)) /= E_Subprogram_Body;
10803 end Is_Subprogram_Stub_Without_Prior_Declaration;
10805 ---------------------------------
10806 -- Is_Synchronized_Tagged_Type --
10807 ---------------------------------
10809 function Is_Synchronized_Tagged_Type (E : Entity_Id) return Boolean is
10810 Kind : constant Entity_Kind := Ekind (Base_Type (E));
10813 -- A task or protected type derived from an interface is a tagged type.
10814 -- Such a tagged type is called a synchronized tagged type, as are
10815 -- synchronized interfaces and private extensions whose declaration
10816 -- includes the reserved word synchronized.
10818 return (Is_Tagged_Type (E)
10819 and then (Kind = E_Task_Type
10820 or else Kind = E_Protected_Type))
10823 and then Is_Synchronized_Interface (E))
10825 (Ekind (E) = E_Record_Type_With_Private
10826 and then Nkind (Parent (E)) = N_Private_Extension_Declaration
10827 and then (Synchronized_Present (Parent (E))
10828 or else Is_Synchronized_Interface (Etype (E))));
10829 end Is_Synchronized_Tagged_Type;
10835 function Is_Transfer (N : Node_Id) return Boolean is
10836 Kind : constant Node_Kind := Nkind (N);
10839 if Kind = N_Simple_Return_Statement
10841 Kind = N_Extended_Return_Statement
10843 Kind = N_Goto_Statement
10845 Kind = N_Raise_Statement
10847 Kind = N_Requeue_Statement
10851 elsif (Kind = N_Exit_Statement or else Kind in N_Raise_xxx_Error)
10852 and then No (Condition (N))
10856 elsif Kind = N_Procedure_Call_Statement
10857 and then Is_Entity_Name (Name (N))
10858 and then Present (Entity (Name (N)))
10859 and then No_Return (Entity (Name (N)))
10863 elsif Nkind (Original_Node (N)) = N_Raise_Statement then
10875 function Is_True (U : Uint) return Boolean is
10880 --------------------------------------
10881 -- Is_Unchecked_Conversion_Instance --
10882 --------------------------------------
10884 function Is_Unchecked_Conversion_Instance (Id : Entity_Id) return Boolean is
10885 Gen_Par : Entity_Id;
10888 -- Look for a function whose generic parent is the predefined intrinsic
10889 -- function Unchecked_Conversion.
10891 if Ekind (Id) = E_Function then
10892 Gen_Par := Generic_Parent (Parent (Id));
10896 and then Chars (Gen_Par) = Name_Unchecked_Conversion
10897 and then Is_Intrinsic_Subprogram (Gen_Par)
10898 and then Is_Predefined_File_Name
10899 (Unit_File_Name (Get_Source_Unit (Gen_Par)));
10903 end Is_Unchecked_Conversion_Instance;
10905 -------------------------------
10906 -- Is_Universal_Numeric_Type --
10907 -------------------------------
10909 function Is_Universal_Numeric_Type (T : Entity_Id) return Boolean is
10911 return T = Universal_Integer or else T = Universal_Real;
10912 end Is_Universal_Numeric_Type;
10914 -------------------
10915 -- Is_Value_Type --
10916 -------------------
10918 function Is_Value_Type (T : Entity_Id) return Boolean is
10920 return VM_Target = CLI_Target
10921 and then Nkind (T) in N_Has_Chars
10922 and then Chars (T) /= No_Name
10923 and then Get_Name_String (Chars (T)) = "valuetype";
10926 ----------------------------
10927 -- Is_Variable_Size_Array --
10928 ----------------------------
10930 function Is_Variable_Size_Array (E : Entity_Id) return Boolean is
10934 pragma Assert (Is_Array_Type (E));
10936 -- Check if some index is initialized with a non-constant value
10938 Idx := First_Index (E);
10939 while Present (Idx) loop
10940 if Nkind (Idx) = N_Range then
10941 if not Is_Constant_Bound (Low_Bound (Idx))
10942 or else not Is_Constant_Bound (High_Bound (Idx))
10948 Idx := Next_Index (Idx);
10952 end Is_Variable_Size_Array;
10954 -----------------------------
10955 -- Is_Variable_Size_Record --
10956 -----------------------------
10958 function Is_Variable_Size_Record (E : Entity_Id) return Boolean is
10960 Comp_Typ : Entity_Id;
10963 pragma Assert (Is_Record_Type (E));
10965 Comp := First_Entity (E);
10966 while Present (Comp) loop
10967 Comp_Typ := Etype (Comp);
10969 -- Recursive call if the record type has discriminants
10971 if Is_Record_Type (Comp_Typ)
10972 and then Has_Discriminants (Comp_Typ)
10973 and then Is_Variable_Size_Record (Comp_Typ)
10977 elsif Is_Array_Type (Comp_Typ)
10978 and then Is_Variable_Size_Array (Comp_Typ)
10983 Next_Entity (Comp);
10987 end Is_Variable_Size_Record;
10989 ---------------------
10990 -- Is_VMS_Operator --
10991 ---------------------
10993 function Is_VMS_Operator (Op : Entity_Id) return Boolean is
10995 -- The VMS operators are declared in a child of System that is loaded
10996 -- through pragma Extend_System. In some rare cases a program is run
10997 -- with this extension but without indicating that the target is VMS.
10999 return Ekind (Op) = E_Function
11000 and then Is_Intrinsic_Subprogram (Op)
11002 ((Present_System_Aux and then Scope (Op) = System_Aux_Id)
11005 and then Scope (Scope (Op)) = RTU_Entity (System)));
11006 end Is_VMS_Operator;
11012 function Is_Variable
11014 Use_Original_Node : Boolean := True) return Boolean
11016 Orig_Node : Node_Id;
11018 function In_Protected_Function (E : Entity_Id) return Boolean;
11019 -- Within a protected function, the private components of the enclosing
11020 -- protected type are constants. A function nested within a (protected)
11021 -- procedure is not itself protected. Within the body of a protected
11022 -- function the current instance of the protected type is a constant.
11024 function Is_Variable_Prefix (P : Node_Id) return Boolean;
11025 -- Prefixes can involve implicit dereferences, in which case we must
11026 -- test for the case of a reference of a constant access type, which can
11027 -- can never be a variable.
11029 ---------------------------
11030 -- In_Protected_Function --
11031 ---------------------------
11033 function In_Protected_Function (E : Entity_Id) return Boolean is
11038 -- E is the current instance of a type
11040 if Is_Type (E) then
11049 if not Is_Protected_Type (Prot) then
11053 S := Current_Scope;
11054 while Present (S) and then S /= Prot loop
11055 if Ekind (S) = E_Function and then Scope (S) = Prot then
11064 end In_Protected_Function;
11066 ------------------------
11067 -- Is_Variable_Prefix --
11068 ------------------------
11070 function Is_Variable_Prefix (P : Node_Id) return Boolean is
11072 if Is_Access_Type (Etype (P)) then
11073 return not Is_Access_Constant (Root_Type (Etype (P)));
11075 -- For the case of an indexed component whose prefix has a packed
11076 -- array type, the prefix has been rewritten into a type conversion.
11077 -- Determine variable-ness from the converted expression.
11079 elsif Nkind (P) = N_Type_Conversion
11080 and then not Comes_From_Source (P)
11081 and then Is_Array_Type (Etype (P))
11082 and then Is_Packed (Etype (P))
11084 return Is_Variable (Expression (P));
11087 return Is_Variable (P);
11089 end Is_Variable_Prefix;
11091 -- Start of processing for Is_Variable
11094 -- Check if we perform the test on the original node since this may be a
11095 -- test of syntactic categories which must not be disturbed by whatever
11096 -- rewriting might have occurred. For example, an aggregate, which is
11097 -- certainly NOT a variable, could be turned into a variable by
11100 if Use_Original_Node then
11101 Orig_Node := Original_Node (N);
11106 -- Definitely OK if Assignment_OK is set. Since this is something that
11107 -- only gets set for expanded nodes, the test is on N, not Orig_Node.
11109 if Nkind (N) in N_Subexpr and then Assignment_OK (N) then
11112 -- Normally we go to the original node, but there is one exception where
11113 -- we use the rewritten node, namely when it is an explicit dereference.
11114 -- The generated code may rewrite a prefix which is an access type with
11115 -- an explicit dereference. The dereference is a variable, even though
11116 -- the original node may not be (since it could be a constant of the
11119 -- In Ada 2005 we have a further case to consider: the prefix may be a
11120 -- function call given in prefix notation. The original node appears to
11121 -- be a selected component, but we need to examine the call.
11123 elsif Nkind (N) = N_Explicit_Dereference
11124 and then Nkind (Orig_Node) /= N_Explicit_Dereference
11125 and then Present (Etype (Orig_Node))
11126 and then Is_Access_Type (Etype (Orig_Node))
11128 -- Note that if the prefix is an explicit dereference that does not
11129 -- come from source, we must check for a rewritten function call in
11130 -- prefixed notation before other forms of rewriting, to prevent a
11134 (Nkind (Orig_Node) = N_Function_Call
11135 and then not Is_Access_Constant (Etype (Prefix (N))))
11137 Is_Variable_Prefix (Original_Node (Prefix (N)));
11139 -- in Ada 2012, the dereference may have been added for a type with
11140 -- a declared implicit dereference aspect.
11142 elsif Nkind (N) = N_Explicit_Dereference
11143 and then Present (Etype (Orig_Node))
11144 and then Ada_Version >= Ada_2012
11145 and then Has_Implicit_Dereference (Etype (Orig_Node))
11149 -- A function call is never a variable
11151 elsif Nkind (N) = N_Function_Call then
11154 -- All remaining checks use the original node
11156 elsif Is_Entity_Name (Orig_Node)
11157 and then Present (Entity (Orig_Node))
11160 E : constant Entity_Id := Entity (Orig_Node);
11161 K : constant Entity_Kind := Ekind (E);
11164 return (K = E_Variable
11165 and then Nkind (Parent (E)) /= N_Exception_Handler)
11166 or else (K = E_Component
11167 and then not In_Protected_Function (E))
11168 or else K = E_Out_Parameter
11169 or else K = E_In_Out_Parameter
11170 or else K = E_Generic_In_Out_Parameter
11172 -- Current instance of type. If this is a protected type, check
11173 -- we are not within the body of one of its protected functions.
11175 or else (Is_Type (E)
11176 and then In_Open_Scopes (E)
11177 and then not In_Protected_Function (E))
11179 or else (Is_Incomplete_Or_Private_Type (E)
11180 and then In_Open_Scopes (Full_View (E)));
11184 case Nkind (Orig_Node) is
11185 when N_Indexed_Component | N_Slice =>
11186 return Is_Variable_Prefix (Prefix (Orig_Node));
11188 when N_Selected_Component =>
11189 return Is_Variable_Prefix (Prefix (Orig_Node))
11190 and then Is_Variable (Selector_Name (Orig_Node));
11192 -- For an explicit dereference, the type of the prefix cannot
11193 -- be an access to constant or an access to subprogram.
11195 when N_Explicit_Dereference =>
11197 Typ : constant Entity_Id := Etype (Prefix (Orig_Node));
11199 return Is_Access_Type (Typ)
11200 and then not Is_Access_Constant (Root_Type (Typ))
11201 and then Ekind (Typ) /= E_Access_Subprogram_Type;
11204 -- The type conversion is the case where we do not deal with the
11205 -- context dependent special case of an actual parameter. Thus
11206 -- the type conversion is only considered a variable for the
11207 -- purposes of this routine if the target type is tagged. However,
11208 -- a type conversion is considered to be a variable if it does not
11209 -- come from source (this deals for example with the conversions
11210 -- of expressions to their actual subtypes).
11212 when N_Type_Conversion =>
11213 return Is_Variable (Expression (Orig_Node))
11215 (not Comes_From_Source (Orig_Node)
11217 (Is_Tagged_Type (Etype (Subtype_Mark (Orig_Node)))
11219 Is_Tagged_Type (Etype (Expression (Orig_Node)))));
11221 -- GNAT allows an unchecked type conversion as a variable. This
11222 -- only affects the generation of internal expanded code, since
11223 -- calls to instantiations of Unchecked_Conversion are never
11224 -- considered variables (since they are function calls).
11226 when N_Unchecked_Type_Conversion =>
11227 return Is_Variable (Expression (Orig_Node));
11235 ---------------------------
11236 -- Is_Visibly_Controlled --
11237 ---------------------------
11239 function Is_Visibly_Controlled (T : Entity_Id) return Boolean is
11240 Root : constant Entity_Id := Root_Type (T);
11242 return Chars (Scope (Root)) = Name_Finalization
11243 and then Chars (Scope (Scope (Root))) = Name_Ada
11244 and then Scope (Scope (Scope (Root))) = Standard_Standard;
11245 end Is_Visibly_Controlled;
11247 ------------------------
11248 -- Is_Volatile_Object --
11249 ------------------------
11251 function Is_Volatile_Object (N : Node_Id) return Boolean is
11253 function Is_Volatile_Prefix (N : Node_Id) return Boolean;
11254 -- If prefix is an implicit dereference, examine designated type
11256 function Object_Has_Volatile_Components (N : Node_Id) return Boolean;
11257 -- Determines if given object has volatile components
11259 ------------------------
11260 -- Is_Volatile_Prefix --
11261 ------------------------
11263 function Is_Volatile_Prefix (N : Node_Id) return Boolean is
11264 Typ : constant Entity_Id := Etype (N);
11267 if Is_Access_Type (Typ) then
11269 Dtyp : constant Entity_Id := Designated_Type (Typ);
11272 return Is_Volatile (Dtyp)
11273 or else Has_Volatile_Components (Dtyp);
11277 return Object_Has_Volatile_Components (N);
11279 end Is_Volatile_Prefix;
11281 ------------------------------------
11282 -- Object_Has_Volatile_Components --
11283 ------------------------------------
11285 function Object_Has_Volatile_Components (N : Node_Id) return Boolean is
11286 Typ : constant Entity_Id := Etype (N);
11289 if Is_Volatile (Typ)
11290 or else Has_Volatile_Components (Typ)
11294 elsif Is_Entity_Name (N)
11295 and then (Has_Volatile_Components (Entity (N))
11296 or else Is_Volatile (Entity (N)))
11300 elsif Nkind (N) = N_Indexed_Component
11301 or else Nkind (N) = N_Selected_Component
11303 return Is_Volatile_Prefix (Prefix (N));
11308 end Object_Has_Volatile_Components;
11310 -- Start of processing for Is_Volatile_Object
11313 if Nkind (N) = N_Defining_Identifier then
11314 return Is_Volatile (N) or else Is_Volatile (Etype (N));
11316 elsif Nkind (N) = N_Expanded_Name then
11317 return Is_Volatile_Object (Entity (N));
11319 elsif Is_Volatile (Etype (N))
11320 or else (Is_Entity_Name (N) and then Is_Volatile (Entity (N)))
11324 elsif Nkind_In (N, N_Indexed_Component, N_Selected_Component)
11325 and then Is_Volatile_Prefix (Prefix (N))
11329 elsif Nkind (N) = N_Selected_Component
11330 and then Is_Volatile (Entity (Selector_Name (N)))
11337 end Is_Volatile_Object;
11339 ---------------------------
11340 -- Itype_Has_Declaration --
11341 ---------------------------
11343 function Itype_Has_Declaration (Id : Entity_Id) return Boolean is
11345 pragma Assert (Is_Itype (Id));
11346 return Present (Parent (Id))
11347 and then Nkind_In (Parent (Id), N_Full_Type_Declaration,
11348 N_Subtype_Declaration)
11349 and then Defining_Entity (Parent (Id)) = Id;
11350 end Itype_Has_Declaration;
11352 -------------------------
11353 -- Kill_Current_Values --
11354 -------------------------
11356 procedure Kill_Current_Values
11358 Last_Assignment_Only : Boolean := False)
11361 -- ??? do we have to worry about clearing cached checks?
11363 if Is_Assignable (Ent) then
11364 Set_Last_Assignment (Ent, Empty);
11367 if Is_Object (Ent) then
11368 if not Last_Assignment_Only then
11370 Set_Current_Value (Ent, Empty);
11372 if not Can_Never_Be_Null (Ent) then
11373 Set_Is_Known_Non_Null (Ent, False);
11376 Set_Is_Known_Null (Ent, False);
11378 -- Reset Is_Known_Valid unless type is always valid, or if we have
11379 -- a loop parameter (loop parameters are always valid, since their
11380 -- bounds are defined by the bounds given in the loop header).
11382 if not Is_Known_Valid (Etype (Ent))
11383 and then Ekind (Ent) /= E_Loop_Parameter
11385 Set_Is_Known_Valid (Ent, False);
11389 end Kill_Current_Values;
11391 procedure Kill_Current_Values (Last_Assignment_Only : Boolean := False) is
11394 procedure Kill_Current_Values_For_Entity_Chain (E : Entity_Id);
11395 -- Clear current value for entity E and all entities chained to E
11397 ------------------------------------------
11398 -- Kill_Current_Values_For_Entity_Chain --
11399 ------------------------------------------
11401 procedure Kill_Current_Values_For_Entity_Chain (E : Entity_Id) is
11405 while Present (Ent) loop
11406 Kill_Current_Values (Ent, Last_Assignment_Only);
11409 end Kill_Current_Values_For_Entity_Chain;
11411 -- Start of processing for Kill_Current_Values
11414 -- Kill all saved checks, a special case of killing saved values
11416 if not Last_Assignment_Only then
11420 -- Loop through relevant scopes, which includes the current scope and
11421 -- any parent scopes if the current scope is a block or a package.
11423 S := Current_Scope;
11426 -- Clear current values of all entities in current scope
11428 Kill_Current_Values_For_Entity_Chain (First_Entity (S));
11430 -- If scope is a package, also clear current values of all private
11431 -- entities in the scope.
11433 if Is_Package_Or_Generic_Package (S)
11434 or else Is_Concurrent_Type (S)
11436 Kill_Current_Values_For_Entity_Chain (First_Private_Entity (S));
11439 -- If this is a not a subprogram, deal with parents
11441 if not Is_Subprogram (S) then
11443 exit Scope_Loop when S = Standard_Standard;
11447 end loop Scope_Loop;
11448 end Kill_Current_Values;
11450 --------------------------
11451 -- Kill_Size_Check_Code --
11452 --------------------------
11454 procedure Kill_Size_Check_Code (E : Entity_Id) is
11456 if (Ekind (E) = E_Constant or else Ekind (E) = E_Variable)
11457 and then Present (Size_Check_Code (E))
11459 Remove (Size_Check_Code (E));
11460 Set_Size_Check_Code (E, Empty);
11462 end Kill_Size_Check_Code;
11464 --------------------------
11465 -- Known_To_Be_Assigned --
11466 --------------------------
11468 function Known_To_Be_Assigned (N : Node_Id) return Boolean is
11469 P : constant Node_Id := Parent (N);
11474 -- Test left side of assignment
11476 when N_Assignment_Statement =>
11477 return N = Name (P);
11479 -- Function call arguments are never lvalues
11481 when N_Function_Call =>
11484 -- Positional parameter for procedure or accept call
11486 when N_Procedure_Call_Statement |
11495 Proc := Get_Subprogram_Entity (P);
11501 -- If we are not a list member, something is strange, so
11502 -- be conservative and return False.
11504 if not Is_List_Member (N) then
11508 -- We are going to find the right formal by stepping forward
11509 -- through the formals, as we step backwards in the actuals.
11511 Form := First_Formal (Proc);
11514 -- If no formal, something is weird, so be conservative
11515 -- and return False.
11522 exit when No (Act);
11523 Next_Formal (Form);
11526 return Ekind (Form) /= E_In_Parameter;
11529 -- Named parameter for procedure or accept call
11531 when N_Parameter_Association =>
11537 Proc := Get_Subprogram_Entity (Parent (P));
11543 -- Loop through formals to find the one that matches
11545 Form := First_Formal (Proc);
11547 -- If no matching formal, that's peculiar, some kind of
11548 -- previous error, so return False to be conservative.
11549 -- Actually this also happens in legal code in the case
11550 -- where P is a parameter association for an Extra_Formal???
11556 -- Else test for match
11558 if Chars (Form) = Chars (Selector_Name (P)) then
11559 return Ekind (Form) /= E_In_Parameter;
11562 Next_Formal (Form);
11566 -- Test for appearing in a conversion that itself appears
11567 -- in an lvalue context, since this should be an lvalue.
11569 when N_Type_Conversion =>
11570 return Known_To_Be_Assigned (P);
11572 -- All other references are definitely not known to be modifications
11578 end Known_To_Be_Assigned;
11580 ---------------------------
11581 -- Last_Source_Statement --
11582 ---------------------------
11584 function Last_Source_Statement (HSS : Node_Id) return Node_Id is
11588 N := Last (Statements (HSS));
11589 while Present (N) loop
11590 exit when Comes_From_Source (N);
11595 end Last_Source_Statement;
11597 ----------------------------------
11598 -- Matching_Static_Array_Bounds --
11599 ----------------------------------
11601 function Matching_Static_Array_Bounds
11603 R_Typ : Node_Id) return Boolean
11605 L_Ndims : constant Nat := Number_Dimensions (L_Typ);
11606 R_Ndims : constant Nat := Number_Dimensions (R_Typ);
11618 if L_Ndims /= R_Ndims then
11622 -- Unconstrained types do not have static bounds
11624 if not Is_Constrained (L_Typ) or else not Is_Constrained (R_Typ) then
11628 -- First treat specially the first dimension, as the lower bound and
11629 -- length of string literals are not stored like those of arrays.
11631 if Ekind (L_Typ) = E_String_Literal_Subtype then
11632 L_Low := String_Literal_Low_Bound (L_Typ);
11633 L_Len := String_Literal_Length (L_Typ);
11635 L_Index := First_Index (L_Typ);
11636 Get_Index_Bounds (L_Index, L_Low, L_High);
11638 if Is_OK_Static_Expression (L_Low)
11639 and then Is_OK_Static_Expression (L_High)
11641 if Expr_Value (L_High) < Expr_Value (L_Low) then
11644 L_Len := (Expr_Value (L_High) - Expr_Value (L_Low)) + 1;
11651 if Ekind (R_Typ) = E_String_Literal_Subtype then
11652 R_Low := String_Literal_Low_Bound (R_Typ);
11653 R_Len := String_Literal_Length (R_Typ);
11655 R_Index := First_Index (R_Typ);
11656 Get_Index_Bounds (R_Index, R_Low, R_High);
11658 if Is_OK_Static_Expression (R_Low)
11659 and then Is_OK_Static_Expression (R_High)
11661 if Expr_Value (R_High) < Expr_Value (R_Low) then
11664 R_Len := (Expr_Value (R_High) - Expr_Value (R_Low)) + 1;
11671 if Is_OK_Static_Expression (L_Low)
11672 and then Is_OK_Static_Expression (R_Low)
11673 and then Expr_Value (L_Low) = Expr_Value (R_Low)
11674 and then L_Len = R_Len
11681 -- Then treat all other dimensions
11683 for Indx in 2 .. L_Ndims loop
11687 Get_Index_Bounds (L_Index, L_Low, L_High);
11688 Get_Index_Bounds (R_Index, R_Low, R_High);
11690 if Is_OK_Static_Expression (L_Low)
11691 and then Is_OK_Static_Expression (L_High)
11692 and then Is_OK_Static_Expression (R_Low)
11693 and then Is_OK_Static_Expression (R_High)
11694 and then Expr_Value (L_Low) = Expr_Value (R_Low)
11695 and then Expr_Value (L_High) = Expr_Value (R_High)
11703 -- If we fall through the loop, all indexes matched
11706 end Matching_Static_Array_Bounds;
11708 -------------------
11709 -- May_Be_Lvalue --
11710 -------------------
11712 function May_Be_Lvalue (N : Node_Id) return Boolean is
11713 P : constant Node_Id := Parent (N);
11718 -- Test left side of assignment
11720 when N_Assignment_Statement =>
11721 return N = Name (P);
11723 -- Test prefix of component or attribute. Note that the prefix of an
11724 -- explicit or implicit dereference cannot be an l-value.
11726 when N_Attribute_Reference =>
11727 return N = Prefix (P)
11728 and then Name_Implies_Lvalue_Prefix (Attribute_Name (P));
11730 -- For an expanded name, the name is an lvalue if the expanded name
11731 -- is an lvalue, but the prefix is never an lvalue, since it is just
11732 -- the scope where the name is found.
11734 when N_Expanded_Name =>
11735 if N = Prefix (P) then
11736 return May_Be_Lvalue (P);
11741 -- For a selected component A.B, A is certainly an lvalue if A.B is.
11742 -- B is a little interesting, if we have A.B := 3, there is some
11743 -- discussion as to whether B is an lvalue or not, we choose to say
11744 -- it is. Note however that A is not an lvalue if it is of an access
11745 -- type since this is an implicit dereference.
11747 when N_Selected_Component =>
11749 and then Present (Etype (N))
11750 and then Is_Access_Type (Etype (N))
11754 return May_Be_Lvalue (P);
11757 -- For an indexed component or slice, the index or slice bounds is
11758 -- never an lvalue. The prefix is an lvalue if the indexed component
11759 -- or slice is an lvalue, except if it is an access type, where we
11760 -- have an implicit dereference.
11762 when N_Indexed_Component | N_Slice =>
11764 or else (Present (Etype (N)) and then Is_Access_Type (Etype (N)))
11768 return May_Be_Lvalue (P);
11771 -- Prefix of a reference is an lvalue if the reference is an lvalue
11773 when N_Reference =>
11774 return May_Be_Lvalue (P);
11776 -- Prefix of explicit dereference is never an lvalue
11778 when N_Explicit_Dereference =>
11781 -- Positional parameter for subprogram, entry, or accept call.
11782 -- In older versions of Ada function call arguments are never
11783 -- lvalues. In Ada 2012 functions can have in-out parameters.
11785 when N_Subprogram_Call |
11786 N_Entry_Call_Statement |
11789 if Nkind (P) = N_Function_Call and then Ada_Version < Ada_2012 then
11793 -- The following mechanism is clumsy and fragile. A single flag
11794 -- set in Resolve_Actuals would be preferable ???
11802 Proc := Get_Subprogram_Entity (P);
11808 -- If we are not a list member, something is strange, so be
11809 -- conservative and return True.
11811 if not Is_List_Member (N) then
11815 -- We are going to find the right formal by stepping forward
11816 -- through the formals, as we step backwards in the actuals.
11818 Form := First_Formal (Proc);
11821 -- If no formal, something is weird, so be conservative and
11829 exit when No (Act);
11830 Next_Formal (Form);
11833 return Ekind (Form) /= E_In_Parameter;
11836 -- Named parameter for procedure or accept call
11838 when N_Parameter_Association =>
11844 Proc := Get_Subprogram_Entity (Parent (P));
11850 -- Loop through formals to find the one that matches
11852 Form := First_Formal (Proc);
11854 -- If no matching formal, that's peculiar, some kind of
11855 -- previous error, so return True to be conservative.
11856 -- Actually happens with legal code for an unresolved call
11857 -- where we may get the wrong homonym???
11863 -- Else test for match
11865 if Chars (Form) = Chars (Selector_Name (P)) then
11866 return Ekind (Form) /= E_In_Parameter;
11869 Next_Formal (Form);
11873 -- Test for appearing in a conversion that itself appears in an
11874 -- lvalue context, since this should be an lvalue.
11876 when N_Type_Conversion =>
11877 return May_Be_Lvalue (P);
11879 -- Test for appearance in object renaming declaration
11881 when N_Object_Renaming_Declaration =>
11884 -- All other references are definitely not lvalues
11892 -----------------------
11893 -- Mark_Coextensions --
11894 -----------------------
11896 procedure Mark_Coextensions (Context_Nod : Node_Id; Root_Nod : Node_Id) is
11897 Is_Dynamic : Boolean;
11898 -- Indicates whether the context causes nested coextensions to be
11899 -- dynamic or static
11901 function Mark_Allocator (N : Node_Id) return Traverse_Result;
11902 -- Recognize an allocator node and label it as a dynamic coextension
11904 --------------------
11905 -- Mark_Allocator --
11906 --------------------
11908 function Mark_Allocator (N : Node_Id) return Traverse_Result is
11910 if Nkind (N) = N_Allocator then
11912 Set_Is_Dynamic_Coextension (N);
11914 -- If the allocator expression is potentially dynamic, it may
11915 -- be expanded out of order and require dynamic allocation
11916 -- anyway, so we treat the coextension itself as dynamic.
11917 -- Potential optimization ???
11919 elsif Nkind (Expression (N)) = N_Qualified_Expression
11920 and then Nkind (Expression (Expression (N))) = N_Op_Concat
11922 Set_Is_Dynamic_Coextension (N);
11924 Set_Is_Static_Coextension (N);
11929 end Mark_Allocator;
11931 procedure Mark_Allocators is new Traverse_Proc (Mark_Allocator);
11933 -- Start of processing Mark_Coextensions
11936 case Nkind (Context_Nod) is
11938 -- Comment here ???
11940 when N_Assignment_Statement =>
11941 Is_Dynamic := Nkind (Expression (Context_Nod)) = N_Allocator;
11943 -- An allocator that is a component of a returned aggregate
11944 -- must be dynamic.
11946 when N_Simple_Return_Statement =>
11948 Expr : constant Node_Id := Expression (Context_Nod);
11951 Nkind (Expr) = N_Allocator
11953 (Nkind (Expr) = N_Qualified_Expression
11954 and then Nkind (Expression (Expr)) = N_Aggregate);
11957 -- An alloctor within an object declaration in an extended return
11958 -- statement is of necessity dynamic.
11960 when N_Object_Declaration =>
11961 Is_Dynamic := Nkind (Root_Nod) = N_Allocator
11963 Nkind (Parent (Context_Nod)) = N_Extended_Return_Statement;
11965 -- This routine should not be called for constructs which may not
11966 -- contain coextensions.
11969 raise Program_Error;
11972 Mark_Allocators (Root_Nod);
11973 end Mark_Coextensions;
11979 function Must_Inline (Subp : Entity_Id) return Boolean is
11982 (Optimization_Level = 0
11984 -- AAMP and VM targets have no support for inlining in the backend.
11985 -- Hence we do as much inlining as possible in the front end.
11987 or else AAMP_On_Target
11988 or else VM_Target /= No_VM)
11989 and then Has_Pragma_Inline (Subp)
11990 and then (Has_Pragma_Inline_Always (Subp) or else Front_End_Inlining);
11993 ----------------------
11994 -- Needs_One_Actual --
11995 ----------------------
11997 function Needs_One_Actual (E : Entity_Id) return Boolean is
11998 Formal : Entity_Id;
12001 -- Ada 2005 or later, and formals present
12003 if Ada_Version >= Ada_2005 and then Present (First_Formal (E)) then
12004 Formal := Next_Formal (First_Formal (E));
12005 while Present (Formal) loop
12006 if No (Default_Value (Formal)) then
12010 Next_Formal (Formal);
12015 -- Ada 83/95 or no formals
12020 end Needs_One_Actual;
12022 ------------------------
12023 -- New_Copy_List_Tree --
12024 ------------------------
12026 function New_Copy_List_Tree (List : List_Id) return List_Id is
12031 if List = No_List then
12038 while Present (E) loop
12039 Append (New_Copy_Tree (E), NL);
12045 end New_Copy_List_Tree;
12047 -------------------
12048 -- New_Copy_Tree --
12049 -------------------
12051 use Atree.Unchecked_Access;
12052 use Atree_Private_Part;
12054 -- Our approach here requires a two pass traversal of the tree. The
12055 -- first pass visits all nodes that eventually will be copied looking
12056 -- for defining Itypes. If any defining Itypes are found, then they are
12057 -- copied, and an entry is added to the replacement map. In the second
12058 -- phase, the tree is copied, using the replacement map to replace any
12059 -- Itype references within the copied tree.
12061 -- The following hash tables are used if the Map supplied has more
12062 -- than hash threshold entries to speed up access to the map. If
12063 -- there are fewer entries, then the map is searched sequentially
12064 -- (because setting up a hash table for only a few entries takes
12065 -- more time than it saves.
12067 function New_Copy_Hash (E : Entity_Id) return NCT_Header_Num;
12068 -- Hash function used for hash operations
12070 -------------------
12071 -- New_Copy_Hash --
12072 -------------------
12074 function New_Copy_Hash (E : Entity_Id) return NCT_Header_Num is
12076 return Nat (E) mod (NCT_Header_Num'Last + 1);
12083 -- The hash table NCT_Assoc associates old entities in the table
12084 -- with their corresponding new entities (i.e. the pairs of entries
12085 -- presented in the original Map argument are Key-Element pairs).
12087 package NCT_Assoc is new Simple_HTable (
12088 Header_Num => NCT_Header_Num,
12089 Element => Entity_Id,
12090 No_Element => Empty,
12092 Hash => New_Copy_Hash,
12093 Equal => Types."=");
12095 ---------------------
12096 -- NCT_Itype_Assoc --
12097 ---------------------
12099 -- The hash table NCT_Itype_Assoc contains entries only for those
12100 -- old nodes which have a non-empty Associated_Node_For_Itype set.
12101 -- The key is the associated node, and the element is the new node
12102 -- itself (NOT the associated node for the new node).
12104 package NCT_Itype_Assoc is new Simple_HTable (
12105 Header_Num => NCT_Header_Num,
12106 Element => Entity_Id,
12107 No_Element => Empty,
12109 Hash => New_Copy_Hash,
12110 Equal => Types."=");
12112 -- Start of processing for New_Copy_Tree function
12114 function New_Copy_Tree
12116 Map : Elist_Id := No_Elist;
12117 New_Sloc : Source_Ptr := No_Location;
12118 New_Scope : Entity_Id := Empty) return Node_Id
12120 Actual_Map : Elist_Id := Map;
12121 -- This is the actual map for the copy. It is initialized with the
12122 -- given elements, and then enlarged as required for Itypes that are
12123 -- copied during the first phase of the copy operation. The visit
12124 -- procedures add elements to this map as Itypes are encountered.
12125 -- The reason we cannot use Map directly, is that it may well be
12126 -- (and normally is) initialized to No_Elist, and if we have mapped
12127 -- entities, we have to reset it to point to a real Elist.
12129 function Assoc (N : Node_Or_Entity_Id) return Node_Id;
12130 -- Called during second phase to map entities into their corresponding
12131 -- copies using Actual_Map. If the argument is not an entity, or is not
12132 -- in Actual_Map, then it is returned unchanged.
12134 procedure Build_NCT_Hash_Tables;
12135 -- Builds hash tables (number of elements >= threshold value)
12137 function Copy_Elist_With_Replacement
12138 (Old_Elist : Elist_Id) return Elist_Id;
12139 -- Called during second phase to copy element list doing replacements
12141 procedure Copy_Itype_With_Replacement (New_Itype : Entity_Id);
12142 -- Called during the second phase to process a copied Itype. The actual
12143 -- copy happened during the first phase (so that we could make the entry
12144 -- in the mapping), but we still have to deal with the descendents of
12145 -- the copied Itype and copy them where necessary.
12147 function Copy_List_With_Replacement (Old_List : List_Id) return List_Id;
12148 -- Called during second phase to copy list doing replacements
12150 function Copy_Node_With_Replacement (Old_Node : Node_Id) return Node_Id;
12151 -- Called during second phase to copy node doing replacements
12153 procedure Visit_Elist (E : Elist_Id);
12154 -- Called during first phase to visit all elements of an Elist
12156 procedure Visit_Field (F : Union_Id; N : Node_Id);
12157 -- Visit a single field, recursing to call Visit_Node or Visit_List
12158 -- if the field is a syntactic descendent of the current node (i.e.
12159 -- its parent is Node N).
12161 procedure Visit_Itype (Old_Itype : Entity_Id);
12162 -- Called during first phase to visit subsidiary fields of a defining
12163 -- Itype, and also create a copy and make an entry in the replacement
12164 -- map for the new copy.
12166 procedure Visit_List (L : List_Id);
12167 -- Called during first phase to visit all elements of a List
12169 procedure Visit_Node (N : Node_Or_Entity_Id);
12170 -- Called during first phase to visit a node and all its subtrees
12176 function Assoc (N : Node_Or_Entity_Id) return Node_Id is
12181 if not Has_Extension (N) or else No (Actual_Map) then
12184 elsif NCT_Hash_Tables_Used then
12185 Ent := NCT_Assoc.Get (Entity_Id (N));
12187 if Present (Ent) then
12193 -- No hash table used, do serial search
12196 E := First_Elmt (Actual_Map);
12197 while Present (E) loop
12198 if Node (E) = N then
12199 return Node (Next_Elmt (E));
12201 E := Next_Elmt (Next_Elmt (E));
12209 ---------------------------
12210 -- Build_NCT_Hash_Tables --
12211 ---------------------------
12213 procedure Build_NCT_Hash_Tables is
12217 if NCT_Hash_Table_Setup then
12219 NCT_Itype_Assoc.Reset;
12222 Elmt := First_Elmt (Actual_Map);
12223 while Present (Elmt) loop
12224 Ent := Node (Elmt);
12226 -- Get new entity, and associate old and new
12229 NCT_Assoc.Set (Ent, Node (Elmt));
12231 if Is_Type (Ent) then
12233 Anode : constant Entity_Id :=
12234 Associated_Node_For_Itype (Ent);
12237 if Present (Anode) then
12239 -- Enter a link between the associated node of the
12240 -- old Itype and the new Itype, for updating later
12241 -- when node is copied.
12243 NCT_Itype_Assoc.Set (Anode, Node (Elmt));
12251 NCT_Hash_Tables_Used := True;
12252 NCT_Hash_Table_Setup := True;
12253 end Build_NCT_Hash_Tables;
12255 ---------------------------------
12256 -- Copy_Elist_With_Replacement --
12257 ---------------------------------
12259 function Copy_Elist_With_Replacement
12260 (Old_Elist : Elist_Id) return Elist_Id
12263 New_Elist : Elist_Id;
12266 if No (Old_Elist) then
12270 New_Elist := New_Elmt_List;
12272 M := First_Elmt (Old_Elist);
12273 while Present (M) loop
12274 Append_Elmt (Copy_Node_With_Replacement (Node (M)), New_Elist);
12280 end Copy_Elist_With_Replacement;
12282 ---------------------------------
12283 -- Copy_Itype_With_Replacement --
12284 ---------------------------------
12286 -- This routine exactly parallels its phase one analog Visit_Itype,
12288 procedure Copy_Itype_With_Replacement (New_Itype : Entity_Id) is
12290 -- Translate Next_Entity, Scope and Etype fields, in case they
12291 -- reference entities that have been mapped into copies.
12293 Set_Next_Entity (New_Itype, Assoc (Next_Entity (New_Itype)));
12294 Set_Etype (New_Itype, Assoc (Etype (New_Itype)));
12296 if Present (New_Scope) then
12297 Set_Scope (New_Itype, New_Scope);
12299 Set_Scope (New_Itype, Assoc (Scope (New_Itype)));
12302 -- Copy referenced fields
12304 if Is_Discrete_Type (New_Itype) then
12305 Set_Scalar_Range (New_Itype,
12306 Copy_Node_With_Replacement (Scalar_Range (New_Itype)));
12308 elsif Has_Discriminants (Base_Type (New_Itype)) then
12309 Set_Discriminant_Constraint (New_Itype,
12310 Copy_Elist_With_Replacement
12311 (Discriminant_Constraint (New_Itype)));
12313 elsif Is_Array_Type (New_Itype) then
12314 if Present (First_Index (New_Itype)) then
12315 Set_First_Index (New_Itype,
12316 First (Copy_List_With_Replacement
12317 (List_Containing (First_Index (New_Itype)))));
12320 if Is_Packed (New_Itype) then
12321 Set_Packed_Array_Type (New_Itype,
12322 Copy_Node_With_Replacement
12323 (Packed_Array_Type (New_Itype)));
12326 end Copy_Itype_With_Replacement;
12328 --------------------------------
12329 -- Copy_List_With_Replacement --
12330 --------------------------------
12332 function Copy_List_With_Replacement
12333 (Old_List : List_Id) return List_Id
12335 New_List : List_Id;
12339 if Old_List = No_List then
12343 New_List := Empty_List;
12345 E := First (Old_List);
12346 while Present (E) loop
12347 Append (Copy_Node_With_Replacement (E), New_List);
12353 end Copy_List_With_Replacement;
12355 --------------------------------
12356 -- Copy_Node_With_Replacement --
12357 --------------------------------
12359 function Copy_Node_With_Replacement
12360 (Old_Node : Node_Id) return Node_Id
12362 New_Node : Node_Id;
12364 procedure Adjust_Named_Associations
12365 (Old_Node : Node_Id;
12366 New_Node : Node_Id);
12367 -- If a call node has named associations, these are chained through
12368 -- the First_Named_Actual, Next_Named_Actual links. These must be
12369 -- propagated separately to the new parameter list, because these
12370 -- are not syntactic fields.
12372 function Copy_Field_With_Replacement
12373 (Field : Union_Id) return Union_Id;
12374 -- Given Field, which is a field of Old_Node, return a copy of it
12375 -- if it is a syntactic field (i.e. its parent is Node), setting
12376 -- the parent of the copy to poit to New_Node. Otherwise returns
12377 -- the field (possibly mapped if it is an entity).
12379 -------------------------------
12380 -- Adjust_Named_Associations --
12381 -------------------------------
12383 procedure Adjust_Named_Associations
12384 (Old_Node : Node_Id;
12385 New_Node : Node_Id)
12390 Old_Next : Node_Id;
12391 New_Next : Node_Id;
12394 Old_E := First (Parameter_Associations (Old_Node));
12395 New_E := First (Parameter_Associations (New_Node));
12396 while Present (Old_E) loop
12397 if Nkind (Old_E) = N_Parameter_Association
12398 and then Present (Next_Named_Actual (Old_E))
12400 if First_Named_Actual (Old_Node)
12401 = Explicit_Actual_Parameter (Old_E)
12403 Set_First_Named_Actual
12404 (New_Node, Explicit_Actual_Parameter (New_E));
12407 -- Now scan parameter list from the beginning,to locate
12408 -- next named actual, which can be out of order.
12410 Old_Next := First (Parameter_Associations (Old_Node));
12411 New_Next := First (Parameter_Associations (New_Node));
12413 while Nkind (Old_Next) /= N_Parameter_Association
12414 or else Explicit_Actual_Parameter (Old_Next)
12415 /= Next_Named_Actual (Old_E)
12421 Set_Next_Named_Actual
12422 (New_E, Explicit_Actual_Parameter (New_Next));
12428 end Adjust_Named_Associations;
12430 ---------------------------------
12431 -- Copy_Field_With_Replacement --
12432 ---------------------------------
12434 function Copy_Field_With_Replacement
12435 (Field : Union_Id) return Union_Id
12438 if Field = Union_Id (Empty) then
12441 elsif Field in Node_Range then
12443 Old_N : constant Node_Id := Node_Id (Field);
12447 -- If syntactic field, as indicated by the parent pointer
12448 -- being set, then copy the referenced node recursively.
12450 if Parent (Old_N) = Old_Node then
12451 New_N := Copy_Node_With_Replacement (Old_N);
12453 if New_N /= Old_N then
12454 Set_Parent (New_N, New_Node);
12457 -- For semantic fields, update possible entity reference
12458 -- from the replacement map.
12461 New_N := Assoc (Old_N);
12464 return Union_Id (New_N);
12467 elsif Field in List_Range then
12469 Old_L : constant List_Id := List_Id (Field);
12473 -- If syntactic field, as indicated by the parent pointer,
12474 -- then recursively copy the entire referenced list.
12476 if Parent (Old_L) = Old_Node then
12477 New_L := Copy_List_With_Replacement (Old_L);
12478 Set_Parent (New_L, New_Node);
12480 -- For semantic list, just returned unchanged
12486 return Union_Id (New_L);
12489 -- Anything other than a list or a node is returned unchanged
12494 end Copy_Field_With_Replacement;
12496 -- Start of processing for Copy_Node_With_Replacement
12499 if Old_Node <= Empty_Or_Error then
12502 elsif Has_Extension (Old_Node) then
12503 return Assoc (Old_Node);
12506 New_Node := New_Copy (Old_Node);
12508 -- If the node we are copying is the associated node of a
12509 -- previously copied Itype, then adjust the associated node
12510 -- of the copy of that Itype accordingly.
12512 if Present (Actual_Map) then
12518 -- Case of hash table used
12520 if NCT_Hash_Tables_Used then
12521 Ent := NCT_Itype_Assoc.Get (Old_Node);
12523 if Present (Ent) then
12524 Set_Associated_Node_For_Itype (Ent, New_Node);
12527 -- Case of no hash table used
12530 E := First_Elmt (Actual_Map);
12531 while Present (E) loop
12532 if Is_Itype (Node (E))
12534 Old_Node = Associated_Node_For_Itype (Node (E))
12536 Set_Associated_Node_For_Itype
12537 (Node (Next_Elmt (E)), New_Node);
12540 E := Next_Elmt (Next_Elmt (E));
12546 -- Recursively copy descendents
12549 (New_Node, Copy_Field_With_Replacement (Field1 (New_Node)));
12551 (New_Node, Copy_Field_With_Replacement (Field2 (New_Node)));
12553 (New_Node, Copy_Field_With_Replacement (Field3 (New_Node)));
12555 (New_Node, Copy_Field_With_Replacement (Field4 (New_Node)));
12557 (New_Node, Copy_Field_With_Replacement (Field5 (New_Node)));
12559 -- Adjust Sloc of new node if necessary
12561 if New_Sloc /= No_Location then
12562 Set_Sloc (New_Node, New_Sloc);
12564 -- If we adjust the Sloc, then we are essentially making
12565 -- a completely new node, so the Comes_From_Source flag
12566 -- should be reset to the proper default value.
12568 Nodes.Table (New_Node).Comes_From_Source :=
12569 Default_Node.Comes_From_Source;
12572 -- If the node is call and has named associations,
12573 -- set the corresponding links in the copy.
12575 if (Nkind (Old_Node) = N_Function_Call
12576 or else Nkind (Old_Node) = N_Entry_Call_Statement
12578 Nkind (Old_Node) = N_Procedure_Call_Statement)
12579 and then Present (First_Named_Actual (Old_Node))
12581 Adjust_Named_Associations (Old_Node, New_Node);
12584 -- Reset First_Real_Statement for Handled_Sequence_Of_Statements.
12585 -- The replacement mechanism applies to entities, and is not used
12586 -- here. Eventually we may need a more general graph-copying
12587 -- routine. For now, do a sequential search to find desired node.
12589 if Nkind (Old_Node) = N_Handled_Sequence_Of_Statements
12590 and then Present (First_Real_Statement (Old_Node))
12593 Old_F : constant Node_Id := First_Real_Statement (Old_Node);
12597 N1 := First (Statements (Old_Node));
12598 N2 := First (Statements (New_Node));
12600 while N1 /= Old_F loop
12605 Set_First_Real_Statement (New_Node, N2);
12610 -- All done, return copied node
12613 end Copy_Node_With_Replacement;
12619 procedure Visit_Elist (E : Elist_Id) is
12622 if Present (E) then
12623 Elmt := First_Elmt (E);
12625 while Elmt /= No_Elmt loop
12626 Visit_Node (Node (Elmt));
12636 procedure Visit_Field (F : Union_Id; N : Node_Id) is
12638 if F = Union_Id (Empty) then
12641 elsif F in Node_Range then
12643 -- Copy node if it is syntactic, i.e. its parent pointer is
12644 -- set to point to the field that referenced it (certain
12645 -- Itypes will also meet this criterion, which is fine, since
12646 -- these are clearly Itypes that do need to be copied, since
12647 -- we are copying their parent.)
12649 if Parent (Node_Id (F)) = N then
12650 Visit_Node (Node_Id (F));
12653 -- Another case, if we are pointing to an Itype, then we want
12654 -- to copy it if its associated node is somewhere in the tree
12657 -- Note: the exclusion of self-referential copies is just an
12658 -- optimization, since the search of the already copied list
12659 -- would catch it, but it is a common case (Etype pointing
12660 -- to itself for an Itype that is a base type).
12662 elsif Has_Extension (Node_Id (F))
12663 and then Is_Itype (Entity_Id (F))
12664 and then Node_Id (F) /= N
12670 P := Associated_Node_For_Itype (Node_Id (F));
12671 while Present (P) loop
12673 Visit_Node (Node_Id (F));
12680 -- An Itype whose parent is not being copied definitely
12681 -- should NOT be copied, since it does not belong in any
12682 -- sense to the copied subtree.
12688 elsif F in List_Range
12689 and then Parent (List_Id (F)) = N
12691 Visit_List (List_Id (F));
12700 procedure Visit_Itype (Old_Itype : Entity_Id) is
12701 New_Itype : Entity_Id;
12706 -- Itypes that describe the designated type of access to subprograms
12707 -- have the structure of subprogram declarations, with signatures,
12708 -- etc. Either we duplicate the signatures completely, or choose to
12709 -- share such itypes, which is fine because their elaboration will
12710 -- have no side effects.
12712 if Ekind (Old_Itype) = E_Subprogram_Type then
12716 New_Itype := New_Copy (Old_Itype);
12718 -- The new Itype has all the attributes of the old one, and
12719 -- we just copy the contents of the entity. However, the back-end
12720 -- needs different names for debugging purposes, so we create a
12721 -- new internal name for it in all cases.
12723 Set_Chars (New_Itype, New_Internal_Name ('T'));
12725 -- If our associated node is an entity that has already been copied,
12726 -- then set the associated node of the copy to point to the right
12727 -- copy. If we have copied an Itype that is itself the associated
12728 -- node of some previously copied Itype, then we set the right
12729 -- pointer in the other direction.
12731 if Present (Actual_Map) then
12733 -- Case of hash tables used
12735 if NCT_Hash_Tables_Used then
12737 Ent := NCT_Assoc.Get (Associated_Node_For_Itype (Old_Itype));
12739 if Present (Ent) then
12740 Set_Associated_Node_For_Itype (New_Itype, Ent);
12743 Ent := NCT_Itype_Assoc.Get (Old_Itype);
12744 if Present (Ent) then
12745 Set_Associated_Node_For_Itype (Ent, New_Itype);
12747 -- If the hash table has no association for this Itype and
12748 -- its associated node, enter one now.
12751 NCT_Itype_Assoc.Set
12752 (Associated_Node_For_Itype (Old_Itype), New_Itype);
12755 -- Case of hash tables not used
12758 E := First_Elmt (Actual_Map);
12759 while Present (E) loop
12760 if Associated_Node_For_Itype (Old_Itype) = Node (E) then
12761 Set_Associated_Node_For_Itype
12762 (New_Itype, Node (Next_Elmt (E)));
12765 if Is_Type (Node (E))
12767 Old_Itype = Associated_Node_For_Itype (Node (E))
12769 Set_Associated_Node_For_Itype
12770 (Node (Next_Elmt (E)), New_Itype);
12773 E := Next_Elmt (Next_Elmt (E));
12778 if Present (Freeze_Node (New_Itype)) then
12779 Set_Is_Frozen (New_Itype, False);
12780 Set_Freeze_Node (New_Itype, Empty);
12783 -- Add new association to map
12785 if No (Actual_Map) then
12786 Actual_Map := New_Elmt_List;
12789 Append_Elmt (Old_Itype, Actual_Map);
12790 Append_Elmt (New_Itype, Actual_Map);
12792 if NCT_Hash_Tables_Used then
12793 NCT_Assoc.Set (Old_Itype, New_Itype);
12796 NCT_Table_Entries := NCT_Table_Entries + 1;
12798 if NCT_Table_Entries > NCT_Hash_Threshold then
12799 Build_NCT_Hash_Tables;
12803 -- If a record subtype is simply copied, the entity list will be
12804 -- shared. Thus cloned_Subtype must be set to indicate the sharing.
12806 if Ekind_In (Old_Itype, E_Record_Subtype, E_Class_Wide_Subtype) then
12807 Set_Cloned_Subtype (New_Itype, Old_Itype);
12810 -- Visit descendents that eventually get copied
12812 Visit_Field (Union_Id (Etype (Old_Itype)), Old_Itype);
12814 if Is_Discrete_Type (Old_Itype) then
12815 Visit_Field (Union_Id (Scalar_Range (Old_Itype)), Old_Itype);
12817 elsif Has_Discriminants (Base_Type (Old_Itype)) then
12818 -- ??? This should involve call to Visit_Field
12819 Visit_Elist (Discriminant_Constraint (Old_Itype));
12821 elsif Is_Array_Type (Old_Itype) then
12822 if Present (First_Index (Old_Itype)) then
12823 Visit_Field (Union_Id (List_Containing
12824 (First_Index (Old_Itype))),
12828 if Is_Packed (Old_Itype) then
12829 Visit_Field (Union_Id (Packed_Array_Type (Old_Itype)),
12839 procedure Visit_List (L : List_Id) is
12842 if L /= No_List then
12845 while Present (N) loop
12856 procedure Visit_Node (N : Node_Or_Entity_Id) is
12858 -- Start of processing for Visit_Node
12861 -- Handle case of an Itype, which must be copied
12863 if Has_Extension (N)
12864 and then Is_Itype (N)
12866 -- Nothing to do if already in the list. This can happen with an
12867 -- Itype entity that appears more than once in the tree.
12868 -- Note that we do not want to visit descendents in this case.
12870 -- Test for already in list when hash table is used
12872 if NCT_Hash_Tables_Used then
12873 if Present (NCT_Assoc.Get (Entity_Id (N))) then
12877 -- Test for already in list when hash table not used
12883 if Present (Actual_Map) then
12884 E := First_Elmt (Actual_Map);
12885 while Present (E) loop
12886 if Node (E) = N then
12889 E := Next_Elmt (Next_Elmt (E));
12899 -- Visit descendents
12901 Visit_Field (Field1 (N), N);
12902 Visit_Field (Field2 (N), N);
12903 Visit_Field (Field3 (N), N);
12904 Visit_Field (Field4 (N), N);
12905 Visit_Field (Field5 (N), N);
12908 -- Start of processing for New_Copy_Tree
12913 -- See if we should use hash table
12915 if No (Actual_Map) then
12916 NCT_Hash_Tables_Used := False;
12923 NCT_Table_Entries := 0;
12925 Elmt := First_Elmt (Actual_Map);
12926 while Present (Elmt) loop
12927 NCT_Table_Entries := NCT_Table_Entries + 1;
12932 if NCT_Table_Entries > NCT_Hash_Threshold then
12933 Build_NCT_Hash_Tables;
12935 NCT_Hash_Tables_Used := False;
12940 -- Hash table set up if required, now start phase one by visiting
12941 -- top node (we will recursively visit the descendents).
12943 Visit_Node (Source);
12945 -- Now the second phase of the copy can start. First we process
12946 -- all the mapped entities, copying their descendents.
12948 if Present (Actual_Map) then
12951 New_Itype : Entity_Id;
12953 Elmt := First_Elmt (Actual_Map);
12954 while Present (Elmt) loop
12956 New_Itype := Node (Elmt);
12957 Copy_Itype_With_Replacement (New_Itype);
12963 -- Now we can copy the actual tree
12965 return Copy_Node_With_Replacement (Source);
12968 -------------------------
12969 -- New_External_Entity --
12970 -------------------------
12972 function New_External_Entity
12973 (Kind : Entity_Kind;
12974 Scope_Id : Entity_Id;
12975 Sloc_Value : Source_Ptr;
12976 Related_Id : Entity_Id;
12977 Suffix : Character;
12978 Suffix_Index : Nat := 0;
12979 Prefix : Character := ' ') return Entity_Id
12981 N : constant Entity_Id :=
12982 Make_Defining_Identifier (Sloc_Value,
12984 (Chars (Related_Id), Suffix, Suffix_Index, Prefix));
12987 Set_Ekind (N, Kind);
12988 Set_Is_Internal (N, True);
12989 Append_Entity (N, Scope_Id);
12990 Set_Public_Status (N);
12992 if Kind in Type_Kind then
12993 Init_Size_Align (N);
12997 end New_External_Entity;
12999 -------------------------
13000 -- New_Internal_Entity --
13001 -------------------------
13003 function New_Internal_Entity
13004 (Kind : Entity_Kind;
13005 Scope_Id : Entity_Id;
13006 Sloc_Value : Source_Ptr;
13007 Id_Char : Character) return Entity_Id
13009 N : constant Entity_Id := Make_Temporary (Sloc_Value, Id_Char);
13012 Set_Ekind (N, Kind);
13013 Set_Is_Internal (N, True);
13014 Append_Entity (N, Scope_Id);
13016 if Kind in Type_Kind then
13017 Init_Size_Align (N);
13021 end New_Internal_Entity;
13027 function Next_Actual (Actual_Id : Node_Id) return Node_Id is
13031 -- If we are pointing at a positional parameter, it is a member of a
13032 -- node list (the list of parameters), and the next parameter is the
13033 -- next node on the list, unless we hit a parameter association, then
13034 -- we shift to using the chain whose head is the First_Named_Actual in
13035 -- the parent, and then is threaded using the Next_Named_Actual of the
13036 -- Parameter_Association. All this fiddling is because the original node
13037 -- list is in the textual call order, and what we need is the
13038 -- declaration order.
13040 if Is_List_Member (Actual_Id) then
13041 N := Next (Actual_Id);
13043 if Nkind (N) = N_Parameter_Association then
13044 return First_Named_Actual (Parent (Actual_Id));
13050 return Next_Named_Actual (Parent (Actual_Id));
13054 procedure Next_Actual (Actual_Id : in out Node_Id) is
13056 Actual_Id := Next_Actual (Actual_Id);
13059 ---------------------
13060 -- No_Scalar_Parts --
13061 ---------------------
13063 function No_Scalar_Parts (T : Entity_Id) return Boolean is
13067 if Is_Scalar_Type (T) then
13070 elsif Is_Array_Type (T) then
13071 return No_Scalar_Parts (Component_Type (T));
13073 elsif Is_Record_Type (T) or else Has_Discriminants (T) then
13074 C := First_Component_Or_Discriminant (T);
13075 while Present (C) loop
13076 if not No_Scalar_Parts (Etype (C)) then
13079 Next_Component_Or_Discriminant (C);
13085 end No_Scalar_Parts;
13087 -----------------------
13088 -- Normalize_Actuals --
13089 -----------------------
13091 -- Chain actuals according to formals of subprogram. If there are no named
13092 -- associations, the chain is simply the list of Parameter Associations,
13093 -- since the order is the same as the declaration order. If there are named
13094 -- associations, then the First_Named_Actual field in the N_Function_Call
13095 -- or N_Procedure_Call_Statement node points to the Parameter_Association
13096 -- node for the parameter that comes first in declaration order. The
13097 -- remaining named parameters are then chained in declaration order using
13098 -- Next_Named_Actual.
13100 -- This routine also verifies that the number of actuals is compatible with
13101 -- the number and default values of formals, but performs no type checking
13102 -- (type checking is done by the caller).
13104 -- If the matching succeeds, Success is set to True and the caller proceeds
13105 -- with type-checking. If the match is unsuccessful, then Success is set to
13106 -- False, and the caller attempts a different interpretation, if there is
13109 -- If the flag Report is on, the call is not overloaded, and a failure to
13110 -- match can be reported here, rather than in the caller.
13112 procedure Normalize_Actuals
13116 Success : out Boolean)
13118 Actuals : constant List_Id := Parameter_Associations (N);
13119 Actual : Node_Id := Empty;
13120 Formal : Entity_Id;
13121 Last : Node_Id := Empty;
13122 First_Named : Node_Id := Empty;
13125 Formals_To_Match : Integer := 0;
13126 Actuals_To_Match : Integer := 0;
13128 procedure Chain (A : Node_Id);
13129 -- Add named actual at the proper place in the list, using the
13130 -- Next_Named_Actual link.
13132 function Reporting return Boolean;
13133 -- Determines if an error is to be reported. To report an error, we
13134 -- need Report to be True, and also we do not report errors caused
13135 -- by calls to init procs that occur within other init procs. Such
13136 -- errors must always be cascaded errors, since if all the types are
13137 -- declared correctly, the compiler will certainly build decent calls!
13143 procedure Chain (A : Node_Id) is
13147 -- Call node points to first actual in list
13149 Set_First_Named_Actual (N, Explicit_Actual_Parameter (A));
13152 Set_Next_Named_Actual (Last, Explicit_Actual_Parameter (A));
13156 Set_Next_Named_Actual (Last, Empty);
13163 function Reporting return Boolean is
13168 elsif not Within_Init_Proc then
13171 elsif Is_Init_Proc (Entity (Name (N))) then
13179 -- Start of processing for Normalize_Actuals
13182 if Is_Access_Type (S) then
13184 -- The name in the call is a function call that returns an access
13185 -- to subprogram. The designated type has the list of formals.
13187 Formal := First_Formal (Designated_Type (S));
13189 Formal := First_Formal (S);
13192 while Present (Formal) loop
13193 Formals_To_Match := Formals_To_Match + 1;
13194 Next_Formal (Formal);
13197 -- Find if there is a named association, and verify that no positional
13198 -- associations appear after named ones.
13200 if Present (Actuals) then
13201 Actual := First (Actuals);
13204 while Present (Actual)
13205 and then Nkind (Actual) /= N_Parameter_Association
13207 Actuals_To_Match := Actuals_To_Match + 1;
13211 if No (Actual) and Actuals_To_Match = Formals_To_Match then
13213 -- Most common case: positional notation, no defaults
13218 elsif Actuals_To_Match > Formals_To_Match then
13220 -- Too many actuals: will not work
13223 if Is_Entity_Name (Name (N)) then
13224 Error_Msg_N ("too many arguments in call to&", Name (N));
13226 Error_Msg_N ("too many arguments in call", N);
13234 First_Named := Actual;
13236 while Present (Actual) loop
13237 if Nkind (Actual) /= N_Parameter_Association then
13239 ("positional parameters not allowed after named ones", Actual);
13244 Actuals_To_Match := Actuals_To_Match + 1;
13250 if Present (Actuals) then
13251 Actual := First (Actuals);
13254 Formal := First_Formal (S);
13255 while Present (Formal) loop
13257 -- Match the formals in order. If the corresponding actual is
13258 -- positional, nothing to do. Else scan the list of named actuals
13259 -- to find the one with the right name.
13261 if Present (Actual)
13262 and then Nkind (Actual) /= N_Parameter_Association
13265 Actuals_To_Match := Actuals_To_Match - 1;
13266 Formals_To_Match := Formals_To_Match - 1;
13269 -- For named parameters, search the list of actuals to find
13270 -- one that matches the next formal name.
13272 Actual := First_Named;
13274 while Present (Actual) loop
13275 if Chars (Selector_Name (Actual)) = Chars (Formal) then
13278 Actuals_To_Match := Actuals_To_Match - 1;
13279 Formals_To_Match := Formals_To_Match - 1;
13287 if Ekind (Formal) /= E_In_Parameter
13288 or else No (Default_Value (Formal))
13291 if (Comes_From_Source (S)
13292 or else Sloc (S) = Standard_Location)
13293 and then Is_Overloadable (S)
13297 (Nkind (Parent (N)) = N_Procedure_Call_Statement
13299 (Nkind (Parent (N)) = N_Function_Call
13301 Nkind (Parent (N)) = N_Parameter_Association))
13302 and then Ekind (S) /= E_Function
13304 Set_Etype (N, Etype (S));
13306 Error_Msg_Name_1 := Chars (S);
13307 Error_Msg_Sloc := Sloc (S);
13309 ("missing argument for parameter & " &
13310 "in call to % declared #", N, Formal);
13313 elsif Is_Overloadable (S) then
13314 Error_Msg_Name_1 := Chars (S);
13316 -- Point to type derivation that generated the
13319 Error_Msg_Sloc := Sloc (Parent (S));
13322 ("missing argument for parameter & " &
13323 "in call to % (inherited) #", N, Formal);
13327 ("missing argument for parameter &", N, Formal);
13335 Formals_To_Match := Formals_To_Match - 1;
13340 Next_Formal (Formal);
13343 if Formals_To_Match = 0 and then Actuals_To_Match = 0 then
13350 -- Find some superfluous named actual that did not get
13351 -- attached to the list of associations.
13353 Actual := First (Actuals);
13354 while Present (Actual) loop
13355 if Nkind (Actual) = N_Parameter_Association
13356 and then Actual /= Last
13357 and then No (Next_Named_Actual (Actual))
13359 Error_Msg_N ("unmatched actual & in call",
13360 Selector_Name (Actual));
13371 end Normalize_Actuals;
13373 --------------------------------
13374 -- Note_Possible_Modification --
13375 --------------------------------
13377 procedure Note_Possible_Modification (N : Node_Id; Sure : Boolean) is
13378 Modification_Comes_From_Source : constant Boolean :=
13379 Comes_From_Source (Parent (N));
13385 -- Loop to find referenced entity, if there is one
13391 if Is_Entity_Name (Exp) then
13392 Ent := Entity (Exp);
13394 -- If the entity is missing, it is an undeclared identifier,
13395 -- and there is nothing to annotate.
13401 elsif Nkind (Exp) = N_Explicit_Dereference then
13403 P : constant Node_Id := Prefix (Exp);
13406 -- In formal verification mode, keep track of all reads and
13407 -- writes through explicit dereferences.
13409 if GNATprove_Mode then
13410 SPARK_Specific.Generate_Dereference (N, 'm');
13413 if Nkind (P) = N_Selected_Component
13414 and then Present (Entry_Formal (Entity (Selector_Name (P))))
13416 -- Case of a reference to an entry formal
13418 Ent := Entry_Formal (Entity (Selector_Name (P)));
13420 elsif Nkind (P) = N_Identifier
13421 and then Nkind (Parent (Entity (P))) = N_Object_Declaration
13422 and then Present (Expression (Parent (Entity (P))))
13423 and then Nkind (Expression (Parent (Entity (P)))) =
13426 -- Case of a reference to a value on which side effects have
13429 Exp := Prefix (Expression (Parent (Entity (P))));
13437 elsif Nkind_In (Exp, N_Type_Conversion,
13438 N_Unchecked_Type_Conversion)
13440 Exp := Expression (Exp);
13443 elsif Nkind_In (Exp, N_Slice,
13444 N_Indexed_Component,
13445 N_Selected_Component)
13447 -- Special check, if the prefix is an access type, then return
13448 -- since we are modifying the thing pointed to, not the prefix.
13449 -- When we are expanding, most usually the prefix is replaced
13450 -- by an explicit dereference, and this test is not needed, but
13451 -- in some cases (notably -gnatc mode and generics) when we do
13452 -- not do full expansion, we need this special test.
13454 if Is_Access_Type (Etype (Prefix (Exp))) then
13457 -- Otherwise go to prefix and keep going
13460 Exp := Prefix (Exp);
13464 -- All other cases, not a modification
13470 -- Now look for entity being referenced
13472 if Present (Ent) then
13473 if Is_Object (Ent) then
13474 if Comes_From_Source (Exp)
13475 or else Modification_Comes_From_Source
13477 -- Give warning if pragma unmodified given and we are
13478 -- sure this is a modification.
13480 if Has_Pragma_Unmodified (Ent) and then Sure then
13482 ("??pragma Unmodified given for &!", N, Ent);
13485 Set_Never_Set_In_Source (Ent, False);
13488 Set_Is_True_Constant (Ent, False);
13489 Set_Current_Value (Ent, Empty);
13490 Set_Is_Known_Null (Ent, False);
13492 if not Can_Never_Be_Null (Ent) then
13493 Set_Is_Known_Non_Null (Ent, False);
13496 -- Follow renaming chain
13498 if (Ekind (Ent) = E_Variable or else Ekind (Ent) = E_Constant)
13499 and then Present (Renamed_Object (Ent))
13501 Exp := Renamed_Object (Ent);
13503 -- If the entity is the loop variable in an iteration over
13504 -- a container, retrieve container expression to indicate
13505 -- possible modificastion.
13507 if Present (Related_Expression (Ent))
13508 and then Nkind (Parent (Related_Expression (Ent))) =
13509 N_Iterator_Specification
13511 Exp := Original_Node (Related_Expression (Ent));
13516 -- The expression may be the renaming of a subcomponent of an
13517 -- array or container. The assignment to the subcomponent is
13518 -- a modification of the container.
13520 elsif Comes_From_Source (Original_Node (Exp))
13521 and then Nkind_In (Original_Node (Exp), N_Selected_Component,
13522 N_Indexed_Component)
13524 Exp := Prefix (Original_Node (Exp));
13528 -- Generate a reference only if the assignment comes from
13529 -- source. This excludes, for example, calls to a dispatching
13530 -- assignment operation when the left-hand side is tagged. In
13531 -- GNATprove mode, we need those references also on generated
13532 -- code, as these are used to compute the local effects of
13535 if Modification_Comes_From_Source or GNATprove_Mode then
13536 Generate_Reference (Ent, Exp, 'm');
13538 -- If the target of the assignment is the bound variable
13539 -- in an iterator, indicate that the corresponding array
13540 -- or container is also modified.
13542 if Ada_Version >= Ada_2012
13544 Nkind (Parent (Ent)) = N_Iterator_Specification
13547 Domain : constant Node_Id := Name (Parent (Ent));
13550 -- TBD : in the full version of the construct, the
13551 -- domain of iteration can be given by an expression.
13553 if Is_Entity_Name (Domain) then
13554 Generate_Reference (Entity (Domain), Exp, 'm');
13555 Set_Is_True_Constant (Entity (Domain), False);
13556 Set_Never_Set_In_Source (Entity (Domain), False);
13562 Check_Nested_Access (Ent);
13567 -- If we are sure this is a modification from source, and we know
13568 -- this modifies a constant, then give an appropriate warning.
13570 if Overlays_Constant (Ent)
13571 and then Modification_Comes_From_Source
13575 A : constant Node_Id := Address_Clause (Ent);
13577 if Present (A) then
13579 Exp : constant Node_Id := Expression (A);
13581 if Nkind (Exp) = N_Attribute_Reference
13582 and then Attribute_Name (Exp) = Name_Address
13583 and then Is_Entity_Name (Prefix (Exp))
13585 Error_Msg_Sloc := Sloc (A);
13587 ("constant& may be modified via address "
13588 & "clause#??", N, Entity (Prefix (Exp)));
13601 end Note_Possible_Modification;
13603 -------------------------
13604 -- Object_Access_Level --
13605 -------------------------
13607 -- Returns the static accessibility level of the view denoted by Obj. Note
13608 -- that the value returned is the result of a call to Scope_Depth. Only
13609 -- scope depths associated with dynamic scopes can actually be returned.
13610 -- Since only relative levels matter for accessibility checking, the fact
13611 -- that the distance between successive levels of accessibility is not
13612 -- always one is immaterial (invariant: if level(E2) is deeper than
13613 -- level(E1), then Scope_Depth(E1) < Scope_Depth(E2)).
13615 function Object_Access_Level (Obj : Node_Id) return Uint is
13616 function Is_Interface_Conversion (N : Node_Id) return Boolean;
13617 -- Determine whether N is a construct of the form
13618 -- Some_Type (Operand._tag'Address)
13619 -- This construct appears in the context of dispatching calls.
13621 function Reference_To (Obj : Node_Id) return Node_Id;
13622 -- An explicit dereference is created when removing side-effects from
13623 -- expressions for constraint checking purposes. In this case a local
13624 -- access type is created for it. The correct access level is that of
13625 -- the original source node. We detect this case by noting that the
13626 -- prefix of the dereference is created by an object declaration whose
13627 -- initial expression is a reference.
13629 -----------------------------
13630 -- Is_Interface_Conversion --
13631 -----------------------------
13633 function Is_Interface_Conversion (N : Node_Id) return Boolean is
13636 Nkind (N) = N_Unchecked_Type_Conversion
13637 and then Nkind (Expression (N)) = N_Attribute_Reference
13638 and then Attribute_Name (Expression (N)) = Name_Address;
13639 end Is_Interface_Conversion;
13645 function Reference_To (Obj : Node_Id) return Node_Id is
13646 Pref : constant Node_Id := Prefix (Obj);
13648 if Is_Entity_Name (Pref)
13649 and then Nkind (Parent (Entity (Pref))) = N_Object_Declaration
13650 and then Present (Expression (Parent (Entity (Pref))))
13651 and then Nkind (Expression (Parent (Entity (Pref)))) = N_Reference
13653 return (Prefix (Expression (Parent (Entity (Pref)))));
13663 -- Start of processing for Object_Access_Level
13666 if Nkind (Obj) = N_Defining_Identifier
13667 or else Is_Entity_Name (Obj)
13669 if Nkind (Obj) = N_Defining_Identifier then
13675 if Is_Prival (E) then
13676 E := Prival_Link (E);
13679 -- If E is a type then it denotes a current instance. For this case
13680 -- we add one to the normal accessibility level of the type to ensure
13681 -- that current instances are treated as always being deeper than
13682 -- than the level of any visible named access type (see 3.10.2(21)).
13684 if Is_Type (E) then
13685 return Type_Access_Level (E) + 1;
13687 elsif Present (Renamed_Object (E)) then
13688 return Object_Access_Level (Renamed_Object (E));
13690 -- Similarly, if E is a component of the current instance of a
13691 -- protected type, any instance of it is assumed to be at a deeper
13692 -- level than the type. For a protected object (whose type is an
13693 -- anonymous protected type) its components are at the same level
13694 -- as the type itself.
13696 elsif not Is_Overloadable (E)
13697 and then Ekind (Scope (E)) = E_Protected_Type
13698 and then Comes_From_Source (Scope (E))
13700 return Type_Access_Level (Scope (E)) + 1;
13703 return Scope_Depth (Enclosing_Dynamic_Scope (E));
13706 elsif Nkind (Obj) = N_Selected_Component then
13707 if Is_Access_Type (Etype (Prefix (Obj))) then
13708 return Type_Access_Level (Etype (Prefix (Obj)));
13710 return Object_Access_Level (Prefix (Obj));
13713 elsif Nkind (Obj) = N_Indexed_Component then
13714 if Is_Access_Type (Etype (Prefix (Obj))) then
13715 return Type_Access_Level (Etype (Prefix (Obj)));
13717 return Object_Access_Level (Prefix (Obj));
13720 elsif Nkind (Obj) = N_Explicit_Dereference then
13722 -- If the prefix is a selected access discriminant then we make a
13723 -- recursive call on the prefix, which will in turn check the level
13724 -- of the prefix object of the selected discriminant.
13726 if Nkind (Prefix (Obj)) = N_Selected_Component
13727 and then Ekind (Etype (Prefix (Obj))) = E_Anonymous_Access_Type
13729 Ekind (Entity (Selector_Name (Prefix (Obj)))) = E_Discriminant
13731 return Object_Access_Level (Prefix (Obj));
13733 -- Detect an interface conversion in the context of a dispatching
13734 -- call. Use the original form of the conversion to find the access
13735 -- level of the operand.
13737 elsif Is_Interface (Etype (Obj))
13738 and then Is_Interface_Conversion (Prefix (Obj))
13739 and then Nkind (Original_Node (Obj)) = N_Type_Conversion
13741 return Object_Access_Level (Original_Node (Obj));
13743 elsif not Comes_From_Source (Obj) then
13745 Ref : constant Node_Id := Reference_To (Obj);
13747 if Present (Ref) then
13748 return Object_Access_Level (Ref);
13750 return Type_Access_Level (Etype (Prefix (Obj)));
13755 return Type_Access_Level (Etype (Prefix (Obj)));
13758 elsif Nkind_In (Obj, N_Type_Conversion, N_Unchecked_Type_Conversion) then
13759 return Object_Access_Level (Expression (Obj));
13761 elsif Nkind (Obj) = N_Function_Call then
13763 -- Function results are objects, so we get either the access level of
13764 -- the function or, in the case of an indirect call, the level of the
13765 -- access-to-subprogram type. (This code is used for Ada 95, but it
13766 -- looks wrong, because it seems that we should be checking the level
13767 -- of the call itself, even for Ada 95. However, using the Ada 2005
13768 -- version of the code causes regressions in several tests that are
13769 -- compiled with -gnat95. ???)
13771 if Ada_Version < Ada_2005 then
13772 if Is_Entity_Name (Name (Obj)) then
13773 return Subprogram_Access_Level (Entity (Name (Obj)));
13775 return Type_Access_Level (Etype (Prefix (Name (Obj))));
13778 -- For Ada 2005, the level of the result object of a function call is
13779 -- defined to be the level of the call's innermost enclosing master.
13780 -- We determine that by querying the depth of the innermost enclosing
13784 Return_Master_Scope_Depth_Of_Call : declare
13786 function Innermost_Master_Scope_Depth
13787 (N : Node_Id) return Uint;
13788 -- Returns the scope depth of the given node's innermost
13789 -- enclosing dynamic scope (effectively the accessibility
13790 -- level of the innermost enclosing master).
13792 ----------------------------------
13793 -- Innermost_Master_Scope_Depth --
13794 ----------------------------------
13796 function Innermost_Master_Scope_Depth
13797 (N : Node_Id) return Uint
13799 Node_Par : Node_Id := Parent (N);
13802 -- Locate the nearest enclosing node (by traversing Parents)
13803 -- that Defining_Entity can be applied to, and return the
13804 -- depth of that entity's nearest enclosing dynamic scope.
13806 while Present (Node_Par) loop
13807 case Nkind (Node_Par) is
13808 when N_Component_Declaration |
13809 N_Entry_Declaration |
13810 N_Formal_Object_Declaration |
13811 N_Formal_Type_Declaration |
13812 N_Full_Type_Declaration |
13813 N_Incomplete_Type_Declaration |
13814 N_Loop_Parameter_Specification |
13815 N_Object_Declaration |
13816 N_Protected_Type_Declaration |
13817 N_Private_Extension_Declaration |
13818 N_Private_Type_Declaration |
13819 N_Subtype_Declaration |
13820 N_Function_Specification |
13821 N_Procedure_Specification |
13822 N_Task_Type_Declaration |
13824 N_Generic_Instantiation |
13826 N_Implicit_Label_Declaration |
13827 N_Package_Declaration |
13828 N_Single_Task_Declaration |
13829 N_Subprogram_Declaration |
13830 N_Generic_Declaration |
13831 N_Renaming_Declaration |
13832 N_Block_Statement |
13833 N_Formal_Subprogram_Declaration |
13834 N_Abstract_Subprogram_Declaration |
13836 N_Exception_Declaration |
13837 N_Formal_Package_Declaration |
13838 N_Number_Declaration |
13839 N_Package_Specification |
13840 N_Parameter_Specification |
13841 N_Single_Protected_Declaration |
13845 (Nearest_Dynamic_Scope
13846 (Defining_Entity (Node_Par)));
13852 Node_Par := Parent (Node_Par);
13855 pragma Assert (False);
13857 -- Should never reach the following return
13859 return Scope_Depth (Current_Scope) + 1;
13860 end Innermost_Master_Scope_Depth;
13862 -- Start of processing for Return_Master_Scope_Depth_Of_Call
13865 return Innermost_Master_Scope_Depth (Obj);
13866 end Return_Master_Scope_Depth_Of_Call;
13869 -- For convenience we handle qualified expressions, even though they
13870 -- aren't technically object names.
13872 elsif Nkind (Obj) = N_Qualified_Expression then
13873 return Object_Access_Level (Expression (Obj));
13875 -- Otherwise return the scope level of Standard. (If there are cases
13876 -- that fall through to this point they will be treated as having
13877 -- global accessibility for now. ???)
13880 return Scope_Depth (Standard_Standard);
13882 end Object_Access_Level;
13884 --------------------------
13885 -- Original_Aspect_Name --
13886 --------------------------
13888 function Original_Aspect_Name (N : Node_Id) return Name_Id is
13893 pragma Assert (Nkind_In (N, N_Aspect_Specification, N_Pragma));
13896 if Is_Rewrite_Substitution (Pras)
13897 and then Nkind (Original_Node (Pras)) = N_Pragma
13899 Pras := Original_Node (Pras);
13902 -- Case where we came from aspect specication
13904 if Nkind (Pras) = N_Pragma and then From_Aspect_Specification (Pras) then
13905 Pras := Corresponding_Aspect (Pras);
13908 -- Get name from aspect or pragma
13910 if Nkind (Pras) = N_Pragma then
13911 Name := Pragma_Name (Pras);
13913 Name := Chars (Identifier (Pras));
13916 -- Deal with 'Class
13918 if Class_Present (Pras) then
13921 -- Names that need converting to special _xxx form
13929 Name := Name_uPost;
13931 when Name_Invariant =>
13932 Name := Name_uInvariant;
13934 when Name_Type_Invariant |
13935 Name_Type_Invariant_Class =>
13936 Name := Name_uType_Invariant;
13938 -- Nothing to do for other cases (e.g. a Check that derived
13939 -- from Pre_Class and has the flag set). Also we do nothing
13940 -- if the name is already in special _xxx form.
13948 end Original_Aspect_Name;
13949 --------------------------------------
13950 -- Original_Corresponding_Operation --
13951 --------------------------------------
13953 function Original_Corresponding_Operation (S : Entity_Id) return Entity_Id
13955 Typ : constant Entity_Id := Find_Dispatching_Type (S);
13958 -- If S is an inherited primitive S2 the original corresponding
13959 -- operation of S is the original corresponding operation of S2
13961 if Present (Alias (S))
13962 and then Find_Dispatching_Type (Alias (S)) /= Typ
13964 return Original_Corresponding_Operation (Alias (S));
13966 -- If S overrides an inherited subprogram S2 the original corresponding
13967 -- operation of S is the original corresponding operation of S2
13969 elsif Present (Overridden_Operation (S)) then
13970 return Original_Corresponding_Operation (Overridden_Operation (S));
13972 -- otherwise it is S itself
13977 end Original_Corresponding_Operation;
13979 -----------------------
13980 -- Private_Component --
13981 -----------------------
13983 function Private_Component (Type_Id : Entity_Id) return Entity_Id is
13984 Ancestor : constant Entity_Id := Base_Type (Type_Id);
13986 function Trace_Components
13988 Check : Boolean) return Entity_Id;
13989 -- Recursive function that does the work, and checks against circular
13990 -- definition for each subcomponent type.
13992 ----------------------
13993 -- Trace_Components --
13994 ----------------------
13996 function Trace_Components
13998 Check : Boolean) return Entity_Id
14000 Btype : constant Entity_Id := Base_Type (T);
14001 Component : Entity_Id;
14003 Candidate : Entity_Id := Empty;
14006 if Check and then Btype = Ancestor then
14007 Error_Msg_N ("circular type definition", Type_Id);
14011 if Is_Private_Type (Btype)
14012 and then not Is_Generic_Type (Btype)
14014 if Present (Full_View (Btype))
14015 and then Is_Record_Type (Full_View (Btype))
14016 and then not Is_Frozen (Btype)
14018 -- To indicate that the ancestor depends on a private type, the
14019 -- current Btype is sufficient. However, to check for circular
14020 -- definition we must recurse on the full view.
14022 Candidate := Trace_Components (Full_View (Btype), True);
14024 if Candidate = Any_Type then
14034 elsif Is_Array_Type (Btype) then
14035 return Trace_Components (Component_Type (Btype), True);
14037 elsif Is_Record_Type (Btype) then
14038 Component := First_Entity (Btype);
14039 while Present (Component)
14040 and then Comes_From_Source (Component)
14042 -- Skip anonymous types generated by constrained components
14044 if not Is_Type (Component) then
14045 P := Trace_Components (Etype (Component), True);
14047 if Present (P) then
14048 if P = Any_Type then
14056 Next_Entity (Component);
14064 end Trace_Components;
14066 -- Start of processing for Private_Component
14069 return Trace_Components (Type_Id, False);
14070 end Private_Component;
14072 ---------------------------
14073 -- Primitive_Names_Match --
14074 ---------------------------
14076 function Primitive_Names_Match (E1, E2 : Entity_Id) return Boolean is
14078 function Non_Internal_Name (E : Entity_Id) return Name_Id;
14079 -- Given an internal name, returns the corresponding non-internal name
14081 ------------------------
14082 -- Non_Internal_Name --
14083 ------------------------
14085 function Non_Internal_Name (E : Entity_Id) return Name_Id is
14087 Get_Name_String (Chars (E));
14088 Name_Len := Name_Len - 1;
14090 end Non_Internal_Name;
14092 -- Start of processing for Primitive_Names_Match
14095 pragma Assert (Present (E1) and then Present (E2));
14097 return Chars (E1) = Chars (E2)
14099 (not Is_Internal_Name (Chars (E1))
14100 and then Is_Internal_Name (Chars (E2))
14101 and then Non_Internal_Name (E2) = Chars (E1))
14103 (not Is_Internal_Name (Chars (E2))
14104 and then Is_Internal_Name (Chars (E1))
14105 and then Non_Internal_Name (E1) = Chars (E2))
14107 (Is_Predefined_Dispatching_Operation (E1)
14108 and then Is_Predefined_Dispatching_Operation (E2)
14109 and then Same_TSS (E1, E2))
14111 (Is_Init_Proc (E1) and then Is_Init_Proc (E2));
14112 end Primitive_Names_Match;
14114 -----------------------
14115 -- Process_End_Label --
14116 -----------------------
14118 procedure Process_End_Label
14127 Label_Ref : Boolean;
14128 -- Set True if reference to end label itself is required
14131 -- Gets set to the operator symbol or identifier that references the
14132 -- entity Ent. For the child unit case, this is the identifier from the
14133 -- designator. For other cases, this is simply Endl.
14135 procedure Generate_Parent_Ref (N : Node_Id; E : Entity_Id);
14136 -- N is an identifier node that appears as a parent unit reference in
14137 -- the case where Ent is a child unit. This procedure generates an
14138 -- appropriate cross-reference entry. E is the corresponding entity.
14140 -------------------------
14141 -- Generate_Parent_Ref --
14142 -------------------------
14144 procedure Generate_Parent_Ref (N : Node_Id; E : Entity_Id) is
14146 -- If names do not match, something weird, skip reference
14148 if Chars (E) = Chars (N) then
14150 -- Generate the reference. We do NOT consider this as a reference
14151 -- for unreferenced symbol purposes.
14153 Generate_Reference (E, N, 'r', Set_Ref => False, Force => True);
14155 if Style_Check then
14156 Style.Check_Identifier (N, E);
14159 end Generate_Parent_Ref;
14161 -- Start of processing for Process_End_Label
14164 -- If no node, ignore. This happens in some error situations, and
14165 -- also for some internally generated structures where no end label
14166 -- references are required in any case.
14172 -- Nothing to do if no End_Label, happens for internally generated
14173 -- constructs where we don't want an end label reference anyway. Also
14174 -- nothing to do if Endl is a string literal, which means there was
14175 -- some prior error (bad operator symbol)
14177 Endl := End_Label (N);
14179 if No (Endl) or else Nkind (Endl) = N_String_Literal then
14183 -- Reference node is not in extended main source unit
14185 if not In_Extended_Main_Source_Unit (N) then
14187 -- Generally we do not collect references except for the extended
14188 -- main source unit. The one exception is the 'e' entry for a
14189 -- package spec, where it is useful for a client to have the
14190 -- ending information to define scopes.
14196 Label_Ref := False;
14198 -- For this case, we can ignore any parent references, but we
14199 -- need the package name itself for the 'e' entry.
14201 if Nkind (Endl) = N_Designator then
14202 Endl := Identifier (Endl);
14206 -- Reference is in extended main source unit
14211 -- For designator, generate references for the parent entries
14213 if Nkind (Endl) = N_Designator then
14215 -- Generate references for the prefix if the END line comes from
14216 -- source (otherwise we do not need these references) We climb the
14217 -- scope stack to find the expected entities.
14219 if Comes_From_Source (Endl) then
14220 Nam := Name (Endl);
14221 Scop := Current_Scope;
14222 while Nkind (Nam) = N_Selected_Component loop
14223 Scop := Scope (Scop);
14224 exit when No (Scop);
14225 Generate_Parent_Ref (Selector_Name (Nam), Scop);
14226 Nam := Prefix (Nam);
14229 if Present (Scop) then
14230 Generate_Parent_Ref (Nam, Scope (Scop));
14234 Endl := Identifier (Endl);
14238 -- If the end label is not for the given entity, then either we have
14239 -- some previous error, or this is a generic instantiation for which
14240 -- we do not need to make a cross-reference in this case anyway. In
14241 -- either case we simply ignore the call.
14243 if Chars (Ent) /= Chars (Endl) then
14247 -- If label was really there, then generate a normal reference and then
14248 -- adjust the location in the end label to point past the name (which
14249 -- should almost always be the semicolon).
14251 Loc := Sloc (Endl);
14253 if Comes_From_Source (Endl) then
14255 -- If a label reference is required, then do the style check and
14256 -- generate an l-type cross-reference entry for the label
14259 if Style_Check then
14260 Style.Check_Identifier (Endl, Ent);
14263 Generate_Reference (Ent, Endl, 'l', Set_Ref => False);
14266 -- Set the location to point past the label (normally this will
14267 -- mean the semicolon immediately following the label). This is
14268 -- done for the sake of the 'e' or 't' entry generated below.
14270 Get_Decoded_Name_String (Chars (Endl));
14271 Set_Sloc (Endl, Sloc (Endl) + Source_Ptr (Name_Len));
14274 -- In SPARK mode, no missing label is allowed for packages and
14275 -- subprogram bodies. Detect those cases by testing whether
14276 -- Process_End_Label was called for a body (Typ = 't') or a package.
14278 if Restriction_Check_Required (SPARK_05)
14279 and then (Typ = 't' or else Ekind (Ent) = E_Package)
14281 Error_Msg_Node_1 := Endl;
14282 Check_SPARK_Restriction ("`END &` required", Endl, Force => True);
14286 -- Now generate the e/t reference
14288 Generate_Reference (Ent, Endl, Typ, Set_Ref => False, Force => True);
14290 -- Restore Sloc, in case modified above, since we have an identifier
14291 -- and the normal Sloc should be left set in the tree.
14293 Set_Sloc (Endl, Loc);
14294 end Process_End_Label;
14300 function Referenced (Id : Entity_Id; Expr : Node_Id) return Boolean is
14301 Seen : Boolean := False;
14303 function Is_Reference (N : Node_Id) return Traverse_Result;
14304 -- Determine whether node N denotes a reference to Id. If this is the
14305 -- case, set global flag Seen to True and stop the traversal.
14311 function Is_Reference (N : Node_Id) return Traverse_Result is
14313 if Is_Entity_Name (N)
14314 and then Present (Entity (N))
14315 and then Entity (N) = Id
14324 procedure Inspect_Expression is new Traverse_Proc (Is_Reference);
14326 -- Start of processing for Referenced
14329 Inspect_Expression (Expr);
14333 ------------------------------------
14334 -- References_Generic_Formal_Type --
14335 ------------------------------------
14337 function References_Generic_Formal_Type (N : Node_Id) return Boolean is
14339 function Process (N : Node_Id) return Traverse_Result;
14340 -- Process one node in search for generic formal type
14346 function Process (N : Node_Id) return Traverse_Result is
14348 if Nkind (N) in N_Has_Entity then
14350 E : constant Entity_Id := Entity (N);
14352 if Present (E) then
14353 if Is_Generic_Type (E) then
14355 elsif Present (Etype (E))
14356 and then Is_Generic_Type (Etype (E))
14367 function Traverse is new Traverse_Func (Process);
14368 -- Traverse tree to look for generic type
14371 if Inside_A_Generic then
14372 return Traverse (N) = Abandon;
14376 end References_Generic_Formal_Type;
14378 --------------------
14379 -- Remove_Homonym --
14380 --------------------
14382 procedure Remove_Homonym (E : Entity_Id) is
14383 Prev : Entity_Id := Empty;
14387 if E = Current_Entity (E) then
14388 if Present (Homonym (E)) then
14389 Set_Current_Entity (Homonym (E));
14391 Set_Name_Entity_Id (Chars (E), Empty);
14395 H := Current_Entity (E);
14396 while Present (H) and then H /= E loop
14401 -- If E is not on the homonym chain, nothing to do
14403 if Present (H) then
14404 Set_Homonym (Prev, Homonym (E));
14407 end Remove_Homonym;
14409 ---------------------
14410 -- Rep_To_Pos_Flag --
14411 ---------------------
14413 function Rep_To_Pos_Flag (E : Entity_Id; Loc : Source_Ptr) return Node_Id is
14415 return New_Occurrence_Of
14416 (Boolean_Literals (not Range_Checks_Suppressed (E)), Loc);
14417 end Rep_To_Pos_Flag;
14419 --------------------
14420 -- Require_Entity --
14421 --------------------
14423 procedure Require_Entity (N : Node_Id) is
14425 if Is_Entity_Name (N) and then No (Entity (N)) then
14426 if Total_Errors_Detected /= 0 then
14427 Set_Entity (N, Any_Id);
14429 raise Program_Error;
14432 end Require_Entity;
14434 ------------------------------
14435 -- Requires_Transient_Scope --
14436 ------------------------------
14438 -- A transient scope is required when variable-sized temporaries are
14439 -- allocated in the primary or secondary stack, or when finalization
14440 -- actions must be generated before the next instruction.
14442 function Requires_Transient_Scope (Id : Entity_Id) return Boolean is
14443 Typ : constant Entity_Id := Underlying_Type (Id);
14445 -- Start of processing for Requires_Transient_Scope
14448 -- This is a private type which is not completed yet. This can only
14449 -- happen in a default expression (of a formal parameter or of a
14450 -- record component). Do not expand transient scope in this case
14455 -- Do not expand transient scope for non-existent procedure return
14457 elsif Typ = Standard_Void_Type then
14460 -- Elementary types do not require a transient scope
14462 elsif Is_Elementary_Type (Typ) then
14465 -- Generally, indefinite subtypes require a transient scope, since the
14466 -- back end cannot generate temporaries, since this is not a valid type
14467 -- for declaring an object. It might be possible to relax this in the
14468 -- future, e.g. by declaring the maximum possible space for the type.
14470 elsif Is_Indefinite_Subtype (Typ) then
14473 -- Functions returning tagged types may dispatch on result so their
14474 -- returned value is allocated on the secondary stack. Controlled
14475 -- type temporaries need finalization.
14477 elsif Is_Tagged_Type (Typ)
14478 or else Has_Controlled_Component (Typ)
14480 return not Is_Value_Type (Typ);
14484 elsif Is_Record_Type (Typ) then
14488 Comp := First_Entity (Typ);
14489 while Present (Comp) loop
14490 if Ekind (Comp) = E_Component
14491 and then Requires_Transient_Scope (Etype (Comp))
14495 Next_Entity (Comp);
14502 -- String literal types never require transient scope
14504 elsif Ekind (Typ) = E_String_Literal_Subtype then
14507 -- Array type. Note that we already know that this is a constrained
14508 -- array, since unconstrained arrays will fail the indefinite test.
14510 elsif Is_Array_Type (Typ) then
14512 -- If component type requires a transient scope, the array does too
14514 if Requires_Transient_Scope (Component_Type (Typ)) then
14517 -- Otherwise, we only need a transient scope if the size depends on
14518 -- the value of one or more discriminants.
14521 return Size_Depends_On_Discriminant (Typ);
14524 -- All other cases do not require a transient scope
14529 end Requires_Transient_Scope;
14531 --------------------------
14532 -- Reset_Analyzed_Flags --
14533 --------------------------
14535 procedure Reset_Analyzed_Flags (N : Node_Id) is
14537 function Clear_Analyzed (N : Node_Id) return Traverse_Result;
14538 -- Function used to reset Analyzed flags in tree. Note that we do
14539 -- not reset Analyzed flags in entities, since there is no need to
14540 -- reanalyze entities, and indeed, it is wrong to do so, since it
14541 -- can result in generating auxiliary stuff more than once.
14543 --------------------
14544 -- Clear_Analyzed --
14545 --------------------
14547 function Clear_Analyzed (N : Node_Id) return Traverse_Result is
14549 if not Has_Extension (N) then
14550 Set_Analyzed (N, False);
14554 end Clear_Analyzed;
14556 procedure Reset_Analyzed is new Traverse_Proc (Clear_Analyzed);
14558 -- Start of processing for Reset_Analyzed_Flags
14561 Reset_Analyzed (N);
14562 end Reset_Analyzed_Flags;
14564 --------------------------------
14565 -- Returns_Unconstrained_Type --
14566 --------------------------------
14568 function Returns_Unconstrained_Type (Subp : Entity_Id) return Boolean is
14570 return Ekind (Subp) = E_Function
14571 and then not Is_Scalar_Type (Etype (Subp))
14572 and then not Is_Access_Type (Etype (Subp))
14573 and then not Is_Constrained (Etype (Subp));
14574 end Returns_Unconstrained_Type;
14576 ---------------------------
14577 -- Safe_To_Capture_Value --
14578 ---------------------------
14580 function Safe_To_Capture_Value
14583 Cond : Boolean := False) return Boolean
14586 -- The only entities for which we track constant values are variables
14587 -- which are not renamings, constants, out parameters, and in out
14588 -- parameters, so check if we have this case.
14590 -- Note: it may seem odd to track constant values for constants, but in
14591 -- fact this routine is used for other purposes than simply capturing
14592 -- the value. In particular, the setting of Known[_Non]_Null.
14594 if (Ekind (Ent) = E_Variable and then No (Renamed_Object (Ent)))
14596 Ekind (Ent) = E_Constant
14598 Ekind (Ent) = E_Out_Parameter
14600 Ekind (Ent) = E_In_Out_Parameter
14604 -- For conditionals, we also allow loop parameters and all formals,
14605 -- including in parameters.
14609 (Ekind (Ent) = E_Loop_Parameter
14611 Ekind (Ent) = E_In_Parameter)
14615 -- For all other cases, not just unsafe, but impossible to capture
14616 -- Current_Value, since the above are the only entities which have
14617 -- Current_Value fields.
14623 -- Skip if volatile or aliased, since funny things might be going on in
14624 -- these cases which we cannot necessarily track. Also skip any variable
14625 -- for which an address clause is given, or whose address is taken. Also
14626 -- never capture value of library level variables (an attempt to do so
14627 -- can occur in the case of package elaboration code).
14629 if Treat_As_Volatile (Ent)
14630 or else Is_Aliased (Ent)
14631 or else Present (Address_Clause (Ent))
14632 or else Address_Taken (Ent)
14633 or else (Is_Library_Level_Entity (Ent)
14634 and then Ekind (Ent) = E_Variable)
14639 -- OK, all above conditions are met. We also require that the scope of
14640 -- the reference be the same as the scope of the entity, not counting
14641 -- packages and blocks and loops.
14644 E_Scope : constant Entity_Id := Scope (Ent);
14645 R_Scope : Entity_Id;
14648 R_Scope := Current_Scope;
14649 while R_Scope /= Standard_Standard loop
14650 exit when R_Scope = E_Scope;
14652 if not Ekind_In (R_Scope, E_Package, E_Block, E_Loop) then
14655 R_Scope := Scope (R_Scope);
14660 -- We also require that the reference does not appear in a context
14661 -- where it is not sure to be executed (i.e. a conditional context
14662 -- or an exception handler). We skip this if Cond is True, since the
14663 -- capturing of values from conditional tests handles this ok.
14676 -- Seems dubious that case expressions are not handled here ???
14679 while Present (P) loop
14680 if Nkind (P) = N_If_Statement
14681 or else Nkind (P) = N_Case_Statement
14682 or else (Nkind (P) in N_Short_Circuit
14683 and then Desc = Right_Opnd (P))
14684 or else (Nkind (P) = N_If_Expression
14685 and then Desc /= First (Expressions (P)))
14686 or else Nkind (P) = N_Exception_Handler
14687 or else Nkind (P) = N_Selective_Accept
14688 or else Nkind (P) = N_Conditional_Entry_Call
14689 or else Nkind (P) = N_Timed_Entry_Call
14690 or else Nkind (P) = N_Asynchronous_Select
14697 -- A special Ada 2012 case: the original node may be part
14698 -- of the else_actions of a conditional expression, in which
14699 -- case it might not have been expanded yet, and appears in
14700 -- a non-syntactic list of actions. In that case it is clearly
14701 -- not safe to save a value.
14704 and then Is_List_Member (Desc)
14705 and then No (Parent (List_Containing (Desc)))
14713 -- OK, looks safe to set value
14716 end Safe_To_Capture_Value;
14722 function Same_Name (N1, N2 : Node_Id) return Boolean is
14723 K1 : constant Node_Kind := Nkind (N1);
14724 K2 : constant Node_Kind := Nkind (N2);
14727 if (K1 = N_Identifier or else K1 = N_Defining_Identifier)
14728 and then (K2 = N_Identifier or else K2 = N_Defining_Identifier)
14730 return Chars (N1) = Chars (N2);
14732 elsif (K1 = N_Selected_Component or else K1 = N_Expanded_Name)
14733 and then (K2 = N_Selected_Component or else K2 = N_Expanded_Name)
14735 return Same_Name (Selector_Name (N1), Selector_Name (N2))
14736 and then Same_Name (Prefix (N1), Prefix (N2));
14747 function Same_Object (Node1, Node2 : Node_Id) return Boolean is
14748 N1 : constant Node_Id := Original_Node (Node1);
14749 N2 : constant Node_Id := Original_Node (Node2);
14750 -- We do the tests on original nodes, since we are most interested
14751 -- in the original source, not any expansion that got in the way.
14753 K1 : constant Node_Kind := Nkind (N1);
14754 K2 : constant Node_Kind := Nkind (N2);
14757 -- First case, both are entities with same entity
14759 if K1 in N_Has_Entity and then K2 in N_Has_Entity then
14761 EN1 : constant Entity_Id := Entity (N1);
14762 EN2 : constant Entity_Id := Entity (N2);
14764 if Present (EN1) and then Present (EN2)
14765 and then (Ekind_In (EN1, E_Variable, E_Constant)
14766 or else Is_Formal (EN1))
14774 -- Second case, selected component with same selector, same record
14776 if K1 = N_Selected_Component
14777 and then K2 = N_Selected_Component
14778 and then Chars (Selector_Name (N1)) = Chars (Selector_Name (N2))
14780 return Same_Object (Prefix (N1), Prefix (N2));
14782 -- Third case, indexed component with same subscripts, same array
14784 elsif K1 = N_Indexed_Component
14785 and then K2 = N_Indexed_Component
14786 and then Same_Object (Prefix (N1), Prefix (N2))
14791 E1 := First (Expressions (N1));
14792 E2 := First (Expressions (N2));
14793 while Present (E1) loop
14794 if not Same_Value (E1, E2) then
14805 -- Fourth case, slice of same array with same bounds
14808 and then K2 = N_Slice
14809 and then Nkind (Discrete_Range (N1)) = N_Range
14810 and then Nkind (Discrete_Range (N2)) = N_Range
14811 and then Same_Value (Low_Bound (Discrete_Range (N1)),
14812 Low_Bound (Discrete_Range (N2)))
14813 and then Same_Value (High_Bound (Discrete_Range (N1)),
14814 High_Bound (Discrete_Range (N2)))
14816 return Same_Name (Prefix (N1), Prefix (N2));
14818 -- All other cases, not clearly the same object
14829 function Same_Type (T1, T2 : Entity_Id) return Boolean is
14834 elsif not Is_Constrained (T1)
14835 and then not Is_Constrained (T2)
14836 and then Base_Type (T1) = Base_Type (T2)
14840 -- For now don't bother with case of identical constraints, to be
14841 -- fiddled with later on perhaps (this is only used for optimization
14842 -- purposes, so it is not critical to do a best possible job)
14853 function Same_Value (Node1, Node2 : Node_Id) return Boolean is
14855 if Compile_Time_Known_Value (Node1)
14856 and then Compile_Time_Known_Value (Node2)
14857 and then Expr_Value (Node1) = Expr_Value (Node2)
14860 elsif Same_Object (Node1, Node2) then
14867 ------------------------
14868 -- Scope_Is_Transient --
14869 ------------------------
14871 function Scope_Is_Transient return Boolean is
14873 return Scope_Stack.Table (Scope_Stack.Last).Is_Transient;
14874 end Scope_Is_Transient;
14880 function Scope_Within (Scope1, Scope2 : Entity_Id) return Boolean is
14885 while Scop /= Standard_Standard loop
14886 Scop := Scope (Scop);
14888 if Scop = Scope2 then
14896 --------------------------
14897 -- Scope_Within_Or_Same --
14898 --------------------------
14900 function Scope_Within_Or_Same (Scope1, Scope2 : Entity_Id) return Boolean is
14905 while Scop /= Standard_Standard loop
14906 if Scop = Scope2 then
14909 Scop := Scope (Scop);
14914 end Scope_Within_Or_Same;
14916 --------------------
14917 -- Set_Convention --
14918 --------------------
14920 procedure Set_Convention (E : Entity_Id; Val : Snames.Convention_Id) is
14922 Basic_Set_Convention (E, Val);
14925 and then Is_Access_Subprogram_Type (Base_Type (E))
14926 and then Has_Foreign_Convention (E)
14928 Set_Can_Use_Internal_Rep (E, False);
14930 end Set_Convention;
14932 ------------------------
14933 -- Set_Current_Entity --
14934 ------------------------
14936 -- The given entity is to be set as the currently visible definition of its
14937 -- associated name (i.e. the Node_Id associated with its name). All we have
14938 -- to do is to get the name from the identifier, and then set the
14939 -- associated Node_Id to point to the given entity.
14941 procedure Set_Current_Entity (E : Entity_Id) is
14943 Set_Name_Entity_Id (Chars (E), E);
14944 end Set_Current_Entity;
14946 ---------------------------
14947 -- Set_Debug_Info_Needed --
14948 ---------------------------
14950 procedure Set_Debug_Info_Needed (T : Entity_Id) is
14952 procedure Set_Debug_Info_Needed_If_Not_Set (E : Entity_Id);
14953 pragma Inline (Set_Debug_Info_Needed_If_Not_Set);
14954 -- Used to set debug info in a related node if not set already
14956 --------------------------------------
14957 -- Set_Debug_Info_Needed_If_Not_Set --
14958 --------------------------------------
14960 procedure Set_Debug_Info_Needed_If_Not_Set (E : Entity_Id) is
14963 and then not Needs_Debug_Info (E)
14965 Set_Debug_Info_Needed (E);
14967 -- For a private type, indicate that the full view also needs
14968 -- debug information.
14971 and then Is_Private_Type (E)
14972 and then Present (Full_View (E))
14974 Set_Debug_Info_Needed (Full_View (E));
14977 end Set_Debug_Info_Needed_If_Not_Set;
14979 -- Start of processing for Set_Debug_Info_Needed
14982 -- Nothing to do if argument is Empty or has Debug_Info_Off set, which
14983 -- indicates that Debug_Info_Needed is never required for the entity.
14986 or else Debug_Info_Off (T)
14991 -- Set flag in entity itself. Note that we will go through the following
14992 -- circuitry even if the flag is already set on T. That's intentional,
14993 -- it makes sure that the flag will be set in subsidiary entities.
14995 Set_Needs_Debug_Info (T);
14997 -- Set flag on subsidiary entities if not set already
14999 if Is_Object (T) then
15000 Set_Debug_Info_Needed_If_Not_Set (Etype (T));
15002 elsif Is_Type (T) then
15003 Set_Debug_Info_Needed_If_Not_Set (Etype (T));
15005 if Is_Record_Type (T) then
15007 Ent : Entity_Id := First_Entity (T);
15009 while Present (Ent) loop
15010 Set_Debug_Info_Needed_If_Not_Set (Ent);
15015 -- For a class wide subtype, we also need debug information
15016 -- for the equivalent type.
15018 if Ekind (T) = E_Class_Wide_Subtype then
15019 Set_Debug_Info_Needed_If_Not_Set (Equivalent_Type (T));
15022 elsif Is_Array_Type (T) then
15023 Set_Debug_Info_Needed_If_Not_Set (Component_Type (T));
15026 Indx : Node_Id := First_Index (T);
15028 while Present (Indx) loop
15029 Set_Debug_Info_Needed_If_Not_Set (Etype (Indx));
15030 Indx := Next_Index (Indx);
15034 -- For a packed array type, we also need debug information for
15035 -- the type used to represent the packed array. Conversely, we
15036 -- also need it for the former if we need it for the latter.
15038 if Is_Packed (T) then
15039 Set_Debug_Info_Needed_If_Not_Set (Packed_Array_Type (T));
15042 if Is_Packed_Array_Type (T) then
15043 Set_Debug_Info_Needed_If_Not_Set (Original_Array_Type (T));
15046 elsif Is_Access_Type (T) then
15047 Set_Debug_Info_Needed_If_Not_Set (Directly_Designated_Type (T));
15049 elsif Is_Private_Type (T) then
15050 Set_Debug_Info_Needed_If_Not_Set (Full_View (T));
15052 elsif Is_Protected_Type (T) then
15053 Set_Debug_Info_Needed_If_Not_Set (Corresponding_Record_Type (T));
15056 end Set_Debug_Info_Needed;
15058 ---------------------------------
15059 -- Set_Entity_With_Style_Check --
15060 ---------------------------------
15062 procedure Set_Entity_With_Style_Check (N : Node_Id; Val : Entity_Id) is
15063 Val_Actual : Entity_Id;
15067 -- Unconditionally set the entity
15069 Set_Entity (N, Val);
15071 -- Check for No_Implementation_Identifiers
15073 if Restriction_Check_Required (No_Implementation_Identifiers) then
15075 -- We have an implementation defined entity if it is marked as
15076 -- implementation defined, or is defined in a package marked as
15077 -- implementation defined. However, library packages themselves
15078 -- are excluded (we don't want to flag Interfaces itself, just
15079 -- the entities within it).
15081 if (Is_Implementation_Defined (Val)
15083 Is_Implementation_Defined (Scope (Val)))
15084 and then not (Ekind_In (Val, E_Package, E_Generic_Package)
15085 and then Is_Library_Level_Entity (Val))
15087 Check_Restriction (No_Implementation_Identifiers, N);
15091 -- Do the style check
15094 and then not Suppress_Style_Checks (Val)
15095 and then not In_Instance
15097 if Nkind (N) = N_Identifier then
15099 elsif Nkind (N) = N_Expanded_Name then
15100 Nod := Selector_Name (N);
15105 -- A special situation arises for derived operations, where we want
15106 -- to do the check against the parent (since the Sloc of the derived
15107 -- operation points to the derived type declaration itself).
15110 while not Comes_From_Source (Val_Actual)
15111 and then Nkind (Val_Actual) in N_Entity
15112 and then (Ekind (Val_Actual) = E_Enumeration_Literal
15113 or else Is_Subprogram (Val_Actual)
15114 or else Is_Generic_Subprogram (Val_Actual))
15115 and then Present (Alias (Val_Actual))
15117 Val_Actual := Alias (Val_Actual);
15120 -- Renaming declarations for generic actuals do not come from source,
15121 -- and have a different name from that of the entity they rename, so
15122 -- there is no style check to perform here.
15124 if Chars (Nod) = Chars (Val_Actual) then
15125 Style.Check_Identifier (Nod, Val_Actual);
15129 Set_Entity (N, Val);
15130 end Set_Entity_With_Style_Check;
15132 ------------------------
15133 -- Set_Name_Entity_Id --
15134 ------------------------
15136 procedure Set_Name_Entity_Id (Id : Name_Id; Val : Entity_Id) is
15138 Set_Name_Table_Info (Id, Int (Val));
15139 end Set_Name_Entity_Id;
15141 ---------------------
15142 -- Set_Next_Actual --
15143 ---------------------
15145 procedure Set_Next_Actual (Ass1_Id : Node_Id; Ass2_Id : Node_Id) is
15147 if Nkind (Parent (Ass1_Id)) = N_Parameter_Association then
15148 Set_First_Named_Actual (Parent (Ass1_Id), Ass2_Id);
15150 end Set_Next_Actual;
15152 ----------------------------------
15153 -- Set_Optimize_Alignment_Flags --
15154 ----------------------------------
15156 procedure Set_Optimize_Alignment_Flags (E : Entity_Id) is
15158 if Optimize_Alignment = 'S' then
15159 Set_Optimize_Alignment_Space (E);
15160 elsif Optimize_Alignment = 'T' then
15161 Set_Optimize_Alignment_Time (E);
15163 end Set_Optimize_Alignment_Flags;
15165 -----------------------
15166 -- Set_Public_Status --
15167 -----------------------
15169 procedure Set_Public_Status (Id : Entity_Id) is
15170 S : constant Entity_Id := Current_Scope;
15172 function Within_HSS_Or_If (E : Entity_Id) return Boolean;
15173 -- Determines if E is defined within handled statement sequence or
15174 -- an if statement, returns True if so, False otherwise.
15176 ----------------------
15177 -- Within_HSS_Or_If --
15178 ----------------------
15180 function Within_HSS_Or_If (E : Entity_Id) return Boolean is
15183 N := Declaration_Node (E);
15190 elsif Nkind_In (N, N_Handled_Sequence_Of_Statements,
15196 end Within_HSS_Or_If;
15198 -- Start of processing for Set_Public_Status
15201 -- Everything in the scope of Standard is public
15203 if S = Standard_Standard then
15204 Set_Is_Public (Id);
15206 -- Entity is definitely not public if enclosing scope is not public
15208 elsif not Is_Public (S) then
15211 -- An object or function declaration that occurs in a handled sequence
15212 -- of statements or within an if statement is the declaration for a
15213 -- temporary object or local subprogram generated by the expander. It
15214 -- never needs to be made public and furthermore, making it public can
15215 -- cause back end problems.
15217 elsif Nkind_In (Parent (Id), N_Object_Declaration,
15218 N_Function_Specification)
15219 and then Within_HSS_Or_If (Id)
15223 -- Entities in public packages or records are public
15225 elsif Ekind (S) = E_Package or Is_Record_Type (S) then
15226 Set_Is_Public (Id);
15228 -- The bounds of an entry family declaration can generate object
15229 -- declarations that are visible to the back-end, e.g. in the
15230 -- the declaration of a composite type that contains tasks.
15232 elsif Is_Concurrent_Type (S)
15233 and then not Has_Completion (S)
15234 and then Nkind (Parent (Id)) = N_Object_Declaration
15236 Set_Is_Public (Id);
15238 end Set_Public_Status;
15240 -----------------------------
15241 -- Set_Referenced_Modified --
15242 -----------------------------
15244 procedure Set_Referenced_Modified (N : Node_Id; Out_Param : Boolean) is
15248 -- Deal with indexed or selected component where prefix is modified
15250 if Nkind_In (N, N_Indexed_Component, N_Selected_Component) then
15251 Pref := Prefix (N);
15253 -- If prefix is access type, then it is the designated object that is
15254 -- being modified, which means we have no entity to set the flag on.
15256 if No (Etype (Pref)) or else Is_Access_Type (Etype (Pref)) then
15259 -- Otherwise chase the prefix
15262 Set_Referenced_Modified (Pref, Out_Param);
15265 -- Otherwise see if we have an entity name (only other case to process)
15267 elsif Is_Entity_Name (N) and then Present (Entity (N)) then
15268 Set_Referenced_As_LHS (Entity (N), not Out_Param);
15269 Set_Referenced_As_Out_Parameter (Entity (N), Out_Param);
15271 end Set_Referenced_Modified;
15273 ----------------------------
15274 -- Set_Scope_Is_Transient --
15275 ----------------------------
15277 procedure Set_Scope_Is_Transient (V : Boolean := True) is
15279 Scope_Stack.Table (Scope_Stack.Last).Is_Transient := V;
15280 end Set_Scope_Is_Transient;
15282 -------------------
15283 -- Set_Size_Info --
15284 -------------------
15286 procedure Set_Size_Info (T1, T2 : Entity_Id) is
15288 -- We copy Esize, but not RM_Size, since in general RM_Size is
15289 -- subtype specific and does not get inherited by all subtypes.
15291 Set_Esize (T1, Esize (T2));
15292 Set_Has_Biased_Representation (T1, Has_Biased_Representation (T2));
15294 if Is_Discrete_Or_Fixed_Point_Type (T1)
15296 Is_Discrete_Or_Fixed_Point_Type (T2)
15298 Set_Is_Unsigned_Type (T1, Is_Unsigned_Type (T2));
15301 Set_Alignment (T1, Alignment (T2));
15304 --------------------
15305 -- Static_Boolean --
15306 --------------------
15308 function Static_Boolean (N : Node_Id) return Uint is
15310 Analyze_And_Resolve (N, Standard_Boolean);
15313 or else Error_Posted (N)
15314 or else Etype (N) = Any_Type
15319 if Is_Static_Expression (N) then
15320 if not Raises_Constraint_Error (N) then
15321 return Expr_Value (N);
15326 elsif Etype (N) = Any_Type then
15330 Flag_Non_Static_Expr
15331 ("static boolean expression required here", N);
15334 end Static_Boolean;
15336 --------------------
15337 -- Static_Integer --
15338 --------------------
15340 function Static_Integer (N : Node_Id) return Uint is
15342 Analyze_And_Resolve (N, Any_Integer);
15345 or else Error_Posted (N)
15346 or else Etype (N) = Any_Type
15351 if Is_Static_Expression (N) then
15352 if not Raises_Constraint_Error (N) then
15353 return Expr_Value (N);
15358 elsif Etype (N) = Any_Type then
15362 Flag_Non_Static_Expr
15363 ("static integer expression required here", N);
15366 end Static_Integer;
15368 --------------------------
15369 -- Statically_Different --
15370 --------------------------
15372 function Statically_Different (E1, E2 : Node_Id) return Boolean is
15373 R1 : constant Node_Id := Get_Referenced_Object (E1);
15374 R2 : constant Node_Id := Get_Referenced_Object (E2);
15376 return Is_Entity_Name (R1)
15377 and then Is_Entity_Name (R2)
15378 and then Entity (R1) /= Entity (R2)
15379 and then not Is_Formal (Entity (R1))
15380 and then not Is_Formal (Entity (R2));
15381 end Statically_Different;
15383 --------------------------------------
15384 -- Subject_To_Loop_Entry_Attributes --
15385 --------------------------------------
15387 function Subject_To_Loop_Entry_Attributes (N : Node_Id) return Boolean is
15393 -- The expansion mechanism transform a loop subject to at least one
15394 -- 'Loop_Entry attribute into a conditional block. Infinite loops lack
15395 -- the conditional part.
15397 if Nkind_In (Stmt, N_Block_Statement, N_If_Statement)
15398 and then Nkind (Original_Node (N)) = N_Loop_Statement
15400 Stmt := Original_Node (N);
15404 Nkind (Stmt) = N_Loop_Statement
15405 and then Present (Identifier (Stmt))
15406 and then Present (Entity (Identifier (Stmt)))
15407 and then Has_Loop_Entry_Attributes (Entity (Identifier (Stmt)));
15408 end Subject_To_Loop_Entry_Attributes;
15410 -----------------------------
15411 -- Subprogram_Access_Level --
15412 -----------------------------
15414 function Subprogram_Access_Level (Subp : Entity_Id) return Uint is
15416 if Present (Alias (Subp)) then
15417 return Subprogram_Access_Level (Alias (Subp));
15419 return Scope_Depth (Enclosing_Dynamic_Scope (Subp));
15421 end Subprogram_Access_Level;
15423 -------------------------------
15424 -- Support_Atomic_Primitives --
15425 -------------------------------
15427 function Support_Atomic_Primitives (Typ : Entity_Id) return Boolean is
15431 -- Verify the alignment of Typ is known
15433 if not Known_Alignment (Typ) then
15437 if Known_Static_Esize (Typ) then
15438 Size := UI_To_Int (Esize (Typ));
15440 -- If the Esize (Object_Size) is unknown at compile time, look at the
15441 -- RM_Size (Value_Size) which may have been set by an explicit rep item.
15443 elsif Known_Static_RM_Size (Typ) then
15444 Size := UI_To_Int (RM_Size (Typ));
15446 -- Otherwise, the size is considered to be unknown.
15452 -- Check that the size of the component is 8, 16, 32 or 64 bits and that
15453 -- Typ is properly aligned.
15456 when 8 | 16 | 32 | 64 =>
15457 return Size = UI_To_Int (Alignment (Typ)) * 8;
15461 end Support_Atomic_Primitives;
15467 procedure Trace_Scope (N : Node_Id; E : Entity_Id; Msg : String) is
15469 if Debug_Flag_W then
15470 for J in 0 .. Scope_Stack.Last loop
15475 Write_Name (Chars (E));
15476 Write_Str (" from ");
15477 Write_Location (Sloc (N));
15482 -----------------------
15483 -- Transfer_Entities --
15484 -----------------------
15486 procedure Transfer_Entities (From : Entity_Id; To : Entity_Id) is
15487 Ent : Entity_Id := First_Entity (From);
15494 if (Last_Entity (To)) = Empty then
15495 Set_First_Entity (To, Ent);
15497 Set_Next_Entity (Last_Entity (To), Ent);
15500 Set_Last_Entity (To, Last_Entity (From));
15502 while Present (Ent) loop
15503 Set_Scope (Ent, To);
15505 if not Is_Public (Ent) then
15506 Set_Public_Status (Ent);
15509 and then Ekind (Ent) = E_Record_Subtype
15512 -- The components of the propagated Itype must be public
15518 Comp := First_Entity (Ent);
15519 while Present (Comp) loop
15520 Set_Is_Public (Comp);
15521 Next_Entity (Comp);
15530 Set_First_Entity (From, Empty);
15531 Set_Last_Entity (From, Empty);
15532 end Transfer_Entities;
15534 -----------------------
15535 -- Type_Access_Level --
15536 -----------------------
15538 function Type_Access_Level (Typ : Entity_Id) return Uint is
15542 Btyp := Base_Type (Typ);
15544 -- Ada 2005 (AI-230): For most cases of anonymous access types, we
15545 -- simply use the level where the type is declared. This is true for
15546 -- stand-alone object declarations, and for anonymous access types
15547 -- associated with components the level is the same as that of the
15548 -- enclosing composite type. However, special treatment is needed for
15549 -- the cases of access parameters, return objects of an anonymous access
15550 -- type, and, in Ada 95, access discriminants of limited types.
15552 if Ekind (Btyp) in Access_Kind then
15553 if Ekind (Btyp) = E_Anonymous_Access_Type then
15555 -- If the type is a nonlocal anonymous access type (such as for
15556 -- an access parameter) we treat it as being declared at the
15557 -- library level to ensure that names such as X.all'access don't
15558 -- fail static accessibility checks.
15560 if not Is_Local_Anonymous_Access (Typ) then
15561 return Scope_Depth (Standard_Standard);
15563 -- If this is a return object, the accessibility level is that of
15564 -- the result subtype of the enclosing function. The test here is
15565 -- little complicated, because we have to account for extended
15566 -- return statements that have been rewritten as blocks, in which
15567 -- case we have to find and the Is_Return_Object attribute of the
15568 -- itype's associated object. It would be nice to find a way to
15569 -- simplify this test, but it doesn't seem worthwhile to add a new
15570 -- flag just for purposes of this test. ???
15572 elsif Ekind (Scope (Btyp)) = E_Return_Statement
15575 and then Nkind (Associated_Node_For_Itype (Btyp)) =
15576 N_Object_Declaration
15577 and then Is_Return_Object
15578 (Defining_Identifier
15579 (Associated_Node_For_Itype (Btyp))))
15585 Scop := Scope (Scope (Btyp));
15586 while Present (Scop) loop
15587 exit when Ekind (Scop) = E_Function;
15588 Scop := Scope (Scop);
15591 -- Treat the return object's type as having the level of the
15592 -- function's result subtype (as per RM05-6.5(5.3/2)).
15594 return Type_Access_Level (Etype (Scop));
15599 Btyp := Root_Type (Btyp);
15601 -- The accessibility level of anonymous access types associated with
15602 -- discriminants is that of the current instance of the type, and
15603 -- that's deeper than the type itself (AARM 3.10.2 (12.3.21)).
15605 -- AI-402: access discriminants have accessibility based on the
15606 -- object rather than the type in Ada 2005, so the above paragraph
15609 -- ??? Needs completion with rules from AI-416
15611 if Ada_Version <= Ada_95
15612 and then Ekind (Typ) = E_Anonymous_Access_Type
15613 and then Present (Associated_Node_For_Itype (Typ))
15614 and then Nkind (Associated_Node_For_Itype (Typ)) =
15615 N_Discriminant_Specification
15617 return Scope_Depth (Enclosing_Dynamic_Scope (Btyp)) + 1;
15621 -- Return library level for a generic formal type. This is done because
15622 -- RM(10.3.2) says that "The statically deeper relationship does not
15623 -- apply to ... a descendant of a generic formal type". Rather than
15624 -- checking at each point where a static accessibility check is
15625 -- performed to see if we are dealing with a formal type, this rule is
15626 -- implemented by having Type_Access_Level and Deepest_Type_Access_Level
15627 -- return extreme values for a formal type; Deepest_Type_Access_Level
15628 -- returns Int'Last. By calling the appropriate function from among the
15629 -- two, we ensure that the static accessibility check will pass if we
15630 -- happen to run into a formal type. More specifically, we should call
15631 -- Deepest_Type_Access_Level instead of Type_Access_Level whenever the
15632 -- call occurs as part of a static accessibility check and the error
15633 -- case is the case where the type's level is too shallow (as opposed
15636 if Is_Generic_Type (Root_Type (Btyp)) then
15637 return Scope_Depth (Standard_Standard);
15640 return Scope_Depth (Enclosing_Dynamic_Scope (Btyp));
15641 end Type_Access_Level;
15643 ------------------------------------
15644 -- Type_Without_Stream_Operation --
15645 ------------------------------------
15647 function Type_Without_Stream_Operation
15649 Op : TSS_Name_Type := TSS_Null) return Entity_Id
15651 BT : constant Entity_Id := Base_Type (T);
15652 Op_Missing : Boolean;
15655 if not Restriction_Active (No_Default_Stream_Attributes) then
15659 if Is_Elementary_Type (T) then
15660 if Op = TSS_Null then
15662 No (TSS (BT, TSS_Stream_Read))
15663 or else No (TSS (BT, TSS_Stream_Write));
15666 Op_Missing := No (TSS (BT, Op));
15675 elsif Is_Array_Type (T) then
15676 return Type_Without_Stream_Operation (Component_Type (T), Op);
15678 elsif Is_Record_Type (T) then
15684 Comp := First_Component (T);
15685 while Present (Comp) loop
15686 C_Typ := Type_Without_Stream_Operation (Etype (Comp), Op);
15688 if Present (C_Typ) then
15692 Next_Component (Comp);
15698 elsif Is_Private_Type (T)
15699 and then Present (Full_View (T))
15701 return Type_Without_Stream_Operation (Full_View (T), Op);
15705 end Type_Without_Stream_Operation;
15707 ----------------------------
15708 -- Unique_Defining_Entity --
15709 ----------------------------
15711 function Unique_Defining_Entity (N : Node_Id) return Entity_Id is
15713 return Unique_Entity (Defining_Entity (N));
15714 end Unique_Defining_Entity;
15716 -------------------
15717 -- Unique_Entity --
15718 -------------------
15720 function Unique_Entity (E : Entity_Id) return Entity_Id is
15721 U : Entity_Id := E;
15727 if Present (Full_View (E)) then
15728 U := Full_View (E);
15732 if Present (Full_View (E)) then
15733 U := Full_View (E);
15736 when E_Package_Body =>
15739 if Nkind (P) = N_Defining_Program_Unit_Name then
15743 U := Corresponding_Spec (P);
15745 when E_Subprogram_Body =>
15748 if Nkind (P) = N_Defining_Program_Unit_Name then
15754 if Nkind (P) = N_Subprogram_Body_Stub then
15755 if Present (Library_Unit (P)) then
15757 -- Get to the function or procedure (generic) entity through
15758 -- the body entity.
15761 Unique_Entity (Defining_Entity (Get_Body_From_Stub (P)));
15764 U := Corresponding_Spec (P);
15767 when Formal_Kind =>
15768 if Present (Spec_Entity (E)) then
15769 U := Spec_Entity (E);
15783 function Unique_Name (E : Entity_Id) return String is
15785 -- Names of E_Subprogram_Body or E_Package_Body entities are not
15786 -- reliable, as they may not include the overloading suffix. Instead,
15787 -- when looking for the name of E or one of its enclosing scope, we get
15788 -- the name of the corresponding Unique_Entity.
15790 function Get_Scoped_Name (E : Entity_Id) return String;
15791 -- Return the name of E prefixed by all the names of the scopes to which
15792 -- E belongs, except for Standard.
15794 ---------------------
15795 -- Get_Scoped_Name --
15796 ---------------------
15798 function Get_Scoped_Name (E : Entity_Id) return String is
15799 Name : constant String := Get_Name_String (Chars (E));
15801 if Has_Fully_Qualified_Name (E)
15802 or else Scope (E) = Standard_Standard
15806 return Get_Scoped_Name (Unique_Entity (Scope (E))) & "__" & Name;
15808 end Get_Scoped_Name;
15810 -- Start of processing for Unique_Name
15813 if E = Standard_Standard then
15814 return Get_Name_String (Name_Standard);
15816 elsif Scope (E) = Standard_Standard
15817 and then not (Ekind (E) = E_Package or else Is_Subprogram (E))
15819 return Get_Name_String (Name_Standard) & "__" &
15820 Get_Name_String (Chars (E));
15822 elsif Ekind (E) = E_Enumeration_Literal then
15823 return Unique_Name (Etype (E)) & "__" & Get_Name_String (Chars (E));
15826 return Get_Scoped_Name (Unique_Entity (E));
15830 ---------------------
15831 -- Unit_Is_Visible --
15832 ---------------------
15834 function Unit_Is_Visible (U : Entity_Id) return Boolean is
15835 Curr : constant Node_Id := Cunit (Current_Sem_Unit);
15836 Curr_Entity : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
15838 function Unit_In_Parent_Context (Par_Unit : Node_Id) return Boolean;
15839 -- For a child unit, check whether unit appears in a with_clause
15842 function Unit_In_Context (Comp_Unit : Node_Id) return Boolean;
15843 -- Scan the context clause of one compilation unit looking for a
15844 -- with_clause for the unit in question.
15846 ----------------------------
15847 -- Unit_In_Parent_Context --
15848 ----------------------------
15850 function Unit_In_Parent_Context (Par_Unit : Node_Id) return Boolean is
15852 if Unit_In_Context (Par_Unit) then
15855 elsif Is_Child_Unit (Defining_Entity (Unit (Par_Unit))) then
15856 return Unit_In_Parent_Context (Parent_Spec (Unit (Par_Unit)));
15861 end Unit_In_Parent_Context;
15863 ---------------------
15864 -- Unit_In_Context --
15865 ---------------------
15867 function Unit_In_Context (Comp_Unit : Node_Id) return Boolean is
15871 Clause := First (Context_Items (Comp_Unit));
15872 while Present (Clause) loop
15873 if Nkind (Clause) = N_With_Clause then
15874 if Library_Unit (Clause) = U then
15877 -- The with_clause may denote a renaming of the unit we are
15878 -- looking for, eg. Text_IO which renames Ada.Text_IO.
15881 Renamed_Entity (Entity (Name (Clause))) =
15882 Defining_Entity (Unit (U))
15892 end Unit_In_Context;
15894 -- Start of processing for Unit_Is_Visible
15897 -- The currrent unit is directly visible
15902 elsif Unit_In_Context (Curr) then
15905 -- If the current unit is a body, check the context of the spec
15907 elsif Nkind (Unit (Curr)) = N_Package_Body
15909 (Nkind (Unit (Curr)) = N_Subprogram_Body
15910 and then not Acts_As_Spec (Unit (Curr)))
15912 if Unit_In_Context (Library_Unit (Curr)) then
15917 -- If the spec is a child unit, examine the parents
15919 if Is_Child_Unit (Curr_Entity) then
15920 if Nkind (Unit (Curr)) in N_Unit_Body then
15922 Unit_In_Parent_Context
15923 (Parent_Spec (Unit (Library_Unit (Curr))));
15925 return Unit_In_Parent_Context (Parent_Spec (Unit (Curr)));
15931 end Unit_Is_Visible;
15933 ------------------------------
15934 -- Universal_Interpretation --
15935 ------------------------------
15937 function Universal_Interpretation (Opnd : Node_Id) return Entity_Id is
15938 Index : Interp_Index;
15942 -- The argument may be a formal parameter of an operator or subprogram
15943 -- with multiple interpretations, or else an expression for an actual.
15945 if Nkind (Opnd) = N_Defining_Identifier
15946 or else not Is_Overloaded (Opnd)
15948 if Etype (Opnd) = Universal_Integer
15949 or else Etype (Opnd) = Universal_Real
15951 return Etype (Opnd);
15957 Get_First_Interp (Opnd, Index, It);
15958 while Present (It.Typ) loop
15959 if It.Typ = Universal_Integer
15960 or else It.Typ = Universal_Real
15965 Get_Next_Interp (Index, It);
15970 end Universal_Interpretation;
15976 function Unqualify (Expr : Node_Id) return Node_Id is
15978 -- Recurse to handle unlikely case of multiple levels of qualification
15980 if Nkind (Expr) = N_Qualified_Expression then
15981 return Unqualify (Expression (Expr));
15983 -- Normal case, not a qualified expression
15990 -----------------------
15991 -- Visible_Ancestors --
15992 -----------------------
15994 function Visible_Ancestors (Typ : Entity_Id) return Elist_Id is
16000 pragma Assert (Is_Record_Type (Typ)
16001 and then Is_Tagged_Type (Typ));
16003 -- Collect all the parents and progenitors of Typ. If the full-view of
16004 -- private parents and progenitors is available then it is used to
16005 -- generate the list of visible ancestors; otherwise their partial
16006 -- view is added to the resulting list.
16011 Use_Full_View => True);
16015 Ifaces_List => List_2,
16016 Exclude_Parents => True,
16017 Use_Full_View => True);
16019 -- Join the two lists. Avoid duplications because an interface may
16020 -- simultaneously be parent and progenitor of a type.
16022 Elmt := First_Elmt (List_2);
16023 while Present (Elmt) loop
16024 Append_Unique_Elmt (Node (Elmt), List_1);
16029 end Visible_Ancestors;
16031 ----------------------
16032 -- Within_Init_Proc --
16033 ----------------------
16035 function Within_Init_Proc return Boolean is
16039 S := Current_Scope;
16040 while not Is_Overloadable (S) loop
16041 if S = Standard_Standard then
16048 return Is_Init_Proc (S);
16049 end Within_Init_Proc;
16055 procedure Wrong_Type (Expr : Node_Id; Expected_Type : Entity_Id) is
16056 Found_Type : constant Entity_Id := First_Subtype (Etype (Expr));
16057 Expec_Type : constant Entity_Id := First_Subtype (Expected_Type);
16059 Matching_Field : Entity_Id;
16060 -- Entity to give a more precise suggestion on how to write a one-
16061 -- element positional aggregate.
16063 function Has_One_Matching_Field return Boolean;
16064 -- Determines if Expec_Type is a record type with a single component or
16065 -- discriminant whose type matches the found type or is one dimensional
16066 -- array whose component type matches the found type. In the case of
16067 -- one discriminant, we ignore the variant parts. That's not accurate,
16068 -- but good enough for the warning.
16070 ----------------------------
16071 -- Has_One_Matching_Field --
16072 ----------------------------
16074 function Has_One_Matching_Field return Boolean is
16078 Matching_Field := Empty;
16080 if Is_Array_Type (Expec_Type)
16081 and then Number_Dimensions (Expec_Type) = 1
16083 Covers (Etype (Component_Type (Expec_Type)), Found_Type)
16085 -- Use type name if available. This excludes multidimensional
16086 -- arrays and anonymous arrays.
16088 if Comes_From_Source (Expec_Type) then
16089 Matching_Field := Expec_Type;
16091 -- For an assignment, use name of target
16093 elsif Nkind (Parent (Expr)) = N_Assignment_Statement
16094 and then Is_Entity_Name (Name (Parent (Expr)))
16096 Matching_Field := Entity (Name (Parent (Expr)));
16101 elsif not Is_Record_Type (Expec_Type) then
16105 E := First_Entity (Expec_Type);
16110 elsif not Ekind_In (E, E_Discriminant, E_Component)
16111 or else Nam_In (Chars (E), Name_uTag, Name_uParent)
16120 if not Covers (Etype (E), Found_Type) then
16123 elsif Present (Next_Entity (E))
16124 and then (Ekind (E) = E_Component
16125 or else Ekind (Next_Entity (E)) = E_Discriminant)
16130 Matching_Field := E;
16134 end Has_One_Matching_Field;
16136 -- Start of processing for Wrong_Type
16139 -- Don't output message if either type is Any_Type, or if a message
16140 -- has already been posted for this node. We need to do the latter
16141 -- check explicitly (it is ordinarily done in Errout), because we
16142 -- are using ! to force the output of the error messages.
16144 if Expec_Type = Any_Type
16145 or else Found_Type = Any_Type
16146 or else Error_Posted (Expr)
16150 -- If one of the types is a Taft-Amendment type and the other it its
16151 -- completion, it must be an illegal use of a TAT in the spec, for
16152 -- which an error was already emitted. Avoid cascaded errors.
16154 elsif Is_Incomplete_Type (Expec_Type)
16155 and then Has_Completion_In_Body (Expec_Type)
16156 and then Full_View (Expec_Type) = Etype (Expr)
16160 elsif Is_Incomplete_Type (Etype (Expr))
16161 and then Has_Completion_In_Body (Etype (Expr))
16162 and then Full_View (Etype (Expr)) = Expec_Type
16166 -- In an instance, there is an ongoing problem with completion of
16167 -- type derived from private types. Their structure is what Gigi
16168 -- expects, but the Etype is the parent type rather than the
16169 -- derived private type itself. Do not flag error in this case. The
16170 -- private completion is an entity without a parent, like an Itype.
16171 -- Similarly, full and partial views may be incorrect in the instance.
16172 -- There is no simple way to insure that it is consistent ???
16174 elsif In_Instance then
16175 if Etype (Etype (Expr)) = Etype (Expected_Type)
16177 (Has_Private_Declaration (Expected_Type)
16178 or else Has_Private_Declaration (Etype (Expr)))
16179 and then No (Parent (Expected_Type))
16185 -- An interesting special check. If the expression is parenthesized
16186 -- and its type corresponds to the type of the sole component of the
16187 -- expected record type, or to the component type of the expected one
16188 -- dimensional array type, then assume we have a bad aggregate attempt.
16190 if Nkind (Expr) in N_Subexpr
16191 and then Paren_Count (Expr) /= 0
16192 and then Has_One_Matching_Field
16194 Error_Msg_N ("positional aggregate cannot have one component", Expr);
16195 if Present (Matching_Field) then
16196 if Is_Array_Type (Expec_Type) then
16198 ("\write instead `&''First ='> ...`", Expr, Matching_Field);
16202 ("\write instead `& ='> ...`", Expr, Matching_Field);
16206 -- Another special check, if we are looking for a pool-specific access
16207 -- type and we found an E_Access_Attribute_Type, then we have the case
16208 -- of an Access attribute being used in a context which needs a pool-
16209 -- specific type, which is never allowed. The one extra check we make
16210 -- is that the expected designated type covers the Found_Type.
16212 elsif Is_Access_Type (Expec_Type)
16213 and then Ekind (Found_Type) = E_Access_Attribute_Type
16214 and then Ekind (Base_Type (Expec_Type)) /= E_General_Access_Type
16215 and then Ekind (Base_Type (Expec_Type)) /= E_Anonymous_Access_Type
16217 (Designated_Type (Expec_Type), Designated_Type (Found_Type))
16219 Error_Msg_N -- CODEFIX
16220 ("result must be general access type!", Expr);
16221 Error_Msg_NE -- CODEFIX
16222 ("add ALL to }!", Expr, Expec_Type);
16224 -- Another special check, if the expected type is an integer type,
16225 -- but the expression is of type System.Address, and the parent is
16226 -- an addition or subtraction operation whose left operand is the
16227 -- expression in question and whose right operand is of an integral
16228 -- type, then this is an attempt at address arithmetic, so give
16229 -- appropriate message.
16231 elsif Is_Integer_Type (Expec_Type)
16232 and then Is_RTE (Found_Type, RE_Address)
16233 and then (Nkind (Parent (Expr)) = N_Op_Add
16235 Nkind (Parent (Expr)) = N_Op_Subtract)
16236 and then Expr = Left_Opnd (Parent (Expr))
16237 and then Is_Integer_Type (Etype (Right_Opnd (Parent (Expr))))
16240 ("address arithmetic not predefined in package System",
16243 ("\possible missing with/use of System.Storage_Elements",
16247 -- If the expected type is an anonymous access type, as for access
16248 -- parameters and discriminants, the error is on the designated types.
16250 elsif Ekind (Expec_Type) = E_Anonymous_Access_Type then
16251 if Comes_From_Source (Expec_Type) then
16252 Error_Msg_NE ("expected}!", Expr, Expec_Type);
16255 ("expected an access type with designated}",
16256 Expr, Designated_Type (Expec_Type));
16259 if Is_Access_Type (Found_Type)
16260 and then not Comes_From_Source (Found_Type)
16263 ("\\found an access type with designated}!",
16264 Expr, Designated_Type (Found_Type));
16266 if From_Limited_With (Found_Type) then
16267 Error_Msg_NE ("\\found incomplete}!", Expr, Found_Type);
16268 Error_Msg_Qual_Level := 99;
16269 Error_Msg_NE -- CODEFIX
16270 ("\\missing `WITH &;", Expr, Scope (Found_Type));
16271 Error_Msg_Qual_Level := 0;
16273 Error_Msg_NE ("found}!", Expr, Found_Type);
16277 -- Normal case of one type found, some other type expected
16280 -- If the names of the two types are the same, see if some number
16281 -- of levels of qualification will help. Don't try more than three
16282 -- levels, and if we get to standard, it's no use (and probably
16283 -- represents an error in the compiler) Also do not bother with
16284 -- internal scope names.
16287 Expec_Scope : Entity_Id;
16288 Found_Scope : Entity_Id;
16291 Expec_Scope := Expec_Type;
16292 Found_Scope := Found_Type;
16294 for Levels in Int range 0 .. 3 loop
16295 if Chars (Expec_Scope) /= Chars (Found_Scope) then
16296 Error_Msg_Qual_Level := Levels;
16300 Expec_Scope := Scope (Expec_Scope);
16301 Found_Scope := Scope (Found_Scope);
16303 exit when Expec_Scope = Standard_Standard
16304 or else Found_Scope = Standard_Standard
16305 or else not Comes_From_Source (Expec_Scope)
16306 or else not Comes_From_Source (Found_Scope);
16310 if Is_Record_Type (Expec_Type)
16311 and then Present (Corresponding_Remote_Type (Expec_Type))
16313 Error_Msg_NE ("expected}!", Expr,
16314 Corresponding_Remote_Type (Expec_Type));
16316 Error_Msg_NE ("expected}!", Expr, Expec_Type);
16319 if Is_Entity_Name (Expr)
16320 and then Is_Package_Or_Generic_Package (Entity (Expr))
16322 Error_Msg_N ("\\found package name!", Expr);
16324 elsif Is_Entity_Name (Expr)
16326 (Ekind (Entity (Expr)) = E_Procedure
16328 Ekind (Entity (Expr)) = E_Generic_Procedure)
16330 if Ekind (Expec_Type) = E_Access_Subprogram_Type then
16332 ("found procedure name, possibly missing Access attribute!",
16336 ("\\found procedure name instead of function!", Expr);
16339 elsif Nkind (Expr) = N_Function_Call
16340 and then Ekind (Expec_Type) = E_Access_Subprogram_Type
16341 and then Etype (Designated_Type (Expec_Type)) = Etype (Expr)
16342 and then No (Parameter_Associations (Expr))
16345 ("found function name, possibly missing Access attribute!",
16348 -- Catch common error: a prefix or infix operator which is not
16349 -- directly visible because the type isn't.
16351 elsif Nkind (Expr) in N_Op
16352 and then Is_Overloaded (Expr)
16353 and then not Is_Immediately_Visible (Expec_Type)
16354 and then not Is_Potentially_Use_Visible (Expec_Type)
16355 and then not In_Use (Expec_Type)
16356 and then Has_Compatible_Type (Right_Opnd (Expr), Expec_Type)
16359 ("operator of the type is not directly visible!", Expr);
16361 elsif Ekind (Found_Type) = E_Void
16362 and then Present (Parent (Found_Type))
16363 and then Nkind (Parent (Found_Type)) = N_Full_Type_Declaration
16365 Error_Msg_NE ("\\found premature usage of}!", Expr, Found_Type);
16368 Error_Msg_NE ("\\found}!", Expr, Found_Type);
16371 -- A special check for cases like M1 and M2 = 0 where M1 and M2 are
16372 -- of the same modular type, and (M1 and M2) = 0 was intended.
16374 if Expec_Type = Standard_Boolean
16375 and then Is_Modular_Integer_Type (Found_Type)
16376 and then Nkind_In (Parent (Expr), N_Op_And, N_Op_Or, N_Op_Xor)
16377 and then Nkind (Right_Opnd (Parent (Expr))) in N_Op_Compare
16380 Op : constant Node_Id := Right_Opnd (Parent (Expr));
16381 L : constant Node_Id := Left_Opnd (Op);
16382 R : constant Node_Id := Right_Opnd (Op);
16384 -- The case for the message is when the left operand of the
16385 -- comparison is the same modular type, or when it is an
16386 -- integer literal (or other universal integer expression),
16387 -- which would have been typed as the modular type if the
16388 -- parens had been there.
16390 if (Etype (L) = Found_Type
16392 Etype (L) = Universal_Integer)
16393 and then Is_Integer_Type (Etype (R))
16396 ("\\possible missing parens for modular operation", Expr);
16401 -- Reset error message qualification indication
16403 Error_Msg_Qual_Level := 0;