1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2014, 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 Aspects; use Aspects;
27 with Atree; use Atree;
28 with Casing; use Casing;
29 with Checks; use Checks;
30 with Debug; use Debug;
31 with Elists; use Elists;
32 with Errout; use Errout;
33 with Exp_Ch11; use Exp_Ch11;
34 with Exp_Disp; use Exp_Disp;
35 with Exp_Util; use Exp_Util;
36 with Fname; use Fname;
37 with Freeze; use Freeze;
39 with Lib.Xref; use Lib.Xref;
40 with Namet.Sp; use Namet.Sp;
41 with Nlists; use Nlists;
42 with Nmake; use Nmake;
43 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_Prag; use Sem_Prag;
54 with Sem_Res; use Sem_Res;
55 with Sem_Type; use Sem_Type;
56 with Sinfo; use Sinfo;
57 with Sinput; use Sinput;
58 with Stand; use Stand;
60 with Stringt; use Stringt;
61 with Targparm; use Targparm;
62 with Tbuild; use Tbuild;
63 with Ttypes; use Ttypes;
64 with Uname; use Uname;
66 with GNAT.HTable; use GNAT.HTable;
68 package body Sem_Util is
70 ----------------------------------------
71 -- Global_Variables for New_Copy_Tree --
72 ----------------------------------------
74 -- These global variables are used by New_Copy_Tree. See description
75 -- of the body of this subprogram for details. Global variables can be
76 -- safely used by New_Copy_Tree, since there is no case of a recursive
77 -- call from the processing inside New_Copy_Tree.
79 NCT_Hash_Threshold : constant := 20;
80 -- If there are more than this number of pairs of entries in the
81 -- map, then Hash_Tables_Used will be set, and the hash tables will
82 -- be initialized and used for the searches.
84 NCT_Hash_Tables_Used : Boolean := False;
85 -- Set to True if hash tables are in use
87 NCT_Table_Entries : Nat := 0;
88 -- Count entries in table to see if threshold is reached
90 NCT_Hash_Table_Setup : Boolean := False;
91 -- Set to True if hash table contains data. We set this True if we
92 -- setup the hash table with data, and leave it set permanently
93 -- from then on, this is a signal that second and subsequent users
94 -- of the hash table must clear the old entries before reuse.
96 subtype NCT_Header_Num is Int range 0 .. 511;
97 -- Defines range of headers in hash tables (512 headers)
99 -----------------------
100 -- Local Subprograms --
101 -----------------------
103 function Build_Component_Subtype
106 T : Entity_Id) return Node_Id;
107 -- This function builds the subtype for Build_Actual_Subtype_Of_Component
108 -- and Build_Discriminal_Subtype_Of_Component. C is a list of constraints,
109 -- Loc is the source location, T is the original subtype.
111 function Is_Fully_Initialized_Variant (Typ : Entity_Id) return Boolean;
112 -- Subsidiary to Is_Fully_Initialized_Type. For an unconstrained type
113 -- with discriminants whose default values are static, examine only the
114 -- components in the selected variant to determine whether all of them
117 function Has_Enabled_Property
118 (Item_Id : Entity_Id;
119 Property : Name_Id) return Boolean;
120 -- Subsidiary to routines Async_xxx_Enabled and Effective_xxx_Enabled.
121 -- Determine whether an abstract state or a variable denoted by entity
122 -- Item_Id has enabled property Property.
124 function Has_Null_Extension (T : Entity_Id) return Boolean;
125 -- T is a derived tagged type. Check whether the type extension is null.
126 -- If the parent type is fully initialized, T can be treated as such.
128 ------------------------------
129 -- Abstract_Interface_List --
130 ------------------------------
132 function Abstract_Interface_List (Typ : Entity_Id) return List_Id is
136 if Is_Concurrent_Type (Typ) then
138 -- If we are dealing with a synchronized subtype, go to the base
139 -- type, whose declaration has the interface list.
141 -- Shouldn't this be Declaration_Node???
143 Nod := Parent (Base_Type (Typ));
145 if Nkind (Nod) = N_Full_Type_Declaration then
149 elsif Ekind (Typ) = E_Record_Type_With_Private then
150 if Nkind (Parent (Typ)) = N_Full_Type_Declaration then
151 Nod := Type_Definition (Parent (Typ));
153 elsif Nkind (Parent (Typ)) = N_Private_Type_Declaration then
154 if Present (Full_View (Typ))
155 and then Nkind (Parent (Full_View (Typ)))
156 = N_Full_Type_Declaration
158 Nod := Type_Definition (Parent (Full_View (Typ)));
160 -- If the full-view is not available we cannot do anything else
161 -- here (the source has errors).
167 -- Support for generic formals with interfaces is still missing ???
169 elsif Nkind (Parent (Typ)) = N_Formal_Type_Declaration then
174 (Nkind (Parent (Typ)) = N_Private_Extension_Declaration);
178 elsif Ekind (Typ) = E_Record_Subtype then
179 Nod := Type_Definition (Parent (Etype (Typ)));
181 elsif Ekind (Typ) = E_Record_Subtype_With_Private then
183 -- Recurse, because parent may still be a private extension. Also
184 -- note that the full view of the subtype or the full view of its
185 -- base type may (both) be unavailable.
187 return Abstract_Interface_List (Etype (Typ));
189 else pragma Assert ((Ekind (Typ)) = E_Record_Type);
190 if Nkind (Parent (Typ)) = N_Formal_Type_Declaration then
191 Nod := Formal_Type_Definition (Parent (Typ));
193 Nod := Type_Definition (Parent (Typ));
197 return Interface_List (Nod);
198 end Abstract_Interface_List;
200 --------------------------------
201 -- Add_Access_Type_To_Process --
202 --------------------------------
204 procedure Add_Access_Type_To_Process (E : Entity_Id; A : Entity_Id) is
208 Ensure_Freeze_Node (E);
209 L := Access_Types_To_Process (Freeze_Node (E));
213 Set_Access_Types_To_Process (Freeze_Node (E), L);
217 end Add_Access_Type_To_Process;
219 --------------------------
220 -- Add_Block_Identifier --
221 --------------------------
223 procedure Add_Block_Identifier (N : Node_Id; Id : out Entity_Id) is
224 Loc : constant Source_Ptr := Sloc (N);
227 pragma Assert (Nkind (N) = N_Block_Statement);
229 -- The block already has a label, return its entity
231 if Present (Identifier (N)) then
232 Id := Entity (Identifier (N));
234 -- Create a new block label and set its attributes
237 Id := New_Internal_Entity (E_Block, Current_Scope, Loc, 'B');
238 Set_Etype (Id, Standard_Void_Type);
241 Set_Identifier (N, New_Occurrence_Of (Id, Loc));
242 Set_Block_Node (Id, Identifier (N));
244 end Add_Block_Identifier;
246 -----------------------
247 -- Add_Contract_Item --
248 -----------------------
250 procedure Add_Contract_Item (Prag : Node_Id; Id : Entity_Id) is
251 Items : constant Node_Id := Contract (Id);
256 -- The related context must have a contract and the item to be added
259 pragma Assert (Present (Items));
260 pragma Assert (Nkind (Prag) = N_Pragma);
262 Nam := Original_Aspect_Name (Prag);
264 -- Contract items related to [generic] packages or instantiations. The
265 -- applicable pragmas are:
269 -- Part_Of (instantiation only)
271 if Ekind_In (Id, E_Generic_Package, E_Package) then
272 if Nam_In (Nam, Name_Abstract_State,
273 Name_Initial_Condition,
276 Set_Next_Pragma (Prag, Classifications (Items));
277 Set_Classifications (Items, Prag);
279 -- Indicator Part_Of must be associated with a package instantiation
281 elsif Nam = Name_Part_Of and then Is_Generic_Instance (Id) then
282 Set_Next_Pragma (Prag, Classifications (Items));
283 Set_Classifications (Items, Prag);
285 -- The pragma is not a proper contract item
291 -- Contract items related to package bodies. The applicable pragmas are:
294 elsif Ekind (Id) = E_Package_Body then
295 if Nam = Name_Refined_State then
296 Set_Next_Pragma (Prag, Classifications (Items));
297 Set_Classifications (Items, Prag);
299 -- The pragma is not a proper contract item
305 -- Contract items related to subprogram or entry declarations. The
306 -- applicable pragmas are:
316 elsif Ekind_In (Id, E_Entry, E_Entry_Family)
317 or else Is_Generic_Subprogram (Id)
318 or else Is_Subprogram (Id)
320 if Nam_In (Nam, Name_Precondition,
327 -- Before we add a precondition or postcondition to the list,
328 -- make sure we do not have a disallowed duplicate, which can
329 -- happen if we use a pragma for Pre[_Class] or Post[_Class]
330 -- instead of the corresponding aspect.
332 if not From_Aspect_Specification (Prag)
333 and then Nam_In (Nam, Name_Pre_Class,
340 N := Pre_Post_Conditions (Items);
341 while Present (N) loop
343 and then Original_Aspect_Name (N) = Nam
345 Error_Msg_Sloc := Sloc (N);
347 ("duplication of aspect for & given#", Prag, Id);
350 N := Next_Pragma (N);
355 Set_Next_Pragma (Prag, Pre_Post_Conditions (Items));
356 Set_Pre_Post_Conditions (Items, Prag);
358 elsif Nam_In (Nam, Name_Contract_Cases, Name_Test_Case) then
359 Set_Next_Pragma (Prag, Contract_Test_Cases (Items));
360 Set_Contract_Test_Cases (Items, Prag);
362 elsif Nam_In (Nam, Name_Depends, Name_Global) then
363 Set_Next_Pragma (Prag, Classifications (Items));
364 Set_Classifications (Items, Prag);
366 -- The pragma is not a proper contract item
372 -- Contract items related to subprogram bodies. The applicable pragmas
378 elsif Ekind (Id) = E_Subprogram_Body then
379 if Nam = Name_Refined_Post then
380 Set_Next_Pragma (Prag, Pre_Post_Conditions (Items));
381 Set_Pre_Post_Conditions (Items, Prag);
383 elsif Nam_In (Nam, Name_Refined_Depends, Name_Refined_Global) then
384 Set_Next_Pragma (Prag, Classifications (Items));
385 Set_Classifications (Items, Prag);
387 -- The pragma is not a proper contract item
393 -- Contract items related to variables. The applicable pragmas are:
400 elsif Ekind (Id) = E_Variable then
401 if Nam_In (Nam, Name_Async_Readers,
403 Name_Effective_Reads,
404 Name_Effective_Writes,
407 Set_Next_Pragma (Prag, Classifications (Items));
408 Set_Classifications (Items, Prag);
410 -- The pragma is not a proper contract item
416 end Add_Contract_Item;
418 ----------------------------
419 -- Add_Global_Declaration --
420 ----------------------------
422 procedure Add_Global_Declaration (N : Node_Id) is
423 Aux_Node : constant Node_Id := Aux_Decls_Node (Cunit (Current_Sem_Unit));
426 if No (Declarations (Aux_Node)) then
427 Set_Declarations (Aux_Node, New_List);
430 Append_To (Declarations (Aux_Node), N);
432 end Add_Global_Declaration;
434 --------------------------------
435 -- Address_Integer_Convert_OK --
436 --------------------------------
438 function Address_Integer_Convert_OK (T1, T2 : Entity_Id) return Boolean is
440 if Allow_Integer_Address
441 and then ((Is_Descendent_Of_Address (T1)
442 and then Is_Private_Type (T1)
443 and then Is_Integer_Type (T2))
445 (Is_Descendent_Of_Address (T2)
446 and then Is_Private_Type (T2)
447 and then Is_Integer_Type (T1)))
453 end Address_Integer_Convert_OK;
459 -- For now, just 8/16/32/64. but analyze later if AAMP is special???
461 function Addressable (V : Uint) return Boolean is
463 return V = Uint_8 or else
469 function Addressable (V : Int) return Boolean is
477 -----------------------
478 -- Alignment_In_Bits --
479 -----------------------
481 function Alignment_In_Bits (E : Entity_Id) return Uint is
483 return Alignment (E) * System_Storage_Unit;
484 end Alignment_In_Bits;
486 ---------------------------------
487 -- Append_Inherited_Subprogram --
488 ---------------------------------
490 procedure Append_Inherited_Subprogram (S : Entity_Id) is
491 Par : constant Entity_Id := Alias (S);
492 -- The parent subprogram
494 Scop : constant Entity_Id := Scope (Par);
495 -- The scope of definition of the parent subprogram
497 Typ : constant Entity_Id := Defining_Entity (Parent (S));
498 -- The derived type of which S is a primitive operation
504 if Ekind (Current_Scope) = E_Package
505 and then In_Private_Part (Current_Scope)
506 and then Has_Private_Declaration (Typ)
507 and then Is_Tagged_Type (Typ)
508 and then Scop = Current_Scope
510 -- The inherited operation is available at the earliest place after
511 -- the derived type declaration ( RM 7.3.1 (6/1)). This is only
512 -- relevant for type extensions. If the parent operation appears
513 -- after the type extension, the operation is not visible.
516 (Visible_Declarations
517 (Package_Specification (Current_Scope)));
518 while Present (Decl) loop
519 if Nkind (Decl) = N_Private_Extension_Declaration
520 and then Defining_Entity (Decl) = Typ
522 if Sloc (Decl) > Sloc (Par) then
523 Next_E := Next_Entity (Par);
524 Set_Next_Entity (Par, S);
525 Set_Next_Entity (S, Next_E);
537 -- If partial view is not a type extension, or it appears before the
538 -- subprogram declaration, insert normally at end of entity list.
540 Append_Entity (S, Current_Scope);
541 end Append_Inherited_Subprogram;
543 -----------------------------------------
544 -- Apply_Compile_Time_Constraint_Error --
545 -----------------------------------------
547 procedure Apply_Compile_Time_Constraint_Error
550 Reason : RT_Exception_Code;
551 Ent : Entity_Id := Empty;
552 Typ : Entity_Id := Empty;
553 Loc : Source_Ptr := No_Location;
554 Rep : Boolean := True;
555 Warn : Boolean := False)
557 Stat : constant Boolean := Is_Static_Expression (N);
558 R_Stat : constant Node_Id :=
559 Make_Raise_Constraint_Error (Sloc (N), Reason => Reason);
570 (Compile_Time_Constraint_Error (N, Msg, Ent, Loc, Warn => Warn));
576 -- Now we replace the node by an N_Raise_Constraint_Error node
577 -- This does not need reanalyzing, so set it as analyzed now.
580 Set_Analyzed (N, True);
583 Set_Raises_Constraint_Error (N);
585 -- Now deal with possible local raise handling
587 Possible_Local_Raise (N, Standard_Constraint_Error);
589 -- If the original expression was marked as static, the result is
590 -- still marked as static, but the Raises_Constraint_Error flag is
591 -- always set so that further static evaluation is not attempted.
594 Set_Is_Static_Expression (N);
596 end Apply_Compile_Time_Constraint_Error;
598 ---------------------------
599 -- Async_Readers_Enabled --
600 ---------------------------
602 function Async_Readers_Enabled (Id : Entity_Id) return Boolean is
604 return Has_Enabled_Property (Id, Name_Async_Readers);
605 end Async_Readers_Enabled;
607 ---------------------------
608 -- Async_Writers_Enabled --
609 ---------------------------
611 function Async_Writers_Enabled (Id : Entity_Id) return Boolean is
613 return Has_Enabled_Property (Id, Name_Async_Writers);
614 end Async_Writers_Enabled;
616 --------------------------------------
617 -- Available_Full_View_Of_Component --
618 --------------------------------------
620 function Available_Full_View_Of_Component (T : Entity_Id) return Boolean is
621 ST : constant Entity_Id := Scope (T);
622 SCT : constant Entity_Id := Scope (Component_Type (T));
624 return In_Open_Scopes (ST)
625 and then In_Open_Scopes (SCT)
626 and then Scope_Depth (ST) >= Scope_Depth (SCT);
627 end Available_Full_View_Of_Component;
633 procedure Bad_Attribute
636 Warn : Boolean := False)
639 Error_Msg_Warn := Warn;
640 Error_Msg_N ("unrecognized attribute&<<", N);
642 -- Check for possible misspelling
644 Error_Msg_Name_1 := First_Attribute_Name;
645 while Error_Msg_Name_1 <= Last_Attribute_Name loop
646 if Is_Bad_Spelling_Of (Nam, Error_Msg_Name_1) then
647 Error_Msg_N -- CODEFIX
648 ("\possible misspelling of %<<", N);
652 Error_Msg_Name_1 := Error_Msg_Name_1 + 1;
656 --------------------------------
657 -- Bad_Predicated_Subtype_Use --
658 --------------------------------
660 procedure Bad_Predicated_Subtype_Use
664 Suggest_Static : Boolean := False)
667 if Has_Predicates (Typ) then
668 if Is_Generic_Actual_Type (Typ) then
669 Error_Msg_Warn := SPARK_Mode /= On;
670 Error_Msg_FE (Msg & "<<", N, Typ);
671 Error_Msg_F ("\Program_Error [<<", N);
673 Make_Raise_Program_Error (Sloc (N),
674 Reason => PE_Bad_Predicated_Generic_Type));
677 Error_Msg_FE (Msg, N, Typ);
680 -- Emit an optional suggestion on how to remedy the error if the
681 -- context warrants it.
683 if Suggest_Static and then Present (Static_Predicate (Typ)) then
684 Error_Msg_FE ("\predicate of & should be marked static", N, Typ);
687 end Bad_Predicated_Subtype_Use;
689 -----------------------------------------
690 -- Bad_Unordered_Enumeration_Reference --
691 -----------------------------------------
693 function Bad_Unordered_Enumeration_Reference
695 T : Entity_Id) return Boolean
698 return Is_Enumeration_Type (T)
699 and then Comes_From_Source (N)
700 and then Warn_On_Unordered_Enumeration_Type
701 and then not Has_Pragma_Ordered (T)
702 and then not In_Same_Extended_Unit (N, T);
703 end Bad_Unordered_Enumeration_Reference;
705 --------------------------
706 -- Build_Actual_Subtype --
707 --------------------------
709 function Build_Actual_Subtype
711 N : Node_Or_Entity_Id) return Node_Id
714 -- Normally Sloc (N), but may point to corresponding body in some cases
716 Constraints : List_Id;
722 Disc_Type : Entity_Id;
728 if Nkind (N) = N_Defining_Identifier then
729 Obj := New_Occurrence_Of (N, Loc);
731 -- If this is a formal parameter of a subprogram declaration, and
732 -- we are compiling the body, we want the declaration for the
733 -- actual subtype to carry the source position of the body, to
734 -- prevent anomalies in gdb when stepping through the code.
736 if Is_Formal (N) then
738 Decl : constant Node_Id := Unit_Declaration_Node (Scope (N));
740 if Nkind (Decl) = N_Subprogram_Declaration
741 and then Present (Corresponding_Body (Decl))
743 Loc := Sloc (Corresponding_Body (Decl));
752 if Is_Array_Type (T) then
753 Constraints := New_List;
754 for J in 1 .. Number_Dimensions (T) loop
756 -- Build an array subtype declaration with the nominal subtype and
757 -- the bounds of the actual. Add the declaration in front of the
758 -- local declarations for the subprogram, for analysis before any
759 -- reference to the formal in the body.
762 Make_Attribute_Reference (Loc,
764 Duplicate_Subexpr_No_Checks (Obj, Name_Req => True),
765 Attribute_Name => Name_First,
766 Expressions => New_List (
767 Make_Integer_Literal (Loc, J)));
770 Make_Attribute_Reference (Loc,
772 Duplicate_Subexpr_No_Checks (Obj, Name_Req => True),
773 Attribute_Name => Name_Last,
774 Expressions => New_List (
775 Make_Integer_Literal (Loc, J)));
777 Append (Make_Range (Loc, Lo, Hi), Constraints);
780 -- If the type has unknown discriminants there is no constrained
781 -- subtype to build. This is never called for a formal or for a
782 -- lhs, so returning the type is ok ???
784 elsif Has_Unknown_Discriminants (T) then
788 Constraints := New_List;
790 -- Type T is a generic derived type, inherit the discriminants from
793 if Is_Private_Type (T)
794 and then No (Full_View (T))
796 -- T was flagged as an error if it was declared as a formal
797 -- derived type with known discriminants. In this case there
798 -- is no need to look at the parent type since T already carries
799 -- its own discriminants.
801 and then not Error_Posted (T)
803 Disc_Type := Etype (Base_Type (T));
808 Discr := First_Discriminant (Disc_Type);
809 while Present (Discr) loop
810 Append_To (Constraints,
811 Make_Selected_Component (Loc,
813 Duplicate_Subexpr_No_Checks (Obj),
814 Selector_Name => New_Occurrence_Of (Discr, Loc)));
815 Next_Discriminant (Discr);
819 Subt := Make_Temporary (Loc, 'S', Related_Node => N);
820 Set_Is_Internal (Subt);
823 Make_Subtype_Declaration (Loc,
824 Defining_Identifier => Subt,
825 Subtype_Indication =>
826 Make_Subtype_Indication (Loc,
827 Subtype_Mark => New_Occurrence_Of (T, Loc),
829 Make_Index_Or_Discriminant_Constraint (Loc,
830 Constraints => Constraints)));
832 Mark_Rewrite_Insertion (Decl);
834 end Build_Actual_Subtype;
836 ---------------------------------------
837 -- Build_Actual_Subtype_Of_Component --
838 ---------------------------------------
840 function Build_Actual_Subtype_Of_Component
842 N : Node_Id) return Node_Id
844 Loc : constant Source_Ptr := Sloc (N);
845 P : constant Node_Id := Prefix (N);
848 Index_Typ : Entity_Id;
850 Desig_Typ : Entity_Id;
851 -- This is either a copy of T, or if T is an access type, then it is
852 -- the directly designated type of this access type.
854 function Build_Actual_Array_Constraint return List_Id;
855 -- If one or more of the bounds of the component depends on
856 -- discriminants, build actual constraint using the discriminants
859 function Build_Actual_Record_Constraint return List_Id;
860 -- Similar to previous one, for discriminated components constrained
861 -- by the discriminant of the enclosing object.
863 -----------------------------------
864 -- Build_Actual_Array_Constraint --
865 -----------------------------------
867 function Build_Actual_Array_Constraint return List_Id is
868 Constraints : constant List_Id := New_List;
876 Indx := First_Index (Desig_Typ);
877 while Present (Indx) loop
878 Old_Lo := Type_Low_Bound (Etype (Indx));
879 Old_Hi := Type_High_Bound (Etype (Indx));
881 if Denotes_Discriminant (Old_Lo) then
883 Make_Selected_Component (Loc,
884 Prefix => New_Copy_Tree (P),
885 Selector_Name => New_Occurrence_Of (Entity (Old_Lo), Loc));
888 Lo := New_Copy_Tree (Old_Lo);
890 -- The new bound will be reanalyzed in the enclosing
891 -- declaration. For literal bounds that come from a type
892 -- declaration, the type of the context must be imposed, so
893 -- insure that analysis will take place. For non-universal
894 -- types this is not strictly necessary.
896 Set_Analyzed (Lo, False);
899 if Denotes_Discriminant (Old_Hi) then
901 Make_Selected_Component (Loc,
902 Prefix => New_Copy_Tree (P),
903 Selector_Name => New_Occurrence_Of (Entity (Old_Hi), Loc));
906 Hi := New_Copy_Tree (Old_Hi);
907 Set_Analyzed (Hi, False);
910 Append (Make_Range (Loc, Lo, Hi), Constraints);
915 end Build_Actual_Array_Constraint;
917 ------------------------------------
918 -- Build_Actual_Record_Constraint --
919 ------------------------------------
921 function Build_Actual_Record_Constraint return List_Id is
922 Constraints : constant List_Id := New_List;
927 D := First_Elmt (Discriminant_Constraint (Desig_Typ));
928 while Present (D) loop
929 if Denotes_Discriminant (Node (D)) then
930 D_Val := Make_Selected_Component (Loc,
931 Prefix => New_Copy_Tree (P),
932 Selector_Name => New_Occurrence_Of (Entity (Node (D)), Loc));
935 D_Val := New_Copy_Tree (Node (D));
938 Append (D_Val, Constraints);
943 end Build_Actual_Record_Constraint;
945 -- Start of processing for Build_Actual_Subtype_Of_Component
948 -- Why the test for Spec_Expression mode here???
950 if In_Spec_Expression then
953 -- More comments for the rest of this body would be good ???
955 elsif Nkind (N) = N_Explicit_Dereference then
956 if Is_Composite_Type (T)
957 and then not Is_Constrained (T)
958 and then not (Is_Class_Wide_Type (T)
959 and then Is_Constrained (Root_Type (T)))
960 and then not Has_Unknown_Discriminants (T)
962 -- If the type of the dereference is already constrained, it is an
965 if Is_Array_Type (Etype (N))
966 and then Is_Constrained (Etype (N))
970 Remove_Side_Effects (P);
971 return Build_Actual_Subtype (T, N);
978 if Ekind (T) = E_Access_Subtype then
979 Desig_Typ := Designated_Type (T);
984 if Ekind (Desig_Typ) = E_Array_Subtype then
985 Id := First_Index (Desig_Typ);
986 while Present (Id) loop
987 Index_Typ := Underlying_Type (Etype (Id));
989 if Denotes_Discriminant (Type_Low_Bound (Index_Typ))
991 Denotes_Discriminant (Type_High_Bound (Index_Typ))
993 Remove_Side_Effects (P);
995 Build_Component_Subtype
996 (Build_Actual_Array_Constraint, Loc, Base_Type (T));
1002 elsif Is_Composite_Type (Desig_Typ)
1003 and then Has_Discriminants (Desig_Typ)
1004 and then not Has_Unknown_Discriminants (Desig_Typ)
1006 if Is_Private_Type (Desig_Typ)
1007 and then No (Discriminant_Constraint (Desig_Typ))
1009 Desig_Typ := Full_View (Desig_Typ);
1012 D := First_Elmt (Discriminant_Constraint (Desig_Typ));
1013 while Present (D) loop
1014 if Denotes_Discriminant (Node (D)) then
1015 Remove_Side_Effects (P);
1017 Build_Component_Subtype (
1018 Build_Actual_Record_Constraint, Loc, Base_Type (T));
1025 -- If none of the above, the actual and nominal subtypes are the same
1028 end Build_Actual_Subtype_Of_Component;
1030 -----------------------------
1031 -- Build_Component_Subtype --
1032 -----------------------------
1034 function Build_Component_Subtype
1037 T : Entity_Id) return Node_Id
1043 -- Unchecked_Union components do not require component subtypes
1045 if Is_Unchecked_Union (T) then
1049 Subt := Make_Temporary (Loc, 'S');
1050 Set_Is_Internal (Subt);
1053 Make_Subtype_Declaration (Loc,
1054 Defining_Identifier => Subt,
1055 Subtype_Indication =>
1056 Make_Subtype_Indication (Loc,
1057 Subtype_Mark => New_Occurrence_Of (Base_Type (T), Loc),
1059 Make_Index_Or_Discriminant_Constraint (Loc,
1060 Constraints => C)));
1062 Mark_Rewrite_Insertion (Decl);
1064 end Build_Component_Subtype;
1066 ---------------------------
1067 -- Build_Default_Subtype --
1068 ---------------------------
1070 function Build_Default_Subtype
1072 N : Node_Id) return Entity_Id
1074 Loc : constant Source_Ptr := Sloc (N);
1078 -- The base type that is to be constrained by the defaults
1081 if not Has_Discriminants (T) or else Is_Constrained (T) then
1085 Bas := Base_Type (T);
1087 -- If T is non-private but its base type is private, this is the
1088 -- completion of a subtype declaration whose parent type is private
1089 -- (see Complete_Private_Subtype in Sem_Ch3). The proper discriminants
1090 -- are to be found in the full view of the base.
1092 if Is_Private_Type (Bas) and then Present (Full_View (Bas)) then
1093 Bas := Full_View (Bas);
1096 Disc := First_Discriminant (T);
1098 if No (Discriminant_Default_Value (Disc)) then
1103 Act : constant Entity_Id := Make_Temporary (Loc, 'S');
1104 Constraints : constant List_Id := New_List;
1108 while Present (Disc) loop
1109 Append_To (Constraints,
1110 New_Copy_Tree (Discriminant_Default_Value (Disc)));
1111 Next_Discriminant (Disc);
1115 Make_Subtype_Declaration (Loc,
1116 Defining_Identifier => Act,
1117 Subtype_Indication =>
1118 Make_Subtype_Indication (Loc,
1119 Subtype_Mark => New_Occurrence_Of (Bas, Loc),
1121 Make_Index_Or_Discriminant_Constraint (Loc,
1122 Constraints => Constraints)));
1124 Insert_Action (N, Decl);
1128 end Build_Default_Subtype;
1130 --------------------------------------------
1131 -- Build_Discriminal_Subtype_Of_Component --
1132 --------------------------------------------
1134 function Build_Discriminal_Subtype_Of_Component
1135 (T : Entity_Id) return Node_Id
1137 Loc : constant Source_Ptr := Sloc (T);
1141 function Build_Discriminal_Array_Constraint return List_Id;
1142 -- If one or more of the bounds of the component depends on
1143 -- discriminants, build actual constraint using the discriminants
1146 function Build_Discriminal_Record_Constraint return List_Id;
1147 -- Similar to previous one, for discriminated components constrained by
1148 -- the discriminant of the enclosing object.
1150 ----------------------------------------
1151 -- Build_Discriminal_Array_Constraint --
1152 ----------------------------------------
1154 function Build_Discriminal_Array_Constraint return List_Id is
1155 Constraints : constant List_Id := New_List;
1163 Indx := First_Index (T);
1164 while Present (Indx) loop
1165 Old_Lo := Type_Low_Bound (Etype (Indx));
1166 Old_Hi := Type_High_Bound (Etype (Indx));
1168 if Denotes_Discriminant (Old_Lo) then
1169 Lo := New_Occurrence_Of (Discriminal (Entity (Old_Lo)), Loc);
1172 Lo := New_Copy_Tree (Old_Lo);
1175 if Denotes_Discriminant (Old_Hi) then
1176 Hi := New_Occurrence_Of (Discriminal (Entity (Old_Hi)), Loc);
1179 Hi := New_Copy_Tree (Old_Hi);
1182 Append (Make_Range (Loc, Lo, Hi), Constraints);
1187 end Build_Discriminal_Array_Constraint;
1189 -----------------------------------------
1190 -- Build_Discriminal_Record_Constraint --
1191 -----------------------------------------
1193 function Build_Discriminal_Record_Constraint return List_Id is
1194 Constraints : constant List_Id := New_List;
1199 D := First_Elmt (Discriminant_Constraint (T));
1200 while Present (D) loop
1201 if Denotes_Discriminant (Node (D)) then
1203 New_Occurrence_Of (Discriminal (Entity (Node (D))), Loc);
1206 D_Val := New_Copy_Tree (Node (D));
1209 Append (D_Val, Constraints);
1214 end Build_Discriminal_Record_Constraint;
1216 -- Start of processing for Build_Discriminal_Subtype_Of_Component
1219 if Ekind (T) = E_Array_Subtype then
1220 Id := First_Index (T);
1221 while Present (Id) loop
1222 if Denotes_Discriminant (Type_Low_Bound (Etype (Id))) or else
1223 Denotes_Discriminant (Type_High_Bound (Etype (Id)))
1225 return Build_Component_Subtype
1226 (Build_Discriminal_Array_Constraint, Loc, T);
1232 elsif Ekind (T) = E_Record_Subtype
1233 and then Has_Discriminants (T)
1234 and then not Has_Unknown_Discriminants (T)
1236 D := First_Elmt (Discriminant_Constraint (T));
1237 while Present (D) loop
1238 if Denotes_Discriminant (Node (D)) then
1239 return Build_Component_Subtype
1240 (Build_Discriminal_Record_Constraint, Loc, T);
1247 -- If none of the above, the actual and nominal subtypes are the same
1250 end Build_Discriminal_Subtype_Of_Component;
1252 ------------------------------
1253 -- Build_Elaboration_Entity --
1254 ------------------------------
1256 procedure Build_Elaboration_Entity (N : Node_Id; Spec_Id : Entity_Id) is
1257 Loc : constant Source_Ptr := Sloc (N);
1259 Elab_Ent : Entity_Id;
1261 procedure Set_Package_Name (Ent : Entity_Id);
1262 -- Given an entity, sets the fully qualified name of the entity in
1263 -- Name_Buffer, with components separated by double underscores. This
1264 -- is a recursive routine that climbs the scope chain to Standard.
1266 ----------------------
1267 -- Set_Package_Name --
1268 ----------------------
1270 procedure Set_Package_Name (Ent : Entity_Id) is
1272 if Scope (Ent) /= Standard_Standard then
1273 Set_Package_Name (Scope (Ent));
1276 Nam : constant String := Get_Name_String (Chars (Ent));
1278 Name_Buffer (Name_Len + 1) := '_';
1279 Name_Buffer (Name_Len + 2) := '_';
1280 Name_Buffer (Name_Len + 3 .. Name_Len + Nam'Length + 2) := Nam;
1281 Name_Len := Name_Len + Nam'Length + 2;
1285 Get_Name_String (Chars (Ent));
1287 end Set_Package_Name;
1289 -- Start of processing for Build_Elaboration_Entity
1292 -- Ignore if already constructed
1294 if Present (Elaboration_Entity (Spec_Id)) then
1298 -- Ignore in ASIS mode, elaboration entity is not in source and plays
1299 -- no role in analysis.
1305 -- Construct name of elaboration entity as xxx_E, where xxx is the unit
1306 -- name with dots replaced by double underscore. We have to manually
1307 -- construct this name, since it will be elaborated in the outer scope,
1308 -- and thus will not have the unit name automatically prepended.
1310 Set_Package_Name (Spec_Id);
1311 Add_Str_To_Name_Buffer ("_E");
1313 -- Create elaboration counter
1315 Elab_Ent := Make_Defining_Identifier (Loc, Chars => Name_Find);
1316 Set_Elaboration_Entity (Spec_Id, Elab_Ent);
1319 Make_Object_Declaration (Loc,
1320 Defining_Identifier => Elab_Ent,
1321 Object_Definition =>
1322 New_Occurrence_Of (Standard_Short_Integer, Loc),
1323 Expression => Make_Integer_Literal (Loc, Uint_0));
1325 Push_Scope (Standard_Standard);
1326 Add_Global_Declaration (Decl);
1329 -- Reset True_Constant indication, since we will indeed assign a value
1330 -- to the variable in the binder main. We also kill the Current_Value
1331 -- and Last_Assignment fields for the same reason.
1333 Set_Is_True_Constant (Elab_Ent, False);
1334 Set_Current_Value (Elab_Ent, Empty);
1335 Set_Last_Assignment (Elab_Ent, Empty);
1337 -- We do not want any further qualification of the name (if we did not
1338 -- do this, we would pick up the name of the generic package in the case
1339 -- of a library level generic instantiation).
1341 Set_Has_Qualified_Name (Elab_Ent);
1342 Set_Has_Fully_Qualified_Name (Elab_Ent);
1343 end Build_Elaboration_Entity;
1345 --------------------------------
1346 -- Build_Explicit_Dereference --
1347 --------------------------------
1349 procedure Build_Explicit_Dereference
1353 Loc : constant Source_Ptr := Sloc (Expr);
1356 -- An entity of a type with a reference aspect is overloaded with
1357 -- both interpretations: with and without the dereference. Now that
1358 -- the dereference is made explicit, set the type of the node properly,
1359 -- to prevent anomalies in the backend. Same if the expression is an
1360 -- overloaded function call whose return type has a reference aspect.
1362 if Is_Entity_Name (Expr) then
1363 Set_Etype (Expr, Etype (Entity (Expr)));
1365 elsif Nkind (Expr) = N_Function_Call then
1366 Set_Etype (Expr, Etype (Name (Expr)));
1369 Set_Is_Overloaded (Expr, False);
1371 -- The expression will often be a generalized indexing that yields a
1372 -- container element that is then dereferenced, in which case the
1373 -- generalized indexing call is also non-overloaded.
1375 if Nkind (Expr) = N_Indexed_Component
1376 and then Present (Generalized_Indexing (Expr))
1378 Set_Is_Overloaded (Generalized_Indexing (Expr), False);
1382 Make_Explicit_Dereference (Loc,
1384 Make_Selected_Component (Loc,
1385 Prefix => Relocate_Node (Expr),
1386 Selector_Name => New_Occurrence_Of (Disc, Loc))));
1387 Set_Etype (Prefix (Expr), Etype (Disc));
1388 Set_Etype (Expr, Designated_Type (Etype (Disc)));
1389 end Build_Explicit_Dereference;
1391 -----------------------------------
1392 -- Cannot_Raise_Constraint_Error --
1393 -----------------------------------
1395 function Cannot_Raise_Constraint_Error (Expr : Node_Id) return Boolean is
1397 if Compile_Time_Known_Value (Expr) then
1400 elsif Do_Range_Check (Expr) then
1403 elsif Raises_Constraint_Error (Expr) then
1407 case Nkind (Expr) is
1408 when N_Identifier =>
1411 when N_Expanded_Name =>
1414 when N_Selected_Component =>
1415 return not Do_Discriminant_Check (Expr);
1417 when N_Attribute_Reference =>
1418 if Do_Overflow_Check (Expr) then
1421 elsif No (Expressions (Expr)) then
1429 N := First (Expressions (Expr));
1430 while Present (N) loop
1431 if Cannot_Raise_Constraint_Error (N) then
1442 when N_Type_Conversion =>
1443 if Do_Overflow_Check (Expr)
1444 or else Do_Length_Check (Expr)
1445 or else Do_Tag_Check (Expr)
1449 return Cannot_Raise_Constraint_Error (Expression (Expr));
1452 when N_Unchecked_Type_Conversion =>
1453 return Cannot_Raise_Constraint_Error (Expression (Expr));
1456 if Do_Overflow_Check (Expr) then
1459 return Cannot_Raise_Constraint_Error (Right_Opnd (Expr));
1466 if Do_Division_Check (Expr)
1467 or else Do_Overflow_Check (Expr)
1472 Cannot_Raise_Constraint_Error (Left_Opnd (Expr))
1474 Cannot_Raise_Constraint_Error (Right_Opnd (Expr));
1493 N_Op_Shift_Right_Arithmetic |
1497 if Do_Overflow_Check (Expr) then
1501 Cannot_Raise_Constraint_Error (Left_Opnd (Expr))
1503 Cannot_Raise_Constraint_Error (Right_Opnd (Expr));
1510 end Cannot_Raise_Constraint_Error;
1512 -----------------------------------------
1513 -- Check_Dynamically_Tagged_Expression --
1514 -----------------------------------------
1516 procedure Check_Dynamically_Tagged_Expression
1519 Related_Nod : Node_Id)
1522 pragma Assert (Is_Tagged_Type (Typ));
1524 -- In order to avoid spurious errors when analyzing the expanded code,
1525 -- this check is done only for nodes that come from source and for
1526 -- actuals of generic instantiations.
1528 if (Comes_From_Source (Related_Nod)
1529 or else In_Generic_Actual (Expr))
1530 and then (Is_Class_Wide_Type (Etype (Expr))
1531 or else Is_Dynamically_Tagged (Expr))
1532 and then Is_Tagged_Type (Typ)
1533 and then not Is_Class_Wide_Type (Typ)
1535 Error_Msg_N ("dynamically tagged expression not allowed!", Expr);
1537 end Check_Dynamically_Tagged_Expression;
1539 -----------------------------------------------
1540 -- Check_Expression_Against_Static_Predicate --
1541 -----------------------------------------------
1543 procedure Check_Expression_Against_Static_Predicate
1548 -- When the predicate is static and the value of the expression is known
1549 -- at compile time, evaluate the predicate check. A type is non-static
1550 -- when it has aspect Dynamic_Predicate.
1552 if Compile_Time_Known_Value (Expr)
1553 and then Has_Predicates (Typ)
1554 and then Present (Static_Predicate (Typ))
1555 and then not Has_Dynamic_Predicate_Aspect (Typ)
1557 -- Either -gnatc is enabled or the expression is ok
1559 if Operating_Mode < Generate_Code
1560 or else Eval_Static_Predicate_Check (Expr, Typ)
1564 -- The expression is prohibited by the static predicate
1568 ("??static expression fails static predicate check on &",
1572 end Check_Expression_Against_Static_Predicate;
1574 --------------------------
1575 -- Check_Fully_Declared --
1576 --------------------------
1578 procedure Check_Fully_Declared (T : Entity_Id; N : Node_Id) is
1580 if Ekind (T) = E_Incomplete_Type then
1582 -- Ada 2005 (AI-50217): If the type is available through a limited
1583 -- with_clause, verify that its full view has been analyzed.
1585 if From_Limited_With (T)
1586 and then Present (Non_Limited_View (T))
1587 and then Ekind (Non_Limited_View (T)) /= E_Incomplete_Type
1589 -- The non-limited view is fully declared
1594 ("premature usage of incomplete}", N, First_Subtype (T));
1597 -- Need comments for these tests ???
1599 elsif Has_Private_Component (T)
1600 and then not Is_Generic_Type (Root_Type (T))
1601 and then not In_Spec_Expression
1603 -- Special case: if T is the anonymous type created for a single
1604 -- task or protected object, use the name of the source object.
1606 if Is_Concurrent_Type (T)
1607 and then not Comes_From_Source (T)
1608 and then Nkind (N) = N_Object_Declaration
1610 Error_Msg_NE ("type of& has incomplete component", N,
1611 Defining_Identifier (N));
1615 ("premature usage of incomplete}", N, First_Subtype (T));
1618 end Check_Fully_Declared;
1620 -------------------------------------
1621 -- Check_Function_Writable_Actuals --
1622 -------------------------------------
1624 procedure Check_Function_Writable_Actuals (N : Node_Id) is
1625 Writable_Actuals_List : Elist_Id := No_Elist;
1626 Identifiers_List : Elist_Id := No_Elist;
1627 Error_Node : Node_Id := Empty;
1629 procedure Collect_Identifiers (N : Node_Id);
1630 -- In a single traversal of subtree N collect in Writable_Actuals_List
1631 -- all the actuals of functions with writable actuals, and in the list
1632 -- Identifiers_List collect all the identifiers that are not actuals of
1633 -- functions with writable actuals. If a writable actual is referenced
1634 -- twice as writable actual then Error_Node is set to reference its
1635 -- second occurrence, the error is reported, and the tree traversal
1638 function Get_Function_Id (Call : Node_Id) return Entity_Id;
1639 -- Return the entity associated with the function call
1641 procedure Preanalyze_Without_Errors (N : Node_Id);
1642 -- Preanalyze N without reporting errors. Very dubious, you can't just
1643 -- go analyzing things more than once???
1645 -------------------------
1646 -- Collect_Identifiers --
1647 -------------------------
1649 procedure Collect_Identifiers (N : Node_Id) is
1651 function Check_Node (N : Node_Id) return Traverse_Result;
1652 -- Process a single node during the tree traversal to collect the
1653 -- writable actuals of functions and all the identifiers which are
1654 -- not writable actuals of functions.
1656 function Contains (List : Elist_Id; N : Node_Id) return Boolean;
1657 -- Returns True if List has a node whose Entity is Entity (N)
1659 -------------------------
1660 -- Check_Function_Call --
1661 -------------------------
1663 function Check_Node (N : Node_Id) return Traverse_Result is
1664 Is_Writable_Actual : Boolean := False;
1668 if Nkind (N) = N_Identifier then
1670 -- No analysis possible if the entity is not decorated
1672 if No (Entity (N)) then
1675 -- Don't collect identifiers of packages, called functions, etc
1677 elsif Ekind_In (Entity (N), E_Package,
1684 -- Analyze if N is a writable actual of a function
1686 elsif Nkind (Parent (N)) = N_Function_Call then
1688 Call : constant Node_Id := Parent (N);
1693 Id := Get_Function_Id (Call);
1695 Formal := First_Formal (Id);
1696 Actual := First_Actual (Call);
1697 while Present (Actual) and then Present (Formal) loop
1699 if Ekind_In (Formal, E_Out_Parameter,
1702 Is_Writable_Actual := True;
1708 Next_Formal (Formal);
1709 Next_Actual (Actual);
1714 if Is_Writable_Actual then
1715 if Contains (Writable_Actuals_List, N) then
1717 ("value may be affected by call to& "
1718 & "because order of evaluation is arbitrary", N, Id);
1723 if Writable_Actuals_List = No_Elist then
1724 Writable_Actuals_List := New_Elmt_List;
1727 Append_Elmt (N, Writable_Actuals_List);
1729 if Identifiers_List = No_Elist then
1730 Identifiers_List := New_Elmt_List;
1733 Append_Unique_Elmt (N, Identifiers_List);
1746 N : Node_Id) return Boolean
1748 pragma Assert (Nkind (N) in N_Has_Entity);
1753 if List = No_Elist then
1757 Elmt := First_Elmt (List);
1758 while Present (Elmt) loop
1759 if Entity (Node (Elmt)) = Entity (N) then
1773 procedure Do_Traversal is new Traverse_Proc (Check_Node);
1774 -- The traversal procedure
1776 -- Start of processing for Collect_Identifiers
1779 if Present (Error_Node) then
1783 if Nkind (N) in N_Subexpr
1784 and then Is_Static_Expression (N)
1790 end Collect_Identifiers;
1792 ---------------------
1793 -- Get_Function_Id --
1794 ---------------------
1796 function Get_Function_Id (Call : Node_Id) return Entity_Id is
1797 Nam : constant Node_Id := Name (Call);
1801 if Nkind (Nam) = N_Explicit_Dereference then
1803 pragma Assert (Ekind (Id) = E_Subprogram_Type);
1805 elsif Nkind (Nam) = N_Selected_Component then
1806 Id := Entity (Selector_Name (Nam));
1808 elsif Nkind (Nam) = N_Indexed_Component then
1809 Id := Entity (Selector_Name (Prefix (Nam)));
1816 end Get_Function_Id;
1818 ---------------------------
1819 -- Preanalyze_Expression --
1820 ---------------------------
1822 procedure Preanalyze_Without_Errors (N : Node_Id) is
1823 Status : constant Boolean := Get_Ignore_Errors;
1825 Set_Ignore_Errors (True);
1827 Set_Ignore_Errors (Status);
1828 end Preanalyze_Without_Errors;
1830 -- Start of processing for Check_Function_Writable_Actuals
1833 -- The check only applies to Ada 2012 code, and only to constructs that
1834 -- have multiple constituents whose order of evaluation is not specified
1837 if Ada_Version < Ada_2012
1838 or else (not (Nkind (N) in N_Op)
1839 and then not (Nkind (N) in N_Membership_Test)
1840 and then not Nkind_In (N, N_Range,
1842 N_Extension_Aggregate,
1843 N_Full_Type_Declaration,
1845 N_Procedure_Call_Statement,
1846 N_Entry_Call_Statement))
1847 or else (Nkind (N) = N_Full_Type_Declaration
1848 and then not Is_Record_Type (Defining_Identifier (N)))
1850 -- In addition, this check only applies to source code, not to code
1851 -- generated by constraint checks.
1853 or else not Comes_From_Source (N)
1858 -- If a construct C has two or more direct constituents that are names
1859 -- or expressions whose evaluation may occur in an arbitrary order, at
1860 -- least one of which contains a function call with an in out or out
1861 -- parameter, then the construct is legal only if: for each name N that
1862 -- is passed as a parameter of mode in out or out to some inner function
1863 -- call C2 (not including the construct C itself), there is no other
1864 -- name anywhere within a direct constituent of the construct C other
1865 -- than the one containing C2, that is known to refer to the same
1866 -- object (RM 6.4.1(6.17/3)).
1870 Collect_Identifiers (Low_Bound (N));
1871 Collect_Identifiers (High_Bound (N));
1873 when N_Op | N_Membership_Test =>
1877 Collect_Identifiers (Left_Opnd (N));
1879 if Present (Right_Opnd (N)) then
1880 Collect_Identifiers (Right_Opnd (N));
1883 if Nkind_In (N, N_In, N_Not_In)
1884 and then Present (Alternatives (N))
1886 Expr := First (Alternatives (N));
1887 while Present (Expr) loop
1888 Collect_Identifiers (Expr);
1895 when N_Full_Type_Declaration =>
1897 function Get_Record_Part (N : Node_Id) return Node_Id;
1898 -- Return the record part of this record type definition
1900 function Get_Record_Part (N : Node_Id) return Node_Id is
1901 Type_Def : constant Node_Id := Type_Definition (N);
1903 if Nkind (Type_Def) = N_Derived_Type_Definition then
1904 return Record_Extension_Part (Type_Def);
1908 end Get_Record_Part;
1911 Def_Id : Entity_Id := Defining_Identifier (N);
1912 Rec : Node_Id := Get_Record_Part (N);
1915 -- No need to perform any analysis if the record has no
1918 if No (Rec) or else No (Component_List (Rec)) then
1922 -- Collect the identifiers starting from the deepest
1923 -- derivation. Done to report the error in the deepest
1927 if Present (Component_List (Rec)) then
1928 Comp := First (Component_Items (Component_List (Rec)));
1929 while Present (Comp) loop
1930 if Nkind (Comp) = N_Component_Declaration
1931 and then Present (Expression (Comp))
1933 Collect_Identifiers (Expression (Comp));
1940 exit when No (Underlying_Type (Etype (Def_Id)))
1941 or else Base_Type (Underlying_Type (Etype (Def_Id)))
1944 Def_Id := Base_Type (Underlying_Type (Etype (Def_Id)));
1945 Rec := Get_Record_Part (Parent (Def_Id));
1949 when N_Subprogram_Call |
1950 N_Entry_Call_Statement =>
1952 Id : constant Entity_Id := Get_Function_Id (N);
1957 Formal := First_Formal (Id);
1958 Actual := First_Actual (N);
1959 while Present (Actual) and then Present (Formal) loop
1960 if Ekind_In (Formal, E_Out_Parameter,
1963 Collect_Identifiers (Actual);
1966 Next_Formal (Formal);
1967 Next_Actual (Actual);
1972 N_Extension_Aggregate =>
1976 Comp_Expr : Node_Id;
1979 -- Handle the N_Others_Choice of array aggregates with static
1980 -- bounds. There is no need to perform this analysis in
1981 -- aggregates without static bounds since we cannot evaluate
1982 -- if the N_Others_Choice covers several elements. There is
1983 -- no need to handle the N_Others choice of record aggregates
1984 -- since at this stage it has been already expanded by
1985 -- Resolve_Record_Aggregate.
1987 if Is_Array_Type (Etype (N))
1988 and then Nkind (N) = N_Aggregate
1989 and then Present (Aggregate_Bounds (N))
1990 and then Compile_Time_Known_Bounds (Etype (N))
1991 and then Expr_Value (High_Bound (Aggregate_Bounds (N)))
1992 > Expr_Value (Low_Bound (Aggregate_Bounds (N)))
1995 Count_Components : Uint := Uint_0;
1996 Num_Components : Uint;
1997 Others_Assoc : Node_Id;
1998 Others_Choice : Node_Id := Empty;
1999 Others_Box_Present : Boolean := False;
2002 -- Count positional associations
2004 if Present (Expressions (N)) then
2005 Comp_Expr := First (Expressions (N));
2006 while Present (Comp_Expr) loop
2007 Count_Components := Count_Components + 1;
2012 -- Count the rest of elements and locate the N_Others
2015 Assoc := First (Component_Associations (N));
2016 while Present (Assoc) loop
2017 Choice := First (Choices (Assoc));
2018 while Present (Choice) loop
2019 if Nkind (Choice) = N_Others_Choice then
2020 Others_Assoc := Assoc;
2021 Others_Choice := Choice;
2022 Others_Box_Present := Box_Present (Assoc);
2024 -- Count several components
2026 elsif Nkind_In (Choice, N_Range,
2027 N_Subtype_Indication)
2028 or else (Is_Entity_Name (Choice)
2029 and then Is_Type (Entity (Choice)))
2034 Get_Index_Bounds (Choice, L, H);
2036 (Compile_Time_Known_Value (L)
2037 and then Compile_Time_Known_Value (H));
2040 + Expr_Value (H) - Expr_Value (L) + 1;
2043 -- Count single component. No other case available
2044 -- since we are handling an aggregate with static
2048 pragma Assert (Is_Static_Expression (Choice)
2049 or else Nkind (Choice) = N_Identifier
2050 or else Nkind (Choice) = N_Integer_Literal);
2052 Count_Components := Count_Components + 1;
2062 Expr_Value (High_Bound (Aggregate_Bounds (N))) -
2063 Expr_Value (Low_Bound (Aggregate_Bounds (N))) + 1;
2065 pragma Assert (Count_Components <= Num_Components);
2067 -- Handle the N_Others choice if it covers several
2070 if Present (Others_Choice)
2071 and then (Num_Components - Count_Components) > 1
2073 if not Others_Box_Present then
2075 -- At this stage, if expansion is active, the
2076 -- expression of the others choice has not been
2077 -- analyzed. Hence we generate a duplicate and
2078 -- we analyze it silently to have available the
2079 -- minimum decoration required to collect the
2082 if not Expander_Active then
2083 Comp_Expr := Expression (Others_Assoc);
2086 New_Copy_Tree (Expression (Others_Assoc));
2087 Preanalyze_Without_Errors (Comp_Expr);
2090 Collect_Identifiers (Comp_Expr);
2092 if Writable_Actuals_List /= No_Elist then
2094 -- As suggested by Robert, at current stage we
2095 -- report occurrences of this case as warnings.
2098 ("writable function parameter may affect "
2099 & "value in other component because order "
2100 & "of evaluation is unspecified??",
2101 Node (First_Elmt (Writable_Actuals_List)));
2108 -- Handle ancestor part of extension aggregates
2110 if Nkind (N) = N_Extension_Aggregate then
2111 Collect_Identifiers (Ancestor_Part (N));
2114 -- Handle positional associations
2116 if Present (Expressions (N)) then
2117 Comp_Expr := First (Expressions (N));
2118 while Present (Comp_Expr) loop
2119 if not Is_Static_Expression (Comp_Expr) then
2120 Collect_Identifiers (Comp_Expr);
2127 -- Handle discrete associations
2129 if Present (Component_Associations (N)) then
2130 Assoc := First (Component_Associations (N));
2131 while Present (Assoc) loop
2133 if not Box_Present (Assoc) then
2134 Choice := First (Choices (Assoc));
2135 while Present (Choice) loop
2137 -- For now we skip discriminants since it requires
2138 -- performing the analysis in two phases: first one
2139 -- analyzing discriminants and second one analyzing
2140 -- the rest of components since discriminants are
2141 -- evaluated prior to components: too much extra
2142 -- work to detect a corner case???
2144 if Nkind (Choice) in N_Has_Entity
2145 and then Present (Entity (Choice))
2146 and then Ekind (Entity (Choice)) = E_Discriminant
2150 elsif Box_Present (Assoc) then
2154 if not Analyzed (Expression (Assoc)) then
2156 New_Copy_Tree (Expression (Assoc));
2157 Set_Parent (Comp_Expr, Parent (N));
2158 Preanalyze_Without_Errors (Comp_Expr);
2160 Comp_Expr := Expression (Assoc);
2163 Collect_Identifiers (Comp_Expr);
2179 -- No further action needed if we already reported an error
2181 if Present (Error_Node) then
2185 -- Check if some writable argument of a function is referenced
2187 if Writable_Actuals_List /= No_Elist
2188 and then Identifiers_List /= No_Elist
2195 Elmt_1 := First_Elmt (Writable_Actuals_List);
2196 while Present (Elmt_1) loop
2197 Elmt_2 := First_Elmt (Identifiers_List);
2198 while Present (Elmt_2) loop
2199 if Entity (Node (Elmt_1)) = Entity (Node (Elmt_2)) then
2200 case Nkind (Parent (Node (Elmt_2))) is
2202 N_Component_Association |
2203 N_Component_Declaration =>
2205 ("value may be affected by call in other "
2206 & "component because they are evaluated "
2207 & "in unspecified order",
2210 when N_In | N_Not_In =>
2212 ("value may be affected by call in other "
2213 & "alternative because they are evaluated "
2214 & "in unspecified order",
2219 ("value of actual may be affected by call in "
2220 & "other actual because they are evaluated "
2221 & "in unspecified order",
2233 end Check_Function_Writable_Actuals;
2235 --------------------------------
2236 -- Check_Implicit_Dereference --
2237 --------------------------------
2239 procedure Check_Implicit_Dereference (Nam : Node_Id; Typ : Entity_Id) is
2244 if Ada_Version < Ada_2012
2245 or else not Has_Implicit_Dereference (Base_Type (Typ))
2249 elsif not Comes_From_Source (Nam) then
2252 elsif Is_Entity_Name (Nam)
2253 and then Is_Type (Entity (Nam))
2258 Disc := First_Discriminant (Typ);
2259 while Present (Disc) loop
2260 if Has_Implicit_Dereference (Disc) then
2261 Desig := Designated_Type (Etype (Disc));
2262 Add_One_Interp (Nam, Disc, Desig);
2266 Next_Discriminant (Disc);
2269 end Check_Implicit_Dereference;
2271 ----------------------------------
2272 -- Check_Internal_Protected_Use --
2273 ----------------------------------
2275 procedure Check_Internal_Protected_Use (N : Node_Id; Nam : Entity_Id) is
2281 while Present (S) loop
2282 if S = Standard_Standard then
2285 elsif Ekind (S) = E_Function
2286 and then Ekind (Scope (S)) = E_Protected_Type
2295 if Scope (Nam) = Prot and then Ekind (Nam) /= E_Function then
2297 -- An indirect function call (e.g. a callback within a protected
2298 -- function body) is not statically illegal. If the access type is
2299 -- anonymous and is the type of an access parameter, the scope of Nam
2300 -- will be the protected type, but it is not a protected operation.
2302 if Ekind (Nam) = E_Subprogram_Type
2304 Nkind (Associated_Node_For_Itype (Nam)) = N_Function_Specification
2308 elsif Nkind (N) = N_Subprogram_Renaming_Declaration then
2310 ("within protected function cannot use protected "
2311 & "procedure in renaming or as generic actual", N);
2313 elsif Nkind (N) = N_Attribute_Reference then
2315 ("within protected function cannot take access of "
2316 & " protected procedure", N);
2320 ("within protected function, protected object is constant", N);
2322 ("\cannot call operation that may modify it", N);
2325 end Check_Internal_Protected_Use;
2327 ---------------------------------------
2328 -- Check_Later_Vs_Basic_Declarations --
2329 ---------------------------------------
2331 procedure Check_Later_Vs_Basic_Declarations
2333 During_Parsing : Boolean)
2335 Body_Sloc : Source_Ptr;
2338 function Is_Later_Declarative_Item (Decl : Node_Id) return Boolean;
2339 -- Return whether Decl is considered as a declarative item.
2340 -- When During_Parsing is True, the semantics of Ada 83 is followed.
2341 -- When During_Parsing is False, the semantics of SPARK is followed.
2343 -------------------------------
2344 -- Is_Later_Declarative_Item --
2345 -------------------------------
2347 function Is_Later_Declarative_Item (Decl : Node_Id) return Boolean is
2349 if Nkind (Decl) in N_Later_Decl_Item then
2352 elsif Nkind (Decl) = N_Pragma then
2355 elsif During_Parsing then
2358 -- In SPARK, a package declaration is not considered as a later
2359 -- declarative item.
2361 elsif Nkind (Decl) = N_Package_Declaration then
2364 -- In SPARK, a renaming is considered as a later declarative item
2366 elsif Nkind (Decl) in N_Renaming_Declaration then
2372 end Is_Later_Declarative_Item;
2374 -- Start of Check_Later_Vs_Basic_Declarations
2377 Decl := First (Decls);
2379 -- Loop through sequence of basic declarative items
2381 Outer : while Present (Decl) loop
2382 if not Nkind_In (Decl, N_Subprogram_Body, N_Package_Body, N_Task_Body)
2383 and then Nkind (Decl) not in N_Body_Stub
2387 -- Once a body is encountered, we only allow later declarative
2388 -- items. The inner loop checks the rest of the list.
2391 Body_Sloc := Sloc (Decl);
2393 Inner : while Present (Decl) loop
2394 if not Is_Later_Declarative_Item (Decl) then
2395 if During_Parsing then
2396 if Ada_Version = Ada_83 then
2397 Error_Msg_Sloc := Body_Sloc;
2399 ("(Ada 83) decl cannot appear after body#", Decl);
2402 Error_Msg_Sloc := Body_Sloc;
2403 Check_SPARK_Restriction
2404 ("decl cannot appear after body#", Decl);
2412 end Check_Later_Vs_Basic_Declarations;
2414 -------------------------
2415 -- Check_Nested_Access --
2416 -------------------------
2418 procedure Check_Nested_Access (Ent : Entity_Id) is
2419 Scop : constant Entity_Id := Current_Scope;
2420 Current_Subp : Entity_Id;
2421 Enclosing : Entity_Id;
2424 -- Currently only enabled for VM back-ends for efficiency, should we
2425 -- enable it more systematically ???
2427 -- Check for Is_Imported needs commenting below ???
2429 if VM_Target /= No_VM
2430 and then (Ekind (Ent) = E_Variable
2432 Ekind (Ent) = E_Constant
2434 Ekind (Ent) = E_Loop_Parameter)
2435 and then Scope (Ent) /= Empty
2436 and then not Is_Library_Level_Entity (Ent)
2437 and then not Is_Imported (Ent)
2439 if Is_Subprogram (Scop)
2440 or else Is_Generic_Subprogram (Scop)
2441 or else Is_Entry (Scop)
2443 Current_Subp := Scop;
2445 Current_Subp := Current_Subprogram;
2448 Enclosing := Enclosing_Subprogram (Ent);
2450 if Enclosing /= Empty
2451 and then Enclosing /= Current_Subp
2453 Set_Has_Up_Level_Access (Ent, True);
2456 end Check_Nested_Access;
2458 ---------------------------
2459 -- Check_No_Hidden_State --
2460 ---------------------------
2462 procedure Check_No_Hidden_State (Id : Entity_Id) is
2463 function Has_Null_Abstract_State (Pkg : Entity_Id) return Boolean;
2464 -- Determine whether the entity of a package denoted by Pkg has a null
2467 -----------------------------
2468 -- Has_Null_Abstract_State --
2469 -----------------------------
2471 function Has_Null_Abstract_State (Pkg : Entity_Id) return Boolean is
2472 States : constant Elist_Id := Abstract_States (Pkg);
2475 -- Check first available state of related package. A null abstract
2476 -- state always appears as the sole element of the state list.
2480 and then Is_Null_State (Node (First_Elmt (States)));
2481 end Has_Null_Abstract_State;
2485 Context : Entity_Id := Empty;
2486 Not_Visible : Boolean := False;
2489 -- Start of processing for Check_No_Hidden_State
2492 pragma Assert (Ekind_In (Id, E_Abstract_State, E_Variable));
2494 -- Find the proper context where the object or state appears
2497 while Present (Scop) loop
2500 -- Keep track of the context's visibility
2502 Not_Visible := Not_Visible or else In_Private_Part (Context);
2504 -- Prevent the search from going too far
2506 if Context = Standard_Standard then
2509 -- Objects and states that appear immediately within a subprogram or
2510 -- inside a construct nested within a subprogram do not introduce a
2511 -- hidden state. They behave as local variable declarations.
2513 elsif Is_Subprogram (Context) then
2516 -- When examining a package body, use the entity of the spec as it
2517 -- carries the abstract state declarations.
2519 elsif Ekind (Context) = E_Package_Body then
2520 Context := Spec_Entity (Context);
2523 -- Stop the traversal when a package subject to a null abstract state
2526 if Ekind_In (Context, E_Generic_Package, E_Package)
2527 and then Has_Null_Abstract_State (Context)
2532 Scop := Scope (Scop);
2535 -- At this point we know that there is at least one package with a null
2536 -- abstract state in visibility. Emit an error message unconditionally
2537 -- if the entity being processed is a state because the placement of the
2538 -- related package is irrelevant. This is not the case for objects as
2539 -- the intermediate context matters.
2541 if Present (Context)
2542 and then (Ekind (Id) = E_Abstract_State or else Not_Visible)
2544 Error_Msg_N ("cannot introduce hidden state &", Id);
2545 Error_Msg_NE ("\package & has null abstract state", Id, Context);
2547 end Check_No_Hidden_State;
2549 ------------------------------------------
2550 -- Check_Potentially_Blocking_Operation --
2551 ------------------------------------------
2553 procedure Check_Potentially_Blocking_Operation (N : Node_Id) is
2557 -- N is one of the potentially blocking operations listed in 9.5.1(8).
2558 -- When pragma Detect_Blocking is active, the run time will raise
2559 -- Program_Error. Here we only issue a warning, since we generally
2560 -- support the use of potentially blocking operations in the absence
2563 -- Indirect blocking through a subprogram call cannot be diagnosed
2564 -- statically without interprocedural analysis, so we do not attempt
2567 S := Scope (Current_Scope);
2568 while Present (S) and then S /= Standard_Standard loop
2569 if Is_Protected_Type (S) then
2571 ("potentially blocking operation in protected operation??", N);
2577 end Check_Potentially_Blocking_Operation;
2579 ---------------------------------
2580 -- Check_Result_And_Post_State --
2581 ---------------------------------
2583 procedure Check_Result_And_Post_State
2585 Result_Seen : in out Boolean)
2587 procedure Check_Expression (Expr : Node_Id);
2588 -- Perform the 'Result and post-state checks on a given expression
2590 function Is_Function_Result (N : Node_Id) return Traverse_Result;
2591 -- Attempt to find attribute 'Result in a subtree denoted by N
2593 function Is_Trivial_Boolean (N : Node_Id) return Boolean;
2594 -- Determine whether source node N denotes "True" or "False"
2596 function Mentions_Post_State (N : Node_Id) return Boolean;
2597 -- Determine whether a subtree denoted by N mentions any construct that
2598 -- denotes a post-state.
2600 procedure Check_Function_Result is
2601 new Traverse_Proc (Is_Function_Result);
2603 ----------------------
2604 -- Check_Expression --
2605 ----------------------
2607 procedure Check_Expression (Expr : Node_Id) is
2609 if not Is_Trivial_Boolean (Expr) then
2610 Check_Function_Result (Expr);
2612 if not Mentions_Post_State (Expr) then
2613 if Pragma_Name (Prag) = Name_Contract_Cases then
2615 ("contract case refers only to pre-state?T?", Expr);
2617 elsif Pragma_Name (Prag) = Name_Refined_Post then
2619 ("refined postcondition refers only to pre-state?T?",
2624 ("postcondition refers only to pre-state?T?", Prag);
2628 end Check_Expression;
2630 ------------------------
2631 -- Is_Function_Result --
2632 ------------------------
2634 function Is_Function_Result (N : Node_Id) return Traverse_Result is
2636 if Is_Attribute_Result (N) then
2637 Result_Seen := True;
2640 -- Continue the traversal
2645 end Is_Function_Result;
2647 ------------------------
2648 -- Is_Trivial_Boolean --
2649 ------------------------
2651 function Is_Trivial_Boolean (N : Node_Id) return Boolean is
2654 Comes_From_Source (N)
2655 and then Is_Entity_Name (N)
2656 and then (Entity (N) = Standard_True
2657 or else Entity (N) = Standard_False);
2658 end Is_Trivial_Boolean;
2660 -------------------------
2661 -- Mentions_Post_State --
2662 -------------------------
2664 function Mentions_Post_State (N : Node_Id) return Boolean is
2665 Post_State_Seen : Boolean := False;
2667 function Is_Post_State (N : Node_Id) return Traverse_Result;
2668 -- Attempt to find a construct that denotes a post-state. If this is
2669 -- the case, set flag Post_State_Seen.
2675 function Is_Post_State (N : Node_Id) return Traverse_Result is
2679 if Nkind_In (N, N_Explicit_Dereference, N_Function_Call) then
2680 Post_State_Seen := True;
2683 elsif Nkind_In (N, N_Expanded_Name, N_Identifier) then
2686 -- The entity may be modifiable through an implicit dereference
2689 or else Ekind (Ent) in Assignable_Kind
2690 or else (Is_Access_Type (Etype (Ent))
2691 and then Nkind (Parent (N)) = N_Selected_Component)
2693 Post_State_Seen := True;
2697 elsif Nkind (N) = N_Attribute_Reference then
2698 if Attribute_Name (N) = Name_Old then
2701 elsif Attribute_Name (N) = Name_Result then
2702 Post_State_Seen := True;
2710 procedure Find_Post_State is new Traverse_Proc (Is_Post_State);
2712 -- Start of processing for Mentions_Post_State
2715 Find_Post_State (N);
2717 return Post_State_Seen;
2718 end Mentions_Post_State;
2722 Expr : constant Node_Id :=
2723 Get_Pragma_Arg (First (Pragma_Argument_Associations (Prag)));
2724 Nam : constant Name_Id := Pragma_Name (Prag);
2727 -- Start of processing for Check_Result_And_Post_State
2730 -- Examine all consequences
2732 if Nam = Name_Contract_Cases then
2733 CCase := First (Component_Associations (Expr));
2734 while Present (CCase) loop
2735 Check_Expression (Expression (CCase));
2740 -- Examine the expression of a postcondition
2742 else pragma Assert (Nam_In (Nam, Name_Postcondition, Name_Refined_Post));
2743 Check_Expression (Expr);
2745 end Check_Result_And_Post_State;
2747 ---------------------------------
2748 -- Check_SPARK_Mode_In_Generic --
2749 ---------------------------------
2751 procedure Check_SPARK_Mode_In_Generic (N : Node_Id) is
2755 -- Try to find aspect SPARK_Mode and flag it as illegal
2757 if Has_Aspects (N) then
2758 Aspect := First (Aspect_Specifications (N));
2759 while Present (Aspect) loop
2760 if Get_Aspect_Id (Aspect) = Aspect_SPARK_Mode then
2761 Error_Msg_Name_1 := Name_SPARK_Mode;
2763 ("incorrect placement of aspect % on a generic", Aspect);
2770 end Check_SPARK_Mode_In_Generic;
2772 ------------------------------
2773 -- Check_Unprotected_Access --
2774 ------------------------------
2776 procedure Check_Unprotected_Access
2780 Cont_Encl_Typ : Entity_Id;
2781 Pref_Encl_Typ : Entity_Id;
2783 function Enclosing_Protected_Type (Obj : Node_Id) return Entity_Id;
2784 -- Check whether Obj is a private component of a protected object.
2785 -- Return the protected type where the component resides, Empty
2788 function Is_Public_Operation return Boolean;
2789 -- Verify that the enclosing operation is callable from outside the
2790 -- protected object, to minimize false positives.
2792 ------------------------------
2793 -- Enclosing_Protected_Type --
2794 ------------------------------
2796 function Enclosing_Protected_Type (Obj : Node_Id) return Entity_Id is
2798 if Is_Entity_Name (Obj) then
2800 Ent : Entity_Id := Entity (Obj);
2803 -- The object can be a renaming of a private component, use
2804 -- the original record component.
2806 if Is_Prival (Ent) then
2807 Ent := Prival_Link (Ent);
2810 if Is_Protected_Type (Scope (Ent)) then
2816 -- For indexed and selected components, recursively check the prefix
2818 if Nkind_In (Obj, N_Indexed_Component, N_Selected_Component) then
2819 return Enclosing_Protected_Type (Prefix (Obj));
2821 -- The object does not denote a protected component
2826 end Enclosing_Protected_Type;
2828 -------------------------
2829 -- Is_Public_Operation --
2830 -------------------------
2832 function Is_Public_Operation return Boolean is
2839 and then S /= Pref_Encl_Typ
2841 if Scope (S) = Pref_Encl_Typ then
2842 E := First_Entity (Pref_Encl_Typ);
2844 and then E /= First_Private_Entity (Pref_Encl_Typ)
2857 end Is_Public_Operation;
2859 -- Start of processing for Check_Unprotected_Access
2862 if Nkind (Expr) = N_Attribute_Reference
2863 and then Attribute_Name (Expr) = Name_Unchecked_Access
2865 Cont_Encl_Typ := Enclosing_Protected_Type (Context);
2866 Pref_Encl_Typ := Enclosing_Protected_Type (Prefix (Expr));
2868 -- Check whether we are trying to export a protected component to a
2869 -- context with an equal or lower access level.
2871 if Present (Pref_Encl_Typ)
2872 and then No (Cont_Encl_Typ)
2873 and then Is_Public_Operation
2874 and then Scope_Depth (Pref_Encl_Typ) >=
2875 Object_Access_Level (Context)
2878 ("??possible unprotected access to protected data", Expr);
2881 end Check_Unprotected_Access;
2887 procedure Check_VMS (Construct : Node_Id) is
2889 if not OpenVMS_On_Target then
2891 ("this construct is allowed only in Open'V'M'S", Construct);
2895 ------------------------
2896 -- Collect_Interfaces --
2897 ------------------------
2899 procedure Collect_Interfaces
2901 Ifaces_List : out Elist_Id;
2902 Exclude_Parents : Boolean := False;
2903 Use_Full_View : Boolean := True)
2905 procedure Collect (Typ : Entity_Id);
2906 -- Subsidiary subprogram used to traverse the whole list
2907 -- of directly and indirectly implemented interfaces
2913 procedure Collect (Typ : Entity_Id) is
2914 Ancestor : Entity_Id;
2922 -- Handle private types
2925 and then Is_Private_Type (Typ)
2926 and then Present (Full_View (Typ))
2928 Full_T := Full_View (Typ);
2931 -- Include the ancestor if we are generating the whole list of
2932 -- abstract interfaces.
2934 if Etype (Full_T) /= Typ
2936 -- Protect the frontend against wrong sources. For example:
2939 -- type A is tagged null record;
2940 -- type B is new A with private;
2941 -- type C is new A with private;
2943 -- type B is new C with null record;
2944 -- type C is new B with null record;
2947 and then Etype (Full_T) /= T
2949 Ancestor := Etype (Full_T);
2952 if Is_Interface (Ancestor)
2953 and then not Exclude_Parents
2955 Append_Unique_Elmt (Ancestor, Ifaces_List);
2959 -- Traverse the graph of ancestor interfaces
2961 if Is_Non_Empty_List (Abstract_Interface_List (Full_T)) then
2962 Id := First (Abstract_Interface_List (Full_T));
2963 while Present (Id) loop
2964 Iface := Etype (Id);
2966 -- Protect against wrong uses. For example:
2967 -- type I is interface;
2968 -- type O is tagged null record;
2969 -- type Wrong is new I and O with null record; -- ERROR
2971 if Is_Interface (Iface) then
2973 and then Etype (T) /= T
2974 and then Interface_Present_In_Ancestor (Etype (T), Iface)
2979 Append_Unique_Elmt (Iface, Ifaces_List);
2988 -- Start of processing for Collect_Interfaces
2991 pragma Assert (Is_Tagged_Type (T) or else Is_Concurrent_Type (T));
2992 Ifaces_List := New_Elmt_List;
2994 end Collect_Interfaces;
2996 ----------------------------------
2997 -- Collect_Interface_Components --
2998 ----------------------------------
3000 procedure Collect_Interface_Components
3001 (Tagged_Type : Entity_Id;
3002 Components_List : out Elist_Id)
3004 procedure Collect (Typ : Entity_Id);
3005 -- Subsidiary subprogram used to climb to the parents
3011 procedure Collect (Typ : Entity_Id) is
3012 Tag_Comp : Entity_Id;
3013 Parent_Typ : Entity_Id;
3016 -- Handle private types
3018 if Present (Full_View (Etype (Typ))) then
3019 Parent_Typ := Full_View (Etype (Typ));
3021 Parent_Typ := Etype (Typ);
3024 if Parent_Typ /= Typ
3026 -- Protect the frontend against wrong sources. For example:
3029 -- type A is tagged null record;
3030 -- type B is new A with private;
3031 -- type C is new A with private;
3033 -- type B is new C with null record;
3034 -- type C is new B with null record;
3037 and then Parent_Typ /= Tagged_Type
3039 Collect (Parent_Typ);
3042 -- Collect the components containing tags of secondary dispatch
3045 Tag_Comp := Next_Tag_Component (First_Tag_Component (Typ));
3046 while Present (Tag_Comp) loop
3047 pragma Assert (Present (Related_Type (Tag_Comp)));
3048 Append_Elmt (Tag_Comp, Components_List);
3050 Tag_Comp := Next_Tag_Component (Tag_Comp);
3054 -- Start of processing for Collect_Interface_Components
3057 pragma Assert (Ekind (Tagged_Type) = E_Record_Type
3058 and then Is_Tagged_Type (Tagged_Type));
3060 Components_List := New_Elmt_List;
3061 Collect (Tagged_Type);
3062 end Collect_Interface_Components;
3064 -----------------------------
3065 -- Collect_Interfaces_Info --
3066 -----------------------------
3068 procedure Collect_Interfaces_Info
3070 Ifaces_List : out Elist_Id;
3071 Components_List : out Elist_Id;
3072 Tags_List : out Elist_Id)
3074 Comps_List : Elist_Id;
3075 Comp_Elmt : Elmt_Id;
3076 Comp_Iface : Entity_Id;
3077 Iface_Elmt : Elmt_Id;
3080 function Search_Tag (Iface : Entity_Id) return Entity_Id;
3081 -- Search for the secondary tag associated with the interface type
3082 -- Iface that is implemented by T.
3088 function Search_Tag (Iface : Entity_Id) return Entity_Id is
3091 if not Is_CPP_Class (T) then
3092 ADT := Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (T))));
3094 ADT := Next_Elmt (First_Elmt (Access_Disp_Table (T)));
3098 and then Is_Tag (Node (ADT))
3099 and then Related_Type (Node (ADT)) /= Iface
3101 -- Skip secondary dispatch table referencing thunks to user
3102 -- defined primitives covered by this interface.
3104 pragma Assert (Has_Suffix (Node (ADT), 'P'));
3107 -- Skip secondary dispatch tables of Ada types
3109 if not Is_CPP_Class (T) then
3111 -- Skip secondary dispatch table referencing thunks to
3112 -- predefined primitives.
3114 pragma Assert (Has_Suffix (Node (ADT), 'Y'));
3117 -- Skip secondary dispatch table referencing user-defined
3118 -- primitives covered by this interface.
3120 pragma Assert (Has_Suffix (Node (ADT), 'D'));
3123 -- Skip secondary dispatch table referencing predefined
3126 pragma Assert (Has_Suffix (Node (ADT), 'Z'));
3131 pragma Assert (Is_Tag (Node (ADT)));
3135 -- Start of processing for Collect_Interfaces_Info
3138 Collect_Interfaces (T, Ifaces_List);
3139 Collect_Interface_Components (T, Comps_List);
3141 -- Search for the record component and tag associated with each
3142 -- interface type of T.
3144 Components_List := New_Elmt_List;
3145 Tags_List := New_Elmt_List;
3147 Iface_Elmt := First_Elmt (Ifaces_List);
3148 while Present (Iface_Elmt) loop
3149 Iface := Node (Iface_Elmt);
3151 -- Associate the primary tag component and the primary dispatch table
3152 -- with all the interfaces that are parents of T
3154 if Is_Ancestor (Iface, T, Use_Full_View => True) then
3155 Append_Elmt (First_Tag_Component (T), Components_List);
3156 Append_Elmt (Node (First_Elmt (Access_Disp_Table (T))), Tags_List);
3158 -- Otherwise search for the tag component and secondary dispatch
3162 Comp_Elmt := First_Elmt (Comps_List);
3163 while Present (Comp_Elmt) loop
3164 Comp_Iface := Related_Type (Node (Comp_Elmt));
3166 if Comp_Iface = Iface
3167 or else Is_Ancestor (Iface, Comp_Iface, Use_Full_View => True)
3169 Append_Elmt (Node (Comp_Elmt), Components_List);
3170 Append_Elmt (Search_Tag (Comp_Iface), Tags_List);
3174 Next_Elmt (Comp_Elmt);
3176 pragma Assert (Present (Comp_Elmt));
3179 Next_Elmt (Iface_Elmt);
3181 end Collect_Interfaces_Info;
3183 ---------------------
3184 -- Collect_Parents --
3185 ---------------------
3187 procedure Collect_Parents
3189 List : out Elist_Id;
3190 Use_Full_View : Boolean := True)
3192 Current_Typ : Entity_Id := T;
3193 Parent_Typ : Entity_Id;
3196 List := New_Elmt_List;
3198 -- No action if the if the type has no parents
3200 if T = Etype (T) then
3205 Parent_Typ := Etype (Current_Typ);
3207 if Is_Private_Type (Parent_Typ)
3208 and then Present (Full_View (Parent_Typ))
3209 and then Use_Full_View
3211 Parent_Typ := Full_View (Base_Type (Parent_Typ));
3214 Append_Elmt (Parent_Typ, List);
3216 exit when Parent_Typ = Current_Typ;
3217 Current_Typ := Parent_Typ;
3219 end Collect_Parents;
3221 ----------------------------------
3222 -- Collect_Primitive_Operations --
3223 ----------------------------------
3225 function Collect_Primitive_Operations (T : Entity_Id) return Elist_Id is
3226 B_Type : constant Entity_Id := Base_Type (T);
3227 B_Decl : constant Node_Id := Original_Node (Parent (B_Type));
3228 B_Scope : Entity_Id := Scope (B_Type);
3232 Is_Type_In_Pkg : Boolean;
3233 Formal_Derived : Boolean := False;
3236 function Match (E : Entity_Id) return Boolean;
3237 -- True if E's base type is B_Type, or E is of an anonymous access type
3238 -- and the base type of its designated type is B_Type.
3244 function Match (E : Entity_Id) return Boolean is
3245 Etyp : Entity_Id := Etype (E);
3248 if Ekind (Etyp) = E_Anonymous_Access_Type then
3249 Etyp := Designated_Type (Etyp);
3252 return Base_Type (Etyp) = B_Type;
3255 -- Start of processing for Collect_Primitive_Operations
3258 -- For tagged types, the primitive operations are collected as they
3259 -- are declared, and held in an explicit list which is simply returned.
3261 if Is_Tagged_Type (B_Type) then
3262 return Primitive_Operations (B_Type);
3264 -- An untagged generic type that is a derived type inherits the
3265 -- primitive operations of its parent type. Other formal types only
3266 -- have predefined operators, which are not explicitly represented.
3268 elsif Is_Generic_Type (B_Type) then
3269 if Nkind (B_Decl) = N_Formal_Type_Declaration
3270 and then Nkind (Formal_Type_Definition (B_Decl))
3271 = N_Formal_Derived_Type_Definition
3273 Formal_Derived := True;
3275 return New_Elmt_List;
3279 Op_List := New_Elmt_List;
3281 if B_Scope = Standard_Standard then
3282 if B_Type = Standard_String then
3283 Append_Elmt (Standard_Op_Concat, Op_List);
3285 elsif B_Type = Standard_Wide_String then
3286 Append_Elmt (Standard_Op_Concatw, Op_List);
3292 -- Locate the primitive subprograms of the type
3295 -- The primitive operations appear after the base type, except
3296 -- if the derivation happens within the private part of B_Scope
3297 -- and the type is a private type, in which case both the type
3298 -- and some primitive operations may appear before the base
3299 -- type, and the list of candidates starts after the type.
3301 if In_Open_Scopes (B_Scope)
3302 and then Scope (T) = B_Scope
3303 and then In_Private_Part (B_Scope)
3305 Id := Next_Entity (T);
3307 Id := Next_Entity (B_Type);
3310 -- Set flag if this is a type in a package spec
3313 Is_Package_Or_Generic_Package (B_Scope)
3315 Nkind (Parent (Declaration_Node (First_Subtype (T)))) /=
3318 while Present (Id) loop
3320 -- Test whether the result type or any of the parameter types of
3321 -- each subprogram following the type match that type when the
3322 -- type is declared in a package spec, is a derived type, or the
3323 -- subprogram is marked as primitive. (The Is_Primitive test is
3324 -- needed to find primitives of nonderived types in declarative
3325 -- parts that happen to override the predefined "=" operator.)
3327 -- Note that generic formal subprograms are not considered to be
3328 -- primitive operations and thus are never inherited.
3330 if Is_Overloadable (Id)
3331 and then (Is_Type_In_Pkg
3332 or else Is_Derived_Type (B_Type)
3333 or else Is_Primitive (Id))
3334 and then Nkind (Parent (Parent (Id)))
3335 not in N_Formal_Subprogram_Declaration
3343 Formal := First_Formal (Id);
3344 while Present (Formal) loop
3345 if Match (Formal) then
3350 Next_Formal (Formal);
3354 -- For a formal derived type, the only primitives are the ones
3355 -- inherited from the parent type. Operations appearing in the
3356 -- package declaration are not primitive for it.
3359 and then (not Formal_Derived
3360 or else Present (Alias (Id)))
3362 -- In the special case of an equality operator aliased to
3363 -- an overriding dispatching equality belonging to the same
3364 -- type, we don't include it in the list of primitives.
3365 -- This avoids inheriting multiple equality operators when
3366 -- deriving from untagged private types whose full type is
3367 -- tagged, which can otherwise cause ambiguities. Note that
3368 -- this should only happen for this kind of untagged parent
3369 -- type, since normally dispatching operations are inherited
3370 -- using the type's Primitive_Operations list.
3372 if Chars (Id) = Name_Op_Eq
3373 and then Is_Dispatching_Operation (Id)
3374 and then Present (Alias (Id))
3375 and then Present (Overridden_Operation (Alias (Id)))
3376 and then Base_Type (Etype (First_Entity (Id))) =
3377 Base_Type (Etype (First_Entity (Alias (Id))))
3381 -- Include the subprogram in the list of primitives
3384 Append_Elmt (Id, Op_List);
3391 -- For a type declared in System, some of its operations may
3392 -- appear in the target-specific extension to System.
3395 and then B_Scope = RTU_Entity (System)
3396 and then Present_System_Aux
3398 B_Scope := System_Aux_Id;
3399 Id := First_Entity (System_Aux_Id);
3405 end Collect_Primitive_Operations;
3407 -----------------------------------
3408 -- Compile_Time_Constraint_Error --
3409 -----------------------------------
3411 function Compile_Time_Constraint_Error
3414 Ent : Entity_Id := Empty;
3415 Loc : Source_Ptr := No_Location;
3416 Warn : Boolean := False) return Node_Id
3418 Msgc : String (1 .. Msg'Length + 3);
3419 -- Copy of message, with room for possible ?? or << and ! at end
3429 -- If this is a warning, convert it into an error if we are in code
3430 -- subject to SPARK_Mode being set ON.
3432 Error_Msg_Warn := SPARK_Mode /= On;
3434 -- A static constraint error in an instance body is not a fatal error.
3435 -- we choose to inhibit the message altogether, because there is no
3436 -- obvious node (for now) on which to post it. On the other hand the
3437 -- offending node must be replaced with a constraint_error in any case.
3439 -- No messages are generated if we already posted an error on this node
3441 if not Error_Posted (N) then
3442 if Loc /= No_Location then
3448 -- Copy message to Msgc, converting any ? in the message into
3449 -- < instead, so that we have an error in GNATprove mode.
3453 for J in 1 .. Msgl loop
3454 if Msg (J) = '?' and then (J = 1 or else Msg (J) /= ''') then
3457 Msgc (J) := Msg (J);
3461 -- Message is a warning, even in Ada 95 case
3463 if Msg (Msg'Last) = '?' or else Msg (Msg'Last) = '<' then
3466 -- In Ada 83, all messages are warnings. In the private part and
3467 -- the body of an instance, constraint_checks are only warnings.
3468 -- We also make this a warning if the Warn parameter is set.
3471 or else (Ada_Version = Ada_83 and then Comes_From_Source (N))
3479 elsif In_Instance_Not_Visible then
3486 -- Otherwise we have a real error message (Ada 95 static case)
3487 -- and we make this an unconditional message. Note that in the
3488 -- warning case we do not make the message unconditional, it seems
3489 -- quite reasonable to delete messages like this (about exceptions
3490 -- that will be raised) in dead code.
3498 -- Should we generate a warning? The answer is not quite yes. The
3499 -- very annoying exception occurs in the case of a short circuit
3500 -- operator where the left operand is static and decisive. Climb
3501 -- parents to see if that is the case we have here. Conditional
3502 -- expressions with decisive conditions are a similar situation.
3510 -- And then with False as left operand
3512 if Nkind (P) = N_And_Then
3513 and then Compile_Time_Known_Value (Left_Opnd (P))
3514 and then Is_False (Expr_Value (Left_Opnd (P)))
3519 -- OR ELSE with True as left operand
3521 elsif Nkind (P) = N_Or_Else
3522 and then Compile_Time_Known_Value (Left_Opnd (P))
3523 and then Is_True (Expr_Value (Left_Opnd (P)))
3530 elsif Nkind (P) = N_If_Expression then
3532 Cond : constant Node_Id := First (Expressions (P));
3533 Texp : constant Node_Id := Next (Cond);
3534 Fexp : constant Node_Id := Next (Texp);
3537 if Compile_Time_Known_Value (Cond) then
3539 -- Condition is True and we are in the right operand
3541 if Is_True (Expr_Value (Cond))
3542 and then OldP = Fexp
3547 -- Condition is False and we are in the left operand
3549 elsif Is_False (Expr_Value (Cond))
3550 and then OldP = Texp
3558 -- Special case for component association in aggregates, where
3559 -- we want to keep climbing up to the parent aggregate.
3561 elsif Nkind (P) = N_Component_Association
3562 and then Nkind (Parent (P)) = N_Aggregate
3566 -- Keep going if within subexpression
3569 exit when Nkind (P) not in N_Subexpr;
3574 Error_Msg_Warn := SPARK_Mode /= On;
3576 if Present (Ent) then
3577 Error_Msg_NEL (Msgc (1 .. Msgl), N, Ent, Eloc);
3579 Error_Msg_NEL (Msgc (1 .. Msgl), N, Etype (N), Eloc);
3584 -- Check whether the context is an Init_Proc
3586 if Inside_Init_Proc then
3588 Conc_Typ : constant Entity_Id :=
3589 Corresponding_Concurrent_Type
3590 (Entity (Parameter_Type (First
3591 (Parameter_Specifications
3592 (Parent (Current_Scope))))));
3595 -- Don't complain if the corresponding concurrent type
3596 -- doesn't come from source (i.e. a single task/protected
3599 if Present (Conc_Typ)
3600 and then not Comes_From_Source (Conc_Typ)
3603 ("\& [<<", N, Standard_Constraint_Error, Eloc);
3606 if GNATprove_Mode then
3608 ("\& would have been raised for objects of this "
3609 & "type", N, Standard_Constraint_Error, Eloc);
3612 ("\& will be raised for objects of this type??",
3613 N, Standard_Constraint_Error, Eloc);
3619 Error_Msg_NEL ("\& [<<", N, Standard_Constraint_Error, Eloc);
3623 Error_Msg ("\static expression fails Constraint_Check", Eloc);
3624 Set_Error_Posted (N);
3630 end Compile_Time_Constraint_Error;
3632 -----------------------
3633 -- Conditional_Delay --
3634 -----------------------
3636 procedure Conditional_Delay (New_Ent, Old_Ent : Entity_Id) is
3638 if Has_Delayed_Freeze (Old_Ent) and then not Is_Frozen (Old_Ent) then
3639 Set_Has_Delayed_Freeze (New_Ent);
3641 end Conditional_Delay;
3643 ----------------------------
3644 -- Contains_Refined_State --
3645 ----------------------------
3647 function Contains_Refined_State (Prag : Node_Id) return Boolean is
3648 function Has_State_In_Dependency (List : Node_Id) return Boolean;
3649 -- Determine whether a dependency list mentions a state with a visible
3652 function Has_State_In_Global (List : Node_Id) return Boolean;
3653 -- Determine whether a global list mentions a state with a visible
3656 function Is_Refined_State (Item : Node_Id) return Boolean;
3657 -- Determine whether Item is a reference to an abstract state with a
3658 -- visible refinement.
3660 -----------------------------
3661 -- Has_State_In_Dependency --
3662 -----------------------------
3664 function Has_State_In_Dependency (List : Node_Id) return Boolean is
3669 -- A null dependency list does not mention any states
3671 if Nkind (List) = N_Null then
3674 -- Dependency clauses appear as component associations of an
3677 elsif Nkind (List) = N_Aggregate
3678 and then Present (Component_Associations (List))
3680 Clause := First (Component_Associations (List));
3681 while Present (Clause) loop
3683 -- Inspect the outputs of a dependency clause
3685 Output := First (Choices (Clause));
3686 while Present (Output) loop
3687 if Is_Refined_State (Output) then
3694 -- Inspect the outputs of a dependency clause
3696 if Is_Refined_State (Expression (Clause)) then
3703 -- If we get here, then none of the dependency clauses mention a
3704 -- state with visible refinement.
3708 -- An illegal pragma managed to sneak in
3711 raise Program_Error;
3713 end Has_State_In_Dependency;
3715 -------------------------
3716 -- Has_State_In_Global --
3717 -------------------------
3719 function Has_State_In_Global (List : Node_Id) return Boolean is
3723 -- A null global list does not mention any states
3725 if Nkind (List) = N_Null then
3728 -- Simple global list or moded global list declaration
3730 elsif Nkind (List) = N_Aggregate then
3732 -- The declaration of a simple global list appear as a collection
3735 if Present (Expressions (List)) then
3736 Item := First (Expressions (List));
3737 while Present (Item) loop
3738 if Is_Refined_State (Item) then
3745 -- The declaration of a moded global list appears as a collection
3746 -- of component associations where individual choices denote
3750 Item := First (Component_Associations (List));
3751 while Present (Item) loop
3752 if Has_State_In_Global (Expression (Item)) then
3760 -- If we get here, then the simple/moded global list did not
3761 -- mention any states with a visible refinement.
3765 -- Single global item declaration
3767 elsif Is_Entity_Name (List) then
3768 return Is_Refined_State (List);
3770 -- An illegal pragma managed to sneak in
3773 raise Program_Error;
3775 end Has_State_In_Global;
3777 ----------------------
3778 -- Is_Refined_State --
3779 ----------------------
3781 function Is_Refined_State (Item : Node_Id) return Boolean is
3783 Item_Id : Entity_Id;
3786 if Nkind (Item) = N_Null then
3789 -- States cannot be subject to attribute 'Result. This case arises
3790 -- in dependency relations.
3792 elsif Nkind (Item) = N_Attribute_Reference
3793 and then Attribute_Name (Item) = Name_Result
3797 -- Multiple items appear as an aggregate. This case arises in
3798 -- dependency relations.
3800 elsif Nkind (Item) = N_Aggregate
3801 and then Present (Expressions (Item))
3803 Elmt := First (Expressions (Item));
3804 while Present (Elmt) loop
3805 if Is_Refined_State (Elmt) then
3812 -- If we get here, then none of the inputs or outputs reference a
3813 -- state with visible refinement.
3820 Item_Id := Entity_Of (Item);
3824 and then Ekind (Item_Id) = E_Abstract_State
3825 and then Has_Visible_Refinement (Item_Id);
3827 end Is_Refined_State;
3831 Arg : constant Node_Id :=
3832 Get_Pragma_Arg (First (Pragma_Argument_Associations (Prag)));
3833 Nam : constant Name_Id := Pragma_Name (Prag);
3835 -- Start of processing for Contains_Refined_State
3838 if Nam = Name_Depends then
3839 return Has_State_In_Dependency (Arg);
3841 else pragma Assert (Nam = Name_Global);
3842 return Has_State_In_Global (Arg);
3844 end Contains_Refined_State;
3846 -------------------------
3847 -- Copy_Component_List --
3848 -------------------------
3850 function Copy_Component_List
3852 Loc : Source_Ptr) return List_Id
3855 Comps : constant List_Id := New_List;
3858 Comp := First_Component (Underlying_Type (R_Typ));
3859 while Present (Comp) loop
3860 if Comes_From_Source (Comp) then
3862 Comp_Decl : constant Node_Id := Declaration_Node (Comp);
3865 Make_Component_Declaration (Loc,
3866 Defining_Identifier =>
3867 Make_Defining_Identifier (Loc, Chars (Comp)),
3868 Component_Definition =>
3870 (Component_Definition (Comp_Decl), New_Sloc => Loc)));
3874 Next_Component (Comp);
3878 end Copy_Component_List;
3880 -------------------------
3881 -- Copy_Parameter_List --
3882 -------------------------
3884 function Copy_Parameter_List (Subp_Id : Entity_Id) return List_Id is
3885 Loc : constant Source_Ptr := Sloc (Subp_Id);
3890 if No (First_Formal (Subp_Id)) then
3894 Formal := First_Formal (Subp_Id);
3895 while Present (Formal) loop
3897 (Make_Parameter_Specification (Loc,
3898 Defining_Identifier =>
3899 Make_Defining_Identifier (Sloc (Formal),
3900 Chars => Chars (Formal)),
3901 In_Present => In_Present (Parent (Formal)),
3902 Out_Present => Out_Present (Parent (Formal)),
3904 New_Occurrence_Of (Etype (Formal), Loc),
3906 New_Copy_Tree (Expression (Parent (Formal)))),
3909 Next_Formal (Formal);
3914 end Copy_Parameter_List;
3916 --------------------------------
3917 -- Corresponding_Generic_Type --
3918 --------------------------------
3920 function Corresponding_Generic_Type (T : Entity_Id) return Entity_Id is
3926 if not Is_Generic_Actual_Type (T) then
3929 -- If the actual is the actual of an enclosing instance, resolution
3930 -- was correct in the generic.
3932 elsif Nkind (Parent (T)) = N_Subtype_Declaration
3933 and then Is_Entity_Name (Subtype_Indication (Parent (T)))
3935 Is_Generic_Actual_Type (Entity (Subtype_Indication (Parent (T))))
3942 if Is_Wrapper_Package (Inst) then
3943 Inst := Related_Instance (Inst);
3948 (Specification (Unit_Declaration_Node (Inst)));
3950 -- Generic actual has the same name as the corresponding formal
3952 Typ := First_Entity (Gen);
3953 while Present (Typ) loop
3954 if Chars (Typ) = Chars (T) then
3963 end Corresponding_Generic_Type;
3965 --------------------
3966 -- Current_Entity --
3967 --------------------
3969 -- The currently visible definition for a given identifier is the
3970 -- one most chained at the start of the visibility chain, i.e. the
3971 -- one that is referenced by the Node_Id value of the name of the
3972 -- given identifier.
3974 function Current_Entity (N : Node_Id) return Entity_Id is
3976 return Get_Name_Entity_Id (Chars (N));
3979 -----------------------------
3980 -- Current_Entity_In_Scope --
3981 -----------------------------
3983 function Current_Entity_In_Scope (N : Node_Id) return Entity_Id is
3985 CS : constant Entity_Id := Current_Scope;
3987 Transient_Case : constant Boolean := Scope_Is_Transient;
3990 E := Get_Name_Entity_Id (Chars (N));
3992 and then Scope (E) /= CS
3993 and then (not Transient_Case or else Scope (E) /= Scope (CS))
3999 end Current_Entity_In_Scope;
4005 function Current_Scope return Entity_Id is
4007 if Scope_Stack.Last = -1 then
4008 return Standard_Standard;
4011 C : constant Entity_Id :=
4012 Scope_Stack.Table (Scope_Stack.Last).Entity;
4017 return Standard_Standard;
4023 ------------------------
4024 -- Current_Subprogram --
4025 ------------------------
4027 function Current_Subprogram return Entity_Id is
4028 Scop : constant Entity_Id := Current_Scope;
4030 if Is_Subprogram (Scop) or else Is_Generic_Subprogram (Scop) then
4033 return Enclosing_Subprogram (Scop);
4035 end Current_Subprogram;
4037 ----------------------------------
4038 -- Deepest_Type_Access_Level --
4039 ----------------------------------
4041 function Deepest_Type_Access_Level (Typ : Entity_Id) return Uint is
4043 if Ekind (Typ) = E_Anonymous_Access_Type
4044 and then not Is_Local_Anonymous_Access (Typ)
4045 and then Nkind (Associated_Node_For_Itype (Typ)) = N_Object_Declaration
4047 -- Typ is the type of an Ada 2012 stand-alone object of an anonymous
4051 Scope_Depth (Enclosing_Dynamic_Scope
4052 (Defining_Identifier
4053 (Associated_Node_For_Itype (Typ))));
4055 -- For generic formal type, return Int'Last (infinite).
4056 -- See comment preceding Is_Generic_Type call in Type_Access_Level.
4058 elsif Is_Generic_Type (Root_Type (Typ)) then
4059 return UI_From_Int (Int'Last);
4062 return Type_Access_Level (Typ);
4064 end Deepest_Type_Access_Level;
4066 ---------------------
4067 -- Defining_Entity --
4068 ---------------------
4070 function Defining_Entity (N : Node_Id) return Entity_Id is
4071 K : constant Node_Kind := Nkind (N);
4072 Err : Entity_Id := Empty;
4077 N_Subprogram_Declaration |
4078 N_Abstract_Subprogram_Declaration |
4080 N_Package_Declaration |
4081 N_Subprogram_Renaming_Declaration |
4082 N_Subprogram_Body_Stub |
4083 N_Generic_Subprogram_Declaration |
4084 N_Generic_Package_Declaration |
4085 N_Formal_Subprogram_Declaration |
4086 N_Expression_Function
4088 return Defining_Entity (Specification (N));
4091 N_Component_Declaration |
4092 N_Defining_Program_Unit_Name |
4093 N_Discriminant_Specification |
4095 N_Entry_Declaration |
4096 N_Entry_Index_Specification |
4097 N_Exception_Declaration |
4098 N_Exception_Renaming_Declaration |
4099 N_Formal_Object_Declaration |
4100 N_Formal_Package_Declaration |
4101 N_Formal_Type_Declaration |
4102 N_Full_Type_Declaration |
4103 N_Implicit_Label_Declaration |
4104 N_Incomplete_Type_Declaration |
4105 N_Loop_Parameter_Specification |
4106 N_Number_Declaration |
4107 N_Object_Declaration |
4108 N_Object_Renaming_Declaration |
4109 N_Package_Body_Stub |
4110 N_Parameter_Specification |
4111 N_Private_Extension_Declaration |
4112 N_Private_Type_Declaration |
4114 N_Protected_Body_Stub |
4115 N_Protected_Type_Declaration |
4116 N_Single_Protected_Declaration |
4117 N_Single_Task_Declaration |
4118 N_Subtype_Declaration |
4121 N_Task_Type_Declaration
4123 return Defining_Identifier (N);
4126 return Defining_Entity (Proper_Body (N));
4129 N_Function_Instantiation |
4130 N_Function_Specification |
4131 N_Generic_Function_Renaming_Declaration |
4132 N_Generic_Package_Renaming_Declaration |
4133 N_Generic_Procedure_Renaming_Declaration |
4135 N_Package_Instantiation |
4136 N_Package_Renaming_Declaration |
4137 N_Package_Specification |
4138 N_Procedure_Instantiation |
4139 N_Procedure_Specification
4142 Nam : constant Node_Id := Defining_Unit_Name (N);
4145 if Nkind (Nam) in N_Entity then
4148 -- For Error, make up a name and attach to declaration
4149 -- so we can continue semantic analysis
4151 elsif Nam = Error then
4152 Err := Make_Temporary (Sloc (N), 'T');
4153 Set_Defining_Unit_Name (N, Err);
4157 -- If not an entity, get defining identifier
4160 return Defining_Identifier (Nam);
4164 when N_Block_Statement =>
4165 return Entity (Identifier (N));
4168 raise Program_Error;
4171 end Defining_Entity;
4173 --------------------------
4174 -- Denotes_Discriminant --
4175 --------------------------
4177 function Denotes_Discriminant
4179 Check_Concurrent : Boolean := False) return Boolean
4183 if not Is_Entity_Name (N)
4184 or else No (Entity (N))
4191 -- If we are checking for a protected type, the discriminant may have
4192 -- been rewritten as the corresponding discriminal of the original type
4193 -- or of the corresponding concurrent record, depending on whether we
4194 -- are in the spec or body of the protected type.
4196 return Ekind (E) = E_Discriminant
4199 and then Ekind (E) = E_In_Parameter
4200 and then Present (Discriminal_Link (E))
4202 (Is_Concurrent_Type (Scope (Discriminal_Link (E)))
4204 Is_Concurrent_Record_Type (Scope (Discriminal_Link (E)))));
4206 end Denotes_Discriminant;
4208 -------------------------
4209 -- Denotes_Same_Object --
4210 -------------------------
4212 function Denotes_Same_Object (A1, A2 : Node_Id) return Boolean is
4213 Obj1 : Node_Id := A1;
4214 Obj2 : Node_Id := A2;
4216 function Has_Prefix (N : Node_Id) return Boolean;
4217 -- Return True if N has attribute Prefix
4219 function Is_Renaming (N : Node_Id) return Boolean;
4220 -- Return true if N names a renaming entity
4222 function Is_Valid_Renaming (N : Node_Id) return Boolean;
4223 -- For renamings, return False if the prefix of any dereference within
4224 -- the renamed object_name is a variable, or any expression within the
4225 -- renamed object_name contains references to variables or calls on
4226 -- nonstatic functions; otherwise return True (RM 6.4.1(6.10/3))
4232 function Has_Prefix (N : Node_Id) return Boolean is
4236 N_Attribute_Reference,
4238 N_Explicit_Dereference,
4239 N_Indexed_Component,
4241 N_Selected_Component,
4249 function Is_Renaming (N : Node_Id) return Boolean is
4251 return Is_Entity_Name (N)
4252 and then Present (Renamed_Entity (Entity (N)));
4255 -----------------------
4256 -- Is_Valid_Renaming --
4257 -----------------------
4259 function Is_Valid_Renaming (N : Node_Id) return Boolean is
4261 function Check_Renaming (N : Node_Id) return Boolean;
4262 -- Recursive function used to traverse all the prefixes of N
4264 function Check_Renaming (N : Node_Id) return Boolean is
4267 and then not Check_Renaming (Renamed_Entity (Entity (N)))
4272 if Nkind (N) = N_Indexed_Component then
4277 Indx := First (Expressions (N));
4278 while Present (Indx) loop
4279 if not Is_OK_Static_Expression (Indx) then
4288 if Has_Prefix (N) then
4290 P : constant Node_Id := Prefix (N);
4293 if Nkind (N) = N_Explicit_Dereference
4294 and then Is_Variable (P)
4298 elsif Is_Entity_Name (P)
4299 and then Ekind (Entity (P)) = E_Function
4303 elsif Nkind (P) = N_Function_Call then
4307 -- Recursion to continue traversing the prefix of the
4308 -- renaming expression
4310 return Check_Renaming (P);
4317 -- Start of processing for Is_Valid_Renaming
4320 return Check_Renaming (N);
4321 end Is_Valid_Renaming;
4323 -- Start of processing for Denotes_Same_Object
4326 -- Both names statically denote the same stand-alone object or parameter
4327 -- (RM 6.4.1(6.5/3))
4329 if Is_Entity_Name (Obj1)
4330 and then Is_Entity_Name (Obj2)
4331 and then Entity (Obj1) = Entity (Obj2)
4336 -- For renamings, the prefix of any dereference within the renamed
4337 -- object_name is not a variable, and any expression within the
4338 -- renamed object_name contains no references to variables nor
4339 -- calls on nonstatic functions (RM 6.4.1(6.10/3)).
4341 if Is_Renaming (Obj1) then
4342 if Is_Valid_Renaming (Obj1) then
4343 Obj1 := Renamed_Entity (Entity (Obj1));
4349 if Is_Renaming (Obj2) then
4350 if Is_Valid_Renaming (Obj2) then
4351 Obj2 := Renamed_Entity (Entity (Obj2));
4357 -- No match if not same node kind (such cases are handled by
4358 -- Denotes_Same_Prefix)
4360 if Nkind (Obj1) /= Nkind (Obj2) then
4363 -- After handling valid renamings, one of the two names statically
4364 -- denoted a renaming declaration whose renamed object_name is known
4365 -- to denote the same object as the other (RM 6.4.1(6.10/3))
4367 elsif Is_Entity_Name (Obj1) then
4368 if Is_Entity_Name (Obj2) then
4369 return Entity (Obj1) = Entity (Obj2);
4374 -- Both names are selected_components, their prefixes are known to
4375 -- denote the same object, and their selector_names denote the same
4376 -- component (RM 6.4.1(6.6/3)
4378 elsif Nkind (Obj1) = N_Selected_Component then
4379 return Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2))
4381 Entity (Selector_Name (Obj1)) = Entity (Selector_Name (Obj2));
4383 -- Both names are dereferences and the dereferenced names are known to
4384 -- denote the same object (RM 6.4.1(6.7/3))
4386 elsif Nkind (Obj1) = N_Explicit_Dereference then
4387 return Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2));
4389 -- Both names are indexed_components, their prefixes are known to denote
4390 -- the same object, and each of the pairs of corresponding index values
4391 -- are either both static expressions with the same static value or both
4392 -- names that are known to denote the same object (RM 6.4.1(6.8/3))
4394 elsif Nkind (Obj1) = N_Indexed_Component then
4395 if not Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2)) then
4403 Indx1 := First (Expressions (Obj1));
4404 Indx2 := First (Expressions (Obj2));
4405 while Present (Indx1) loop
4407 -- Indexes must denote the same static value or same object
4409 if Is_OK_Static_Expression (Indx1) then
4410 if not Is_OK_Static_Expression (Indx2) then
4413 elsif Expr_Value (Indx1) /= Expr_Value (Indx2) then
4417 elsif not Denotes_Same_Object (Indx1, Indx2) then
4429 -- Both names are slices, their prefixes are known to denote the same
4430 -- object, and the two slices have statically matching index constraints
4431 -- (RM 6.4.1(6.9/3))
4433 elsif Nkind (Obj1) = N_Slice
4434 and then Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2))
4437 Lo1, Lo2, Hi1, Hi2 : Node_Id;
4440 Get_Index_Bounds (Etype (Obj1), Lo1, Hi1);
4441 Get_Index_Bounds (Etype (Obj2), Lo2, Hi2);
4443 -- Check whether bounds are statically identical. There is no
4444 -- attempt to detect partial overlap of slices.
4446 return Denotes_Same_Object (Lo1, Lo2)
4447 and then Denotes_Same_Object (Hi1, Hi2);
4450 -- In the recursion, literals appear as indexes.
4452 elsif Nkind (Obj1) = N_Integer_Literal
4453 and then Nkind (Obj2) = N_Integer_Literal
4455 return Intval (Obj1) = Intval (Obj2);
4460 end Denotes_Same_Object;
4462 -------------------------
4463 -- Denotes_Same_Prefix --
4464 -------------------------
4466 function Denotes_Same_Prefix (A1, A2 : Node_Id) return Boolean is
4469 if Is_Entity_Name (A1) then
4470 if Nkind_In (A2, N_Selected_Component, N_Indexed_Component)
4471 and then not Is_Access_Type (Etype (A1))
4473 return Denotes_Same_Object (A1, Prefix (A2))
4474 or else Denotes_Same_Prefix (A1, Prefix (A2));
4479 elsif Is_Entity_Name (A2) then
4480 return Denotes_Same_Prefix (A1 => A2, A2 => A1);
4482 elsif Nkind_In (A1, N_Selected_Component, N_Indexed_Component, N_Slice)
4484 Nkind_In (A2, N_Selected_Component, N_Indexed_Component, N_Slice)
4487 Root1, Root2 : Node_Id;
4488 Depth1, Depth2 : Int := 0;
4491 Root1 := Prefix (A1);
4492 while not Is_Entity_Name (Root1) loop
4494 (Root1, N_Selected_Component, N_Indexed_Component)
4498 Root1 := Prefix (Root1);
4501 Depth1 := Depth1 + 1;
4504 Root2 := Prefix (A2);
4505 while not Is_Entity_Name (Root2) loop
4507 (Root2, N_Selected_Component, N_Indexed_Component)
4511 Root2 := Prefix (Root2);
4514 Depth2 := Depth2 + 1;
4517 -- If both have the same depth and they do not denote the same
4518 -- object, they are disjoint and no warning is needed.
4520 if Depth1 = Depth2 then
4523 elsif Depth1 > Depth2 then
4524 Root1 := Prefix (A1);
4525 for I in 1 .. Depth1 - Depth2 - 1 loop
4526 Root1 := Prefix (Root1);
4529 return Denotes_Same_Object (Root1, A2);
4532 Root2 := Prefix (A2);
4533 for I in 1 .. Depth2 - Depth1 - 1 loop
4534 Root2 := Prefix (Root2);
4537 return Denotes_Same_Object (A1, Root2);
4544 end Denotes_Same_Prefix;
4546 ----------------------
4547 -- Denotes_Variable --
4548 ----------------------
4550 function Denotes_Variable (N : Node_Id) return Boolean is
4552 return Is_Variable (N) and then Paren_Count (N) = 0;
4553 end Denotes_Variable;
4555 -----------------------------
4556 -- Depends_On_Discriminant --
4557 -----------------------------
4559 function Depends_On_Discriminant (N : Node_Id) return Boolean is
4564 Get_Index_Bounds (N, L, H);
4565 return Denotes_Discriminant (L) or else Denotes_Discriminant (H);
4566 end Depends_On_Discriminant;
4568 -------------------------
4569 -- Designate_Same_Unit --
4570 -------------------------
4572 function Designate_Same_Unit
4574 Name2 : Node_Id) return Boolean
4576 K1 : constant Node_Kind := Nkind (Name1);
4577 K2 : constant Node_Kind := Nkind (Name2);
4579 function Prefix_Node (N : Node_Id) return Node_Id;
4580 -- Returns the parent unit name node of a defining program unit name
4581 -- or the prefix if N is a selected component or an expanded name.
4583 function Select_Node (N : Node_Id) return Node_Id;
4584 -- Returns the defining identifier node of a defining program unit
4585 -- name or the selector node if N is a selected component or an
4592 function Prefix_Node (N : Node_Id) return Node_Id is
4594 if Nkind (N) = N_Defining_Program_Unit_Name then
4606 function Select_Node (N : Node_Id) return Node_Id is
4608 if Nkind (N) = N_Defining_Program_Unit_Name then
4609 return Defining_Identifier (N);
4612 return Selector_Name (N);
4616 -- Start of processing for Designate_Next_Unit
4619 if (K1 = N_Identifier or else
4620 K1 = N_Defining_Identifier)
4622 (K2 = N_Identifier or else
4623 K2 = N_Defining_Identifier)
4625 return Chars (Name1) = Chars (Name2);
4628 (K1 = N_Expanded_Name or else
4629 K1 = N_Selected_Component or else
4630 K1 = N_Defining_Program_Unit_Name)
4632 (K2 = N_Expanded_Name or else
4633 K2 = N_Selected_Component or else
4634 K2 = N_Defining_Program_Unit_Name)
4637 (Chars (Select_Node (Name1)) = Chars (Select_Node (Name2)))
4639 Designate_Same_Unit (Prefix_Node (Name1), Prefix_Node (Name2));
4644 end Designate_Same_Unit;
4646 ------------------------------------------
4647 -- function Dynamic_Accessibility_Level --
4648 ------------------------------------------
4650 function Dynamic_Accessibility_Level (Expr : Node_Id) return Node_Id is
4652 Loc : constant Source_Ptr := Sloc (Expr);
4654 function Make_Level_Literal (Level : Uint) return Node_Id;
4655 -- Construct an integer literal representing an accessibility level
4656 -- with its type set to Natural.
4658 ------------------------
4659 -- Make_Level_Literal --
4660 ------------------------
4662 function Make_Level_Literal (Level : Uint) return Node_Id is
4663 Result : constant Node_Id := Make_Integer_Literal (Loc, Level);
4665 Set_Etype (Result, Standard_Natural);
4667 end Make_Level_Literal;
4669 -- Start of processing for Dynamic_Accessibility_Level
4672 if Is_Entity_Name (Expr) then
4675 if Present (Renamed_Object (E)) then
4676 return Dynamic_Accessibility_Level (Renamed_Object (E));
4679 if Is_Formal (E) or else Ekind_In (E, E_Variable, E_Constant) then
4680 if Present (Extra_Accessibility (E)) then
4681 return New_Occurrence_Of (Extra_Accessibility (E), Loc);
4686 -- Unimplemented: Ptr.all'Access, where Ptr has Extra_Accessibility ???
4688 case Nkind (Expr) is
4690 -- For access discriminant, the level of the enclosing object
4692 when N_Selected_Component =>
4693 if Ekind (Entity (Selector_Name (Expr))) = E_Discriminant
4694 and then Ekind (Etype (Entity (Selector_Name (Expr)))) =
4695 E_Anonymous_Access_Type
4697 return Make_Level_Literal (Object_Access_Level (Expr));
4700 when N_Attribute_Reference =>
4701 case Get_Attribute_Id (Attribute_Name (Expr)) is
4703 -- For X'Access, the level of the prefix X
4705 when Attribute_Access =>
4706 return Make_Level_Literal
4707 (Object_Access_Level (Prefix (Expr)));
4709 -- Treat the unchecked attributes as library-level
4711 when Attribute_Unchecked_Access |
4712 Attribute_Unrestricted_Access =>
4713 return Make_Level_Literal (Scope_Depth (Standard_Standard));
4715 -- No other access-valued attributes
4718 raise Program_Error;
4723 -- Unimplemented: depends on context. As an actual parameter where
4724 -- formal type is anonymous, use
4725 -- Scope_Depth (Current_Scope) + 1.
4726 -- For other cases, see 3.10.2(14/3) and following. ???
4730 when N_Type_Conversion =>
4731 if not Is_Local_Anonymous_Access (Etype (Expr)) then
4733 -- Handle type conversions introduced for a rename of an
4734 -- Ada 2012 stand-alone object of an anonymous access type.
4736 return Dynamic_Accessibility_Level (Expression (Expr));
4743 return Make_Level_Literal (Type_Access_Level (Etype (Expr)));
4744 end Dynamic_Accessibility_Level;
4746 -----------------------------------
4747 -- Effective_Extra_Accessibility --
4748 -----------------------------------
4750 function Effective_Extra_Accessibility (Id : Entity_Id) return Entity_Id is
4752 if Present (Renamed_Object (Id))
4753 and then Is_Entity_Name (Renamed_Object (Id))
4755 return Effective_Extra_Accessibility (Entity (Renamed_Object (Id)));
4757 return Extra_Accessibility (Id);
4759 end Effective_Extra_Accessibility;
4761 -----------------------------
4762 -- Effective_Reads_Enabled --
4763 -----------------------------
4765 function Effective_Reads_Enabled (Id : Entity_Id) return Boolean is
4767 return Has_Enabled_Property (Id, Name_Effective_Reads);
4768 end Effective_Reads_Enabled;
4770 ------------------------------
4771 -- Effective_Writes_Enabled --
4772 ------------------------------
4774 function Effective_Writes_Enabled (Id : Entity_Id) return Boolean is
4776 return Has_Enabled_Property (Id, Name_Effective_Writes);
4777 end Effective_Writes_Enabled;
4779 ------------------------------
4780 -- Enclosing_Comp_Unit_Node --
4781 ------------------------------
4783 function Enclosing_Comp_Unit_Node (N : Node_Id) return Node_Id is
4784 Current_Node : Node_Id;
4788 while Present (Current_Node)
4789 and then Nkind (Current_Node) /= N_Compilation_Unit
4791 Current_Node := Parent (Current_Node);
4794 if Nkind (Current_Node) /= N_Compilation_Unit then
4797 return Current_Node;
4799 end Enclosing_Comp_Unit_Node;
4801 --------------------------
4802 -- Enclosing_CPP_Parent --
4803 --------------------------
4805 function Enclosing_CPP_Parent (Typ : Entity_Id) return Entity_Id is
4806 Parent_Typ : Entity_Id := Typ;
4809 while not Is_CPP_Class (Parent_Typ)
4810 and then Etype (Parent_Typ) /= Parent_Typ
4812 Parent_Typ := Etype (Parent_Typ);
4814 if Is_Private_Type (Parent_Typ) then
4815 Parent_Typ := Full_View (Base_Type (Parent_Typ));
4819 pragma Assert (Is_CPP_Class (Parent_Typ));
4821 end Enclosing_CPP_Parent;
4823 ----------------------------
4824 -- Enclosing_Generic_Body --
4825 ----------------------------
4827 function Enclosing_Generic_Body
4828 (N : Node_Id) return Node_Id
4836 while Present (P) loop
4837 if Nkind (P) = N_Package_Body
4838 or else Nkind (P) = N_Subprogram_Body
4840 Spec := Corresponding_Spec (P);
4842 if Present (Spec) then
4843 Decl := Unit_Declaration_Node (Spec);
4845 if Nkind (Decl) = N_Generic_Package_Declaration
4846 or else Nkind (Decl) = N_Generic_Subprogram_Declaration
4857 end Enclosing_Generic_Body;
4859 ----------------------------
4860 -- Enclosing_Generic_Unit --
4861 ----------------------------
4863 function Enclosing_Generic_Unit
4864 (N : Node_Id) return Node_Id
4872 while Present (P) loop
4873 if Nkind (P) = N_Generic_Package_Declaration
4874 or else Nkind (P) = N_Generic_Subprogram_Declaration
4878 elsif Nkind (P) = N_Package_Body
4879 or else Nkind (P) = N_Subprogram_Body
4881 Spec := Corresponding_Spec (P);
4883 if Present (Spec) then
4884 Decl := Unit_Declaration_Node (Spec);
4886 if Nkind (Decl) = N_Generic_Package_Declaration
4887 or else Nkind (Decl) = N_Generic_Subprogram_Declaration
4898 end Enclosing_Generic_Unit;
4900 -------------------------------
4901 -- Enclosing_Lib_Unit_Entity --
4902 -------------------------------
4904 function Enclosing_Lib_Unit_Entity
4905 (E : Entity_Id := Current_Scope) return Entity_Id
4907 Unit_Entity : Entity_Id;
4910 -- Look for enclosing library unit entity by following scope links.
4911 -- Equivalent to, but faster than indexing through the scope stack.
4914 while (Present (Scope (Unit_Entity))
4915 and then Scope (Unit_Entity) /= Standard_Standard)
4916 and not Is_Child_Unit (Unit_Entity)
4918 Unit_Entity := Scope (Unit_Entity);
4922 end Enclosing_Lib_Unit_Entity;
4924 -----------------------
4925 -- Enclosing_Package --
4926 -----------------------
4928 function Enclosing_Package (E : Entity_Id) return Entity_Id is
4929 Dynamic_Scope : constant Entity_Id := Enclosing_Dynamic_Scope (E);
4932 if Dynamic_Scope = Standard_Standard then
4933 return Standard_Standard;
4935 elsif Dynamic_Scope = Empty then
4938 elsif Ekind_In (Dynamic_Scope, E_Package, E_Package_Body,
4941 return Dynamic_Scope;
4944 return Enclosing_Package (Dynamic_Scope);
4946 end Enclosing_Package;
4948 --------------------------
4949 -- Enclosing_Subprogram --
4950 --------------------------
4952 function Enclosing_Subprogram (E : Entity_Id) return Entity_Id is
4953 Dynamic_Scope : constant Entity_Id := Enclosing_Dynamic_Scope (E);
4956 if Dynamic_Scope = Standard_Standard then
4959 elsif Dynamic_Scope = Empty then
4962 elsif Ekind (Dynamic_Scope) = E_Subprogram_Body then
4963 return Corresponding_Spec (Parent (Parent (Dynamic_Scope)));
4965 elsif Ekind (Dynamic_Scope) = E_Block
4966 or else Ekind (Dynamic_Scope) = E_Return_Statement
4968 return Enclosing_Subprogram (Dynamic_Scope);
4970 elsif Ekind (Dynamic_Scope) = E_Task_Type then
4971 return Get_Task_Body_Procedure (Dynamic_Scope);
4973 elsif Ekind (Dynamic_Scope) = E_Limited_Private_Type
4974 and then Present (Full_View (Dynamic_Scope))
4975 and then Ekind (Full_View (Dynamic_Scope)) = E_Task_Type
4977 return Get_Task_Body_Procedure (Full_View (Dynamic_Scope));
4979 -- No body is generated if the protected operation is eliminated
4981 elsif Convention (Dynamic_Scope) = Convention_Protected
4982 and then not Is_Eliminated (Dynamic_Scope)
4983 and then Present (Protected_Body_Subprogram (Dynamic_Scope))
4985 return Protected_Body_Subprogram (Dynamic_Scope);
4988 return Dynamic_Scope;
4990 end Enclosing_Subprogram;
4992 ------------------------
4993 -- Ensure_Freeze_Node --
4994 ------------------------
4996 procedure Ensure_Freeze_Node (E : Entity_Id) is
4999 if No (Freeze_Node (E)) then
5000 FN := Make_Freeze_Entity (Sloc (E));
5001 Set_Has_Delayed_Freeze (E);
5002 Set_Freeze_Node (E, FN);
5003 Set_Access_Types_To_Process (FN, No_Elist);
5004 Set_TSS_Elist (FN, No_Elist);
5007 end Ensure_Freeze_Node;
5013 procedure Enter_Name (Def_Id : Entity_Id) is
5014 C : constant Entity_Id := Current_Entity (Def_Id);
5015 E : constant Entity_Id := Current_Entity_In_Scope (Def_Id);
5016 S : constant Entity_Id := Current_Scope;
5019 Generate_Definition (Def_Id);
5021 -- Add new name to current scope declarations. Check for duplicate
5022 -- declaration, which may or may not be a genuine error.
5026 -- Case of previous entity entered because of a missing declaration
5027 -- or else a bad subtype indication. Best is to use the new entity,
5028 -- and make the previous one invisible.
5030 if Etype (E) = Any_Type then
5031 Set_Is_Immediately_Visible (E, False);
5033 -- Case of renaming declaration constructed for package instances.
5034 -- if there is an explicit declaration with the same identifier,
5035 -- the renaming is not immediately visible any longer, but remains
5036 -- visible through selected component notation.
5038 elsif Nkind (Parent (E)) = N_Package_Renaming_Declaration
5039 and then not Comes_From_Source (E)
5041 Set_Is_Immediately_Visible (E, False);
5043 -- The new entity may be the package renaming, which has the same
5044 -- same name as a generic formal which has been seen already.
5046 elsif Nkind (Parent (Def_Id)) = N_Package_Renaming_Declaration
5047 and then not Comes_From_Source (Def_Id)
5049 Set_Is_Immediately_Visible (E, False);
5051 -- For a fat pointer corresponding to a remote access to subprogram,
5052 -- we use the same identifier as the RAS type, so that the proper
5053 -- name appears in the stub. This type is only retrieved through
5054 -- the RAS type and never by visibility, and is not added to the
5055 -- visibility list (see below).
5057 elsif Nkind (Parent (Def_Id)) = N_Full_Type_Declaration
5058 and then Ekind (Def_Id) = E_Record_Type
5059 and then Present (Corresponding_Remote_Type (Def_Id))
5063 -- Case of an implicit operation or derived literal. The new entity
5064 -- hides the implicit one, which is removed from all visibility,
5065 -- i.e. the entity list of its scope, and homonym chain of its name.
5067 elsif (Is_Overloadable (E) and then Is_Inherited_Operation (E))
5068 or else Is_Internal (E)
5072 Prev_Vis : Entity_Id;
5073 Decl : constant Node_Id := Parent (E);
5076 -- If E is an implicit declaration, it cannot be the first
5077 -- entity in the scope.
5079 Prev := First_Entity (Current_Scope);
5080 while Present (Prev)
5081 and then Next_Entity (Prev) /= E
5088 -- If E is not on the entity chain of the current scope,
5089 -- it is an implicit declaration in the generic formal
5090 -- part of a generic subprogram. When analyzing the body,
5091 -- the generic formals are visible but not on the entity
5092 -- chain of the subprogram. The new entity will become
5093 -- the visible one in the body.
5096 (Nkind (Parent (Decl)) = N_Generic_Subprogram_Declaration);
5100 Set_Next_Entity (Prev, Next_Entity (E));
5102 if No (Next_Entity (Prev)) then
5103 Set_Last_Entity (Current_Scope, Prev);
5106 if E = Current_Entity (E) then
5110 Prev_Vis := Current_Entity (E);
5111 while Homonym (Prev_Vis) /= E loop
5112 Prev_Vis := Homonym (Prev_Vis);
5116 if Present (Prev_Vis) then
5118 -- Skip E in the visibility chain
5120 Set_Homonym (Prev_Vis, Homonym (E));
5123 Set_Name_Entity_Id (Chars (E), Homonym (E));
5128 -- This section of code could use a comment ???
5130 elsif Present (Etype (E))
5131 and then Is_Concurrent_Type (Etype (E))
5136 -- If the homograph is a protected component renaming, it should not
5137 -- be hiding the current entity. Such renamings are treated as weak
5140 elsif Is_Prival (E) then
5141 Set_Is_Immediately_Visible (E, False);
5143 -- In this case the current entity is a protected component renaming.
5144 -- Perform minimal decoration by setting the scope and return since
5145 -- the prival should not be hiding other visible entities.
5147 elsif Is_Prival (Def_Id) then
5148 Set_Scope (Def_Id, Current_Scope);
5151 -- Analogous to privals, the discriminal generated for an entry index
5152 -- parameter acts as a weak declaration. Perform minimal decoration
5153 -- to avoid bogus errors.
5155 elsif Is_Discriminal (Def_Id)
5156 and then Ekind (Discriminal_Link (Def_Id)) = E_Entry_Index_Parameter
5158 Set_Scope (Def_Id, Current_Scope);
5161 -- In the body or private part of an instance, a type extension may
5162 -- introduce a component with the same name as that of an actual. The
5163 -- legality rule is not enforced, but the semantics of the full type
5164 -- with two components of same name are not clear at this point???
5166 elsif In_Instance_Not_Visible then
5169 -- When compiling a package body, some child units may have become
5170 -- visible. They cannot conflict with local entities that hide them.
5172 elsif Is_Child_Unit (E)
5173 and then In_Open_Scopes (Scope (E))
5174 and then not Is_Immediately_Visible (E)
5178 -- Conversely, with front-end inlining we may compile the parent body
5179 -- first, and a child unit subsequently. The context is now the
5180 -- parent spec, and body entities are not visible.
5182 elsif Is_Child_Unit (Def_Id)
5183 and then Is_Package_Body_Entity (E)
5184 and then not In_Package_Body (Current_Scope)
5188 -- Case of genuine duplicate declaration
5191 Error_Msg_Sloc := Sloc (E);
5193 -- If the previous declaration is an incomplete type declaration
5194 -- this may be an attempt to complete it with a private type. The
5195 -- following avoids confusing cascaded errors.
5197 if Nkind (Parent (E)) = N_Incomplete_Type_Declaration
5198 and then Nkind (Parent (Def_Id)) = N_Private_Type_Declaration
5201 ("incomplete type cannot be completed with a private " &
5202 "declaration", Parent (Def_Id));
5203 Set_Is_Immediately_Visible (E, False);
5204 Set_Full_View (E, Def_Id);
5206 -- An inherited component of a record conflicts with a new
5207 -- discriminant. The discriminant is inserted first in the scope,
5208 -- but the error should be posted on it, not on the component.
5210 elsif Ekind (E) = E_Discriminant
5211 and then Present (Scope (Def_Id))
5212 and then Scope (Def_Id) /= Current_Scope
5214 Error_Msg_Sloc := Sloc (Def_Id);
5215 Error_Msg_N ("& conflicts with declaration#", E);
5218 -- If the name of the unit appears in its own context clause, a
5219 -- dummy package with the name has already been created, and the
5220 -- error emitted. Try to continue quietly.
5222 elsif Error_Posted (E)
5223 and then Sloc (E) = No_Location
5224 and then Nkind (Parent (E)) = N_Package_Specification
5225 and then Current_Scope = Standard_Standard
5227 Set_Scope (Def_Id, Current_Scope);
5231 Error_Msg_N ("& conflicts with declaration#", Def_Id);
5233 -- Avoid cascaded messages with duplicate components in
5236 if Ekind_In (E, E_Component, E_Discriminant) then
5241 if Nkind (Parent (Parent (Def_Id))) =
5242 N_Generic_Subprogram_Declaration
5244 Defining_Entity (Specification (Parent (Parent (Def_Id))))
5246 Error_Msg_N ("\generic units cannot be overloaded", Def_Id);
5249 -- If entity is in standard, then we are in trouble, because it
5250 -- means that we have a library package with a duplicated name.
5251 -- That's hard to recover from, so abort.
5253 if S = Standard_Standard then
5254 raise Unrecoverable_Error;
5256 -- Otherwise we continue with the declaration. Having two
5257 -- identical declarations should not cause us too much trouble.
5265 -- If we fall through, declaration is OK, at least OK enough to continue
5267 -- If Def_Id is a discriminant or a record component we are in the midst
5268 -- of inheriting components in a derived record definition. Preserve
5269 -- their Ekind and Etype.
5271 if Ekind_In (Def_Id, E_Discriminant, E_Component) then
5274 -- If a type is already set, leave it alone (happens when a type
5275 -- declaration is reanalyzed following a call to the optimizer).
5277 elsif Present (Etype (Def_Id)) then
5280 -- Otherwise, the kind E_Void insures that premature uses of the entity
5281 -- will be detected. Any_Type insures that no cascaded errors will occur
5284 Set_Ekind (Def_Id, E_Void);
5285 Set_Etype (Def_Id, Any_Type);
5288 -- Inherited discriminants and components in derived record types are
5289 -- immediately visible. Itypes are not.
5291 -- Unless the Itype is for a record type with a corresponding remote
5292 -- type (what is that about, it was not commented ???)
5294 if Ekind_In (Def_Id, E_Discriminant, E_Component)
5296 ((not Is_Record_Type (Def_Id)
5297 or else No (Corresponding_Remote_Type (Def_Id)))
5298 and then not Is_Itype (Def_Id))
5300 Set_Is_Immediately_Visible (Def_Id);
5301 Set_Current_Entity (Def_Id);
5304 Set_Homonym (Def_Id, C);
5305 Append_Entity (Def_Id, S);
5306 Set_Public_Status (Def_Id);
5308 -- Declaring a homonym is not allowed in SPARK ...
5311 and then Restriction_Check_Required (SPARK_05)
5314 Enclosing_Subp : constant Node_Id := Enclosing_Subprogram (Def_Id);
5315 Enclosing_Pack : constant Node_Id := Enclosing_Package (Def_Id);
5316 Other_Scope : constant Node_Id := Enclosing_Dynamic_Scope (C);
5319 -- ... unless the new declaration is in a subprogram, and the
5320 -- visible declaration is a variable declaration or a parameter
5321 -- specification outside that subprogram.
5323 if Present (Enclosing_Subp)
5324 and then Nkind_In (Parent (C), N_Object_Declaration,
5325 N_Parameter_Specification)
5326 and then not Scope_Within_Or_Same (Other_Scope, Enclosing_Subp)
5330 -- ... or the new declaration is in a package, and the visible
5331 -- declaration occurs outside that package.
5333 elsif Present (Enclosing_Pack)
5334 and then not Scope_Within_Or_Same (Other_Scope, Enclosing_Pack)
5338 -- ... or the new declaration is a component declaration in a
5339 -- record type definition.
5341 elsif Nkind (Parent (Def_Id)) = N_Component_Declaration then
5344 -- Don't issue error for non-source entities
5346 elsif Comes_From_Source (Def_Id)
5347 and then Comes_From_Source (C)
5349 Error_Msg_Sloc := Sloc (C);
5350 Check_SPARK_Restriction
5351 ("redeclaration of identifier &#", Def_Id);
5356 -- Warn if new entity hides an old one
5358 if Warn_On_Hiding and then Present (C)
5360 -- Don't warn for record components since they always have a well
5361 -- defined scope which does not confuse other uses. Note that in
5362 -- some cases, Ekind has not been set yet.
5364 and then Ekind (C) /= E_Component
5365 and then Ekind (C) /= E_Discriminant
5366 and then Nkind (Parent (C)) /= N_Component_Declaration
5367 and then Ekind (Def_Id) /= E_Component
5368 and then Ekind (Def_Id) /= E_Discriminant
5369 and then Nkind (Parent (Def_Id)) /= N_Component_Declaration
5371 -- Don't warn for one character variables. It is too common to use
5372 -- such variables as locals and will just cause too many false hits.
5374 and then Length_Of_Name (Chars (C)) /= 1
5376 -- Don't warn for non-source entities
5378 and then Comes_From_Source (C)
5379 and then Comes_From_Source (Def_Id)
5381 -- Don't warn unless entity in question is in extended main source
5383 and then In_Extended_Main_Source_Unit (Def_Id)
5385 -- Finally, the hidden entity must be either immediately visible or
5386 -- use visible (i.e. from a used package).
5389 (Is_Immediately_Visible (C)
5391 Is_Potentially_Use_Visible (C))
5393 Error_Msg_Sloc := Sloc (C);
5394 Error_Msg_N ("declaration hides &#?h?", Def_Id);
5402 function Entity_Of (N : Node_Id) return Entity_Id is
5408 if Is_Entity_Name (N) then
5411 -- Follow a possible chain of renamings to reach the root renamed
5414 while Present (Id) and then Present (Renamed_Object (Id)) loop
5415 if Is_Entity_Name (Renamed_Object (Id)) then
5416 Id := Entity (Renamed_Object (Id));
5427 --------------------------
5428 -- Explain_Limited_Type --
5429 --------------------------
5431 procedure Explain_Limited_Type (T : Entity_Id; N : Node_Id) is
5435 -- For array, component type must be limited
5437 if Is_Array_Type (T) then
5438 Error_Msg_Node_2 := T;
5440 ("\component type& of type& is limited", N, Component_Type (T));
5441 Explain_Limited_Type (Component_Type (T), N);
5443 elsif Is_Record_Type (T) then
5445 -- No need for extra messages if explicit limited record
5447 if Is_Limited_Record (Base_Type (T)) then
5451 -- Otherwise find a limited component. Check only components that
5452 -- come from source, or inherited components that appear in the
5453 -- source of the ancestor.
5455 C := First_Component (T);
5456 while Present (C) loop
5457 if Is_Limited_Type (Etype (C))
5459 (Comes_From_Source (C)
5461 (Present (Original_Record_Component (C))
5463 Comes_From_Source (Original_Record_Component (C))))
5465 Error_Msg_Node_2 := T;
5466 Error_Msg_NE ("\component& of type& has limited type", N, C);
5467 Explain_Limited_Type (Etype (C), N);
5474 -- The type may be declared explicitly limited, even if no component
5475 -- of it is limited, in which case we fall out of the loop.
5478 end Explain_Limited_Type;
5484 procedure Find_Actual
5486 Formal : out Entity_Id;
5489 Parnt : constant Node_Id := Parent (N);
5493 if (Nkind (Parnt) = N_Indexed_Component
5495 Nkind (Parnt) = N_Selected_Component)
5496 and then N = Prefix (Parnt)
5498 Find_Actual (Parnt, Formal, Call);
5501 elsif Nkind (Parnt) = N_Parameter_Association
5502 and then N = Explicit_Actual_Parameter (Parnt)
5504 Call := Parent (Parnt);
5506 elsif Nkind (Parnt) in N_Subprogram_Call then
5515 -- If we have a call to a subprogram look for the parameter. Note that
5516 -- we exclude overloaded calls, since we don't know enough to be sure
5517 -- of giving the right answer in this case.
5519 if Nkind_In (Call, N_Function_Call, N_Procedure_Call_Statement)
5520 and then Is_Entity_Name (Name (Call))
5521 and then Present (Entity (Name (Call)))
5522 and then Is_Overloadable (Entity (Name (Call)))
5523 and then not Is_Overloaded (Name (Call))
5525 -- Fall here if we are definitely a parameter
5527 Actual := First_Actual (Call);
5528 Formal := First_Formal (Entity (Name (Call)));
5529 while Present (Formal) and then Present (Actual) loop
5533 -- An actual that is the prefix in a prefixed call may have
5534 -- been rewritten in the call, after the deferred reference
5535 -- was collected. Check if sloc and kinds and names match.
5537 elsif Sloc (Actual) = Sloc (N)
5538 and then Nkind (Actual) = N_Identifier
5539 and then Nkind (Actual) = Nkind (N)
5540 and then Chars (Actual) = Chars (N)
5545 Actual := Next_Actual (Actual);
5546 Formal := Next_Formal (Formal);
5551 -- Fall through here if we did not find matching actual
5557 ---------------------------
5558 -- Find_Body_Discriminal --
5559 ---------------------------
5561 function Find_Body_Discriminal
5562 (Spec_Discriminant : Entity_Id) return Entity_Id
5568 -- If expansion is suppressed, then the scope can be the concurrent type
5569 -- itself rather than a corresponding concurrent record type.
5571 if Is_Concurrent_Type (Scope (Spec_Discriminant)) then
5572 Tsk := Scope (Spec_Discriminant);
5575 pragma Assert (Is_Concurrent_Record_Type (Scope (Spec_Discriminant)));
5577 Tsk := Corresponding_Concurrent_Type (Scope (Spec_Discriminant));
5580 -- Find discriminant of original concurrent type, and use its current
5581 -- discriminal, which is the renaming within the task/protected body.
5583 Disc := First_Discriminant (Tsk);
5584 while Present (Disc) loop
5585 if Chars (Disc) = Chars (Spec_Discriminant) then
5586 return Discriminal (Disc);
5589 Next_Discriminant (Disc);
5592 -- That loop should always succeed in finding a matching entry and
5593 -- returning. Fatal error if not.
5595 raise Program_Error;
5596 end Find_Body_Discriminal;
5598 -------------------------------------
5599 -- Find_Corresponding_Discriminant --
5600 -------------------------------------
5602 function Find_Corresponding_Discriminant
5604 Typ : Entity_Id) return Entity_Id
5606 Par_Disc : Entity_Id;
5607 Old_Disc : Entity_Id;
5608 New_Disc : Entity_Id;
5611 Par_Disc := Original_Record_Component (Original_Discriminant (Id));
5613 -- The original type may currently be private, and the discriminant
5614 -- only appear on its full view.
5616 if Is_Private_Type (Scope (Par_Disc))
5617 and then not Has_Discriminants (Scope (Par_Disc))
5618 and then Present (Full_View (Scope (Par_Disc)))
5620 Old_Disc := First_Discriminant (Full_View (Scope (Par_Disc)));
5622 Old_Disc := First_Discriminant (Scope (Par_Disc));
5625 if Is_Class_Wide_Type (Typ) then
5626 New_Disc := First_Discriminant (Root_Type (Typ));
5628 New_Disc := First_Discriminant (Typ);
5631 while Present (Old_Disc) and then Present (New_Disc) loop
5632 if Old_Disc = Par_Disc then
5635 Next_Discriminant (Old_Disc);
5636 Next_Discriminant (New_Disc);
5640 -- Should always find it
5642 raise Program_Error;
5643 end Find_Corresponding_Discriminant;
5645 ----------------------------------
5646 -- Find_Enclosing_Iterator_Loop --
5647 ----------------------------------
5649 function Find_Enclosing_Iterator_Loop (Id : Entity_Id) return Entity_Id is
5654 -- Traverse the scope chain looking for an iterator loop. Such loops are
5655 -- usually transformed into blocks, hence the use of Original_Node.
5658 while Present (S) and then S /= Standard_Standard loop
5659 if Ekind (S) = E_Loop
5660 and then Nkind (Parent (S)) = N_Implicit_Label_Declaration
5662 Constr := Original_Node (Label_Construct (Parent (S)));
5664 if Nkind (Constr) = N_Loop_Statement
5665 and then Present (Iteration_Scheme (Constr))
5666 and then Nkind (Iterator_Specification
5667 (Iteration_Scheme (Constr))) =
5668 N_Iterator_Specification
5678 end Find_Enclosing_Iterator_Loop;
5680 ------------------------------------
5681 -- Find_Loop_In_Conditional_Block --
5682 ------------------------------------
5684 function Find_Loop_In_Conditional_Block (N : Node_Id) return Node_Id is
5690 if Nkind (Stmt) = N_If_Statement then
5691 Stmt := First (Then_Statements (Stmt));
5694 pragma Assert (Nkind (Stmt) = N_Block_Statement);
5696 -- Inspect the statements of the conditional block. In general the loop
5697 -- should be the first statement in the statement sequence of the block,
5698 -- but the finalization machinery may have introduced extra object
5701 Stmt := First (Statements (Handled_Statement_Sequence (Stmt)));
5702 while Present (Stmt) loop
5703 if Nkind (Stmt) = N_Loop_Statement then
5710 -- The expansion of attribute 'Loop_Entry produced a malformed block
5712 raise Program_Error;
5713 end Find_Loop_In_Conditional_Block;
5715 --------------------------
5716 -- Find_Overlaid_Entity --
5717 --------------------------
5719 procedure Find_Overlaid_Entity
5721 Ent : out Entity_Id;
5727 -- We are looking for one of the two following forms:
5729 -- for X'Address use Y'Address
5733 -- Const : constant Address := expr;
5735 -- for X'Address use Const;
5737 -- In the second case, the expr is either Y'Address, or recursively a
5738 -- constant that eventually references Y'Address.
5743 if Nkind (N) = N_Attribute_Definition_Clause
5744 and then Chars (N) = Name_Address
5746 Expr := Expression (N);
5748 -- This loop checks the form of the expression for Y'Address,
5749 -- using recursion to deal with intermediate constants.
5752 -- Check for Y'Address
5754 if Nkind (Expr) = N_Attribute_Reference
5755 and then Attribute_Name (Expr) = Name_Address
5757 Expr := Prefix (Expr);
5760 -- Check for Const where Const is a constant entity
5762 elsif Is_Entity_Name (Expr)
5763 and then Ekind (Entity (Expr)) = E_Constant
5765 Expr := Constant_Value (Entity (Expr));
5767 -- Anything else does not need checking
5774 -- This loop checks the form of the prefix for an entity, using
5775 -- recursion to deal with intermediate components.
5778 -- Check for Y where Y is an entity
5780 if Is_Entity_Name (Expr) then
5781 Ent := Entity (Expr);
5784 -- Check for components
5787 Nkind_In (Expr, N_Selected_Component, N_Indexed_Component)
5789 Expr := Prefix (Expr);
5792 -- Anything else does not need checking
5799 end Find_Overlaid_Entity;
5801 -------------------------
5802 -- Find_Parameter_Type --
5803 -------------------------
5805 function Find_Parameter_Type (Param : Node_Id) return Entity_Id is
5807 if Nkind (Param) /= N_Parameter_Specification then
5810 -- For an access parameter, obtain the type from the formal entity
5811 -- itself, because access to subprogram nodes do not carry a type.
5812 -- Shouldn't we always use the formal entity ???
5814 elsif Nkind (Parameter_Type (Param)) = N_Access_Definition then
5815 return Etype (Defining_Identifier (Param));
5818 return Etype (Parameter_Type (Param));
5820 end Find_Parameter_Type;
5822 -----------------------------------
5823 -- Find_Placement_In_State_Space --
5824 -----------------------------------
5826 procedure Find_Placement_In_State_Space
5827 (Item_Id : Entity_Id;
5828 Placement : out State_Space_Kind;
5829 Pack_Id : out Entity_Id)
5831 Context : Entity_Id;
5834 -- Assume that the item does not appear in the state space of a package
5836 Placement := Not_In_Package;
5839 -- Climb the scope stack and examine the enclosing context
5841 Context := Scope (Item_Id);
5842 while Present (Context) and then Context /= Standard_Standard loop
5843 if Ekind (Context) = E_Package then
5846 -- A package body is a cut off point for the traversal as the item
5847 -- cannot be visible to the outside from this point on. Note that
5848 -- this test must be done first as a body is also classified as a
5851 if In_Package_Body (Context) then
5852 Placement := Body_State_Space;
5855 -- The private part of a package is a cut off point for the
5856 -- traversal as the item cannot be visible to the outside from
5859 elsif In_Private_Part (Context) then
5860 Placement := Private_State_Space;
5863 -- When the item appears in the visible state space of a package,
5864 -- continue to climb the scope stack as this may not be the final
5868 Placement := Visible_State_Space;
5870 -- The visible state space of a child unit acts as the proper
5871 -- placement of an item.
5873 if Is_Child_Unit (Context) then
5878 -- The item or its enclosing package appear in a construct that has
5882 Placement := Not_In_Package;
5886 Context := Scope (Context);
5888 end Find_Placement_In_State_Space;
5890 -----------------------------
5891 -- Find_Static_Alternative --
5892 -----------------------------
5894 function Find_Static_Alternative (N : Node_Id) return Node_Id is
5895 Expr : constant Node_Id := Expression (N);
5896 Val : constant Uint := Expr_Value (Expr);
5901 Alt := First (Alternatives (N));
5904 if Nkind (Alt) /= N_Pragma then
5905 Choice := First (Discrete_Choices (Alt));
5906 while Present (Choice) loop
5908 -- Others choice, always matches
5910 if Nkind (Choice) = N_Others_Choice then
5913 -- Range, check if value is in the range
5915 elsif Nkind (Choice) = N_Range then
5917 Val >= Expr_Value (Low_Bound (Choice))
5919 Val <= Expr_Value (High_Bound (Choice));
5921 -- Choice is a subtype name. Note that we know it must
5922 -- be a static subtype, since otherwise it would have
5923 -- been diagnosed as illegal.
5925 elsif Is_Entity_Name (Choice)
5926 and then Is_Type (Entity (Choice))
5928 exit Search when Is_In_Range (Expr, Etype (Choice),
5929 Assume_Valid => False);
5931 -- Choice is a subtype indication
5933 elsif Nkind (Choice) = N_Subtype_Indication then
5935 C : constant Node_Id := Constraint (Choice);
5936 R : constant Node_Id := Range_Expression (C);
5940 Val >= Expr_Value (Low_Bound (R))
5942 Val <= Expr_Value (High_Bound (R));
5945 -- Choice is a simple expression
5948 exit Search when Val = Expr_Value (Choice);
5956 pragma Assert (Present (Alt));
5959 -- The above loop *must* terminate by finding a match, since
5960 -- we know the case statement is valid, and the value of the
5961 -- expression is known at compile time. When we fall out of
5962 -- the loop, Alt points to the alternative that we know will
5963 -- be selected at run time.
5966 end Find_Static_Alternative;
5972 function First_Actual (Node : Node_Id) return Node_Id is
5976 if No (Parameter_Associations (Node)) then
5980 N := First (Parameter_Associations (Node));
5982 if Nkind (N) = N_Parameter_Association then
5983 return First_Named_Actual (Node);
5989 -----------------------
5990 -- Gather_Components --
5991 -----------------------
5993 procedure Gather_Components
5995 Comp_List : Node_Id;
5996 Governed_By : List_Id;
5998 Report_Errors : out Boolean)
6002 Discrete_Choice : Node_Id;
6003 Comp_Item : Node_Id;
6005 Discrim : Entity_Id;
6006 Discrim_Name : Node_Id;
6007 Discrim_Value : Node_Id;
6010 Report_Errors := False;
6012 if No (Comp_List) or else Null_Present (Comp_List) then
6015 elsif Present (Component_Items (Comp_List)) then
6016 Comp_Item := First (Component_Items (Comp_List));
6022 while Present (Comp_Item) loop
6024 -- Skip the tag of a tagged record, the interface tags, as well
6025 -- as all items that are not user components (anonymous types,
6026 -- rep clauses, Parent field, controller field).
6028 if Nkind (Comp_Item) = N_Component_Declaration then
6030 Comp : constant Entity_Id := Defining_Identifier (Comp_Item);
6032 if not Is_Tag (Comp)
6033 and then Chars (Comp) /= Name_uParent
6035 Append_Elmt (Comp, Into);
6043 if No (Variant_Part (Comp_List)) then
6046 Discrim_Name := Name (Variant_Part (Comp_List));
6047 Variant := First_Non_Pragma (Variants (Variant_Part (Comp_List)));
6050 -- Look for the discriminant that governs this variant part.
6051 -- The discriminant *must* be in the Governed_By List
6053 Assoc := First (Governed_By);
6054 Find_Constraint : loop
6055 Discrim := First (Choices (Assoc));
6056 exit Find_Constraint when Chars (Discrim_Name) = Chars (Discrim)
6057 or else (Present (Corresponding_Discriminant (Entity (Discrim)))
6059 Chars (Corresponding_Discriminant (Entity (Discrim))) =
6060 Chars (Discrim_Name))
6061 or else Chars (Original_Record_Component (Entity (Discrim)))
6062 = Chars (Discrim_Name);
6064 if No (Next (Assoc)) then
6065 if not Is_Constrained (Typ)
6066 and then Is_Derived_Type (Typ)
6067 and then Present (Stored_Constraint (Typ))
6069 -- If the type is a tagged type with inherited discriminants,
6070 -- use the stored constraint on the parent in order to find
6071 -- the values of discriminants that are otherwise hidden by an
6072 -- explicit constraint. Renamed discriminants are handled in
6075 -- If several parent discriminants are renamed by a single
6076 -- discriminant of the derived type, the call to obtain the
6077 -- Corresponding_Discriminant field only retrieves the last
6078 -- of them. We recover the constraint on the others from the
6079 -- Stored_Constraint as well.
6086 D := First_Discriminant (Etype (Typ));
6087 C := First_Elmt (Stored_Constraint (Typ));
6088 while Present (D) and then Present (C) loop
6089 if Chars (Discrim_Name) = Chars (D) then
6090 if Is_Entity_Name (Node (C))
6091 and then Entity (Node (C)) = Entity (Discrim)
6093 -- D is renamed by Discrim, whose value is given in
6100 Make_Component_Association (Sloc (Typ),
6102 (New_Occurrence_Of (D, Sloc (Typ))),
6103 Duplicate_Subexpr_No_Checks (Node (C)));
6105 exit Find_Constraint;
6108 Next_Discriminant (D);
6115 if No (Next (Assoc)) then
6116 Error_Msg_NE (" missing value for discriminant&",
6117 First (Governed_By), Discrim_Name);
6118 Report_Errors := True;
6123 end loop Find_Constraint;
6125 Discrim_Value := Expression (Assoc);
6127 if not Is_OK_Static_Expression (Discrim_Value) then
6129 ("value for discriminant & must be static!",
6130 Discrim_Value, Discrim);
6131 Why_Not_Static (Discrim_Value);
6132 Report_Errors := True;
6136 Search_For_Discriminant_Value : declare
6142 UI_Discrim_Value : constant Uint := Expr_Value (Discrim_Value);
6145 Find_Discrete_Value : while Present (Variant) loop
6146 Discrete_Choice := First (Discrete_Choices (Variant));
6147 while Present (Discrete_Choice) loop
6148 exit Find_Discrete_Value when
6149 Nkind (Discrete_Choice) = N_Others_Choice;
6151 Get_Index_Bounds (Discrete_Choice, Low, High);
6153 UI_Low := Expr_Value (Low);
6154 UI_High := Expr_Value (High);
6156 exit Find_Discrete_Value when
6157 UI_Low <= UI_Discrim_Value
6159 UI_High >= UI_Discrim_Value;
6161 Next (Discrete_Choice);
6164 Next_Non_Pragma (Variant);
6165 end loop Find_Discrete_Value;
6166 end Search_For_Discriminant_Value;
6168 if No (Variant) then
6170 ("value of discriminant & is out of range", Discrim_Value, Discrim);
6171 Report_Errors := True;
6175 -- If we have found the corresponding choice, recursively add its
6176 -- components to the Into list.
6179 (Empty, Component_List (Variant), Governed_By, Into, Report_Errors);
6180 end Gather_Components;
6182 ------------------------
6183 -- Get_Actual_Subtype --
6184 ------------------------
6186 function Get_Actual_Subtype (N : Node_Id) return Entity_Id is
6187 Typ : constant Entity_Id := Etype (N);
6188 Utyp : Entity_Id := Underlying_Type (Typ);
6197 -- If what we have is an identifier that references a subprogram
6198 -- formal, or a variable or constant object, then we get the actual
6199 -- subtype from the referenced entity if one has been built.
6201 if Nkind (N) = N_Identifier
6203 (Is_Formal (Entity (N))
6204 or else Ekind (Entity (N)) = E_Constant
6205 or else Ekind (Entity (N)) = E_Variable)
6206 and then Present (Actual_Subtype (Entity (N)))
6208 return Actual_Subtype (Entity (N));
6210 -- Actual subtype of unchecked union is always itself. We never need
6211 -- the "real" actual subtype. If we did, we couldn't get it anyway
6212 -- because the discriminant is not available. The restrictions on
6213 -- Unchecked_Union are designed to make sure that this is OK.
6215 elsif Is_Unchecked_Union (Base_Type (Utyp)) then
6218 -- Here for the unconstrained case, we must find actual subtype
6219 -- No actual subtype is available, so we must build it on the fly.
6221 -- Checking the type, not the underlying type, for constrainedness
6222 -- seems to be necessary. Maybe all the tests should be on the type???
6224 elsif (not Is_Constrained (Typ))
6225 and then (Is_Array_Type (Utyp)
6226 or else (Is_Record_Type (Utyp)
6227 and then Has_Discriminants (Utyp)))
6228 and then not Has_Unknown_Discriminants (Utyp)
6229 and then not (Ekind (Utyp) = E_String_Literal_Subtype)
6231 -- Nothing to do if in spec expression (why not???)
6233 if In_Spec_Expression then
6236 elsif Is_Private_Type (Typ)
6237 and then not Has_Discriminants (Typ)
6239 -- If the type has no discriminants, there is no subtype to
6240 -- build, even if the underlying type is discriminated.
6244 -- Else build the actual subtype
6247 Decl := Build_Actual_Subtype (Typ, N);
6248 Atyp := Defining_Identifier (Decl);
6250 -- If Build_Actual_Subtype generated a new declaration then use it
6254 -- The actual subtype is an Itype, so analyze the declaration,
6255 -- but do not attach it to the tree, to get the type defined.
6257 Set_Parent (Decl, N);
6258 Set_Is_Itype (Atyp);
6259 Analyze (Decl, Suppress => All_Checks);
6260 Set_Associated_Node_For_Itype (Atyp, N);
6261 Set_Has_Delayed_Freeze (Atyp, False);
6263 -- We need to freeze the actual subtype immediately. This is
6264 -- needed, because otherwise this Itype will not get frozen
6265 -- at all, and it is always safe to freeze on creation because
6266 -- any associated types must be frozen at this point.
6268 Freeze_Itype (Atyp, N);
6271 -- Otherwise we did not build a declaration, so return original
6278 -- For all remaining cases, the actual subtype is the same as
6279 -- the nominal type.
6284 end Get_Actual_Subtype;
6286 -------------------------------------
6287 -- Get_Actual_Subtype_If_Available --
6288 -------------------------------------
6290 function Get_Actual_Subtype_If_Available (N : Node_Id) return Entity_Id is
6291 Typ : constant Entity_Id := Etype (N);
6294 -- If what we have is an identifier that references a subprogram
6295 -- formal, or a variable or constant object, then we get the actual
6296 -- subtype from the referenced entity if one has been built.
6298 if Nkind (N) = N_Identifier
6300 (Is_Formal (Entity (N))
6301 or else Ekind (Entity (N)) = E_Constant
6302 or else Ekind (Entity (N)) = E_Variable)
6303 and then Present (Actual_Subtype (Entity (N)))
6305 return Actual_Subtype (Entity (N));
6307 -- Otherwise the Etype of N is returned unchanged
6312 end Get_Actual_Subtype_If_Available;
6314 ------------------------
6315 -- Get_Body_From_Stub --
6316 ------------------------
6318 function Get_Body_From_Stub (N : Node_Id) return Node_Id is
6320 return Proper_Body (Unit (Library_Unit (N)));
6321 end Get_Body_From_Stub;
6323 ---------------------
6324 -- Get_Cursor_Type --
6325 ---------------------
6327 function Get_Cursor_Type
6329 Typ : Entity_Id) return Entity_Id
6333 First_Op : Entity_Id;
6337 -- If error already detected, return
6339 if Error_Posted (Aspect) then
6343 -- The cursor type for an Iterable aspect is the return type of a
6344 -- non-overloaded First primitive operation. Locate association for
6347 Assoc := First (Component_Associations (Expression (Aspect)));
6349 while Present (Assoc) loop
6350 if Chars (First (Choices (Assoc))) = Name_First then
6351 First_Op := Expression (Assoc);
6358 if First_Op = Any_Id then
6359 Error_Msg_N ("aspect Iterable must specify First operation", Aspect);
6365 -- Locate function with desired name and profile in scope of type
6367 Func := First_Entity (Scope (Typ));
6368 while Present (Func) loop
6369 if Chars (Func) = Chars (First_Op)
6370 and then Ekind (Func) = E_Function
6371 and then Present (First_Formal (Func))
6372 and then Etype (First_Formal (Func)) = Typ
6373 and then No (Next_Formal (First_Formal (Func)))
6375 if Cursor /= Any_Type then
6377 ("Operation First for iterable type must be unique", Aspect);
6380 Cursor := Etype (Func);
6387 -- If not found, no way to resolve remaining primitives.
6389 if Cursor = Any_Type then
6391 ("No legal primitive operation First for Iterable type", Aspect);
6395 end Get_Cursor_Type;
6397 -------------------------------
6398 -- Get_Default_External_Name --
6399 -------------------------------
6401 function Get_Default_External_Name (E : Node_Or_Entity_Id) return Node_Id is
6403 Get_Decoded_Name_String (Chars (E));
6405 if Opt.External_Name_Imp_Casing = Uppercase then
6406 Set_Casing (All_Upper_Case);
6408 Set_Casing (All_Lower_Case);
6412 Make_String_Literal (Sloc (E),
6413 Strval => String_From_Name_Buffer);
6414 end Get_Default_External_Name;
6416 --------------------------
6417 -- Get_Enclosing_Object --
6418 --------------------------
6420 function Get_Enclosing_Object (N : Node_Id) return Entity_Id is
6422 if Is_Entity_Name (N) then
6426 when N_Indexed_Component |
6428 N_Selected_Component =>
6430 -- If not generating code, a dereference may be left implicit.
6431 -- In thoses cases, return Empty.
6433 if Is_Access_Type (Etype (Prefix (N))) then
6436 return Get_Enclosing_Object (Prefix (N));
6439 when N_Type_Conversion =>
6440 return Get_Enclosing_Object (Expression (N));
6446 end Get_Enclosing_Object;
6448 ---------------------------
6449 -- Get_Enum_Lit_From_Pos --
6450 ---------------------------
6452 function Get_Enum_Lit_From_Pos
6455 Loc : Source_Ptr) return Node_Id
6457 Btyp : Entity_Id := Base_Type (T);
6461 -- In the case where the literal is of type Character, Wide_Character
6462 -- or Wide_Wide_Character or of a type derived from them, there needs
6463 -- to be some special handling since there is no explicit chain of
6464 -- literals to search. Instead, an N_Character_Literal node is created
6465 -- with the appropriate Char_Code and Chars fields.
6467 if Is_Standard_Character_Type (T) then
6468 Set_Character_Literal_Name (UI_To_CC (Pos));
6470 Make_Character_Literal (Loc,
6472 Char_Literal_Value => Pos);
6474 -- For all other cases, we have a complete table of literals, and
6475 -- we simply iterate through the chain of literal until the one
6476 -- with the desired position value is found.
6480 if Is_Private_Type (Btyp) and then Present (Full_View (Btyp)) then
6481 Btyp := Full_View (Btyp);
6484 Lit := First_Literal (Btyp);
6485 for J in 1 .. UI_To_Int (Pos) loop
6489 return New_Occurrence_Of (Lit, Loc);
6491 end Get_Enum_Lit_From_Pos;
6493 ---------------------------------
6494 -- Get_Ensures_From_CTC_Pragma --
6495 ---------------------------------
6497 function Get_Ensures_From_CTC_Pragma (N : Node_Id) return Node_Id is
6498 Args : constant List_Id := Pragma_Argument_Associations (N);
6502 if List_Length (Args) = 4 then
6503 Res := Pick (Args, 4);
6505 elsif List_Length (Args) = 3 then
6506 Res := Pick (Args, 3);
6508 if Chars (Res) /= Name_Ensures then
6517 end Get_Ensures_From_CTC_Pragma;
6519 ------------------------
6520 -- Get_Generic_Entity --
6521 ------------------------
6523 function Get_Generic_Entity (N : Node_Id) return Entity_Id is
6524 Ent : constant Entity_Id := Entity (Name (N));
6526 if Present (Renamed_Object (Ent)) then
6527 return Renamed_Object (Ent);
6531 end Get_Generic_Entity;
6533 -------------------------------------
6534 -- Get_Incomplete_View_Of_Ancestor --
6535 -------------------------------------
6537 function Get_Incomplete_View_Of_Ancestor (E : Entity_Id) return Entity_Id is
6538 Cur_Unit : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
6539 Par_Scope : Entity_Id;
6540 Par_Type : Entity_Id;
6543 -- The incomplete view of an ancestor is only relevant for private
6544 -- derived types in child units.
6546 if not Is_Derived_Type (E)
6547 or else not Is_Child_Unit (Cur_Unit)
6552 Par_Scope := Scope (Cur_Unit);
6553 if No (Par_Scope) then
6557 Par_Type := Etype (Base_Type (E));
6559 -- Traverse list of ancestor types until we find one declared in
6560 -- a parent or grandparent unit (two levels seem sufficient).
6562 while Present (Par_Type) loop
6563 if Scope (Par_Type) = Par_Scope
6564 or else Scope (Par_Type) = Scope (Par_Scope)
6568 elsif not Is_Derived_Type (Par_Type) then
6572 Par_Type := Etype (Base_Type (Par_Type));
6576 -- If none found, there is no relevant ancestor type.
6580 end Get_Incomplete_View_Of_Ancestor;
6582 ----------------------
6583 -- Get_Index_Bounds --
6584 ----------------------
6586 procedure Get_Index_Bounds (N : Node_Id; L, H : out Node_Id) is
6587 Kind : constant Node_Kind := Nkind (N);
6591 if Kind = N_Range then
6593 H := High_Bound (N);
6595 elsif Kind = N_Subtype_Indication then
6596 R := Range_Expression (Constraint (N));
6604 L := Low_Bound (Range_Expression (Constraint (N)));
6605 H := High_Bound (Range_Expression (Constraint (N)));
6608 elsif Is_Entity_Name (N) and then Is_Type (Entity (N)) then
6609 if Error_Posted (Scalar_Range (Entity (N))) then
6613 elsif Nkind (Scalar_Range (Entity (N))) = N_Subtype_Indication then
6614 Get_Index_Bounds (Scalar_Range (Entity (N)), L, H);
6617 L := Low_Bound (Scalar_Range (Entity (N)));
6618 H := High_Bound (Scalar_Range (Entity (N)));
6622 -- N is an expression, indicating a range with one value
6627 end Get_Index_Bounds;
6629 ---------------------------------
6630 -- Get_Iterable_Type_Primitive --
6631 ---------------------------------
6633 function Get_Iterable_Type_Primitive
6635 Nam : Name_Id) return Entity_Id
6637 Funcs : constant Node_Id := Find_Value_Of_Aspect (Typ, Aspect_Iterable);
6645 Assoc := First (Component_Associations (Funcs));
6646 while Present (Assoc) loop
6647 if Chars (First (Choices (Assoc))) = Nam then
6648 return Entity (Expression (Assoc));
6651 Assoc := Next (Assoc);
6656 end Get_Iterable_Type_Primitive;
6658 ----------------------------------
6659 -- Get_Library_Unit_Name_string --
6660 ----------------------------------
6662 procedure Get_Library_Unit_Name_String (Decl_Node : Node_Id) is
6663 Unit_Name_Id : constant Unit_Name_Type := Get_Unit_Name (Decl_Node);
6666 Get_Unit_Name_String (Unit_Name_Id);
6668 -- Remove seven last character (" (spec)" or " (body)")
6670 Name_Len := Name_Len - 7;
6671 pragma Assert (Name_Buffer (Name_Len + 1) = ' ');
6672 end Get_Library_Unit_Name_String;
6674 ------------------------
6675 -- Get_Name_Entity_Id --
6676 ------------------------
6678 function Get_Name_Entity_Id (Id : Name_Id) return Entity_Id is
6680 return Entity_Id (Get_Name_Table_Info (Id));
6681 end Get_Name_Entity_Id;
6683 ------------------------------
6684 -- Get_Name_From_CTC_Pragma --
6685 ------------------------------
6687 function Get_Name_From_CTC_Pragma (N : Node_Id) return String_Id is
6688 Arg : constant Node_Id :=
6689 Get_Pragma_Arg (First (Pragma_Argument_Associations (N)));
6691 return Strval (Expr_Value_S (Arg));
6692 end Get_Name_From_CTC_Pragma;
6698 function Get_Pragma_Id (N : Node_Id) return Pragma_Id is
6700 return Get_Pragma_Id (Pragma_Name (N));
6703 -----------------------
6704 -- Get_Reason_String --
6705 -----------------------
6707 procedure Get_Reason_String (N : Node_Id) is
6709 if Nkind (N) = N_String_Literal then
6710 Store_String_Chars (Strval (N));
6712 elsif Nkind (N) = N_Op_Concat then
6713 Get_Reason_String (Left_Opnd (N));
6714 Get_Reason_String (Right_Opnd (N));
6716 -- If not of required form, error
6720 ("Reason for pragma Warnings has wrong form", N);
6722 ("\must be string literal or concatenation of string literals", N);
6725 end Get_Reason_String;
6727 ---------------------------
6728 -- Get_Referenced_Object --
6729 ---------------------------
6731 function Get_Referenced_Object (N : Node_Id) return Node_Id is
6736 while Is_Entity_Name (R)
6737 and then Present (Renamed_Object (Entity (R)))
6739 R := Renamed_Object (Entity (R));
6743 end Get_Referenced_Object;
6745 ------------------------
6746 -- Get_Renamed_Entity --
6747 ------------------------
6749 function Get_Renamed_Entity (E : Entity_Id) return Entity_Id is
6754 while Present (Renamed_Entity (R)) loop
6755 R := Renamed_Entity (R);
6759 end Get_Renamed_Entity;
6761 ----------------------------------
6762 -- Get_Requires_From_CTC_Pragma --
6763 ----------------------------------
6765 function Get_Requires_From_CTC_Pragma (N : Node_Id) return Node_Id is
6766 Args : constant List_Id := Pragma_Argument_Associations (N);
6770 if List_Length (Args) >= 3 then
6771 Res := Pick (Args, 3);
6773 if Chars (Res) /= Name_Requires then
6782 end Get_Requires_From_CTC_Pragma;
6784 -------------------------
6785 -- Get_Subprogram_Body --
6786 -------------------------
6788 function Get_Subprogram_Body (E : Entity_Id) return Node_Id is
6792 Decl := Unit_Declaration_Node (E);
6794 if Nkind (Decl) = N_Subprogram_Body then
6797 -- The below comment is bad, because it is possible for
6798 -- Nkind (Decl) to be an N_Subprogram_Body_Stub ???
6800 else -- Nkind (Decl) = N_Subprogram_Declaration
6802 if Present (Corresponding_Body (Decl)) then
6803 return Unit_Declaration_Node (Corresponding_Body (Decl));
6805 -- Imported subprogram case
6811 end Get_Subprogram_Body;
6813 ---------------------------
6814 -- Get_Subprogram_Entity --
6815 ---------------------------
6817 function Get_Subprogram_Entity (Nod : Node_Id) return Entity_Id is
6819 Subp_Id : Entity_Id;
6822 if Nkind (Nod) = N_Accept_Statement then
6823 Subp := Entry_Direct_Name (Nod);
6825 elsif Nkind (Nod) = N_Slice then
6826 Subp := Prefix (Nod);
6832 -- Strip the subprogram call
6835 if Nkind_In (Subp, N_Explicit_Dereference,
6836 N_Indexed_Component,
6837 N_Selected_Component)
6839 Subp := Prefix (Subp);
6841 elsif Nkind_In (Subp, N_Type_Conversion,
6842 N_Unchecked_Type_Conversion)
6844 Subp := Expression (Subp);
6851 -- Extract the entity of the subprogram call
6853 if Is_Entity_Name (Subp) then
6854 Subp_Id := Entity (Subp);
6856 if Ekind (Subp_Id) = E_Access_Subprogram_Type then
6857 Subp_Id := Directly_Designated_Type (Subp_Id);
6860 if Is_Subprogram (Subp_Id) then
6866 -- The search did not find a construct that denotes a subprogram
6871 end Get_Subprogram_Entity;
6873 -----------------------------
6874 -- Get_Task_Body_Procedure --
6875 -----------------------------
6877 function Get_Task_Body_Procedure (E : Entity_Id) return Node_Id is
6879 -- Note: A task type may be the completion of a private type with
6880 -- discriminants. When performing elaboration checks on a task
6881 -- declaration, the current view of the type may be the private one,
6882 -- and the procedure that holds the body of the task is held in its
6885 -- This is an odd function, why not have Task_Body_Procedure do
6886 -- the following digging???
6888 return Task_Body_Procedure (Underlying_Type (Root_Type (E)));
6889 end Get_Task_Body_Procedure;
6891 -----------------------
6892 -- Has_Access_Values --
6893 -----------------------
6895 function Has_Access_Values (T : Entity_Id) return Boolean is
6896 Typ : constant Entity_Id := Underlying_Type (T);
6899 -- Case of a private type which is not completed yet. This can only
6900 -- happen in the case of a generic format type appearing directly, or
6901 -- as a component of the type to which this function is being applied
6902 -- at the top level. Return False in this case, since we certainly do
6903 -- not know that the type contains access types.
6908 elsif Is_Access_Type (Typ) then
6911 elsif Is_Array_Type (Typ) then
6912 return Has_Access_Values (Component_Type (Typ));
6914 elsif Is_Record_Type (Typ) then
6919 -- Loop to Check components
6921 Comp := First_Component_Or_Discriminant (Typ);
6922 while Present (Comp) loop
6924 -- Check for access component, tag field does not count, even
6925 -- though it is implemented internally using an access type.
6927 if Has_Access_Values (Etype (Comp))
6928 and then Chars (Comp) /= Name_uTag
6933 Next_Component_Or_Discriminant (Comp);
6942 end Has_Access_Values;
6944 ------------------------------
6945 -- Has_Compatible_Alignment --
6946 ------------------------------
6948 function Has_Compatible_Alignment
6950 Expr : Node_Id) return Alignment_Result
6952 function Has_Compatible_Alignment_Internal
6955 Default : Alignment_Result) return Alignment_Result;
6956 -- This is the internal recursive function that actually does the work.
6957 -- There is one additional parameter, which says what the result should
6958 -- be if no alignment information is found, and there is no definite
6959 -- indication of compatible alignments. At the outer level, this is set
6960 -- to Unknown, but for internal recursive calls in the case where types
6961 -- are known to be correct, it is set to Known_Compatible.
6963 ---------------------------------------
6964 -- Has_Compatible_Alignment_Internal --
6965 ---------------------------------------
6967 function Has_Compatible_Alignment_Internal
6970 Default : Alignment_Result) return Alignment_Result
6972 Result : Alignment_Result := Known_Compatible;
6973 -- Holds the current status of the result. Note that once a value of
6974 -- Known_Incompatible is set, it is sticky and does not get changed
6975 -- to Unknown (the value in Result only gets worse as we go along,
6978 Offs : Uint := No_Uint;
6979 -- Set to a factor of the offset from the base object when Expr is a
6980 -- selected or indexed component, based on Component_Bit_Offset and
6981 -- Component_Size respectively. A negative value is used to represent
6982 -- a value which is not known at compile time.
6984 procedure Check_Prefix;
6985 -- Checks the prefix recursively in the case where the expression
6986 -- is an indexed or selected component.
6988 procedure Set_Result (R : Alignment_Result);
6989 -- If R represents a worse outcome (unknown instead of known
6990 -- compatible, or known incompatible), then set Result to R.
6996 procedure Check_Prefix is
6998 -- The subtlety here is that in doing a recursive call to check
6999 -- the prefix, we have to decide what to do in the case where we
7000 -- don't find any specific indication of an alignment problem.
7002 -- At the outer level, we normally set Unknown as the result in
7003 -- this case, since we can only set Known_Compatible if we really
7004 -- know that the alignment value is OK, but for the recursive
7005 -- call, in the case where the types match, and we have not
7006 -- specified a peculiar alignment for the object, we are only
7007 -- concerned about suspicious rep clauses, the default case does
7008 -- not affect us, since the compiler will, in the absence of such
7009 -- rep clauses, ensure that the alignment is correct.
7011 if Default = Known_Compatible
7013 (Etype (Obj) = Etype (Expr)
7014 and then (Unknown_Alignment (Obj)
7016 Alignment (Obj) = Alignment (Etype (Obj))))
7019 (Has_Compatible_Alignment_Internal
7020 (Obj, Prefix (Expr), Known_Compatible));
7022 -- In all other cases, we need a full check on the prefix
7026 (Has_Compatible_Alignment_Internal
7027 (Obj, Prefix (Expr), Unknown));
7035 procedure Set_Result (R : Alignment_Result) is
7042 -- Start of processing for Has_Compatible_Alignment_Internal
7045 -- If Expr is a selected component, we must make sure there is no
7046 -- potentially troublesome component clause, and that the record is
7049 if Nkind (Expr) = N_Selected_Component then
7051 -- Packed record always generate unknown alignment
7053 if Is_Packed (Etype (Prefix (Expr))) then
7054 Set_Result (Unknown);
7057 -- Check prefix and component offset
7060 Offs := Component_Bit_Offset (Entity (Selector_Name (Expr)));
7062 -- If Expr is an indexed component, we must make sure there is no
7063 -- potentially troublesome Component_Size clause and that the array
7064 -- is not bit-packed.
7066 elsif Nkind (Expr) = N_Indexed_Component then
7068 Typ : constant Entity_Id := Etype (Prefix (Expr));
7069 Ind : constant Node_Id := First_Index (Typ);
7072 -- Bit packed array always generates unknown alignment
7074 if Is_Bit_Packed_Array (Typ) then
7075 Set_Result (Unknown);
7078 -- Check prefix and component offset
7081 Offs := Component_Size (Typ);
7083 -- Small optimization: compute the full offset when possible
7086 and then Offs > Uint_0
7087 and then Present (Ind)
7088 and then Nkind (Ind) = N_Range
7089 and then Compile_Time_Known_Value (Low_Bound (Ind))
7090 and then Compile_Time_Known_Value (First (Expressions (Expr)))
7092 Offs := Offs * (Expr_Value (First (Expressions (Expr)))
7093 - Expr_Value (Low_Bound ((Ind))));
7098 -- If we have a null offset, the result is entirely determined by
7099 -- the base object and has already been computed recursively.
7101 if Offs = Uint_0 then
7104 -- Case where we know the alignment of the object
7106 elsif Known_Alignment (Obj) then
7108 ObjA : constant Uint := Alignment (Obj);
7109 ExpA : Uint := No_Uint;
7110 SizA : Uint := No_Uint;
7113 -- If alignment of Obj is 1, then we are always OK
7116 Set_Result (Known_Compatible);
7118 -- Alignment of Obj is greater than 1, so we need to check
7121 -- If we have an offset, see if it is compatible
7123 if Offs /= No_Uint and Offs > Uint_0 then
7124 if Offs mod (System_Storage_Unit * ObjA) /= 0 then
7125 Set_Result (Known_Incompatible);
7128 -- See if Expr is an object with known alignment
7130 elsif Is_Entity_Name (Expr)
7131 and then Known_Alignment (Entity (Expr))
7133 ExpA := Alignment (Entity (Expr));
7135 -- Otherwise, we can use the alignment of the type of
7136 -- Expr given that we already checked for
7137 -- discombobulating rep clauses for the cases of indexed
7138 -- and selected components above.
7140 elsif Known_Alignment (Etype (Expr)) then
7141 ExpA := Alignment (Etype (Expr));
7143 -- Otherwise the alignment is unknown
7146 Set_Result (Default);
7149 -- If we got an alignment, see if it is acceptable
7151 if ExpA /= No_Uint and then ExpA < ObjA then
7152 Set_Result (Known_Incompatible);
7155 -- If Expr is not a piece of a larger object, see if size
7156 -- is given. If so, check that it is not too small for the
7157 -- required alignment.
7159 if Offs /= No_Uint then
7162 -- See if Expr is an object with known size
7164 elsif Is_Entity_Name (Expr)
7165 and then Known_Static_Esize (Entity (Expr))
7167 SizA := Esize (Entity (Expr));
7169 -- Otherwise, we check the object size of the Expr type
7171 elsif Known_Static_Esize (Etype (Expr)) then
7172 SizA := Esize (Etype (Expr));
7175 -- If we got a size, see if it is a multiple of the Obj
7176 -- alignment, if not, then the alignment cannot be
7177 -- acceptable, since the size is always a multiple of the
7180 if SizA /= No_Uint then
7181 if SizA mod (ObjA * Ttypes.System_Storage_Unit) /= 0 then
7182 Set_Result (Known_Incompatible);
7188 -- If we do not know required alignment, any non-zero offset is a
7189 -- potential problem (but certainly may be OK, so result is unknown).
7191 elsif Offs /= No_Uint then
7192 Set_Result (Unknown);
7194 -- If we can't find the result by direct comparison of alignment
7195 -- values, then there is still one case that we can determine known
7196 -- result, and that is when we can determine that the types are the
7197 -- same, and no alignments are specified. Then we known that the
7198 -- alignments are compatible, even if we don't know the alignment
7199 -- value in the front end.
7201 elsif Etype (Obj) = Etype (Expr) then
7203 -- Types are the same, but we have to check for possible size
7204 -- and alignments on the Expr object that may make the alignment
7205 -- different, even though the types are the same.
7207 if Is_Entity_Name (Expr) then
7209 -- First check alignment of the Expr object. Any alignment less
7210 -- than Maximum_Alignment is worrisome since this is the case
7211 -- where we do not know the alignment of Obj.
7213 if Known_Alignment (Entity (Expr))
7215 UI_To_Int (Alignment (Entity (Expr))) <
7216 Ttypes.Maximum_Alignment
7218 Set_Result (Unknown);
7220 -- Now check size of Expr object. Any size that is not an
7221 -- even multiple of Maximum_Alignment is also worrisome
7222 -- since it may cause the alignment of the object to be less
7223 -- than the alignment of the type.
7225 elsif Known_Static_Esize (Entity (Expr))
7227 (UI_To_Int (Esize (Entity (Expr))) mod
7228 (Ttypes.Maximum_Alignment * Ttypes.System_Storage_Unit))
7231 Set_Result (Unknown);
7233 -- Otherwise same type is decisive
7236 Set_Result (Known_Compatible);
7240 -- Another case to deal with is when there is an explicit size or
7241 -- alignment clause when the types are not the same. If so, then the
7242 -- result is Unknown. We don't need to do this test if the Default is
7243 -- Unknown, since that result will be set in any case.
7245 elsif Default /= Unknown
7246 and then (Has_Size_Clause (Etype (Expr))
7248 Has_Alignment_Clause (Etype (Expr)))
7250 Set_Result (Unknown);
7252 -- If no indication found, set default
7255 Set_Result (Default);
7258 -- Return worst result found
7261 end Has_Compatible_Alignment_Internal;
7263 -- Start of processing for Has_Compatible_Alignment
7266 -- If Obj has no specified alignment, then set alignment from the type
7267 -- alignment. Perhaps we should always do this, but for sure we should
7268 -- do it when there is an address clause since we can do more if the
7269 -- alignment is known.
7271 if Unknown_Alignment (Obj) then
7272 Set_Alignment (Obj, Alignment (Etype (Obj)));
7275 -- Now do the internal call that does all the work
7277 return Has_Compatible_Alignment_Internal (Obj, Expr, Unknown);
7278 end Has_Compatible_Alignment;
7280 ----------------------
7281 -- Has_Declarations --
7282 ----------------------
7284 function Has_Declarations (N : Node_Id) return Boolean is
7286 return Nkind_In (Nkind (N), N_Accept_Statement,
7288 N_Compilation_Unit_Aux,
7294 N_Package_Specification);
7295 end Has_Declarations;
7301 function Has_Denormals (E : Entity_Id) return Boolean is
7303 return Is_Floating_Point_Type (E)
7304 and then Denorm_On_Target
7305 and then not Vax_Float (E);
7308 -------------------------------------------
7309 -- Has_Discriminant_Dependent_Constraint --
7310 -------------------------------------------
7312 function Has_Discriminant_Dependent_Constraint
7313 (Comp : Entity_Id) return Boolean
7315 Comp_Decl : constant Node_Id := Parent (Comp);
7316 Subt_Indic : Node_Id;
7321 -- Discriminants can't depend on discriminants
7323 if Ekind (Comp) = E_Discriminant then
7327 Subt_Indic := Subtype_Indication (Component_Definition (Comp_Decl));
7329 if Nkind (Subt_Indic) = N_Subtype_Indication then
7330 Constr := Constraint (Subt_Indic);
7332 if Nkind (Constr) = N_Index_Or_Discriminant_Constraint then
7333 Assn := First (Constraints (Constr));
7334 while Present (Assn) loop
7335 case Nkind (Assn) is
7336 when N_Subtype_Indication |
7340 if Depends_On_Discriminant (Assn) then
7344 when N_Discriminant_Association =>
7345 if Depends_On_Discriminant (Expression (Assn)) then
7360 end Has_Discriminant_Dependent_Constraint;
7362 --------------------------
7363 -- Has_Enabled_Property --
7364 --------------------------
7366 function Has_Enabled_Property
7367 (Item_Id : Entity_Id;
7368 Property : Name_Id) return Boolean
7370 function State_Has_Enabled_Property return Boolean;
7371 -- Determine whether a state denoted by Item_Id has the property
7373 function Variable_Has_Enabled_Property return Boolean;
7374 -- Determine whether a variable denoted by Item_Id has the property
7376 --------------------------------
7377 -- State_Has_Enabled_Property --
7378 --------------------------------
7380 function State_Has_Enabled_Property return Boolean is
7381 Decl : constant Node_Id := Parent (Item_Id);
7389 -- The declaration of an external abstract state appears as an
7390 -- extension aggregate. If this is not the case, properties can never
7393 if Nkind (Decl) /= N_Extension_Aggregate then
7397 -- When External appears as a simple option, it automatically enables
7400 Opt := First (Expressions (Decl));
7401 while Present (Opt) loop
7402 if Nkind (Opt) = N_Identifier
7403 and then Chars (Opt) = Name_External
7411 -- When External specifies particular properties, inspect those and
7412 -- find the desired one (if any).
7414 Opt := First (Component_Associations (Decl));
7415 while Present (Opt) loop
7416 Opt_Nam := First (Choices (Opt));
7418 if Nkind (Opt_Nam) = N_Identifier
7419 and then Chars (Opt_Nam) = Name_External
7421 Props := Expression (Opt);
7423 -- Multiple properties appear as an aggregate
7425 if Nkind (Props) = N_Aggregate then
7427 -- Simple property form
7429 Prop := First (Expressions (Props));
7430 while Present (Prop) loop
7431 if Chars (Prop) = Property then
7438 -- Property with expression form
7440 Prop := First (Component_Associations (Props));
7441 while Present (Prop) loop
7442 Prop_Nam := First (Choices (Prop));
7444 -- The property can be represented in two ways:
7445 -- others => <value>
7446 -- <property> => <value>
7448 if Nkind (Prop_Nam) = N_Others_Choice
7449 or else (Nkind (Prop_Nam) = N_Identifier
7450 and then Chars (Prop_Nam) = Property)
7452 return Is_True (Expr_Value (Expression (Prop)));
7461 return Chars (Props) = Property;
7469 end State_Has_Enabled_Property;
7471 -----------------------------------
7472 -- Variable_Has_Enabled_Property --
7473 -----------------------------------
7475 function Variable_Has_Enabled_Property return Boolean is
7476 AR : constant Node_Id :=
7477 Get_Pragma (Item_Id, Pragma_Async_Readers);
7478 AW : constant Node_Id :=
7479 Get_Pragma (Item_Id, Pragma_Async_Writers);
7480 ER : constant Node_Id :=
7481 Get_Pragma (Item_Id, Pragma_Effective_Reads);
7482 EW : constant Node_Id :=
7483 Get_Pragma (Item_Id, Pragma_Effective_Writes);
7485 -- A non-volatile object can never possess external properties
7487 if not Is_SPARK_Volatile (Item_Id) then
7490 -- External properties related to variables come in two flavors -
7491 -- explicit and implicit. The explicit case is characterized by the
7492 -- presence of a property pragma while the implicit case lacks all
7495 elsif Property = Name_Async_Readers
7499 (No (AW) and then No (ER) and then No (EW)))
7503 elsif Property = Name_Async_Writers
7507 (No (AR) and then No (ER) and then No (EW)))
7511 elsif Property = Name_Effective_Reads
7515 (No (AR) and then No (AW) and then No (EW)))
7519 elsif Property = Name_Effective_Writes
7521 (Present (EW) or else (No (AR) and then No (AW) and then No (ER)))
7528 end Variable_Has_Enabled_Property;
7530 -- Start of processing for Has_Enabled_Property
7533 -- Abstract states and variables have a flexible scheme of specifying
7534 -- external properties.
7536 if Ekind (Item_Id) = E_Abstract_State then
7537 return State_Has_Enabled_Property;
7539 elsif Ekind (Item_Id) = E_Variable then
7540 return Variable_Has_Enabled_Property;
7542 -- Otherwise a property is enabled when the related object is volatile
7545 return Is_SPARK_Volatile (Item_Id);
7547 end Has_Enabled_Property;
7549 --------------------
7550 -- Has_Infinities --
7551 --------------------
7553 function Has_Infinities (E : Entity_Id) return Boolean is
7556 Is_Floating_Point_Type (E)
7557 and then Nkind (Scalar_Range (E)) = N_Range
7558 and then Includes_Infinities (Scalar_Range (E));
7561 --------------------
7562 -- Has_Interfaces --
7563 --------------------
7565 function Has_Interfaces
7567 Use_Full_View : Boolean := True) return Boolean
7569 Typ : Entity_Id := Base_Type (T);
7572 -- Handle concurrent types
7574 if Is_Concurrent_Type (Typ) then
7575 Typ := Corresponding_Record_Type (Typ);
7578 if not Present (Typ)
7579 or else not Is_Record_Type (Typ)
7580 or else not Is_Tagged_Type (Typ)
7585 -- Handle private types
7588 and then Present (Full_View (Typ))
7590 Typ := Full_View (Typ);
7593 -- Handle concurrent record types
7595 if Is_Concurrent_Record_Type (Typ)
7596 and then Is_Non_Empty_List (Abstract_Interface_List (Typ))
7602 if Is_Interface (Typ)
7604 (Is_Record_Type (Typ)
7605 and then Present (Interfaces (Typ))
7606 and then not Is_Empty_Elmt_List (Interfaces (Typ)))
7611 exit when Etype (Typ) = Typ
7613 -- Handle private types
7615 or else (Present (Full_View (Etype (Typ)))
7616 and then Full_View (Etype (Typ)) = Typ)
7618 -- Protect the frontend against wrong source with cyclic
7621 or else Etype (Typ) = T;
7623 -- Climb to the ancestor type handling private types
7625 if Present (Full_View (Etype (Typ))) then
7626 Typ := Full_View (Etype (Typ));
7635 ---------------------------------
7636 -- Has_No_Obvious_Side_Effects --
7637 ---------------------------------
7639 function Has_No_Obvious_Side_Effects (N : Node_Id) return Boolean is
7641 -- For now, just handle literals, constants, and non-volatile
7642 -- variables and expressions combining these with operators or
7643 -- short circuit forms.
7645 if Nkind (N) in N_Numeric_Or_String_Literal then
7648 elsif Nkind (N) = N_Character_Literal then
7651 elsif Nkind (N) in N_Unary_Op then
7652 return Has_No_Obvious_Side_Effects (Right_Opnd (N));
7654 elsif Nkind (N) in N_Binary_Op or else Nkind (N) in N_Short_Circuit then
7655 return Has_No_Obvious_Side_Effects (Left_Opnd (N))
7657 Has_No_Obvious_Side_Effects (Right_Opnd (N));
7659 elsif Nkind (N) = N_Expression_With_Actions
7661 Is_Empty_List (Actions (N))
7663 return Has_No_Obvious_Side_Effects (Expression (N));
7665 elsif Nkind (N) in N_Has_Entity then
7666 return Present (Entity (N))
7667 and then Ekind_In (Entity (N), E_Variable,
7669 E_Enumeration_Literal,
7673 and then not Is_Volatile (Entity (N));
7678 end Has_No_Obvious_Side_Effects;
7680 ------------------------
7681 -- Has_Null_Exclusion --
7682 ------------------------
7684 function Has_Null_Exclusion (N : Node_Id) return Boolean is
7687 when N_Access_Definition |
7688 N_Access_Function_Definition |
7689 N_Access_Procedure_Definition |
7690 N_Access_To_Object_Definition |
7692 N_Derived_Type_Definition |
7693 N_Function_Specification |
7694 N_Subtype_Declaration =>
7695 return Null_Exclusion_Present (N);
7697 when N_Component_Definition |
7698 N_Formal_Object_Declaration |
7699 N_Object_Renaming_Declaration =>
7700 if Present (Subtype_Mark (N)) then
7701 return Null_Exclusion_Present (N);
7702 else pragma Assert (Present (Access_Definition (N)));
7703 return Null_Exclusion_Present (Access_Definition (N));
7706 when N_Discriminant_Specification =>
7707 if Nkind (Discriminant_Type (N)) = N_Access_Definition then
7708 return Null_Exclusion_Present (Discriminant_Type (N));
7710 return Null_Exclusion_Present (N);
7713 when N_Object_Declaration =>
7714 if Nkind (Object_Definition (N)) = N_Access_Definition then
7715 return Null_Exclusion_Present (Object_Definition (N));
7717 return Null_Exclusion_Present (N);
7720 when N_Parameter_Specification =>
7721 if Nkind (Parameter_Type (N)) = N_Access_Definition then
7722 return Null_Exclusion_Present (Parameter_Type (N));
7724 return Null_Exclusion_Present (N);
7731 end Has_Null_Exclusion;
7733 ------------------------
7734 -- Has_Null_Extension --
7735 ------------------------
7737 function Has_Null_Extension (T : Entity_Id) return Boolean is
7738 B : constant Entity_Id := Base_Type (T);
7743 if Nkind (Parent (B)) = N_Full_Type_Declaration
7744 and then Present (Record_Extension_Part (Type_Definition (Parent (B))))
7746 Ext := Record_Extension_Part (Type_Definition (Parent (B)));
7748 if Present (Ext) then
7749 if Null_Present (Ext) then
7752 Comps := Component_List (Ext);
7754 -- The null component list is rewritten during analysis to
7755 -- include the parent component. Any other component indicates
7756 -- that the extension was not originally null.
7758 return Null_Present (Comps)
7759 or else No (Next (First (Component_Items (Comps))));
7768 end Has_Null_Extension;
7770 -------------------------------
7771 -- Has_Overriding_Initialize --
7772 -------------------------------
7774 function Has_Overriding_Initialize (T : Entity_Id) return Boolean is
7775 BT : constant Entity_Id := Base_Type (T);
7779 if Is_Controlled (BT) then
7780 if Is_RTU (Scope (BT), Ada_Finalization) then
7783 elsif Present (Primitive_Operations (BT)) then
7784 P := First_Elmt (Primitive_Operations (BT));
7785 while Present (P) loop
7787 Init : constant Entity_Id := Node (P);
7788 Formal : constant Entity_Id := First_Formal (Init);
7790 if Ekind (Init) = E_Procedure
7791 and then Chars (Init) = Name_Initialize
7792 and then Comes_From_Source (Init)
7793 and then Present (Formal)
7794 and then Etype (Formal) = BT
7795 and then No (Next_Formal (Formal))
7796 and then (Ada_Version < Ada_2012
7797 or else not Null_Present (Parent (Init)))
7807 -- Here if type itself does not have a non-null Initialize operation:
7808 -- check immediate ancestor.
7810 if Is_Derived_Type (BT)
7811 and then Has_Overriding_Initialize (Etype (BT))
7818 end Has_Overriding_Initialize;
7820 --------------------------------------
7821 -- Has_Preelaborable_Initialization --
7822 --------------------------------------
7824 function Has_Preelaborable_Initialization (E : Entity_Id) return Boolean is
7827 procedure Check_Components (E : Entity_Id);
7828 -- Check component/discriminant chain, sets Has_PE False if a component
7829 -- or discriminant does not meet the preelaborable initialization rules.
7831 ----------------------
7832 -- Check_Components --
7833 ----------------------
7835 procedure Check_Components (E : Entity_Id) is
7839 function Is_Preelaborable_Expression (N : Node_Id) return Boolean;
7840 -- Returns True if and only if the expression denoted by N does not
7841 -- violate restrictions on preelaborable constructs (RM-10.2.1(5-9)).
7843 ---------------------------------
7844 -- Is_Preelaborable_Expression --
7845 ---------------------------------
7847 function Is_Preelaborable_Expression (N : Node_Id) return Boolean is
7851 Comp_Type : Entity_Id;
7852 Is_Array_Aggr : Boolean;
7855 if Is_Static_Expression (N) then
7858 elsif Nkind (N) = N_Null then
7861 -- Attributes are allowed in general, even if their prefix is a
7862 -- formal type. (It seems that certain attributes known not to be
7863 -- static might not be allowed, but there are no rules to prevent
7866 elsif Nkind (N) = N_Attribute_Reference then
7869 -- The name of a discriminant evaluated within its parent type is
7870 -- defined to be preelaborable (10.2.1(8)). Note that we test for
7871 -- names that denote discriminals as well as discriminants to
7872 -- catch references occurring within init procs.
7874 elsif Is_Entity_Name (N)
7876 (Ekind (Entity (N)) = E_Discriminant
7878 ((Ekind (Entity (N)) = E_Constant
7879 or else Ekind (Entity (N)) = E_In_Parameter)
7880 and then Present (Discriminal_Link (Entity (N)))))
7884 elsif Nkind (N) = N_Qualified_Expression then
7885 return Is_Preelaborable_Expression (Expression (N));
7887 -- For aggregates we have to check that each of the associations
7888 -- is preelaborable.
7890 elsif Nkind (N) = N_Aggregate
7891 or else Nkind (N) = N_Extension_Aggregate
7893 Is_Array_Aggr := Is_Array_Type (Etype (N));
7895 if Is_Array_Aggr then
7896 Comp_Type := Component_Type (Etype (N));
7899 -- Check the ancestor part of extension aggregates, which must
7900 -- be either the name of a type that has preelaborable init or
7901 -- an expression that is preelaborable.
7903 if Nkind (N) = N_Extension_Aggregate then
7905 Anc_Part : constant Node_Id := Ancestor_Part (N);
7908 if Is_Entity_Name (Anc_Part)
7909 and then Is_Type (Entity (Anc_Part))
7911 if not Has_Preelaborable_Initialization
7917 elsif not Is_Preelaborable_Expression (Anc_Part) then
7923 -- Check positional associations
7925 Exp := First (Expressions (N));
7926 while Present (Exp) loop
7927 if not Is_Preelaborable_Expression (Exp) then
7934 -- Check named associations
7936 Assn := First (Component_Associations (N));
7937 while Present (Assn) loop
7938 Choice := First (Choices (Assn));
7939 while Present (Choice) loop
7940 if Is_Array_Aggr then
7941 if Nkind (Choice) = N_Others_Choice then
7944 elsif Nkind (Choice) = N_Range then
7945 if not Is_Static_Range (Choice) then
7949 elsif not Is_Static_Expression (Choice) then
7954 Comp_Type := Etype (Choice);
7960 -- If the association has a <> at this point, then we have
7961 -- to check whether the component's type has preelaborable
7962 -- initialization. Note that this only occurs when the
7963 -- association's corresponding component does not have a
7964 -- default expression, the latter case having already been
7965 -- expanded as an expression for the association.
7967 if Box_Present (Assn) then
7968 if not Has_Preelaborable_Initialization (Comp_Type) then
7972 -- In the expression case we check whether the expression
7973 -- is preelaborable.
7976 not Is_Preelaborable_Expression (Expression (Assn))
7984 -- If we get here then aggregate as a whole is preelaborable
7988 -- All other cases are not preelaborable
7993 end Is_Preelaborable_Expression;
7995 -- Start of processing for Check_Components
7998 -- Loop through entities of record or protected type
8001 while Present (Ent) loop
8003 -- We are interested only in components and discriminants
8010 -- Get default expression if any. If there is no declaration
8011 -- node, it means we have an internal entity. The parent and
8012 -- tag fields are examples of such entities. For such cases,
8013 -- we just test the type of the entity.
8015 if Present (Declaration_Node (Ent)) then
8016 Exp := Expression (Declaration_Node (Ent));
8019 when E_Discriminant =>
8021 -- Note: for a renamed discriminant, the Declaration_Node
8022 -- may point to the one from the ancestor, and have a
8023 -- different expression, so use the proper attribute to
8024 -- retrieve the expression from the derived constraint.
8026 Exp := Discriminant_Default_Value (Ent);
8029 goto Check_Next_Entity;
8032 -- A component has PI if it has no default expression and the
8033 -- component type has PI.
8036 if not Has_Preelaborable_Initialization (Etype (Ent)) then
8041 -- Require the default expression to be preelaborable
8043 elsif not Is_Preelaborable_Expression (Exp) then
8048 <<Check_Next_Entity>>
8051 end Check_Components;
8053 -- Start of processing for Has_Preelaborable_Initialization
8056 -- Immediate return if already marked as known preelaborable init. This
8057 -- covers types for which this function has already been called once
8058 -- and returned True (in which case the result is cached), and also
8059 -- types to which a pragma Preelaborable_Initialization applies.
8061 if Known_To_Have_Preelab_Init (E) then
8065 -- If the type is a subtype representing a generic actual type, then
8066 -- test whether its base type has preelaborable initialization since
8067 -- the subtype representing the actual does not inherit this attribute
8068 -- from the actual or formal. (but maybe it should???)
8070 if Is_Generic_Actual_Type (E) then
8071 return Has_Preelaborable_Initialization (Base_Type (E));
8074 -- All elementary types have preelaborable initialization
8076 if Is_Elementary_Type (E) then
8079 -- Array types have PI if the component type has PI
8081 elsif Is_Array_Type (E) then
8082 Has_PE := Has_Preelaborable_Initialization (Component_Type (E));
8084 -- A derived type has preelaborable initialization if its parent type
8085 -- has preelaborable initialization and (in the case of a derived record
8086 -- extension) if the non-inherited components all have preelaborable
8087 -- initialization. However, a user-defined controlled type with an
8088 -- overriding Initialize procedure does not have preelaborable
8091 elsif Is_Derived_Type (E) then
8093 -- If the derived type is a private extension then it doesn't have
8094 -- preelaborable initialization.
8096 if Ekind (Base_Type (E)) = E_Record_Type_With_Private then
8100 -- First check whether ancestor type has preelaborable initialization
8102 Has_PE := Has_Preelaborable_Initialization (Etype (Base_Type (E)));
8104 -- If OK, check extension components (if any)
8106 if Has_PE and then Is_Record_Type (E) then
8107 Check_Components (First_Entity (E));
8110 -- Check specifically for 10.2.1(11.4/2) exception: a controlled type
8111 -- with a user defined Initialize procedure does not have PI.
8114 and then Is_Controlled (E)
8115 and then Has_Overriding_Initialize (E)
8120 -- Private types not derived from a type having preelaborable init and
8121 -- that are not marked with pragma Preelaborable_Initialization do not
8122 -- have preelaborable initialization.
8124 elsif Is_Private_Type (E) then
8127 -- Record type has PI if it is non private and all components have PI
8129 elsif Is_Record_Type (E) then
8131 Check_Components (First_Entity (E));
8133 -- Protected types must not have entries, and components must meet
8134 -- same set of rules as for record components.
8136 elsif Is_Protected_Type (E) then
8137 if Has_Entries (E) then
8141 Check_Components (First_Entity (E));
8142 Check_Components (First_Private_Entity (E));
8145 -- Type System.Address always has preelaborable initialization
8147 elsif Is_RTE (E, RE_Address) then
8150 -- In all other cases, type does not have preelaborable initialization
8156 -- If type has preelaborable initialization, cache result
8159 Set_Known_To_Have_Preelab_Init (E);
8163 end Has_Preelaborable_Initialization;
8165 ---------------------------
8166 -- Has_Private_Component --
8167 ---------------------------
8169 function Has_Private_Component (Type_Id : Entity_Id) return Boolean is
8170 Btype : Entity_Id := Base_Type (Type_Id);
8171 Component : Entity_Id;
8174 if Error_Posted (Type_Id)
8175 or else Error_Posted (Btype)
8180 if Is_Class_Wide_Type (Btype) then
8181 Btype := Root_Type (Btype);
8184 if Is_Private_Type (Btype) then
8186 UT : constant Entity_Id := Underlying_Type (Btype);
8189 if No (Full_View (Btype)) then
8190 return not Is_Generic_Type (Btype)
8191 and then not Is_Generic_Type (Root_Type (Btype));
8193 return not Is_Generic_Type (Root_Type (Full_View (Btype)));
8196 return not Is_Frozen (UT) and then Has_Private_Component (UT);
8200 elsif Is_Array_Type (Btype) then
8201 return Has_Private_Component (Component_Type (Btype));
8203 elsif Is_Record_Type (Btype) then
8204 Component := First_Component (Btype);
8205 while Present (Component) loop
8206 if Has_Private_Component (Etype (Component)) then
8210 Next_Component (Component);
8215 elsif Is_Protected_Type (Btype)
8216 and then Present (Corresponding_Record_Type (Btype))
8218 return Has_Private_Component (Corresponding_Record_Type (Btype));
8223 end Has_Private_Component;
8225 ----------------------
8226 -- Has_Signed_Zeros --
8227 ----------------------
8229 function Has_Signed_Zeros (E : Entity_Id) return Boolean is
8231 return Is_Floating_Point_Type (E)
8232 and then Signed_Zeros_On_Target
8233 and then not Vax_Float (E);
8234 end Has_Signed_Zeros;
8236 -----------------------------
8237 -- Has_Static_Array_Bounds --
8238 -----------------------------
8240 function Has_Static_Array_Bounds (Typ : Node_Id) return Boolean is
8241 Ndims : constant Nat := Number_Dimensions (Typ);
8248 -- Unconstrained types do not have static bounds
8250 if not Is_Constrained (Typ) then
8254 -- First treat string literals specially, as the lower bound and length
8255 -- of string literals are not stored like those of arrays.
8257 -- A string literal always has static bounds
8259 if Ekind (Typ) = E_String_Literal_Subtype then
8263 -- Treat all dimensions in turn
8265 Index := First_Index (Typ);
8266 for Indx in 1 .. Ndims loop
8268 -- In case of an illegal index which is not a discrete type, return
8269 -- that the type is not static.
8271 if not Is_Discrete_Type (Etype (Index))
8272 or else Etype (Index) = Any_Type
8277 Get_Index_Bounds (Index, Low, High);
8279 if Error_Posted (Low) or else Error_Posted (High) then
8283 if Is_OK_Static_Expression (Low)
8285 Is_OK_Static_Expression (High)
8295 -- If we fall through the loop, all indexes matched
8298 end Has_Static_Array_Bounds;
8304 function Has_Stream (T : Entity_Id) return Boolean is
8311 elsif Is_RTE (Root_Type (T), RE_Root_Stream_Type) then
8314 elsif Is_Array_Type (T) then
8315 return Has_Stream (Component_Type (T));
8317 elsif Is_Record_Type (T) then
8318 E := First_Component (T);
8319 while Present (E) loop
8320 if Has_Stream (Etype (E)) then
8329 elsif Is_Private_Type (T) then
8330 return Has_Stream (Underlying_Type (T));
8341 function Has_Suffix (E : Entity_Id; Suffix : Character) return Boolean is
8343 Get_Name_String (Chars (E));
8344 return Name_Buffer (Name_Len) = Suffix;
8351 function Add_Suffix (E : Entity_Id; Suffix : Character) return Name_Id is
8353 Get_Name_String (Chars (E));
8354 Add_Char_To_Name_Buffer (Suffix);
8362 function Remove_Suffix (E : Entity_Id; Suffix : Character) return Name_Id is
8364 pragma Assert (Has_Suffix (E, Suffix));
8365 Get_Name_String (Chars (E));
8366 Name_Len := Name_Len - 1;
8370 --------------------------
8371 -- Has_Tagged_Component --
8372 --------------------------
8374 function Has_Tagged_Component (Typ : Entity_Id) return Boolean is
8378 if Is_Private_Type (Typ)
8379 and then Present (Underlying_Type (Typ))
8381 return Has_Tagged_Component (Underlying_Type (Typ));
8383 elsif Is_Array_Type (Typ) then
8384 return Has_Tagged_Component (Component_Type (Typ));
8386 elsif Is_Tagged_Type (Typ) then
8389 elsif Is_Record_Type (Typ) then
8390 Comp := First_Component (Typ);
8391 while Present (Comp) loop
8392 if Has_Tagged_Component (Etype (Comp)) then
8396 Next_Component (Comp);
8404 end Has_Tagged_Component;
8406 ----------------------------
8407 -- Has_Volatile_Component --
8408 ----------------------------
8410 function Has_Volatile_Component (Typ : Entity_Id) return Boolean is
8414 if Has_Volatile_Components (Typ) then
8417 elsif Is_Array_Type (Typ) then
8418 return Is_Volatile (Component_Type (Typ));
8420 elsif Is_Record_Type (Typ) then
8421 Comp := First_Component (Typ);
8422 while Present (Comp) loop
8423 if Is_Volatile_Object (Comp) then
8427 Comp := Next_Component (Comp);
8432 end Has_Volatile_Component;
8434 -------------------------
8435 -- Implementation_Kind --
8436 -------------------------
8438 function Implementation_Kind (Subp : Entity_Id) return Name_Id is
8439 Impl_Prag : constant Node_Id := Get_Rep_Pragma (Subp, Name_Implemented);
8442 pragma Assert (Present (Impl_Prag));
8443 Arg := Last (Pragma_Argument_Associations (Impl_Prag));
8444 return Chars (Get_Pragma_Arg (Arg));
8445 end Implementation_Kind;
8447 --------------------------
8448 -- Implements_Interface --
8449 --------------------------
8451 function Implements_Interface
8452 (Typ_Ent : Entity_Id;
8453 Iface_Ent : Entity_Id;
8454 Exclude_Parents : Boolean := False) return Boolean
8456 Ifaces_List : Elist_Id;
8458 Iface : Entity_Id := Base_Type (Iface_Ent);
8459 Typ : Entity_Id := Base_Type (Typ_Ent);
8462 if Is_Class_Wide_Type (Typ) then
8463 Typ := Root_Type (Typ);
8466 if not Has_Interfaces (Typ) then
8470 if Is_Class_Wide_Type (Iface) then
8471 Iface := Root_Type (Iface);
8474 Collect_Interfaces (Typ, Ifaces_List);
8476 Elmt := First_Elmt (Ifaces_List);
8477 while Present (Elmt) loop
8478 if Is_Ancestor (Node (Elmt), Typ, Use_Full_View => True)
8479 and then Exclude_Parents
8483 elsif Node (Elmt) = Iface then
8491 end Implements_Interface;
8493 ------------------------------------
8494 -- In_Assertion_Expression_Pragma --
8495 ------------------------------------
8497 function In_Assertion_Expression_Pragma (N : Node_Id) return Boolean is
8499 Prag : Node_Id := Empty;
8502 -- Climb the parent chain looking for an enclosing pragma
8505 while Present (Par) loop
8506 if Nkind (Par) = N_Pragma then
8510 -- Precondition-like pragmas are expanded into if statements, check
8511 -- the original node instead.
8513 elsif Nkind (Original_Node (Par)) = N_Pragma then
8514 Prag := Original_Node (Par);
8517 -- Prevent the search from going too far
8519 elsif Is_Body_Or_Package_Declaration (Par) then
8523 Par := Parent (Par);
8528 and then Assertion_Expression_Pragma (Get_Pragma_Id (Prag));
8529 end In_Assertion_Expression_Pragma;
8535 function In_Instance return Boolean is
8536 Curr_Unit : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
8542 and then S /= Standard_Standard
8544 if (Ekind (S) = E_Function
8545 or else Ekind (S) = E_Package
8546 or else Ekind (S) = E_Procedure)
8547 and then Is_Generic_Instance (S)
8549 -- A child instance is always compiled in the context of a parent
8550 -- instance. Nevertheless, the actuals are not analyzed in an
8551 -- instance context. We detect this case by examining the current
8552 -- compilation unit, which must be a child instance, and checking
8553 -- that it is not currently on the scope stack.
8555 if Is_Child_Unit (Curr_Unit)
8557 Nkind (Unit (Cunit (Current_Sem_Unit)))
8558 = N_Package_Instantiation
8559 and then not In_Open_Scopes (Curr_Unit)
8573 ----------------------
8574 -- In_Instance_Body --
8575 ----------------------
8577 function In_Instance_Body return Boolean is
8583 and then S /= Standard_Standard
8585 if (Ekind (S) = E_Function
8586 or else Ekind (S) = E_Procedure)
8587 and then Is_Generic_Instance (S)
8591 elsif Ekind (S) = E_Package
8592 and then In_Package_Body (S)
8593 and then Is_Generic_Instance (S)
8602 end In_Instance_Body;
8604 -----------------------------
8605 -- In_Instance_Not_Visible --
8606 -----------------------------
8608 function In_Instance_Not_Visible return Boolean is
8614 and then S /= Standard_Standard
8616 if (Ekind (S) = E_Function
8617 or else Ekind (S) = E_Procedure)
8618 and then Is_Generic_Instance (S)
8622 elsif Ekind (S) = E_Package
8623 and then (In_Package_Body (S) or else In_Private_Part (S))
8624 and then Is_Generic_Instance (S)
8633 end In_Instance_Not_Visible;
8635 ------------------------------
8636 -- In_Instance_Visible_Part --
8637 ------------------------------
8639 function In_Instance_Visible_Part return Boolean is
8645 and then S /= Standard_Standard
8647 if Ekind (S) = E_Package
8648 and then Is_Generic_Instance (S)
8649 and then not In_Package_Body (S)
8650 and then not In_Private_Part (S)
8659 end In_Instance_Visible_Part;
8661 ---------------------
8662 -- In_Package_Body --
8663 ---------------------
8665 function In_Package_Body return Boolean is
8671 and then S /= Standard_Standard
8673 if Ekind (S) = E_Package
8674 and then In_Package_Body (S)
8683 end In_Package_Body;
8685 --------------------------------
8686 -- In_Parameter_Specification --
8687 --------------------------------
8689 function In_Parameter_Specification (N : Node_Id) return Boolean is
8694 while Present (PN) loop
8695 if Nkind (PN) = N_Parameter_Specification then
8703 end In_Parameter_Specification;
8705 --------------------------
8706 -- In_Pragma_Expression --
8707 --------------------------
8709 function In_Pragma_Expression (N : Node_Id; Nam : Name_Id) return Boolean is
8716 elsif Nkind (P) = N_Pragma and then Pragma_Name (P) = Nam then
8722 end In_Pragma_Expression;
8724 -------------------------------------
8725 -- In_Reverse_Storage_Order_Object --
8726 -------------------------------------
8728 function In_Reverse_Storage_Order_Object (N : Node_Id) return Boolean is
8730 Btyp : Entity_Id := Empty;
8733 -- Climb up indexed components
8737 case Nkind (Pref) is
8738 when N_Selected_Component =>
8739 Pref := Prefix (Pref);
8742 when N_Indexed_Component =>
8743 Pref := Prefix (Pref);
8751 if Present (Pref) then
8752 Btyp := Base_Type (Etype (Pref));
8757 and then (Is_Record_Type (Btyp) or else Is_Array_Type (Btyp))
8758 and then Reverse_Storage_Order (Btyp);
8759 end In_Reverse_Storage_Order_Object;
8761 --------------------------------------
8762 -- In_Subprogram_Or_Concurrent_Unit --
8763 --------------------------------------
8765 function In_Subprogram_Or_Concurrent_Unit return Boolean is
8770 -- Use scope chain to check successively outer scopes
8776 if K in Subprogram_Kind
8777 or else K in Concurrent_Kind
8778 or else K in Generic_Subprogram_Kind
8782 elsif E = Standard_Standard then
8788 end In_Subprogram_Or_Concurrent_Unit;
8790 ---------------------
8791 -- In_Visible_Part --
8792 ---------------------
8794 function In_Visible_Part (Scope_Id : Entity_Id) return Boolean is
8797 Is_Package_Or_Generic_Package (Scope_Id)
8798 and then In_Open_Scopes (Scope_Id)
8799 and then not In_Package_Body (Scope_Id)
8800 and then not In_Private_Part (Scope_Id);
8801 end In_Visible_Part;
8803 --------------------------------
8804 -- Incomplete_Or_Private_View --
8805 --------------------------------
8807 function Incomplete_Or_Private_View (Typ : Entity_Id) return Entity_Id is
8808 function Inspect_Decls
8810 Taft : Boolean := False) return Entity_Id;
8811 -- Check whether a declarative region contains the incomplete or private
8818 function Inspect_Decls
8820 Taft : Boolean := False) return Entity_Id
8826 Decl := First (Decls);
8827 while Present (Decl) loop
8831 if Nkind (Decl) = N_Incomplete_Type_Declaration then
8832 Match := Defining_Identifier (Decl);
8836 if Nkind_In (Decl, N_Private_Extension_Declaration,
8837 N_Private_Type_Declaration)
8839 Match := Defining_Identifier (Decl);
8844 and then Present (Full_View (Match))
8845 and then Full_View (Match) = Typ
8860 -- Start of processing for Incomplete_Or_Partial_View
8863 -- Incomplete type case
8865 Prev := Current_Entity_In_Scope (Typ);
8868 and then Is_Incomplete_Type (Prev)
8869 and then Present (Full_View (Prev))
8870 and then Full_View (Prev) = Typ
8875 -- Private or Taft amendment type case
8878 Pkg : constant Entity_Id := Scope (Typ);
8879 Pkg_Decl : Node_Id := Pkg;
8882 if Ekind (Pkg) = E_Package then
8883 while Nkind (Pkg_Decl) /= N_Package_Specification loop
8884 Pkg_Decl := Parent (Pkg_Decl);
8887 -- It is knows that Typ has a private view, look for it in the
8888 -- visible declarations of the enclosing scope. A special case
8889 -- of this is when the two views have been exchanged - the full
8890 -- appears earlier than the private.
8892 if Has_Private_Declaration (Typ) then
8893 Prev := Inspect_Decls (Visible_Declarations (Pkg_Decl));
8895 -- Exchanged view case, look in the private declarations
8898 Prev := Inspect_Decls (Private_Declarations (Pkg_Decl));
8903 -- Otherwise if this is the package body, then Typ is a potential
8904 -- Taft amendment type. The incomplete view should be located in
8905 -- the private declarations of the enclosing scope.
8907 elsif In_Package_Body (Pkg) then
8908 return Inspect_Decls (Private_Declarations (Pkg_Decl), True);
8913 -- The type has no incomplete or private view
8916 end Incomplete_Or_Private_View;
8918 ---------------------------------
8919 -- Insert_Explicit_Dereference --
8920 ---------------------------------
8922 procedure Insert_Explicit_Dereference (N : Node_Id) is
8923 New_Prefix : constant Node_Id := Relocate_Node (N);
8924 Ent : Entity_Id := Empty;
8931 Save_Interps (N, New_Prefix);
8934 Make_Explicit_Dereference (Sloc (Parent (N)),
8935 Prefix => New_Prefix));
8937 Set_Etype (N, Designated_Type (Etype (New_Prefix)));
8939 if Is_Overloaded (New_Prefix) then
8941 -- The dereference is also overloaded, and its interpretations are
8942 -- the designated types of the interpretations of the original node.
8944 Set_Etype (N, Any_Type);
8946 Get_First_Interp (New_Prefix, I, It);
8947 while Present (It.Nam) loop
8950 if Is_Access_Type (T) then
8951 Add_One_Interp (N, Designated_Type (T), Designated_Type (T));
8954 Get_Next_Interp (I, It);
8960 -- Prefix is unambiguous: mark the original prefix (which might
8961 -- Come_From_Source) as a reference, since the new (relocated) one
8962 -- won't be taken into account.
8964 if Is_Entity_Name (New_Prefix) then
8965 Ent := Entity (New_Prefix);
8968 -- For a retrieval of a subcomponent of some composite object,
8969 -- retrieve the ultimate entity if there is one.
8971 elsif Nkind (New_Prefix) = N_Selected_Component
8972 or else Nkind (New_Prefix) = N_Indexed_Component
8974 Pref := Prefix (New_Prefix);
8975 while Present (Pref)
8977 (Nkind (Pref) = N_Selected_Component
8978 or else Nkind (Pref) = N_Indexed_Component)
8980 Pref := Prefix (Pref);
8983 if Present (Pref) and then Is_Entity_Name (Pref) then
8984 Ent := Entity (Pref);
8988 -- Place the reference on the entity node
8990 if Present (Ent) then
8991 Generate_Reference (Ent, Pref);
8994 end Insert_Explicit_Dereference;
8996 ------------------------------------------
8997 -- Inspect_Deferred_Constant_Completion --
8998 ------------------------------------------
9000 procedure Inspect_Deferred_Constant_Completion (Decls : List_Id) is
9004 Decl := First (Decls);
9005 while Present (Decl) loop
9007 -- Deferred constant signature
9009 if Nkind (Decl) = N_Object_Declaration
9010 and then Constant_Present (Decl)
9011 and then No (Expression (Decl))
9013 -- No need to check internally generated constants
9015 and then Comes_From_Source (Decl)
9017 -- The constant is not completed. A full object declaration or a
9018 -- pragma Import complete a deferred constant.
9020 and then not Has_Completion (Defining_Identifier (Decl))
9023 ("constant declaration requires initialization expression",
9024 Defining_Identifier (Decl));
9027 Decl := Next (Decl);
9029 end Inspect_Deferred_Constant_Completion;
9031 -----------------------------
9032 -- Is_Actual_Out_Parameter --
9033 -----------------------------
9035 function Is_Actual_Out_Parameter (N : Node_Id) return Boolean is
9039 Find_Actual (N, Formal, Call);
9040 return Present (Formal) and then Ekind (Formal) = E_Out_Parameter;
9041 end Is_Actual_Out_Parameter;
9043 -------------------------
9044 -- Is_Actual_Parameter --
9045 -------------------------
9047 function Is_Actual_Parameter (N : Node_Id) return Boolean is
9048 PK : constant Node_Kind := Nkind (Parent (N));
9052 when N_Parameter_Association =>
9053 return N = Explicit_Actual_Parameter (Parent (N));
9055 when N_Subprogram_Call =>
9056 return Is_List_Member (N)
9058 List_Containing (N) = Parameter_Associations (Parent (N));
9063 end Is_Actual_Parameter;
9065 --------------------------------
9066 -- Is_Actual_Tagged_Parameter --
9067 --------------------------------
9069 function Is_Actual_Tagged_Parameter (N : Node_Id) return Boolean is
9073 Find_Actual (N, Formal, Call);
9074 return Present (Formal) and then Is_Tagged_Type (Etype (Formal));
9075 end Is_Actual_Tagged_Parameter;
9077 ---------------------
9078 -- Is_Aliased_View --
9079 ---------------------
9081 function Is_Aliased_View (Obj : Node_Id) return Boolean is
9085 if Is_Entity_Name (Obj) then
9092 or else (Present (Renamed_Object (E))
9093 and then Is_Aliased_View (Renamed_Object (E)))))
9095 or else ((Is_Formal (E)
9096 or else Ekind (E) = E_Generic_In_Out_Parameter
9097 or else Ekind (E) = E_Generic_In_Parameter)
9098 and then Is_Tagged_Type (Etype (E)))
9100 or else (Is_Concurrent_Type (E) and then In_Open_Scopes (E))
9102 -- Current instance of type, either directly or as rewritten
9103 -- reference to the current object.
9105 or else (Is_Entity_Name (Original_Node (Obj))
9106 and then Present (Entity (Original_Node (Obj)))
9107 and then Is_Type (Entity (Original_Node (Obj))))
9109 or else (Is_Type (E) and then E = Current_Scope)
9111 or else (Is_Incomplete_Or_Private_Type (E)
9112 and then Full_View (E) = Current_Scope)
9114 -- Ada 2012 AI05-0053: the return object of an extended return
9115 -- statement is aliased if its type is immutably limited.
9117 or else (Is_Return_Object (E)
9118 and then Is_Limited_View (Etype (E)));
9120 elsif Nkind (Obj) = N_Selected_Component then
9121 return Is_Aliased (Entity (Selector_Name (Obj)));
9123 elsif Nkind (Obj) = N_Indexed_Component then
9124 return Has_Aliased_Components (Etype (Prefix (Obj)))
9126 (Is_Access_Type (Etype (Prefix (Obj)))
9127 and then Has_Aliased_Components
9128 (Designated_Type (Etype (Prefix (Obj)))));
9130 elsif Nkind_In (Obj, N_Unchecked_Type_Conversion, N_Type_Conversion) then
9131 return Is_Tagged_Type (Etype (Obj))
9132 and then Is_Aliased_View (Expression (Obj));
9134 elsif Nkind (Obj) = N_Explicit_Dereference then
9135 return Nkind (Original_Node (Obj)) /= N_Function_Call;
9140 end Is_Aliased_View;
9142 -------------------------
9143 -- Is_Ancestor_Package --
9144 -------------------------
9146 function Is_Ancestor_Package
9148 E2 : Entity_Id) return Boolean
9155 and then Par /= Standard_Standard
9165 end Is_Ancestor_Package;
9167 ----------------------
9168 -- Is_Atomic_Object --
9169 ----------------------
9171 function Is_Atomic_Object (N : Node_Id) return Boolean is
9173 function Object_Has_Atomic_Components (N : Node_Id) return Boolean;
9174 -- Determines if given object has atomic components
9176 function Is_Atomic_Prefix (N : Node_Id) return Boolean;
9177 -- If prefix is an implicit dereference, examine designated type
9179 ----------------------
9180 -- Is_Atomic_Prefix --
9181 ----------------------
9183 function Is_Atomic_Prefix (N : Node_Id) return Boolean is
9185 if Is_Access_Type (Etype (N)) then
9187 Has_Atomic_Components (Designated_Type (Etype (N)));
9189 return Object_Has_Atomic_Components (N);
9191 end Is_Atomic_Prefix;
9193 ----------------------------------
9194 -- Object_Has_Atomic_Components --
9195 ----------------------------------
9197 function Object_Has_Atomic_Components (N : Node_Id) return Boolean is
9199 if Has_Atomic_Components (Etype (N))
9200 or else Is_Atomic (Etype (N))
9204 elsif Is_Entity_Name (N)
9205 and then (Has_Atomic_Components (Entity (N))
9206 or else Is_Atomic (Entity (N)))
9210 elsif Nkind (N) = N_Selected_Component
9211 and then Is_Atomic (Entity (Selector_Name (N)))
9215 elsif Nkind (N) = N_Indexed_Component
9216 or else Nkind (N) = N_Selected_Component
9218 return Is_Atomic_Prefix (Prefix (N));
9223 end Object_Has_Atomic_Components;
9225 -- Start of processing for Is_Atomic_Object
9228 -- Predicate is not relevant to subprograms
9230 if Is_Entity_Name (N) and then Is_Overloadable (Entity (N)) then
9233 elsif Is_Atomic (Etype (N))
9234 or else (Is_Entity_Name (N) and then Is_Atomic (Entity (N)))
9238 elsif Nkind (N) = N_Selected_Component
9239 and then Is_Atomic (Entity (Selector_Name (N)))
9243 elsif Nkind (N) = N_Indexed_Component
9244 or else Nkind (N) = N_Selected_Component
9246 return Is_Atomic_Prefix (Prefix (N));
9251 end Is_Atomic_Object;
9253 -------------------------
9254 -- Is_Attribute_Result --
9255 -------------------------
9257 function Is_Attribute_Result (N : Node_Id) return Boolean is
9260 Nkind (N) = N_Attribute_Reference
9261 and then Attribute_Name (N) = Name_Result;
9262 end Is_Attribute_Result;
9264 ------------------------------------
9265 -- Is_Body_Or_Package_Declaration --
9266 ------------------------------------
9268 function Is_Body_Or_Package_Declaration (N : Node_Id) return Boolean is
9270 return Nkind_In (N, N_Entry_Body,
9272 N_Package_Declaration,
9276 end Is_Body_Or_Package_Declaration;
9278 -----------------------
9279 -- Is_Bounded_String --
9280 -----------------------
9282 function Is_Bounded_String (T : Entity_Id) return Boolean is
9283 Under : constant Entity_Id := Underlying_Type (Root_Type (T));
9286 -- Check whether T is ultimately derived from Ada.Strings.Superbounded.
9287 -- Super_String, or one of the [Wide_]Wide_ versions. This will
9288 -- be True for all the Bounded_String types in instances of the
9289 -- Generic_Bounded_Length generics, and for types derived from those.
9291 return Present (Under)
9292 and then (Is_RTE (Root_Type (Under), RO_SU_Super_String) or else
9293 Is_RTE (Root_Type (Under), RO_WI_Super_String) or else
9294 Is_RTE (Root_Type (Under), RO_WW_Super_String));
9295 end Is_Bounded_String;
9297 -------------------------
9298 -- Is_Child_Or_Sibling --
9299 -------------------------
9301 function Is_Child_Or_Sibling
9302 (Pack_1 : Entity_Id;
9303 Pack_2 : Entity_Id) return Boolean
9305 function Distance_From_Standard (Pack : Entity_Id) return Nat;
9306 -- Given an arbitrary package, return the number of "climbs" necessary
9307 -- to reach scope Standard_Standard.
9309 procedure Equalize_Depths
9310 (Pack : in out Entity_Id;
9312 Depth_To_Reach : Nat);
9313 -- Given an arbitrary package, its depth and a target depth to reach,
9314 -- climb the scope chain until the said depth is reached. The pointer
9315 -- to the package and its depth a modified during the climb.
9317 ----------------------------
9318 -- Distance_From_Standard --
9319 ----------------------------
9321 function Distance_From_Standard (Pack : Entity_Id) return Nat is
9328 while Present (Scop) and then Scop /= Standard_Standard loop
9330 Scop := Scope (Scop);
9334 end Distance_From_Standard;
9336 ---------------------
9337 -- Equalize_Depths --
9338 ---------------------
9340 procedure Equalize_Depths
9341 (Pack : in out Entity_Id;
9343 Depth_To_Reach : Nat)
9346 -- The package must be at a greater or equal depth
9348 if Depth < Depth_To_Reach then
9349 raise Program_Error;
9352 -- Climb the scope chain until the desired depth is reached
9354 while Present (Pack) and then Depth /= Depth_To_Reach loop
9355 Pack := Scope (Pack);
9358 end Equalize_Depths;
9362 P_1 : Entity_Id := Pack_1;
9363 P_1_Child : Boolean := False;
9364 P_1_Depth : Nat := Distance_From_Standard (P_1);
9365 P_2 : Entity_Id := Pack_2;
9366 P_2_Child : Boolean := False;
9367 P_2_Depth : Nat := Distance_From_Standard (P_2);
9369 -- Start of processing for Is_Child_Or_Sibling
9373 (Ekind (Pack_1) = E_Package and then Ekind (Pack_2) = E_Package);
9375 -- Both packages denote the same entity, therefore they cannot be
9376 -- children or siblings.
9381 -- One of the packages is at a deeper level than the other. Note that
9382 -- both may still come from differen hierarchies.
9390 elsif P_1_Depth > P_2_Depth then
9394 Depth_To_Reach => P_2_Depth);
9403 elsif P_2_Depth > P_1_Depth then
9407 Depth_To_Reach => P_1_Depth);
9411 -- At this stage the package pointers have been elevated to the same
9412 -- depth. If the related entities are the same, then one package is a
9413 -- potential child of the other:
9417 -- X became P_1 P_2 or vica versa
9423 return Is_Child_Unit (Pack_1);
9425 else pragma Assert (P_2_Child);
9426 return Is_Child_Unit (Pack_2);
9429 -- The packages may come from the same package chain or from entirely
9430 -- different hierarcies. To determine this, climb the scope stack until
9431 -- a common root is found.
9433 -- (root) (root 1) (root 2)
9438 while Present (P_1) and then Present (P_2) loop
9440 -- The two packages may be siblings
9443 return Is_Child_Unit (Pack_1) and then Is_Child_Unit (Pack_2);
9452 end Is_Child_Or_Sibling;
9454 -----------------------------
9455 -- Is_Concurrent_Interface --
9456 -----------------------------
9458 function Is_Concurrent_Interface (T : Entity_Id) return Boolean is
9463 (Is_Protected_Interface (T)
9464 or else Is_Synchronized_Interface (T)
9465 or else Is_Task_Interface (T));
9466 end Is_Concurrent_Interface;
9468 ---------------------------
9469 -- Is_Container_Element --
9470 ---------------------------
9472 function Is_Container_Element (Exp : Node_Id) return Boolean is
9473 Loc : constant Source_Ptr := Sloc (Exp);
9474 Pref : constant Node_Id := Prefix (Exp);
9477 -- Call to an indexing aspect
9479 Cont_Typ : Entity_Id;
9480 -- The type of the container being accessed
9482 Elem_Typ : Entity_Id;
9485 Indexing : Entity_Id;
9487 -- Indicates that constant indexing is used, and the element is thus
9490 Ref_Typ : Entity_Id;
9491 -- The reference type returned by the indexing operation
9494 -- If C is a container, in a context that imposes the element type of
9495 -- that container, the indexing notation C (X) is rewritten as:
9497 -- Indexing (C, X).Discr.all
9499 -- where Indexing is one of the indexing aspects of the container.
9500 -- If the context does not require a reference, the construct can be
9505 -- First, verify that the construct has the proper form
9507 if not Expander_Active then
9510 elsif Nkind (Pref) /= N_Selected_Component then
9513 elsif Nkind (Prefix (Pref)) /= N_Function_Call then
9517 Call := Prefix (Pref);
9518 Ref_Typ := Etype (Call);
9521 if not Has_Implicit_Dereference (Ref_Typ)
9522 or else No (First (Parameter_Associations (Call)))
9523 or else not Is_Entity_Name (Name (Call))
9528 -- Retrieve type of container object, and its iterator aspects
9530 Cont_Typ := Etype (First (Parameter_Associations (Call)));
9531 Indexing := Find_Value_Of_Aspect (Cont_Typ, Aspect_Constant_Indexing);
9534 if No (Indexing) then
9536 -- Container should have at least one indexing operation
9540 elsif Entity (Name (Call)) /= Entity (Indexing) then
9542 -- This may be a variable indexing operation
9544 Indexing := Find_Value_Of_Aspect (Cont_Typ, Aspect_Variable_Indexing);
9547 or else Entity (Name (Call)) /= Entity (Indexing)
9556 Elem_Typ := Find_Value_Of_Aspect (Cont_Typ, Aspect_Iterator_Element);
9558 if No (Elem_Typ) or else Entity (Elem_Typ) /= Etype (Exp) then
9562 -- Check that the expression is not the target of an assignment, in
9563 -- which case the rewriting is not possible.
9565 if not Is_Const then
9573 if Nkind (Parent (Par)) = N_Assignment_Statement
9574 and then Par = Name (Parent (Par))
9578 -- A renaming produces a reference, and the transformation
9581 elsif Nkind (Parent (Par)) = N_Object_Renaming_Declaration then
9585 (Nkind (Parent (Par)), N_Function_Call,
9586 N_Procedure_Call_Statement,
9587 N_Entry_Call_Statement)
9589 -- Check that the element is not part of an actual for an
9590 -- in-out parameter.
9597 F := First_Formal (Entity (Name (Parent (Par))));
9598 A := First (Parameter_Associations (Parent (Par)));
9599 while Present (F) loop
9600 if A = Par and then Ekind (F) /= E_In_Parameter then
9609 -- E_In_Parameter in a call: element is not modified.
9614 Par := Parent (Par);
9619 -- The expression has the proper form and the context requires the
9620 -- element type. Retrieve the Element function of the container and
9621 -- rewrite the construct as a call to it.
9627 Op := First_Elmt (Primitive_Operations (Cont_Typ));
9628 while Present (Op) loop
9629 exit when Chars (Node (Op)) = Name_Element;
9638 Make_Function_Call (Loc,
9639 Name => New_Occurrence_Of (Node (Op), Loc),
9640 Parameter_Associations => Parameter_Associations (Call)));
9641 Analyze_And_Resolve (Exp, Entity (Elem_Typ));
9645 end Is_Container_Element;
9647 -----------------------
9648 -- Is_Constant_Bound --
9649 -----------------------
9651 function Is_Constant_Bound (Exp : Node_Id) return Boolean is
9653 if Compile_Time_Known_Value (Exp) then
9656 elsif Is_Entity_Name (Exp) and then Present (Entity (Exp)) then
9657 return Is_Constant_Object (Entity (Exp))
9658 or else Ekind (Entity (Exp)) = E_Enumeration_Literal;
9660 elsif Nkind (Exp) in N_Binary_Op then
9661 return Is_Constant_Bound (Left_Opnd (Exp))
9662 and then Is_Constant_Bound (Right_Opnd (Exp))
9663 and then Scope (Entity (Exp)) = Standard_Standard;
9668 end Is_Constant_Bound;
9670 --------------------------------------
9671 -- Is_Controlling_Limited_Procedure --
9672 --------------------------------------
9674 function Is_Controlling_Limited_Procedure
9675 (Proc_Nam : Entity_Id) return Boolean
9677 Param_Typ : Entity_Id := Empty;
9680 if Ekind (Proc_Nam) = E_Procedure
9681 and then Present (Parameter_Specifications (Parent (Proc_Nam)))
9683 Param_Typ := Etype (Parameter_Type (First (
9684 Parameter_Specifications (Parent (Proc_Nam)))));
9686 -- In this case where an Itype was created, the procedure call has been
9689 elsif Present (Associated_Node_For_Itype (Proc_Nam))
9690 and then Present (Original_Node (Associated_Node_For_Itype (Proc_Nam)))
9692 Present (Parameter_Associations
9693 (Associated_Node_For_Itype (Proc_Nam)))
9696 Etype (First (Parameter_Associations
9697 (Associated_Node_For_Itype (Proc_Nam))));
9700 if Present (Param_Typ) then
9702 Is_Interface (Param_Typ)
9703 and then Is_Limited_Record (Param_Typ);
9707 end Is_Controlling_Limited_Procedure;
9709 -----------------------------
9710 -- Is_CPP_Constructor_Call --
9711 -----------------------------
9713 function Is_CPP_Constructor_Call (N : Node_Id) return Boolean is
9715 return Nkind (N) = N_Function_Call
9716 and then Is_CPP_Class (Etype (Etype (N)))
9717 and then Is_Constructor (Entity (Name (N)))
9718 and then Is_Imported (Entity (Name (N)));
9719 end Is_CPP_Constructor_Call;
9725 function Is_Delegate (T : Entity_Id) return Boolean is
9726 Desig_Type : Entity_Id;
9729 if VM_Target /= CLI_Target then
9733 -- Access-to-subprograms are delegates in CIL
9735 if Ekind (T) = E_Access_Subprogram_Type then
9739 if not Is_Access_Type (T) then
9741 -- A delegate is a managed pointer. If no designated type is defined
9742 -- it means that it's not a delegate.
9747 Desig_Type := Etype (Directly_Designated_Type (T));
9749 if not Is_Tagged_Type (Desig_Type) then
9753 -- Test if the type is inherited from [mscorlib]System.Delegate
9755 while Etype (Desig_Type) /= Desig_Type loop
9756 if Chars (Scope (Desig_Type)) /= No_Name
9757 and then Is_Imported (Scope (Desig_Type))
9758 and then Get_Name_String (Chars (Scope (Desig_Type))) = "delegate"
9763 Desig_Type := Etype (Desig_Type);
9769 ----------------------------------------------
9770 -- Is_Dependent_Component_Of_Mutable_Object --
9771 ----------------------------------------------
9773 function Is_Dependent_Component_Of_Mutable_Object
9774 (Object : Node_Id) return Boolean
9776 function Is_Declared_Within_Variant (Comp : Entity_Id) return Boolean;
9777 -- Returns True if and only if Comp is declared within a variant part
9779 --------------------------------
9780 -- Is_Declared_Within_Variant --
9781 --------------------------------
9783 function Is_Declared_Within_Variant (Comp : Entity_Id) return Boolean is
9784 Comp_Decl : constant Node_Id := Parent (Comp);
9785 Comp_List : constant Node_Id := Parent (Comp_Decl);
9787 return Nkind (Parent (Comp_List)) = N_Variant;
9788 end Is_Declared_Within_Variant;
9791 Prefix_Type : Entity_Id;
9792 P_Aliased : Boolean := False;
9795 Deref : Node_Id := Object;
9796 -- Dereference node, in something like X.all.Y(2)
9798 -- Start of processing for Is_Dependent_Component_Of_Mutable_Object
9801 -- Find the dereference node if any
9803 while Nkind_In (Deref, N_Indexed_Component,
9804 N_Selected_Component,
9807 Deref := Prefix (Deref);
9810 -- Ada 2005: If we have a component or slice of a dereference,
9811 -- something like X.all.Y (2), and the type of X is access-to-constant,
9812 -- Is_Variable will return False, because it is indeed a constant
9813 -- view. But it might be a view of a variable object, so we want the
9814 -- following condition to be True in that case.
9816 if Is_Variable (Object)
9817 or else (Ada_Version >= Ada_2005
9818 and then Nkind (Deref) = N_Explicit_Dereference)
9820 if Nkind (Object) = N_Selected_Component then
9821 P := Prefix (Object);
9822 Prefix_Type := Etype (P);
9824 if Is_Entity_Name (P) then
9825 if Ekind (Entity (P)) = E_Generic_In_Out_Parameter then
9826 Prefix_Type := Base_Type (Prefix_Type);
9829 if Is_Aliased (Entity (P)) then
9833 -- A discriminant check on a selected component may be expanded
9834 -- into a dereference when removing side-effects. Recover the
9835 -- original node and its type, which may be unconstrained.
9837 elsif Nkind (P) = N_Explicit_Dereference
9838 and then not (Comes_From_Source (P))
9840 P := Original_Node (P);
9841 Prefix_Type := Etype (P);
9844 -- Check for prefix being an aliased component???
9850 -- A heap object is constrained by its initial value
9852 -- Ada 2005 (AI-363): Always assume the object could be mutable in
9853 -- the dereferenced case, since the access value might denote an
9854 -- unconstrained aliased object, whereas in Ada 95 the designated
9855 -- object is guaranteed to be constrained. A worst-case assumption
9856 -- has to apply in Ada 2005 because we can't tell at compile
9857 -- time whether the object is "constrained by its initial value"
9858 -- (despite the fact that 3.10.2(26/2) and 8.5.1(5/2) are semantic
9859 -- rules (these rules are acknowledged to need fixing).
9861 if Ada_Version < Ada_2005 then
9862 if Is_Access_Type (Prefix_Type)
9863 or else Nkind (P) = N_Explicit_Dereference
9868 else pragma Assert (Ada_Version >= Ada_2005);
9869 if Is_Access_Type (Prefix_Type) then
9871 -- If the access type is pool-specific, and there is no
9872 -- constrained partial view of the designated type, then the
9873 -- designated object is known to be constrained.
9875 if Ekind (Prefix_Type) = E_Access_Type
9876 and then not Object_Type_Has_Constrained_Partial_View
9877 (Typ => Designated_Type (Prefix_Type),
9878 Scop => Current_Scope)
9882 -- Otherwise (general access type, or there is a constrained
9883 -- partial view of the designated type), we need to check
9884 -- based on the designated type.
9887 Prefix_Type := Designated_Type (Prefix_Type);
9893 Original_Record_Component (Entity (Selector_Name (Object)));
9895 -- As per AI-0017, the renaming is illegal in a generic body, even
9896 -- if the subtype is indefinite.
9898 -- Ada 2005 (AI-363): In Ada 2005 an aliased object can be mutable
9900 if not Is_Constrained (Prefix_Type)
9901 and then (not Is_Indefinite_Subtype (Prefix_Type)
9903 (Is_Generic_Type (Prefix_Type)
9904 and then Ekind (Current_Scope) = E_Generic_Package
9905 and then In_Package_Body (Current_Scope)))
9907 and then (Is_Declared_Within_Variant (Comp)
9908 or else Has_Discriminant_Dependent_Constraint (Comp))
9909 and then (not P_Aliased or else Ada_Version >= Ada_2005)
9913 -- If the prefix is of an access type at this point, then we want
9914 -- to return False, rather than calling this function recursively
9915 -- on the access object (which itself might be a discriminant-
9916 -- dependent component of some other object, but that isn't
9917 -- relevant to checking the object passed to us). This avoids
9918 -- issuing wrong errors when compiling with -gnatc, where there
9919 -- can be implicit dereferences that have not been expanded.
9921 elsif Is_Access_Type (Etype (Prefix (Object))) then
9926 Is_Dependent_Component_Of_Mutable_Object (Prefix (Object));
9929 elsif Nkind (Object) = N_Indexed_Component
9930 or else Nkind (Object) = N_Slice
9932 return Is_Dependent_Component_Of_Mutable_Object (Prefix (Object));
9934 -- A type conversion that Is_Variable is a view conversion:
9935 -- go back to the denoted object.
9937 elsif Nkind (Object) = N_Type_Conversion then
9939 Is_Dependent_Component_Of_Mutable_Object (Expression (Object));
9944 end Is_Dependent_Component_Of_Mutable_Object;
9946 ---------------------
9947 -- Is_Dereferenced --
9948 ---------------------
9950 function Is_Dereferenced (N : Node_Id) return Boolean is
9951 P : constant Node_Id := Parent (N);
9954 (Nkind (P) = N_Selected_Component
9956 Nkind (P) = N_Explicit_Dereference
9958 Nkind (P) = N_Indexed_Component
9960 Nkind (P) = N_Slice)
9961 and then Prefix (P) = N;
9962 end Is_Dereferenced;
9964 ----------------------
9965 -- Is_Descendent_Of --
9966 ----------------------
9968 function Is_Descendent_Of (T1 : Entity_Id; T2 : Entity_Id) return Boolean is
9973 pragma Assert (Nkind (T1) in N_Entity);
9974 pragma Assert (Nkind (T2) in N_Entity);
9976 T := Base_Type (T1);
9978 -- Immediate return if the types match
9983 -- Comment needed here ???
9985 elsif Ekind (T) = E_Class_Wide_Type then
9986 return Etype (T) = T2;
9994 -- Done if we found the type we are looking for
9999 -- Done if no more derivations to check
10006 -- Following test catches error cases resulting from prev errors
10008 elsif No (Etyp) then
10011 elsif Is_Private_Type (T) and then Etyp = Full_View (T) then
10014 elsif Is_Private_Type (Etyp) and then Full_View (Etyp) = T then
10018 T := Base_Type (Etyp);
10021 end Is_Descendent_Of;
10023 ----------------------------
10024 -- Is_Expression_Function --
10025 ----------------------------
10027 function Is_Expression_Function (Subp : Entity_Id) return Boolean is
10031 if Ekind (Subp) /= E_Function then
10035 Decl := Unit_Declaration_Node (Subp);
10036 return Nkind (Decl) = N_Subprogram_Declaration
10038 (Nkind (Original_Node (Decl)) = N_Expression_Function
10040 (Present (Corresponding_Body (Decl))
10042 Nkind (Original_Node
10043 (Unit_Declaration_Node
10044 (Corresponding_Body (Decl)))) =
10045 N_Expression_Function));
10047 end Is_Expression_Function;
10053 function Is_False (U : Uint) return Boolean is
10058 ---------------------------
10059 -- Is_Fixed_Model_Number --
10060 ---------------------------
10062 function Is_Fixed_Model_Number (U : Ureal; T : Entity_Id) return Boolean is
10063 S : constant Ureal := Small_Value (T);
10064 M : Urealp.Save_Mark;
10068 R := (U = UR_Trunc (U / S) * S);
10069 Urealp.Release (M);
10071 end Is_Fixed_Model_Number;
10073 -------------------------------
10074 -- Is_Fully_Initialized_Type --
10075 -------------------------------
10077 function Is_Fully_Initialized_Type (Typ : Entity_Id) return Boolean is
10079 -- In Ada2012, a scalar type with an aspect Default_Value
10080 -- is fully initialized.
10082 if Is_Scalar_Type (Typ) then
10083 return Ada_Version >= Ada_2012 and then Has_Default_Aspect (Typ);
10085 elsif Is_Access_Type (Typ) then
10088 elsif Is_Array_Type (Typ) then
10089 if Is_Fully_Initialized_Type (Component_Type (Typ))
10090 or else (Ada_Version >= Ada_2012 and then Has_Default_Aspect (Typ))
10095 -- An interesting case, if we have a constrained type one of whose
10096 -- bounds is known to be null, then there are no elements to be
10097 -- initialized, so all the elements are initialized.
10099 if Is_Constrained (Typ) then
10102 Indx_Typ : Entity_Id;
10103 Lbd, Hbd : Node_Id;
10106 Indx := First_Index (Typ);
10107 while Present (Indx) loop
10108 if Etype (Indx) = Any_Type then
10111 -- If index is a range, use directly
10113 elsif Nkind (Indx) = N_Range then
10114 Lbd := Low_Bound (Indx);
10115 Hbd := High_Bound (Indx);
10118 Indx_Typ := Etype (Indx);
10120 if Is_Private_Type (Indx_Typ) then
10121 Indx_Typ := Full_View (Indx_Typ);
10124 if No (Indx_Typ) or else Etype (Indx_Typ) = Any_Type then
10127 Lbd := Type_Low_Bound (Indx_Typ);
10128 Hbd := Type_High_Bound (Indx_Typ);
10132 if Compile_Time_Known_Value (Lbd)
10133 and then Compile_Time_Known_Value (Hbd)
10135 if Expr_Value (Hbd) < Expr_Value (Lbd) then
10145 -- If no null indexes, then type is not fully initialized
10151 elsif Is_Record_Type (Typ) then
10152 if Has_Discriminants (Typ)
10154 Present (Discriminant_Default_Value (First_Discriminant (Typ)))
10155 and then Is_Fully_Initialized_Variant (Typ)
10160 -- We consider bounded string types to be fully initialized, because
10161 -- otherwise we get false alarms when the Data component is not
10162 -- default-initialized.
10164 if Is_Bounded_String (Typ) then
10168 -- Controlled records are considered to be fully initialized if
10169 -- there is a user defined Initialize routine. This may not be
10170 -- entirely correct, but as the spec notes, we are guessing here
10171 -- what is best from the point of view of issuing warnings.
10173 if Is_Controlled (Typ) then
10175 Utyp : constant Entity_Id := Underlying_Type (Typ);
10178 if Present (Utyp) then
10180 Init : constant Entity_Id :=
10182 (Underlying_Type (Typ), Name_Initialize));
10186 and then Comes_From_Source (Init)
10188 Is_Predefined_File_Name
10189 (File_Name (Get_Source_File_Index (Sloc (Init))))
10193 elsif Has_Null_Extension (Typ)
10195 Is_Fully_Initialized_Type
10196 (Etype (Base_Type (Typ)))
10205 -- Otherwise see if all record components are initialized
10211 Ent := First_Entity (Typ);
10212 while Present (Ent) loop
10213 if Ekind (Ent) = E_Component
10214 and then (No (Parent (Ent))
10215 or else No (Expression (Parent (Ent))))
10216 and then not Is_Fully_Initialized_Type (Etype (Ent))
10218 -- Special VM case for tag components, which need to be
10219 -- defined in this case, but are never initialized as VMs
10220 -- are using other dispatching mechanisms. Ignore this
10221 -- uninitialized case. Note that this applies both to the
10222 -- uTag entry and the main vtable pointer (CPP_Class case).
10224 and then (Tagged_Type_Expansion or else not Is_Tag (Ent))
10233 -- No uninitialized components, so type is fully initialized.
10234 -- Note that this catches the case of no components as well.
10238 elsif Is_Concurrent_Type (Typ) then
10241 elsif Is_Private_Type (Typ) then
10243 U : constant Entity_Id := Underlying_Type (Typ);
10249 return Is_Fully_Initialized_Type (U);
10256 end Is_Fully_Initialized_Type;
10258 ----------------------------------
10259 -- Is_Fully_Initialized_Variant --
10260 ----------------------------------
10262 function Is_Fully_Initialized_Variant (Typ : Entity_Id) return Boolean is
10263 Loc : constant Source_Ptr := Sloc (Typ);
10264 Constraints : constant List_Id := New_List;
10265 Components : constant Elist_Id := New_Elmt_List;
10266 Comp_Elmt : Elmt_Id;
10268 Comp_List : Node_Id;
10270 Discr_Val : Node_Id;
10272 Report_Errors : Boolean;
10273 pragma Warnings (Off, Report_Errors);
10276 if Serious_Errors_Detected > 0 then
10280 if Is_Record_Type (Typ)
10281 and then Nkind (Parent (Typ)) = N_Full_Type_Declaration
10282 and then Nkind (Type_Definition (Parent (Typ))) = N_Record_Definition
10284 Comp_List := Component_List (Type_Definition (Parent (Typ)));
10286 Discr := First_Discriminant (Typ);
10287 while Present (Discr) loop
10288 if Nkind (Parent (Discr)) = N_Discriminant_Specification then
10289 Discr_Val := Expression (Parent (Discr));
10291 if Present (Discr_Val)
10292 and then Is_OK_Static_Expression (Discr_Val)
10294 Append_To (Constraints,
10295 Make_Component_Association (Loc,
10296 Choices => New_List (New_Occurrence_Of (Discr, Loc)),
10297 Expression => New_Copy (Discr_Val)));
10305 Next_Discriminant (Discr);
10310 Comp_List => Comp_List,
10311 Governed_By => Constraints,
10312 Into => Components,
10313 Report_Errors => Report_Errors);
10315 -- Check that each component present is fully initialized
10317 Comp_Elmt := First_Elmt (Components);
10318 while Present (Comp_Elmt) loop
10319 Comp_Id := Node (Comp_Elmt);
10321 if Ekind (Comp_Id) = E_Component
10322 and then (No (Parent (Comp_Id))
10323 or else No (Expression (Parent (Comp_Id))))
10324 and then not Is_Fully_Initialized_Type (Etype (Comp_Id))
10329 Next_Elmt (Comp_Elmt);
10334 elsif Is_Private_Type (Typ) then
10336 U : constant Entity_Id := Underlying_Type (Typ);
10342 return Is_Fully_Initialized_Variant (U);
10349 end Is_Fully_Initialized_Variant;
10351 ----------------------------
10352 -- Is_Inherited_Operation --
10353 ----------------------------
10355 function Is_Inherited_Operation (E : Entity_Id) return Boolean is
10356 pragma Assert (Is_Overloadable (E));
10357 Kind : constant Node_Kind := Nkind (Parent (E));
10359 return Kind = N_Full_Type_Declaration
10360 or else Kind = N_Private_Extension_Declaration
10361 or else Kind = N_Subtype_Declaration
10362 or else (Ekind (E) = E_Enumeration_Literal
10363 and then Is_Derived_Type (Etype (E)));
10364 end Is_Inherited_Operation;
10366 -------------------------------------
10367 -- Is_Inherited_Operation_For_Type --
10368 -------------------------------------
10370 function Is_Inherited_Operation_For_Type
10372 Typ : Entity_Id) return Boolean
10375 -- Check that the operation has been created by the type declaration
10377 return Is_Inherited_Operation (E)
10378 and then Defining_Identifier (Parent (E)) = Typ;
10379 end Is_Inherited_Operation_For_Type;
10385 function Is_Iterator (Typ : Entity_Id) return Boolean is
10386 Ifaces_List : Elist_Id;
10387 Iface_Elmt : Elmt_Id;
10391 if Is_Class_Wide_Type (Typ)
10393 Nam_In (Chars (Etype (Typ)), Name_Forward_Iterator,
10394 Name_Reversible_Iterator)
10396 Is_Predefined_File_Name
10397 (Unit_File_Name (Get_Source_Unit (Etype (Typ))))
10401 elsif not Is_Tagged_Type (Typ) or else not Is_Derived_Type (Typ) then
10404 elsif Present (Find_Value_Of_Aspect (Typ, Aspect_Iterable)) then
10408 Collect_Interfaces (Typ, Ifaces_List);
10410 Iface_Elmt := First_Elmt (Ifaces_List);
10411 while Present (Iface_Elmt) loop
10412 Iface := Node (Iface_Elmt);
10413 if Chars (Iface) = Name_Forward_Iterator
10415 Is_Predefined_File_Name
10416 (Unit_File_Name (Get_Source_Unit (Iface)))
10421 Next_Elmt (Iface_Elmt);
10432 function Is_Junk_Name (N : Name_Id) return Boolean is
10433 function Match (S : String) return Boolean;
10434 -- Return true if substring S is found in Name_Buffer (1 .. Name_Len)
10440 function Match (S : String) return Boolean is
10441 Slen1 : constant Integer := S'Length - 1;
10444 for J in 1 .. Name_Len - S'Length + 1 loop
10445 if Name_Buffer (J .. J + Slen1) = S then
10453 -- Start of processing for Is_Junk_Name
10456 Get_Unqualified_Decoded_Name_String (N);
10457 Set_All_Upper_Case;
10460 Match ("DISCARD") or else
10461 Match ("DUMMY") or else
10462 Match ("IGNORE") or else
10463 Match ("JUNK") or else
10471 -- We seem to have a lot of overlapping functions that do similar things
10472 -- (testing for left hand sides or lvalues???).
10474 function Is_LHS (N : Node_Id) return Is_LHS_Result is
10475 P : constant Node_Id := Parent (N);
10478 -- Return True if we are the left hand side of an assignment statement
10480 if Nkind (P) = N_Assignment_Statement then
10481 if Name (P) = N then
10487 -- Case of prefix of indexed or selected component or slice
10489 elsif Nkind_In (P, N_Indexed_Component, N_Selected_Component, N_Slice)
10490 and then N = Prefix (P)
10492 -- Here we have the case where the parent P is N.Q or N(Q .. R).
10493 -- If P is an LHS, then N is also effectively an LHS, but there
10494 -- is an important exception. If N is of an access type, then
10495 -- what we really have is N.all.Q (or N.all(Q .. R)). In either
10496 -- case this makes N.all a left hand side but not N itself.
10498 -- If we don't know the type yet, this is the case where we return
10499 -- Unknown, since the answer depends on the type which is unknown.
10501 if No (Etype (N)) then
10504 -- We have an Etype set, so we can check it
10506 elsif Is_Access_Type (Etype (N)) then
10509 -- OK, not access type case, so just test whole expression
10515 -- All other cases are not left hand sides
10522 -----------------------------
10523 -- Is_Library_Level_Entity --
10524 -----------------------------
10526 function Is_Library_Level_Entity (E : Entity_Id) return Boolean is
10528 -- The following is a small optimization, and it also properly handles
10529 -- discriminals, which in task bodies might appear in expressions before
10530 -- the corresponding procedure has been created, and which therefore do
10531 -- not have an assigned scope.
10533 if Is_Formal (E) then
10537 -- Normal test is simply that the enclosing dynamic scope is Standard
10539 return Enclosing_Dynamic_Scope (E) = Standard_Standard;
10540 end Is_Library_Level_Entity;
10542 --------------------------------
10543 -- Is_Limited_Class_Wide_Type --
10544 --------------------------------
10546 function Is_Limited_Class_Wide_Type (Typ : Entity_Id) return Boolean is
10549 Is_Class_Wide_Type (Typ)
10550 and then (Is_Limited_Type (Typ) or else From_Limited_With (Typ));
10551 end Is_Limited_Class_Wide_Type;
10553 ---------------------------------
10554 -- Is_Local_Variable_Reference --
10555 ---------------------------------
10557 function Is_Local_Variable_Reference (Expr : Node_Id) return Boolean is
10559 if not Is_Entity_Name (Expr) then
10564 Ent : constant Entity_Id := Entity (Expr);
10565 Sub : constant Entity_Id := Enclosing_Subprogram (Ent);
10567 if not Ekind_In (Ent, E_Variable, E_In_Out_Parameter) then
10570 return Present (Sub) and then Sub = Current_Subprogram;
10574 end Is_Local_Variable_Reference;
10576 -------------------------
10577 -- Is_Object_Reference --
10578 -------------------------
10580 function Is_Object_Reference (N : Node_Id) return Boolean is
10582 function Is_Internally_Generated_Renaming (N : Node_Id) return Boolean;
10583 -- Determine whether N is the name of an internally-generated renaming
10585 --------------------------------------
10586 -- Is_Internally_Generated_Renaming --
10587 --------------------------------------
10589 function Is_Internally_Generated_Renaming (N : Node_Id) return Boolean is
10594 while Present (P) loop
10595 if Nkind (P) = N_Object_Renaming_Declaration then
10596 return not Comes_From_Source (P);
10597 elsif Is_List_Member (P) then
10605 end Is_Internally_Generated_Renaming;
10607 -- Start of processing for Is_Object_Reference
10610 if Is_Entity_Name (N) then
10611 return Present (Entity (N)) and then Is_Object (Entity (N));
10615 when N_Indexed_Component | N_Slice =>
10617 Is_Object_Reference (Prefix (N))
10618 or else Is_Access_Type (Etype (Prefix (N)));
10620 -- In Ada 95, a function call is a constant object; a procedure
10623 when N_Function_Call =>
10624 return Etype (N) /= Standard_Void_Type;
10626 -- Attributes 'Input, 'Old and 'Result produce objects
10628 when N_Attribute_Reference =>
10631 (Attribute_Name (N), Name_Input, Name_Old, Name_Result);
10633 when N_Selected_Component =>
10635 Is_Object_Reference (Selector_Name (N))
10637 (Is_Object_Reference (Prefix (N))
10638 or else Is_Access_Type (Etype (Prefix (N))));
10640 when N_Explicit_Dereference =>
10643 -- A view conversion of a tagged object is an object reference
10645 when N_Type_Conversion =>
10646 return Is_Tagged_Type (Etype (Subtype_Mark (N)))
10647 and then Is_Tagged_Type (Etype (Expression (N)))
10648 and then Is_Object_Reference (Expression (N));
10650 -- An unchecked type conversion is considered to be an object if
10651 -- the operand is an object (this construction arises only as a
10652 -- result of expansion activities).
10654 when N_Unchecked_Type_Conversion =>
10657 -- Allow string literals to act as objects as long as they appear
10658 -- in internally-generated renamings. The expansion of iterators
10659 -- may generate such renamings when the range involves a string
10662 when N_String_Literal =>
10663 return Is_Internally_Generated_Renaming (Parent (N));
10665 -- AI05-0003: In Ada 2012 a qualified expression is a name.
10666 -- This allows disambiguation of function calls and the use
10667 -- of aggregates in more contexts.
10669 when N_Qualified_Expression =>
10670 if Ada_Version < Ada_2012 then
10673 return Is_Object_Reference (Expression (N))
10674 or else Nkind (Expression (N)) = N_Aggregate;
10681 end Is_Object_Reference;
10683 -----------------------------------
10684 -- Is_OK_Variable_For_Out_Formal --
10685 -----------------------------------
10687 function Is_OK_Variable_For_Out_Formal (AV : Node_Id) return Boolean is
10689 Note_Possible_Modification (AV, Sure => True);
10691 -- We must reject parenthesized variable names. Comes_From_Source is
10692 -- checked because there are currently cases where the compiler violates
10693 -- this rule (e.g. passing a task object to its controlled Initialize
10694 -- routine). This should be properly documented in sinfo???
10696 if Paren_Count (AV) > 0 and then Comes_From_Source (AV) then
10699 -- A variable is always allowed
10701 elsif Is_Variable (AV) then
10704 -- Unchecked conversions are allowed only if they come from the
10705 -- generated code, which sometimes uses unchecked conversions for out
10706 -- parameters in cases where code generation is unaffected. We tell
10707 -- source unchecked conversions by seeing if they are rewrites of
10708 -- an original Unchecked_Conversion function call, or of an explicit
10709 -- conversion of a function call or an aggregate (as may happen in the
10710 -- expansion of a packed array aggregate).
10712 elsif Nkind (AV) = N_Unchecked_Type_Conversion then
10713 if Nkind_In (Original_Node (AV), N_Function_Call, N_Aggregate) then
10716 elsif Comes_From_Source (AV)
10717 and then Nkind (Original_Node (Expression (AV))) = N_Function_Call
10721 elsif Nkind (Original_Node (AV)) = N_Type_Conversion then
10722 return Is_OK_Variable_For_Out_Formal (Expression (AV));
10728 -- Normal type conversions are allowed if argument is a variable
10730 elsif Nkind (AV) = N_Type_Conversion then
10731 if Is_Variable (Expression (AV))
10732 and then Paren_Count (Expression (AV)) = 0
10734 Note_Possible_Modification (Expression (AV), Sure => True);
10737 -- We also allow a non-parenthesized expression that raises
10738 -- constraint error if it rewrites what used to be a variable
10740 elsif Raises_Constraint_Error (Expression (AV))
10741 and then Paren_Count (Expression (AV)) = 0
10742 and then Is_Variable (Original_Node (Expression (AV)))
10746 -- Type conversion of something other than a variable
10752 -- If this node is rewritten, then test the original form, if that is
10753 -- OK, then we consider the rewritten node OK (for example, if the
10754 -- original node is a conversion, then Is_Variable will not be true
10755 -- but we still want to allow the conversion if it converts a variable).
10757 elsif Original_Node (AV) /= AV then
10759 -- In Ada 2012, the explicit dereference may be a rewritten call to a
10760 -- Reference function.
10762 if Ada_Version >= Ada_2012
10763 and then Nkind (Original_Node (AV)) = N_Function_Call
10765 Has_Implicit_Dereference (Etype (Name (Original_Node (AV))))
10770 return Is_OK_Variable_For_Out_Formal (Original_Node (AV));
10773 -- All other non-variables are rejected
10778 end Is_OK_Variable_For_Out_Formal;
10780 -----------------------------------
10781 -- Is_Partially_Initialized_Type --
10782 -----------------------------------
10784 function Is_Partially_Initialized_Type
10786 Include_Implicit : Boolean := True) return Boolean
10789 if Is_Scalar_Type (Typ) then
10792 elsif Is_Access_Type (Typ) then
10793 return Include_Implicit;
10795 elsif Is_Array_Type (Typ) then
10797 -- If component type is partially initialized, so is array type
10799 if Is_Partially_Initialized_Type
10800 (Component_Type (Typ), Include_Implicit)
10804 -- Otherwise we are only partially initialized if we are fully
10805 -- initialized (this is the empty array case, no point in us
10806 -- duplicating that code here).
10809 return Is_Fully_Initialized_Type (Typ);
10812 elsif Is_Record_Type (Typ) then
10814 -- A discriminated type is always partially initialized if in
10817 if Has_Discriminants (Typ) and then Include_Implicit then
10820 -- A tagged type is always partially initialized
10822 elsif Is_Tagged_Type (Typ) then
10825 -- Case of non-discriminated record
10831 Component_Present : Boolean := False;
10832 -- Set True if at least one component is present. If no
10833 -- components are present, then record type is fully
10834 -- initialized (another odd case, like the null array).
10837 -- Loop through components
10839 Ent := First_Entity (Typ);
10840 while Present (Ent) loop
10841 if Ekind (Ent) = E_Component then
10842 Component_Present := True;
10844 -- If a component has an initialization expression then
10845 -- the enclosing record type is partially initialized
10847 if Present (Parent (Ent))
10848 and then Present (Expression (Parent (Ent)))
10852 -- If a component is of a type which is itself partially
10853 -- initialized, then the enclosing record type is also.
10855 elsif Is_Partially_Initialized_Type
10856 (Etype (Ent), Include_Implicit)
10865 -- No initialized components found. If we found any components
10866 -- they were all uninitialized so the result is false.
10868 if Component_Present then
10871 -- But if we found no components, then all the components are
10872 -- initialized so we consider the type to be initialized.
10880 -- Concurrent types are always fully initialized
10882 elsif Is_Concurrent_Type (Typ) then
10885 -- For a private type, go to underlying type. If there is no underlying
10886 -- type then just assume this partially initialized. Not clear if this
10887 -- can happen in a non-error case, but no harm in testing for this.
10889 elsif Is_Private_Type (Typ) then
10891 U : constant Entity_Id := Underlying_Type (Typ);
10896 return Is_Partially_Initialized_Type (U, Include_Implicit);
10900 -- For any other type (are there any?) assume partially initialized
10905 end Is_Partially_Initialized_Type;
10907 ------------------------------------
10908 -- Is_Potentially_Persistent_Type --
10909 ------------------------------------
10911 function Is_Potentially_Persistent_Type (T : Entity_Id) return Boolean is
10916 -- For private type, test corresponding full type
10918 if Is_Private_Type (T) then
10919 return Is_Potentially_Persistent_Type (Full_View (T));
10921 -- Scalar types are potentially persistent
10923 elsif Is_Scalar_Type (T) then
10926 -- Record type is potentially persistent if not tagged and the types of
10927 -- all it components are potentially persistent, and no component has
10928 -- an initialization expression.
10930 elsif Is_Record_Type (T)
10931 and then not Is_Tagged_Type (T)
10932 and then not Is_Partially_Initialized_Type (T)
10934 Comp := First_Component (T);
10935 while Present (Comp) loop
10936 if not Is_Potentially_Persistent_Type (Etype (Comp)) then
10939 Next_Entity (Comp);
10945 -- Array type is potentially persistent if its component type is
10946 -- potentially persistent and if all its constraints are static.
10948 elsif Is_Array_Type (T) then
10949 if not Is_Potentially_Persistent_Type (Component_Type (T)) then
10953 Indx := First_Index (T);
10954 while Present (Indx) loop
10955 if not Is_OK_Static_Subtype (Etype (Indx)) then
10964 -- All other types are not potentially persistent
10969 end Is_Potentially_Persistent_Type;
10971 --------------------------------
10972 -- Is_Potentially_Unevaluated --
10973 --------------------------------
10975 function Is_Potentially_Unevaluated (N : Node_Id) return Boolean is
10982 while not Nkind_In (Par, N_If_Expression,
10990 Par := Parent (Par);
10992 -- If the context is not an expression, or if is the result of
10993 -- expansion of an enclosing construct (such as another attribute)
10994 -- the predicate does not apply.
10996 if Nkind (Par) not in N_Subexpr
10997 or else not Comes_From_Source (Par)
11003 if Nkind (Par) = N_If_Expression then
11004 return Is_Elsif (Par) or else Expr /= First (Expressions (Par));
11006 elsif Nkind (Par) = N_Case_Expression then
11007 return Expr /= Expression (Par);
11009 elsif Nkind_In (Par, N_And_Then, N_Or_Else) then
11010 return Expr = Right_Opnd (Par);
11012 elsif Nkind_In (Par, N_In, N_Not_In) then
11013 return Expr /= Left_Opnd (Par);
11018 end Is_Potentially_Unevaluated;
11020 ---------------------------------
11021 -- Is_Protected_Self_Reference --
11022 ---------------------------------
11024 function Is_Protected_Self_Reference (N : Node_Id) return Boolean is
11026 function In_Access_Definition (N : Node_Id) return Boolean;
11027 -- Returns true if N belongs to an access definition
11029 --------------------------
11030 -- In_Access_Definition --
11031 --------------------------
11033 function In_Access_Definition (N : Node_Id) return Boolean is
11038 while Present (P) loop
11039 if Nkind (P) = N_Access_Definition then
11047 end In_Access_Definition;
11049 -- Start of processing for Is_Protected_Self_Reference
11052 -- Verify that prefix is analyzed and has the proper form. Note that
11053 -- the attributes Elab_Spec, Elab_Body, Elab_Subp_Body and UET_Address,
11054 -- which also produce the address of an entity, do not analyze their
11055 -- prefix because they denote entities that are not necessarily visible.
11056 -- Neither of them can apply to a protected type.
11058 return Ada_Version >= Ada_2005
11059 and then Is_Entity_Name (N)
11060 and then Present (Entity (N))
11061 and then Is_Protected_Type (Entity (N))
11062 and then In_Open_Scopes (Entity (N))
11063 and then not In_Access_Definition (N);
11064 end Is_Protected_Self_Reference;
11066 -----------------------------
11067 -- Is_RCI_Pkg_Spec_Or_Body --
11068 -----------------------------
11070 function Is_RCI_Pkg_Spec_Or_Body (Cunit : Node_Id) return Boolean is
11072 function Is_RCI_Pkg_Decl_Cunit (Cunit : Node_Id) return Boolean;
11073 -- Return True if the unit of Cunit is an RCI package declaration
11075 ---------------------------
11076 -- Is_RCI_Pkg_Decl_Cunit --
11077 ---------------------------
11079 function Is_RCI_Pkg_Decl_Cunit (Cunit : Node_Id) return Boolean is
11080 The_Unit : constant Node_Id := Unit (Cunit);
11083 if Nkind (The_Unit) /= N_Package_Declaration then
11087 return Is_Remote_Call_Interface (Defining_Entity (The_Unit));
11088 end Is_RCI_Pkg_Decl_Cunit;
11090 -- Start of processing for Is_RCI_Pkg_Spec_Or_Body
11093 return Is_RCI_Pkg_Decl_Cunit (Cunit)
11095 (Nkind (Unit (Cunit)) = N_Package_Body
11096 and then Is_RCI_Pkg_Decl_Cunit (Library_Unit (Cunit)));
11097 end Is_RCI_Pkg_Spec_Or_Body;
11099 -----------------------------------------
11100 -- Is_Remote_Access_To_Class_Wide_Type --
11101 -----------------------------------------
11103 function Is_Remote_Access_To_Class_Wide_Type
11104 (E : Entity_Id) return Boolean
11107 -- A remote access to class-wide type is a general access to object type
11108 -- declared in the visible part of a Remote_Types or Remote_Call_
11111 return Ekind (E) = E_General_Access_Type
11112 and then (Is_Remote_Call_Interface (E) or else Is_Remote_Types (E));
11113 end Is_Remote_Access_To_Class_Wide_Type;
11115 -----------------------------------------
11116 -- Is_Remote_Access_To_Subprogram_Type --
11117 -----------------------------------------
11119 function Is_Remote_Access_To_Subprogram_Type
11120 (E : Entity_Id) return Boolean
11123 return (Ekind (E) = E_Access_Subprogram_Type
11124 or else (Ekind (E) = E_Record_Type
11125 and then Present (Corresponding_Remote_Type (E))))
11126 and then (Is_Remote_Call_Interface (E) or else Is_Remote_Types (E));
11127 end Is_Remote_Access_To_Subprogram_Type;
11129 --------------------
11130 -- Is_Remote_Call --
11131 --------------------
11133 function Is_Remote_Call (N : Node_Id) return Boolean is
11135 if Nkind (N) not in N_Subprogram_Call then
11137 -- An entry call cannot be remote
11141 elsif Nkind (Name (N)) in N_Has_Entity
11142 and then Is_Remote_Call_Interface (Entity (Name (N)))
11144 -- A subprogram declared in the spec of a RCI package is remote
11148 elsif Nkind (Name (N)) = N_Explicit_Dereference
11149 and then Is_Remote_Access_To_Subprogram_Type
11150 (Etype (Prefix (Name (N))))
11152 -- The dereference of a RAS is a remote call
11156 elsif Present (Controlling_Argument (N))
11157 and then Is_Remote_Access_To_Class_Wide_Type
11158 (Etype (Controlling_Argument (N)))
11160 -- Any primitive operation call with a controlling argument of
11161 -- a RACW type is a remote call.
11166 -- All other calls are local calls
11169 end Is_Remote_Call;
11171 ----------------------
11172 -- Is_Renamed_Entry --
11173 ----------------------
11175 function Is_Renamed_Entry (Proc_Nam : Entity_Id) return Boolean is
11176 Orig_Node : Node_Id := Empty;
11177 Subp_Decl : Node_Id := Parent (Parent (Proc_Nam));
11179 function Is_Entry (Nam : Node_Id) return Boolean;
11180 -- Determine whether Nam is an entry. Traverse selectors if there are
11181 -- nested selected components.
11187 function Is_Entry (Nam : Node_Id) return Boolean is
11189 if Nkind (Nam) = N_Selected_Component then
11190 return Is_Entry (Selector_Name (Nam));
11193 return Ekind (Entity (Nam)) = E_Entry;
11196 -- Start of processing for Is_Renamed_Entry
11199 if Present (Alias (Proc_Nam)) then
11200 Subp_Decl := Parent (Parent (Alias (Proc_Nam)));
11203 -- Look for a rewritten subprogram renaming declaration
11205 if Nkind (Subp_Decl) = N_Subprogram_Declaration
11206 and then Present (Original_Node (Subp_Decl))
11208 Orig_Node := Original_Node (Subp_Decl);
11211 -- The rewritten subprogram is actually an entry
11213 if Present (Orig_Node)
11214 and then Nkind (Orig_Node) = N_Subprogram_Renaming_Declaration
11215 and then Is_Entry (Name (Orig_Node))
11221 end Is_Renamed_Entry;
11223 ----------------------------
11224 -- Is_Reversible_Iterator --
11225 ----------------------------
11227 function Is_Reversible_Iterator (Typ : Entity_Id) return Boolean is
11228 Ifaces_List : Elist_Id;
11229 Iface_Elmt : Elmt_Id;
11233 if Is_Class_Wide_Type (Typ)
11234 and then Chars (Etype (Typ)) = Name_Reversible_Iterator
11236 Is_Predefined_File_Name
11237 (Unit_File_Name (Get_Source_Unit (Etype (Typ))))
11241 elsif not Is_Tagged_Type (Typ)
11242 or else not Is_Derived_Type (Typ)
11247 Collect_Interfaces (Typ, Ifaces_List);
11249 Iface_Elmt := First_Elmt (Ifaces_List);
11250 while Present (Iface_Elmt) loop
11251 Iface := Node (Iface_Elmt);
11252 if Chars (Iface) = Name_Reversible_Iterator
11254 Is_Predefined_File_Name
11255 (Unit_File_Name (Get_Source_Unit (Iface)))
11260 Next_Elmt (Iface_Elmt);
11265 end Is_Reversible_Iterator;
11267 ----------------------
11268 -- Is_Selector_Name --
11269 ----------------------
11271 function Is_Selector_Name (N : Node_Id) return Boolean is
11273 if not Is_List_Member (N) then
11275 P : constant Node_Id := Parent (N);
11276 K : constant Node_Kind := Nkind (P);
11279 (K = N_Expanded_Name or else
11280 K = N_Generic_Association or else
11281 K = N_Parameter_Association or else
11282 K = N_Selected_Component)
11283 and then Selector_Name (P) = N;
11288 L : constant List_Id := List_Containing (N);
11289 P : constant Node_Id := Parent (L);
11291 return (Nkind (P) = N_Discriminant_Association
11292 and then Selector_Names (P) = L)
11294 (Nkind (P) = N_Component_Association
11295 and then Choices (P) = L);
11298 end Is_Selector_Name;
11300 ----------------------------------
11301 -- Is_SPARK_Initialization_Expr --
11302 ----------------------------------
11304 function Is_SPARK_Initialization_Expr (N : Node_Id) return Boolean is
11307 Comp_Assn : Node_Id;
11308 Orig_N : constant Node_Id := Original_Node (N);
11313 if not Comes_From_Source (Orig_N) then
11317 pragma Assert (Nkind (Orig_N) in N_Subexpr);
11319 case Nkind (Orig_N) is
11320 when N_Character_Literal |
11321 N_Integer_Literal |
11323 N_String_Literal =>
11326 when N_Identifier |
11328 if Is_Entity_Name (Orig_N)
11329 and then Present (Entity (Orig_N)) -- needed in some cases
11331 case Ekind (Entity (Orig_N)) is
11333 E_Enumeration_Literal |
11338 if Is_Type (Entity (Orig_N)) then
11346 when N_Qualified_Expression |
11347 N_Type_Conversion =>
11348 Is_Ok := Is_SPARK_Initialization_Expr (Expression (Orig_N));
11351 Is_Ok := Is_SPARK_Initialization_Expr (Right_Opnd (Orig_N));
11355 N_Membership_Test =>
11356 Is_Ok := Is_SPARK_Initialization_Expr (Left_Opnd (Orig_N))
11357 and then Is_SPARK_Initialization_Expr (Right_Opnd (Orig_N));
11360 N_Extension_Aggregate =>
11361 if Nkind (Orig_N) = N_Extension_Aggregate then
11362 Is_Ok := Is_SPARK_Initialization_Expr (Ancestor_Part (Orig_N));
11365 Expr := First (Expressions (Orig_N));
11366 while Present (Expr) loop
11367 if not Is_SPARK_Initialization_Expr (Expr) then
11375 Comp_Assn := First (Component_Associations (Orig_N));
11376 while Present (Comp_Assn) loop
11377 Expr := Expression (Comp_Assn);
11378 if Present (Expr) -- needed for box association
11379 and then not Is_SPARK_Initialization_Expr (Expr)
11388 when N_Attribute_Reference =>
11389 if Nkind (Prefix (Orig_N)) in N_Subexpr then
11390 Is_Ok := Is_SPARK_Initialization_Expr (Prefix (Orig_N));
11393 Expr := First (Expressions (Orig_N));
11394 while Present (Expr) loop
11395 if not Is_SPARK_Initialization_Expr (Expr) then
11403 -- Selected components might be expanded named not yet resolved, so
11404 -- default on the safe side. (Eg on sparklex.ads)
11406 when N_Selected_Component =>
11415 end Is_SPARK_Initialization_Expr;
11417 -------------------------------
11418 -- Is_SPARK_Object_Reference --
11419 -------------------------------
11421 function Is_SPARK_Object_Reference (N : Node_Id) return Boolean is
11423 if Is_Entity_Name (N) then
11424 return Present (Entity (N))
11426 (Ekind_In (Entity (N), E_Constant, E_Variable)
11427 or else Ekind (Entity (N)) in Formal_Kind);
11431 when N_Selected_Component =>
11432 return Is_SPARK_Object_Reference (Prefix (N));
11438 end Is_SPARK_Object_Reference;
11440 -----------------------
11441 -- Is_SPARK_Volatile --
11442 -----------------------
11444 function Is_SPARK_Volatile (Id : Entity_Id) return Boolean is
11446 return Is_Volatile (Id) or else Is_Volatile (Etype (Id));
11447 end Is_SPARK_Volatile;
11449 ------------------------------
11450 -- Is_SPARK_Volatile_Object --
11451 ------------------------------
11453 function Is_SPARK_Volatile_Object (N : Node_Id) return Boolean is
11455 if Is_Entity_Name (N) then
11456 return Is_SPARK_Volatile (Entity (N));
11458 elsif Nkind (N) = N_Expanded_Name then
11459 return Is_SPARK_Volatile (Entity (N));
11461 elsif Nkind (N) = N_Indexed_Component then
11462 return Is_SPARK_Volatile_Object (Prefix (N));
11464 elsif Nkind (N) = N_Selected_Component then
11466 Is_SPARK_Volatile_Object (Prefix (N))
11468 Is_SPARK_Volatile_Object (Selector_Name (N));
11473 end Is_SPARK_Volatile_Object;
11479 function Is_Statement (N : Node_Id) return Boolean is
11482 Nkind (N) in N_Statement_Other_Than_Procedure_Call
11483 or else Nkind (N) = N_Procedure_Call_Statement;
11486 --------------------------------------------------
11487 -- Is_Subprogram_Stub_Without_Prior_Declaration --
11488 --------------------------------------------------
11490 function Is_Subprogram_Stub_Without_Prior_Declaration
11491 (N : Node_Id) return Boolean
11494 -- A subprogram stub without prior declaration serves as declaration for
11495 -- the actual subprogram body. As such, it has an attached defining
11496 -- entity of E_[Generic_]Function or E_[Generic_]Procedure.
11498 return Nkind (N) = N_Subprogram_Body_Stub
11499 and then Ekind (Defining_Entity (N)) /= E_Subprogram_Body;
11500 end Is_Subprogram_Stub_Without_Prior_Declaration;
11502 ---------------------------------
11503 -- Is_Synchronized_Tagged_Type --
11504 ---------------------------------
11506 function Is_Synchronized_Tagged_Type (E : Entity_Id) return Boolean is
11507 Kind : constant Entity_Kind := Ekind (Base_Type (E));
11510 -- A task or protected type derived from an interface is a tagged type.
11511 -- Such a tagged type is called a synchronized tagged type, as are
11512 -- synchronized interfaces and private extensions whose declaration
11513 -- includes the reserved word synchronized.
11515 return (Is_Tagged_Type (E)
11516 and then (Kind = E_Task_Type
11517 or else Kind = E_Protected_Type))
11520 and then Is_Synchronized_Interface (E))
11522 (Ekind (E) = E_Record_Type_With_Private
11523 and then Nkind (Parent (E)) = N_Private_Extension_Declaration
11524 and then (Synchronized_Present (Parent (E))
11525 or else Is_Synchronized_Interface (Etype (E))));
11526 end Is_Synchronized_Tagged_Type;
11532 function Is_Transfer (N : Node_Id) return Boolean is
11533 Kind : constant Node_Kind := Nkind (N);
11536 if Kind = N_Simple_Return_Statement
11538 Kind = N_Extended_Return_Statement
11540 Kind = N_Goto_Statement
11542 Kind = N_Raise_Statement
11544 Kind = N_Requeue_Statement
11548 elsif (Kind = N_Exit_Statement or else Kind in N_Raise_xxx_Error)
11549 and then No (Condition (N))
11553 elsif Kind = N_Procedure_Call_Statement
11554 and then Is_Entity_Name (Name (N))
11555 and then Present (Entity (Name (N)))
11556 and then No_Return (Entity (Name (N)))
11560 elsif Nkind (Original_Node (N)) = N_Raise_Statement then
11572 function Is_True (U : Uint) return Boolean is
11577 --------------------------------------
11578 -- Is_Unchecked_Conversion_Instance --
11579 --------------------------------------
11581 function Is_Unchecked_Conversion_Instance (Id : Entity_Id) return Boolean is
11582 Gen_Par : Entity_Id;
11585 -- Look for a function whose generic parent is the predefined intrinsic
11586 -- function Unchecked_Conversion.
11588 if Ekind (Id) = E_Function then
11589 Gen_Par := Generic_Parent (Parent (Id));
11593 and then Chars (Gen_Par) = Name_Unchecked_Conversion
11594 and then Is_Intrinsic_Subprogram (Gen_Par)
11595 and then Is_Predefined_File_Name
11596 (Unit_File_Name (Get_Source_Unit (Gen_Par)));
11600 end Is_Unchecked_Conversion_Instance;
11602 -------------------------------
11603 -- Is_Universal_Numeric_Type --
11604 -------------------------------
11606 function Is_Universal_Numeric_Type (T : Entity_Id) return Boolean is
11608 return T = Universal_Integer or else T = Universal_Real;
11609 end Is_Universal_Numeric_Type;
11611 -------------------
11612 -- Is_Value_Type --
11613 -------------------
11615 function Is_Value_Type (T : Entity_Id) return Boolean is
11617 return VM_Target = CLI_Target
11618 and then Nkind (T) in N_Has_Chars
11619 and then Chars (T) /= No_Name
11620 and then Get_Name_String (Chars (T)) = "valuetype";
11623 ----------------------------
11624 -- Is_Variable_Size_Array --
11625 ----------------------------
11627 function Is_Variable_Size_Array (E : Entity_Id) return Boolean is
11631 pragma Assert (Is_Array_Type (E));
11633 -- Check if some index is initialized with a non-constant value
11635 Idx := First_Index (E);
11636 while Present (Idx) loop
11637 if Nkind (Idx) = N_Range then
11638 if not Is_Constant_Bound (Low_Bound (Idx))
11639 or else not Is_Constant_Bound (High_Bound (Idx))
11645 Idx := Next_Index (Idx);
11649 end Is_Variable_Size_Array;
11651 -----------------------------
11652 -- Is_Variable_Size_Record --
11653 -----------------------------
11655 function Is_Variable_Size_Record (E : Entity_Id) return Boolean is
11657 Comp_Typ : Entity_Id;
11660 pragma Assert (Is_Record_Type (E));
11662 Comp := First_Entity (E);
11663 while Present (Comp) loop
11664 Comp_Typ := Etype (Comp);
11666 -- Recursive call if the record type has discriminants
11668 if Is_Record_Type (Comp_Typ)
11669 and then Has_Discriminants (Comp_Typ)
11670 and then Is_Variable_Size_Record (Comp_Typ)
11674 elsif Is_Array_Type (Comp_Typ)
11675 and then Is_Variable_Size_Array (Comp_Typ)
11680 Next_Entity (Comp);
11684 end Is_Variable_Size_Record;
11686 ---------------------
11687 -- Is_VMS_Operator --
11688 ---------------------
11690 function Is_VMS_Operator (Op : Entity_Id) return Boolean is
11692 -- The VMS operators are declared in a child of System that is loaded
11693 -- through pragma Extend_System. In some rare cases a program is run
11694 -- with this extension but without indicating that the target is VMS.
11696 return Ekind (Op) = E_Function
11697 and then Is_Intrinsic_Subprogram (Op)
11699 ((Present_System_Aux and then Scope (Op) = System_Aux_Id)
11702 and then Scope (Scope (Op)) = RTU_Entity (System)));
11703 end Is_VMS_Operator;
11709 function Is_Variable
11711 Use_Original_Node : Boolean := True) return Boolean
11713 Orig_Node : Node_Id;
11715 function In_Protected_Function (E : Entity_Id) return Boolean;
11716 -- Within a protected function, the private components of the enclosing
11717 -- protected type are constants. A function nested within a (protected)
11718 -- procedure is not itself protected. Within the body of a protected
11719 -- function the current instance of the protected type is a constant.
11721 function Is_Variable_Prefix (P : Node_Id) return Boolean;
11722 -- Prefixes can involve implicit dereferences, in which case we must
11723 -- test for the case of a reference of a constant access type, which can
11724 -- can never be a variable.
11726 ---------------------------
11727 -- In_Protected_Function --
11728 ---------------------------
11730 function In_Protected_Function (E : Entity_Id) return Boolean is
11735 -- E is the current instance of a type
11737 if Is_Type (E) then
11746 if not Is_Protected_Type (Prot) then
11750 S := Current_Scope;
11751 while Present (S) and then S /= Prot loop
11752 if Ekind (S) = E_Function and then Scope (S) = Prot then
11761 end In_Protected_Function;
11763 ------------------------
11764 -- Is_Variable_Prefix --
11765 ------------------------
11767 function Is_Variable_Prefix (P : Node_Id) return Boolean is
11769 if Is_Access_Type (Etype (P)) then
11770 return not Is_Access_Constant (Root_Type (Etype (P)));
11772 -- For the case of an indexed component whose prefix has a packed
11773 -- array type, the prefix has been rewritten into a type conversion.
11774 -- Determine variable-ness from the converted expression.
11776 elsif Nkind (P) = N_Type_Conversion
11777 and then not Comes_From_Source (P)
11778 and then Is_Array_Type (Etype (P))
11779 and then Is_Packed (Etype (P))
11781 return Is_Variable (Expression (P));
11784 return Is_Variable (P);
11786 end Is_Variable_Prefix;
11788 -- Start of processing for Is_Variable
11791 -- Check if we perform the test on the original node since this may be a
11792 -- test of syntactic categories which must not be disturbed by whatever
11793 -- rewriting might have occurred. For example, an aggregate, which is
11794 -- certainly NOT a variable, could be turned into a variable by
11797 if Use_Original_Node then
11798 Orig_Node := Original_Node (N);
11803 -- Definitely OK if Assignment_OK is set. Since this is something that
11804 -- only gets set for expanded nodes, the test is on N, not Orig_Node.
11806 if Nkind (N) in N_Subexpr and then Assignment_OK (N) then
11809 -- Normally we go to the original node, but there is one exception where
11810 -- we use the rewritten node, namely when it is an explicit dereference.
11811 -- The generated code may rewrite a prefix which is an access type with
11812 -- an explicit dereference. The dereference is a variable, even though
11813 -- the original node may not be (since it could be a constant of the
11816 -- In Ada 2005 we have a further case to consider: the prefix may be a
11817 -- function call given in prefix notation. The original node appears to
11818 -- be a selected component, but we need to examine the call.
11820 elsif Nkind (N) = N_Explicit_Dereference
11821 and then Nkind (Orig_Node) /= N_Explicit_Dereference
11822 and then Present (Etype (Orig_Node))
11823 and then Is_Access_Type (Etype (Orig_Node))
11825 -- Note that if the prefix is an explicit dereference that does not
11826 -- come from source, we must check for a rewritten function call in
11827 -- prefixed notation before other forms of rewriting, to prevent a
11831 (Nkind (Orig_Node) = N_Function_Call
11832 and then not Is_Access_Constant (Etype (Prefix (N))))
11834 Is_Variable_Prefix (Original_Node (Prefix (N)));
11836 -- in Ada 2012, the dereference may have been added for a type with
11837 -- a declared implicit dereference aspect.
11839 elsif Nkind (N) = N_Explicit_Dereference
11840 and then Present (Etype (Orig_Node))
11841 and then Ada_Version >= Ada_2012
11842 and then Has_Implicit_Dereference (Etype (Orig_Node))
11846 -- A function call is never a variable
11848 elsif Nkind (N) = N_Function_Call then
11851 -- All remaining checks use the original node
11853 elsif Is_Entity_Name (Orig_Node)
11854 and then Present (Entity (Orig_Node))
11857 E : constant Entity_Id := Entity (Orig_Node);
11858 K : constant Entity_Kind := Ekind (E);
11861 return (K = E_Variable
11862 and then Nkind (Parent (E)) /= N_Exception_Handler)
11863 or else (K = E_Component
11864 and then not In_Protected_Function (E))
11865 or else K = E_Out_Parameter
11866 or else K = E_In_Out_Parameter
11867 or else K = E_Generic_In_Out_Parameter
11869 -- Current instance of type. If this is a protected type, check
11870 -- we are not within the body of one of its protected functions.
11872 or else (Is_Type (E)
11873 and then In_Open_Scopes (E)
11874 and then not In_Protected_Function (E))
11876 or else (Is_Incomplete_Or_Private_Type (E)
11877 and then In_Open_Scopes (Full_View (E)));
11881 case Nkind (Orig_Node) is
11882 when N_Indexed_Component | N_Slice =>
11883 return Is_Variable_Prefix (Prefix (Orig_Node));
11885 when N_Selected_Component =>
11886 return (Is_Variable (Selector_Name (Orig_Node))
11887 and then Is_Variable_Prefix (Prefix (Orig_Node)))
11889 (Nkind (N) = N_Expanded_Name
11890 and then Scope (Entity (N)) = Entity (Prefix (N)));
11892 -- For an explicit dereference, the type of the prefix cannot
11893 -- be an access to constant or an access to subprogram.
11895 when N_Explicit_Dereference =>
11897 Typ : constant Entity_Id := Etype (Prefix (Orig_Node));
11899 return Is_Access_Type (Typ)
11900 and then not Is_Access_Constant (Root_Type (Typ))
11901 and then Ekind (Typ) /= E_Access_Subprogram_Type;
11904 -- The type conversion is the case where we do not deal with the
11905 -- context dependent special case of an actual parameter. Thus
11906 -- the type conversion is only considered a variable for the
11907 -- purposes of this routine if the target type is tagged. However,
11908 -- a type conversion is considered to be a variable if it does not
11909 -- come from source (this deals for example with the conversions
11910 -- of expressions to their actual subtypes).
11912 when N_Type_Conversion =>
11913 return Is_Variable (Expression (Orig_Node))
11915 (not Comes_From_Source (Orig_Node)
11917 (Is_Tagged_Type (Etype (Subtype_Mark (Orig_Node)))
11919 Is_Tagged_Type (Etype (Expression (Orig_Node)))));
11921 -- GNAT allows an unchecked type conversion as a variable. This
11922 -- only affects the generation of internal expanded code, since
11923 -- calls to instantiations of Unchecked_Conversion are never
11924 -- considered variables (since they are function calls).
11926 when N_Unchecked_Type_Conversion =>
11927 return Is_Variable (Expression (Orig_Node));
11935 ---------------------------
11936 -- Is_Visibly_Controlled --
11937 ---------------------------
11939 function Is_Visibly_Controlled (T : Entity_Id) return Boolean is
11940 Root : constant Entity_Id := Root_Type (T);
11942 return Chars (Scope (Root)) = Name_Finalization
11943 and then Chars (Scope (Scope (Root))) = Name_Ada
11944 and then Scope (Scope (Scope (Root))) = Standard_Standard;
11945 end Is_Visibly_Controlled;
11947 ------------------------
11948 -- Is_Volatile_Object --
11949 ------------------------
11951 function Is_Volatile_Object (N : Node_Id) return Boolean is
11953 function Is_Volatile_Prefix (N : Node_Id) return Boolean;
11954 -- If prefix is an implicit dereference, examine designated type
11956 function Object_Has_Volatile_Components (N : Node_Id) return Boolean;
11957 -- Determines if given object has volatile components
11959 ------------------------
11960 -- Is_Volatile_Prefix --
11961 ------------------------
11963 function Is_Volatile_Prefix (N : Node_Id) return Boolean is
11964 Typ : constant Entity_Id := Etype (N);
11967 if Is_Access_Type (Typ) then
11969 Dtyp : constant Entity_Id := Designated_Type (Typ);
11972 return Is_Volatile (Dtyp)
11973 or else Has_Volatile_Components (Dtyp);
11977 return Object_Has_Volatile_Components (N);
11979 end Is_Volatile_Prefix;
11981 ------------------------------------
11982 -- Object_Has_Volatile_Components --
11983 ------------------------------------
11985 function Object_Has_Volatile_Components (N : Node_Id) return Boolean is
11986 Typ : constant Entity_Id := Etype (N);
11989 if Is_Volatile (Typ)
11990 or else Has_Volatile_Components (Typ)
11994 elsif Is_Entity_Name (N)
11995 and then (Has_Volatile_Components (Entity (N))
11996 or else Is_Volatile (Entity (N)))
12000 elsif Nkind (N) = N_Indexed_Component
12001 or else Nkind (N) = N_Selected_Component
12003 return Is_Volatile_Prefix (Prefix (N));
12008 end Object_Has_Volatile_Components;
12010 -- Start of processing for Is_Volatile_Object
12013 if Nkind (N) = N_Defining_Identifier then
12014 return Is_Volatile (N) or else Is_Volatile (Etype (N));
12016 elsif Nkind (N) = N_Expanded_Name then
12017 return Is_Volatile_Object (Entity (N));
12019 elsif Is_Volatile (Etype (N))
12020 or else (Is_Entity_Name (N) and then Is_Volatile (Entity (N)))
12024 elsif Nkind_In (N, N_Indexed_Component, N_Selected_Component)
12025 and then Is_Volatile_Prefix (Prefix (N))
12029 elsif Nkind (N) = N_Selected_Component
12030 and then Is_Volatile (Entity (Selector_Name (N)))
12037 end Is_Volatile_Object;
12039 ---------------------------
12040 -- Itype_Has_Declaration --
12041 ---------------------------
12043 function Itype_Has_Declaration (Id : Entity_Id) return Boolean is
12045 pragma Assert (Is_Itype (Id));
12046 return Present (Parent (Id))
12047 and then Nkind_In (Parent (Id), N_Full_Type_Declaration,
12048 N_Subtype_Declaration)
12049 and then Defining_Entity (Parent (Id)) = Id;
12050 end Itype_Has_Declaration;
12052 -------------------------
12053 -- Kill_Current_Values --
12054 -------------------------
12056 procedure Kill_Current_Values
12058 Last_Assignment_Only : Boolean := False)
12061 if Is_Assignable (Ent) then
12062 Set_Last_Assignment (Ent, Empty);
12065 if Is_Object (Ent) then
12066 if not Last_Assignment_Only then
12068 Set_Current_Value (Ent, Empty);
12070 if not Can_Never_Be_Null (Ent) then
12071 Set_Is_Known_Non_Null (Ent, False);
12074 Set_Is_Known_Null (Ent, False);
12076 -- Reset Is_Known_Valid unless type is always valid, or if we have
12077 -- a loop parameter (loop parameters are always valid, since their
12078 -- bounds are defined by the bounds given in the loop header).
12080 if not Is_Known_Valid (Etype (Ent))
12081 and then Ekind (Ent) /= E_Loop_Parameter
12083 Set_Is_Known_Valid (Ent, False);
12087 end Kill_Current_Values;
12089 procedure Kill_Current_Values (Last_Assignment_Only : Boolean := False) is
12092 procedure Kill_Current_Values_For_Entity_Chain (E : Entity_Id);
12093 -- Clear current value for entity E and all entities chained to E
12095 ------------------------------------------
12096 -- Kill_Current_Values_For_Entity_Chain --
12097 ------------------------------------------
12099 procedure Kill_Current_Values_For_Entity_Chain (E : Entity_Id) is
12103 while Present (Ent) loop
12104 Kill_Current_Values (Ent, Last_Assignment_Only);
12107 end Kill_Current_Values_For_Entity_Chain;
12109 -- Start of processing for Kill_Current_Values
12112 -- Kill all saved checks, a special case of killing saved values
12114 if not Last_Assignment_Only then
12118 -- Loop through relevant scopes, which includes the current scope and
12119 -- any parent scopes if the current scope is a block or a package.
12121 S := Current_Scope;
12124 -- Clear current values of all entities in current scope
12126 Kill_Current_Values_For_Entity_Chain (First_Entity (S));
12128 -- If scope is a package, also clear current values of all private
12129 -- entities in the scope.
12131 if Is_Package_Or_Generic_Package (S)
12132 or else Is_Concurrent_Type (S)
12134 Kill_Current_Values_For_Entity_Chain (First_Private_Entity (S));
12137 -- If this is a not a subprogram, deal with parents
12139 if not Is_Subprogram (S) then
12141 exit Scope_Loop when S = Standard_Standard;
12145 end loop Scope_Loop;
12146 end Kill_Current_Values;
12148 --------------------------
12149 -- Kill_Size_Check_Code --
12150 --------------------------
12152 procedure Kill_Size_Check_Code (E : Entity_Id) is
12154 if (Ekind (E) = E_Constant or else Ekind (E) = E_Variable)
12155 and then Present (Size_Check_Code (E))
12157 Remove (Size_Check_Code (E));
12158 Set_Size_Check_Code (E, Empty);
12160 end Kill_Size_Check_Code;
12162 --------------------------
12163 -- Known_To_Be_Assigned --
12164 --------------------------
12166 function Known_To_Be_Assigned (N : Node_Id) return Boolean is
12167 P : constant Node_Id := Parent (N);
12172 -- Test left side of assignment
12174 when N_Assignment_Statement =>
12175 return N = Name (P);
12177 -- Function call arguments are never lvalues
12179 when N_Function_Call =>
12182 -- Positional parameter for procedure or accept call
12184 when N_Procedure_Call_Statement |
12193 Proc := Get_Subprogram_Entity (P);
12199 -- If we are not a list member, something is strange, so
12200 -- be conservative and return False.
12202 if not Is_List_Member (N) then
12206 -- We are going to find the right formal by stepping forward
12207 -- through the formals, as we step backwards in the actuals.
12209 Form := First_Formal (Proc);
12212 -- If no formal, something is weird, so be conservative
12213 -- and return False.
12220 exit when No (Act);
12221 Next_Formal (Form);
12224 return Ekind (Form) /= E_In_Parameter;
12227 -- Named parameter for procedure or accept call
12229 when N_Parameter_Association =>
12235 Proc := Get_Subprogram_Entity (Parent (P));
12241 -- Loop through formals to find the one that matches
12243 Form := First_Formal (Proc);
12245 -- If no matching formal, that's peculiar, some kind of
12246 -- previous error, so return False to be conservative.
12247 -- Actually this also happens in legal code in the case
12248 -- where P is a parameter association for an Extra_Formal???
12254 -- Else test for match
12256 if Chars (Form) = Chars (Selector_Name (P)) then
12257 return Ekind (Form) /= E_In_Parameter;
12260 Next_Formal (Form);
12264 -- Test for appearing in a conversion that itself appears
12265 -- in an lvalue context, since this should be an lvalue.
12267 when N_Type_Conversion =>
12268 return Known_To_Be_Assigned (P);
12270 -- All other references are definitely not known to be modifications
12276 end Known_To_Be_Assigned;
12278 ---------------------------
12279 -- Last_Source_Statement --
12280 ---------------------------
12282 function Last_Source_Statement (HSS : Node_Id) return Node_Id is
12286 N := Last (Statements (HSS));
12287 while Present (N) loop
12288 exit when Comes_From_Source (N);
12293 end Last_Source_Statement;
12295 ----------------------------------
12296 -- Matching_Static_Array_Bounds --
12297 ----------------------------------
12299 function Matching_Static_Array_Bounds
12301 R_Typ : Node_Id) return Boolean
12303 L_Ndims : constant Nat := Number_Dimensions (L_Typ);
12304 R_Ndims : constant Nat := Number_Dimensions (R_Typ);
12316 if L_Ndims /= R_Ndims then
12320 -- Unconstrained types do not have static bounds
12322 if not Is_Constrained (L_Typ) or else not Is_Constrained (R_Typ) then
12326 -- First treat specially the first dimension, as the lower bound and
12327 -- length of string literals are not stored like those of arrays.
12329 if Ekind (L_Typ) = E_String_Literal_Subtype then
12330 L_Low := String_Literal_Low_Bound (L_Typ);
12331 L_Len := String_Literal_Length (L_Typ);
12333 L_Index := First_Index (L_Typ);
12334 Get_Index_Bounds (L_Index, L_Low, L_High);
12336 if Is_OK_Static_Expression (L_Low)
12337 and then Is_OK_Static_Expression (L_High)
12339 if Expr_Value (L_High) < Expr_Value (L_Low) then
12342 L_Len := (Expr_Value (L_High) - Expr_Value (L_Low)) + 1;
12349 if Ekind (R_Typ) = E_String_Literal_Subtype then
12350 R_Low := String_Literal_Low_Bound (R_Typ);
12351 R_Len := String_Literal_Length (R_Typ);
12353 R_Index := First_Index (R_Typ);
12354 Get_Index_Bounds (R_Index, R_Low, R_High);
12356 if Is_OK_Static_Expression (R_Low)
12357 and then Is_OK_Static_Expression (R_High)
12359 if Expr_Value (R_High) < Expr_Value (R_Low) then
12362 R_Len := (Expr_Value (R_High) - Expr_Value (R_Low)) + 1;
12369 if Is_OK_Static_Expression (L_Low)
12370 and then Is_OK_Static_Expression (R_Low)
12371 and then Expr_Value (L_Low) = Expr_Value (R_Low)
12372 and then L_Len = R_Len
12379 -- Then treat all other dimensions
12381 for Indx in 2 .. L_Ndims loop
12385 Get_Index_Bounds (L_Index, L_Low, L_High);
12386 Get_Index_Bounds (R_Index, R_Low, R_High);
12388 if Is_OK_Static_Expression (L_Low)
12389 and then Is_OK_Static_Expression (L_High)
12390 and then Is_OK_Static_Expression (R_Low)
12391 and then Is_OK_Static_Expression (R_High)
12392 and then Expr_Value (L_Low) = Expr_Value (R_Low)
12393 and then Expr_Value (L_High) = Expr_Value (R_High)
12401 -- If we fall through the loop, all indexes matched
12404 end Matching_Static_Array_Bounds;
12406 -------------------
12407 -- May_Be_Lvalue --
12408 -------------------
12410 function May_Be_Lvalue (N : Node_Id) return Boolean is
12411 P : constant Node_Id := Parent (N);
12416 -- Test left side of assignment
12418 when N_Assignment_Statement =>
12419 return N = Name (P);
12421 -- Test prefix of component or attribute. Note that the prefix of an
12422 -- explicit or implicit dereference cannot be an l-value.
12424 when N_Attribute_Reference =>
12425 return N = Prefix (P)
12426 and then Name_Implies_Lvalue_Prefix (Attribute_Name (P));
12428 -- For an expanded name, the name is an lvalue if the expanded name
12429 -- is an lvalue, but the prefix is never an lvalue, since it is just
12430 -- the scope where the name is found.
12432 when N_Expanded_Name =>
12433 if N = Prefix (P) then
12434 return May_Be_Lvalue (P);
12439 -- For a selected component A.B, A is certainly an lvalue if A.B is.
12440 -- B is a little interesting, if we have A.B := 3, there is some
12441 -- discussion as to whether B is an lvalue or not, we choose to say
12442 -- it is. Note however that A is not an lvalue if it is of an access
12443 -- type since this is an implicit dereference.
12445 when N_Selected_Component =>
12447 and then Present (Etype (N))
12448 and then Is_Access_Type (Etype (N))
12452 return May_Be_Lvalue (P);
12455 -- For an indexed component or slice, the index or slice bounds is
12456 -- never an lvalue. The prefix is an lvalue if the indexed component
12457 -- or slice is an lvalue, except if it is an access type, where we
12458 -- have an implicit dereference.
12460 when N_Indexed_Component | N_Slice =>
12462 or else (Present (Etype (N)) and then Is_Access_Type (Etype (N)))
12466 return May_Be_Lvalue (P);
12469 -- Prefix of a reference is an lvalue if the reference is an lvalue
12471 when N_Reference =>
12472 return May_Be_Lvalue (P);
12474 -- Prefix of explicit dereference is never an lvalue
12476 when N_Explicit_Dereference =>
12479 -- Positional parameter for subprogram, entry, or accept call.
12480 -- In older versions of Ada function call arguments are never
12481 -- lvalues. In Ada 2012 functions can have in-out parameters.
12483 when N_Subprogram_Call |
12484 N_Entry_Call_Statement |
12487 if Nkind (P) = N_Function_Call and then Ada_Version < Ada_2012 then
12491 -- The following mechanism is clumsy and fragile. A single flag
12492 -- set in Resolve_Actuals would be preferable ???
12500 Proc := Get_Subprogram_Entity (P);
12506 -- If we are not a list member, something is strange, so be
12507 -- conservative and return True.
12509 if not Is_List_Member (N) then
12513 -- We are going to find the right formal by stepping forward
12514 -- through the formals, as we step backwards in the actuals.
12516 Form := First_Formal (Proc);
12519 -- If no formal, something is weird, so be conservative and
12527 exit when No (Act);
12528 Next_Formal (Form);
12531 return Ekind (Form) /= E_In_Parameter;
12534 -- Named parameter for procedure or accept call
12536 when N_Parameter_Association =>
12542 Proc := Get_Subprogram_Entity (Parent (P));
12548 -- Loop through formals to find the one that matches
12550 Form := First_Formal (Proc);
12552 -- If no matching formal, that's peculiar, some kind of
12553 -- previous error, so return True to be conservative.
12554 -- Actually happens with legal code for an unresolved call
12555 -- where we may get the wrong homonym???
12561 -- Else test for match
12563 if Chars (Form) = Chars (Selector_Name (P)) then
12564 return Ekind (Form) /= E_In_Parameter;
12567 Next_Formal (Form);
12571 -- Test for appearing in a conversion that itself appears in an
12572 -- lvalue context, since this should be an lvalue.
12574 when N_Type_Conversion =>
12575 return May_Be_Lvalue (P);
12577 -- Test for appearance in object renaming declaration
12579 when N_Object_Renaming_Declaration =>
12582 -- All other references are definitely not lvalues
12590 -----------------------
12591 -- Mark_Coextensions --
12592 -----------------------
12594 procedure Mark_Coextensions (Context_Nod : Node_Id; Root_Nod : Node_Id) is
12595 Is_Dynamic : Boolean;
12596 -- Indicates whether the context causes nested coextensions to be
12597 -- dynamic or static
12599 function Mark_Allocator (N : Node_Id) return Traverse_Result;
12600 -- Recognize an allocator node and label it as a dynamic coextension
12602 --------------------
12603 -- Mark_Allocator --
12604 --------------------
12606 function Mark_Allocator (N : Node_Id) return Traverse_Result is
12608 if Nkind (N) = N_Allocator then
12610 Set_Is_Dynamic_Coextension (N);
12612 -- If the allocator expression is potentially dynamic, it may
12613 -- be expanded out of order and require dynamic allocation
12614 -- anyway, so we treat the coextension itself as dynamic.
12615 -- Potential optimization ???
12617 elsif Nkind (Expression (N)) = N_Qualified_Expression
12618 and then Nkind (Expression (Expression (N))) = N_Op_Concat
12620 Set_Is_Dynamic_Coextension (N);
12622 Set_Is_Static_Coextension (N);
12627 end Mark_Allocator;
12629 procedure Mark_Allocators is new Traverse_Proc (Mark_Allocator);
12631 -- Start of processing Mark_Coextensions
12634 case Nkind (Context_Nod) is
12636 -- Comment here ???
12638 when N_Assignment_Statement =>
12639 Is_Dynamic := Nkind (Expression (Context_Nod)) = N_Allocator;
12641 -- An allocator that is a component of a returned aggregate
12642 -- must be dynamic.
12644 when N_Simple_Return_Statement =>
12646 Expr : constant Node_Id := Expression (Context_Nod);
12649 Nkind (Expr) = N_Allocator
12651 (Nkind (Expr) = N_Qualified_Expression
12652 and then Nkind (Expression (Expr)) = N_Aggregate);
12655 -- An alloctor within an object declaration in an extended return
12656 -- statement is of necessity dynamic.
12658 when N_Object_Declaration =>
12659 Is_Dynamic := Nkind (Root_Nod) = N_Allocator
12661 Nkind (Parent (Context_Nod)) = N_Extended_Return_Statement;
12663 -- This routine should not be called for constructs which may not
12664 -- contain coextensions.
12667 raise Program_Error;
12670 Mark_Allocators (Root_Nod);
12671 end Mark_Coextensions;
12677 function Must_Inline (Subp : Entity_Id) return Boolean is
12680 (Optimization_Level = 0
12682 -- AAMP and VM targets have no support for inlining in the backend.
12683 -- Hence we do as much inlining as possible in the front end.
12685 or else AAMP_On_Target
12686 or else VM_Target /= No_VM)
12687 and then Has_Pragma_Inline (Subp)
12688 and then (Has_Pragma_Inline_Always (Subp) or else Front_End_Inlining);
12691 ----------------------
12692 -- Needs_One_Actual --
12693 ----------------------
12695 function Needs_One_Actual (E : Entity_Id) return Boolean is
12696 Formal : Entity_Id;
12699 -- Ada 2005 or later, and formals present
12701 if Ada_Version >= Ada_2005 and then Present (First_Formal (E)) then
12702 Formal := Next_Formal (First_Formal (E));
12703 while Present (Formal) loop
12704 if No (Default_Value (Formal)) then
12708 Next_Formal (Formal);
12713 -- Ada 83/95 or no formals
12718 end Needs_One_Actual;
12720 ------------------------
12721 -- New_Copy_List_Tree --
12722 ------------------------
12724 function New_Copy_List_Tree (List : List_Id) return List_Id is
12729 if List = No_List then
12736 while Present (E) loop
12737 Append (New_Copy_Tree (E), NL);
12743 end New_Copy_List_Tree;
12745 -------------------
12746 -- New_Copy_Tree --
12747 -------------------
12749 use Atree.Unchecked_Access;
12750 use Atree_Private_Part;
12752 -- Our approach here requires a two pass traversal of the tree. The
12753 -- first pass visits all nodes that eventually will be copied looking
12754 -- for defining Itypes. If any defining Itypes are found, then they are
12755 -- copied, and an entry is added to the replacement map. In the second
12756 -- phase, the tree is copied, using the replacement map to replace any
12757 -- Itype references within the copied tree.
12759 -- The following hash tables are used if the Map supplied has more
12760 -- than hash threshold entries to speed up access to the map. If
12761 -- there are fewer entries, then the map is searched sequentially
12762 -- (because setting up a hash table for only a few entries takes
12763 -- more time than it saves.
12765 function New_Copy_Hash (E : Entity_Id) return NCT_Header_Num;
12766 -- Hash function used for hash operations
12768 -------------------
12769 -- New_Copy_Hash --
12770 -------------------
12772 function New_Copy_Hash (E : Entity_Id) return NCT_Header_Num is
12774 return Nat (E) mod (NCT_Header_Num'Last + 1);
12781 -- The hash table NCT_Assoc associates old entities in the table
12782 -- with their corresponding new entities (i.e. the pairs of entries
12783 -- presented in the original Map argument are Key-Element pairs).
12785 package NCT_Assoc is new Simple_HTable (
12786 Header_Num => NCT_Header_Num,
12787 Element => Entity_Id,
12788 No_Element => Empty,
12790 Hash => New_Copy_Hash,
12791 Equal => Types."=");
12793 ---------------------
12794 -- NCT_Itype_Assoc --
12795 ---------------------
12797 -- The hash table NCT_Itype_Assoc contains entries only for those
12798 -- old nodes which have a non-empty Associated_Node_For_Itype set.
12799 -- The key is the associated node, and the element is the new node
12800 -- itself (NOT the associated node for the new node).
12802 package NCT_Itype_Assoc is new Simple_HTable (
12803 Header_Num => NCT_Header_Num,
12804 Element => Entity_Id,
12805 No_Element => Empty,
12807 Hash => New_Copy_Hash,
12808 Equal => Types."=");
12810 -- Start of processing for New_Copy_Tree function
12812 function New_Copy_Tree
12814 Map : Elist_Id := No_Elist;
12815 New_Sloc : Source_Ptr := No_Location;
12816 New_Scope : Entity_Id := Empty) return Node_Id
12818 Actual_Map : Elist_Id := Map;
12819 -- This is the actual map for the copy. It is initialized with the
12820 -- given elements, and then enlarged as required for Itypes that are
12821 -- copied during the first phase of the copy operation. The visit
12822 -- procedures add elements to this map as Itypes are encountered.
12823 -- The reason we cannot use Map directly, is that it may well be
12824 -- (and normally is) initialized to No_Elist, and if we have mapped
12825 -- entities, we have to reset it to point to a real Elist.
12827 function Assoc (N : Node_Or_Entity_Id) return Node_Id;
12828 -- Called during second phase to map entities into their corresponding
12829 -- copies using Actual_Map. If the argument is not an entity, or is not
12830 -- in Actual_Map, then it is returned unchanged.
12832 procedure Build_NCT_Hash_Tables;
12833 -- Builds hash tables (number of elements >= threshold value)
12835 function Copy_Elist_With_Replacement
12836 (Old_Elist : Elist_Id) return Elist_Id;
12837 -- Called during second phase to copy element list doing replacements
12839 procedure Copy_Itype_With_Replacement (New_Itype : Entity_Id);
12840 -- Called during the second phase to process a copied Itype. The actual
12841 -- copy happened during the first phase (so that we could make the entry
12842 -- in the mapping), but we still have to deal with the descendents of
12843 -- the copied Itype and copy them where necessary.
12845 function Copy_List_With_Replacement (Old_List : List_Id) return List_Id;
12846 -- Called during second phase to copy list doing replacements
12848 function Copy_Node_With_Replacement (Old_Node : Node_Id) return Node_Id;
12849 -- Called during second phase to copy node doing replacements
12851 procedure Visit_Elist (E : Elist_Id);
12852 -- Called during first phase to visit all elements of an Elist
12854 procedure Visit_Field (F : Union_Id; N : Node_Id);
12855 -- Visit a single field, recursing to call Visit_Node or Visit_List
12856 -- if the field is a syntactic descendent of the current node (i.e.
12857 -- its parent is Node N).
12859 procedure Visit_Itype (Old_Itype : Entity_Id);
12860 -- Called during first phase to visit subsidiary fields of a defining
12861 -- Itype, and also create a copy and make an entry in the replacement
12862 -- map for the new copy.
12864 procedure Visit_List (L : List_Id);
12865 -- Called during first phase to visit all elements of a List
12867 procedure Visit_Node (N : Node_Or_Entity_Id);
12868 -- Called during first phase to visit a node and all its subtrees
12874 function Assoc (N : Node_Or_Entity_Id) return Node_Id is
12879 if not Has_Extension (N) or else No (Actual_Map) then
12882 elsif NCT_Hash_Tables_Used then
12883 Ent := NCT_Assoc.Get (Entity_Id (N));
12885 if Present (Ent) then
12891 -- No hash table used, do serial search
12894 E := First_Elmt (Actual_Map);
12895 while Present (E) loop
12896 if Node (E) = N then
12897 return Node (Next_Elmt (E));
12899 E := Next_Elmt (Next_Elmt (E));
12907 ---------------------------
12908 -- Build_NCT_Hash_Tables --
12909 ---------------------------
12911 procedure Build_NCT_Hash_Tables is
12915 if NCT_Hash_Table_Setup then
12917 NCT_Itype_Assoc.Reset;
12920 Elmt := First_Elmt (Actual_Map);
12921 while Present (Elmt) loop
12922 Ent := Node (Elmt);
12924 -- Get new entity, and associate old and new
12927 NCT_Assoc.Set (Ent, Node (Elmt));
12929 if Is_Type (Ent) then
12931 Anode : constant Entity_Id :=
12932 Associated_Node_For_Itype (Ent);
12935 if Present (Anode) then
12937 -- Enter a link between the associated node of the
12938 -- old Itype and the new Itype, for updating later
12939 -- when node is copied.
12941 NCT_Itype_Assoc.Set (Anode, Node (Elmt));
12949 NCT_Hash_Tables_Used := True;
12950 NCT_Hash_Table_Setup := True;
12951 end Build_NCT_Hash_Tables;
12953 ---------------------------------
12954 -- Copy_Elist_With_Replacement --
12955 ---------------------------------
12957 function Copy_Elist_With_Replacement
12958 (Old_Elist : Elist_Id) return Elist_Id
12961 New_Elist : Elist_Id;
12964 if No (Old_Elist) then
12968 New_Elist := New_Elmt_List;
12970 M := First_Elmt (Old_Elist);
12971 while Present (M) loop
12972 Append_Elmt (Copy_Node_With_Replacement (Node (M)), New_Elist);
12978 end Copy_Elist_With_Replacement;
12980 ---------------------------------
12981 -- Copy_Itype_With_Replacement --
12982 ---------------------------------
12984 -- This routine exactly parallels its phase one analog Visit_Itype,
12986 procedure Copy_Itype_With_Replacement (New_Itype : Entity_Id) is
12988 -- Translate Next_Entity, Scope and Etype fields, in case they
12989 -- reference entities that have been mapped into copies.
12991 Set_Next_Entity (New_Itype, Assoc (Next_Entity (New_Itype)));
12992 Set_Etype (New_Itype, Assoc (Etype (New_Itype)));
12994 if Present (New_Scope) then
12995 Set_Scope (New_Itype, New_Scope);
12997 Set_Scope (New_Itype, Assoc (Scope (New_Itype)));
13000 -- Copy referenced fields
13002 if Is_Discrete_Type (New_Itype) then
13003 Set_Scalar_Range (New_Itype,
13004 Copy_Node_With_Replacement (Scalar_Range (New_Itype)));
13006 elsif Has_Discriminants (Base_Type (New_Itype)) then
13007 Set_Discriminant_Constraint (New_Itype,
13008 Copy_Elist_With_Replacement
13009 (Discriminant_Constraint (New_Itype)));
13011 elsif Is_Array_Type (New_Itype) then
13012 if Present (First_Index (New_Itype)) then
13013 Set_First_Index (New_Itype,
13014 First (Copy_List_With_Replacement
13015 (List_Containing (First_Index (New_Itype)))));
13018 if Is_Packed (New_Itype) then
13019 Set_Packed_Array_Type (New_Itype,
13020 Copy_Node_With_Replacement
13021 (Packed_Array_Type (New_Itype)));
13024 end Copy_Itype_With_Replacement;
13026 --------------------------------
13027 -- Copy_List_With_Replacement --
13028 --------------------------------
13030 function Copy_List_With_Replacement
13031 (Old_List : List_Id) return List_Id
13033 New_List : List_Id;
13037 if Old_List = No_List then
13041 New_List := Empty_List;
13043 E := First (Old_List);
13044 while Present (E) loop
13045 Append (Copy_Node_With_Replacement (E), New_List);
13051 end Copy_List_With_Replacement;
13053 --------------------------------
13054 -- Copy_Node_With_Replacement --
13055 --------------------------------
13057 function Copy_Node_With_Replacement
13058 (Old_Node : Node_Id) return Node_Id
13060 New_Node : Node_Id;
13062 procedure Adjust_Named_Associations
13063 (Old_Node : Node_Id;
13064 New_Node : Node_Id);
13065 -- If a call node has named associations, these are chained through
13066 -- the First_Named_Actual, Next_Named_Actual links. These must be
13067 -- propagated separately to the new parameter list, because these
13068 -- are not syntactic fields.
13070 function Copy_Field_With_Replacement
13071 (Field : Union_Id) return Union_Id;
13072 -- Given Field, which is a field of Old_Node, return a copy of it
13073 -- if it is a syntactic field (i.e. its parent is Node), setting
13074 -- the parent of the copy to poit to New_Node. Otherwise returns
13075 -- the field (possibly mapped if it is an entity).
13077 -------------------------------
13078 -- Adjust_Named_Associations --
13079 -------------------------------
13081 procedure Adjust_Named_Associations
13082 (Old_Node : Node_Id;
13083 New_Node : Node_Id)
13088 Old_Next : Node_Id;
13089 New_Next : Node_Id;
13092 Old_E := First (Parameter_Associations (Old_Node));
13093 New_E := First (Parameter_Associations (New_Node));
13094 while Present (Old_E) loop
13095 if Nkind (Old_E) = N_Parameter_Association
13096 and then Present (Next_Named_Actual (Old_E))
13098 if First_Named_Actual (Old_Node)
13099 = Explicit_Actual_Parameter (Old_E)
13101 Set_First_Named_Actual
13102 (New_Node, Explicit_Actual_Parameter (New_E));
13105 -- Now scan parameter list from the beginning,to locate
13106 -- next named actual, which can be out of order.
13108 Old_Next := First (Parameter_Associations (Old_Node));
13109 New_Next := First (Parameter_Associations (New_Node));
13111 while Nkind (Old_Next) /= N_Parameter_Association
13112 or else Explicit_Actual_Parameter (Old_Next)
13113 /= Next_Named_Actual (Old_E)
13119 Set_Next_Named_Actual
13120 (New_E, Explicit_Actual_Parameter (New_Next));
13126 end Adjust_Named_Associations;
13128 ---------------------------------
13129 -- Copy_Field_With_Replacement --
13130 ---------------------------------
13132 function Copy_Field_With_Replacement
13133 (Field : Union_Id) return Union_Id
13136 if Field = Union_Id (Empty) then
13139 elsif Field in Node_Range then
13141 Old_N : constant Node_Id := Node_Id (Field);
13145 -- If syntactic field, as indicated by the parent pointer
13146 -- being set, then copy the referenced node recursively.
13148 if Parent (Old_N) = Old_Node then
13149 New_N := Copy_Node_With_Replacement (Old_N);
13151 if New_N /= Old_N then
13152 Set_Parent (New_N, New_Node);
13155 -- For semantic fields, update possible entity reference
13156 -- from the replacement map.
13159 New_N := Assoc (Old_N);
13162 return Union_Id (New_N);
13165 elsif Field in List_Range then
13167 Old_L : constant List_Id := List_Id (Field);
13171 -- If syntactic field, as indicated by the parent pointer,
13172 -- then recursively copy the entire referenced list.
13174 if Parent (Old_L) = Old_Node then
13175 New_L := Copy_List_With_Replacement (Old_L);
13176 Set_Parent (New_L, New_Node);
13178 -- For semantic list, just returned unchanged
13184 return Union_Id (New_L);
13187 -- Anything other than a list or a node is returned unchanged
13192 end Copy_Field_With_Replacement;
13194 -- Start of processing for Copy_Node_With_Replacement
13197 if Old_Node <= Empty_Or_Error then
13200 elsif Has_Extension (Old_Node) then
13201 return Assoc (Old_Node);
13204 New_Node := New_Copy (Old_Node);
13206 -- If the node we are copying is the associated node of a
13207 -- previously copied Itype, then adjust the associated node
13208 -- of the copy of that Itype accordingly.
13210 if Present (Actual_Map) then
13216 -- Case of hash table used
13218 if NCT_Hash_Tables_Used then
13219 Ent := NCT_Itype_Assoc.Get (Old_Node);
13221 if Present (Ent) then
13222 Set_Associated_Node_For_Itype (Ent, New_Node);
13225 -- Case of no hash table used
13228 E := First_Elmt (Actual_Map);
13229 while Present (E) loop
13230 if Is_Itype (Node (E))
13232 Old_Node = Associated_Node_For_Itype (Node (E))
13234 Set_Associated_Node_For_Itype
13235 (Node (Next_Elmt (E)), New_Node);
13238 E := Next_Elmt (Next_Elmt (E));
13244 -- Recursively copy descendents
13247 (New_Node, Copy_Field_With_Replacement (Field1 (New_Node)));
13249 (New_Node, Copy_Field_With_Replacement (Field2 (New_Node)));
13251 (New_Node, Copy_Field_With_Replacement (Field3 (New_Node)));
13253 (New_Node, Copy_Field_With_Replacement (Field4 (New_Node)));
13255 (New_Node, Copy_Field_With_Replacement (Field5 (New_Node)));
13257 -- Adjust Sloc of new node if necessary
13259 if New_Sloc /= No_Location then
13260 Set_Sloc (New_Node, New_Sloc);
13262 -- If we adjust the Sloc, then we are essentially making
13263 -- a completely new node, so the Comes_From_Source flag
13264 -- should be reset to the proper default value.
13266 Nodes.Table (New_Node).Comes_From_Source :=
13267 Default_Node.Comes_From_Source;
13270 -- If the node is call and has named associations,
13271 -- set the corresponding links in the copy.
13273 if (Nkind (Old_Node) = N_Function_Call
13274 or else Nkind (Old_Node) = N_Entry_Call_Statement
13276 Nkind (Old_Node) = N_Procedure_Call_Statement)
13277 and then Present (First_Named_Actual (Old_Node))
13279 Adjust_Named_Associations (Old_Node, New_Node);
13282 -- Reset First_Real_Statement for Handled_Sequence_Of_Statements.
13283 -- The replacement mechanism applies to entities, and is not used
13284 -- here. Eventually we may need a more general graph-copying
13285 -- routine. For now, do a sequential search to find desired node.
13287 if Nkind (Old_Node) = N_Handled_Sequence_Of_Statements
13288 and then Present (First_Real_Statement (Old_Node))
13291 Old_F : constant Node_Id := First_Real_Statement (Old_Node);
13295 N1 := First (Statements (Old_Node));
13296 N2 := First (Statements (New_Node));
13298 while N1 /= Old_F loop
13303 Set_First_Real_Statement (New_Node, N2);
13308 -- All done, return copied node
13311 end Copy_Node_With_Replacement;
13317 procedure Visit_Elist (E : Elist_Id) is
13320 if Present (E) then
13321 Elmt := First_Elmt (E);
13323 while Elmt /= No_Elmt loop
13324 Visit_Node (Node (Elmt));
13334 procedure Visit_Field (F : Union_Id; N : Node_Id) is
13336 if F = Union_Id (Empty) then
13339 elsif F in Node_Range then
13341 -- Copy node if it is syntactic, i.e. its parent pointer is
13342 -- set to point to the field that referenced it (certain
13343 -- Itypes will also meet this criterion, which is fine, since
13344 -- these are clearly Itypes that do need to be copied, since
13345 -- we are copying their parent.)
13347 if Parent (Node_Id (F)) = N then
13348 Visit_Node (Node_Id (F));
13351 -- Another case, if we are pointing to an Itype, then we want
13352 -- to copy it if its associated node is somewhere in the tree
13355 -- Note: the exclusion of self-referential copies is just an
13356 -- optimization, since the search of the already copied list
13357 -- would catch it, but it is a common case (Etype pointing
13358 -- to itself for an Itype that is a base type).
13360 elsif Has_Extension (Node_Id (F))
13361 and then Is_Itype (Entity_Id (F))
13362 and then Node_Id (F) /= N
13368 P := Associated_Node_For_Itype (Node_Id (F));
13369 while Present (P) loop
13371 Visit_Node (Node_Id (F));
13378 -- An Itype whose parent is not being copied definitely
13379 -- should NOT be copied, since it does not belong in any
13380 -- sense to the copied subtree.
13386 elsif F in List_Range
13387 and then Parent (List_Id (F)) = N
13389 Visit_List (List_Id (F));
13398 procedure Visit_Itype (Old_Itype : Entity_Id) is
13399 New_Itype : Entity_Id;
13404 -- Itypes that describe the designated type of access to subprograms
13405 -- have the structure of subprogram declarations, with signatures,
13406 -- etc. Either we duplicate the signatures completely, or choose to
13407 -- share such itypes, which is fine because their elaboration will
13408 -- have no side effects.
13410 if Ekind (Old_Itype) = E_Subprogram_Type then
13414 New_Itype := New_Copy (Old_Itype);
13416 -- The new Itype has all the attributes of the old one, and
13417 -- we just copy the contents of the entity. However, the back-end
13418 -- needs different names for debugging purposes, so we create a
13419 -- new internal name for it in all cases.
13421 Set_Chars (New_Itype, New_Internal_Name ('T'));
13423 -- If our associated node is an entity that has already been copied,
13424 -- then set the associated node of the copy to point to the right
13425 -- copy. If we have copied an Itype that is itself the associated
13426 -- node of some previously copied Itype, then we set the right
13427 -- pointer in the other direction.
13429 if Present (Actual_Map) then
13431 -- Case of hash tables used
13433 if NCT_Hash_Tables_Used then
13435 Ent := NCT_Assoc.Get (Associated_Node_For_Itype (Old_Itype));
13437 if Present (Ent) then
13438 Set_Associated_Node_For_Itype (New_Itype, Ent);
13441 Ent := NCT_Itype_Assoc.Get (Old_Itype);
13442 if Present (Ent) then
13443 Set_Associated_Node_For_Itype (Ent, New_Itype);
13445 -- If the hash table has no association for this Itype and
13446 -- its associated node, enter one now.
13449 NCT_Itype_Assoc.Set
13450 (Associated_Node_For_Itype (Old_Itype), New_Itype);
13453 -- Case of hash tables not used
13456 E := First_Elmt (Actual_Map);
13457 while Present (E) loop
13458 if Associated_Node_For_Itype (Old_Itype) = Node (E) then
13459 Set_Associated_Node_For_Itype
13460 (New_Itype, Node (Next_Elmt (E)));
13463 if Is_Type (Node (E))
13465 Old_Itype = Associated_Node_For_Itype (Node (E))
13467 Set_Associated_Node_For_Itype
13468 (Node (Next_Elmt (E)), New_Itype);
13471 E := Next_Elmt (Next_Elmt (E));
13476 if Present (Freeze_Node (New_Itype)) then
13477 Set_Is_Frozen (New_Itype, False);
13478 Set_Freeze_Node (New_Itype, Empty);
13481 -- Add new association to map
13483 if No (Actual_Map) then
13484 Actual_Map := New_Elmt_List;
13487 Append_Elmt (Old_Itype, Actual_Map);
13488 Append_Elmt (New_Itype, Actual_Map);
13490 if NCT_Hash_Tables_Used then
13491 NCT_Assoc.Set (Old_Itype, New_Itype);
13494 NCT_Table_Entries := NCT_Table_Entries + 1;
13496 if NCT_Table_Entries > NCT_Hash_Threshold then
13497 Build_NCT_Hash_Tables;
13501 -- If a record subtype is simply copied, the entity list will be
13502 -- shared. Thus cloned_Subtype must be set to indicate the sharing.
13504 if Ekind_In (Old_Itype, E_Record_Subtype, E_Class_Wide_Subtype) then
13505 Set_Cloned_Subtype (New_Itype, Old_Itype);
13508 -- Visit descendents that eventually get copied
13510 Visit_Field (Union_Id (Etype (Old_Itype)), Old_Itype);
13512 if Is_Discrete_Type (Old_Itype) then
13513 Visit_Field (Union_Id (Scalar_Range (Old_Itype)), Old_Itype);
13515 elsif Has_Discriminants (Base_Type (Old_Itype)) then
13516 -- ??? This should involve call to Visit_Field
13517 Visit_Elist (Discriminant_Constraint (Old_Itype));
13519 elsif Is_Array_Type (Old_Itype) then
13520 if Present (First_Index (Old_Itype)) then
13521 Visit_Field (Union_Id (List_Containing
13522 (First_Index (Old_Itype))),
13526 if Is_Packed (Old_Itype) then
13527 Visit_Field (Union_Id (Packed_Array_Type (Old_Itype)),
13537 procedure Visit_List (L : List_Id) is
13540 if L /= No_List then
13543 while Present (N) loop
13554 procedure Visit_Node (N : Node_Or_Entity_Id) is
13556 -- Start of processing for Visit_Node
13559 -- Handle case of an Itype, which must be copied
13561 if Has_Extension (N)
13562 and then Is_Itype (N)
13564 -- Nothing to do if already in the list. This can happen with an
13565 -- Itype entity that appears more than once in the tree.
13566 -- Note that we do not want to visit descendents in this case.
13568 -- Test for already in list when hash table is used
13570 if NCT_Hash_Tables_Used then
13571 if Present (NCT_Assoc.Get (Entity_Id (N))) then
13575 -- Test for already in list when hash table not used
13581 if Present (Actual_Map) then
13582 E := First_Elmt (Actual_Map);
13583 while Present (E) loop
13584 if Node (E) = N then
13587 E := Next_Elmt (Next_Elmt (E));
13597 -- Visit descendents
13599 Visit_Field (Field1 (N), N);
13600 Visit_Field (Field2 (N), N);
13601 Visit_Field (Field3 (N), N);
13602 Visit_Field (Field4 (N), N);
13603 Visit_Field (Field5 (N), N);
13606 -- Start of processing for New_Copy_Tree
13611 -- See if we should use hash table
13613 if No (Actual_Map) then
13614 NCT_Hash_Tables_Used := False;
13621 NCT_Table_Entries := 0;
13623 Elmt := First_Elmt (Actual_Map);
13624 while Present (Elmt) loop
13625 NCT_Table_Entries := NCT_Table_Entries + 1;
13630 if NCT_Table_Entries > NCT_Hash_Threshold then
13631 Build_NCT_Hash_Tables;
13633 NCT_Hash_Tables_Used := False;
13638 -- Hash table set up if required, now start phase one by visiting
13639 -- top node (we will recursively visit the descendents).
13641 Visit_Node (Source);
13643 -- Now the second phase of the copy can start. First we process
13644 -- all the mapped entities, copying their descendents.
13646 if Present (Actual_Map) then
13649 New_Itype : Entity_Id;
13651 Elmt := First_Elmt (Actual_Map);
13652 while Present (Elmt) loop
13654 New_Itype := Node (Elmt);
13655 Copy_Itype_With_Replacement (New_Itype);
13661 -- Now we can copy the actual tree
13663 return Copy_Node_With_Replacement (Source);
13666 -------------------------
13667 -- New_External_Entity --
13668 -------------------------
13670 function New_External_Entity
13671 (Kind : Entity_Kind;
13672 Scope_Id : Entity_Id;
13673 Sloc_Value : Source_Ptr;
13674 Related_Id : Entity_Id;
13675 Suffix : Character;
13676 Suffix_Index : Nat := 0;
13677 Prefix : Character := ' ') return Entity_Id
13679 N : constant Entity_Id :=
13680 Make_Defining_Identifier (Sloc_Value,
13682 (Chars (Related_Id), Suffix, Suffix_Index, Prefix));
13685 Set_Ekind (N, Kind);
13686 Set_Is_Internal (N, True);
13687 Append_Entity (N, Scope_Id);
13688 Set_Public_Status (N);
13690 if Kind in Type_Kind then
13691 Init_Size_Align (N);
13695 end New_External_Entity;
13697 -------------------------
13698 -- New_Internal_Entity --
13699 -------------------------
13701 function New_Internal_Entity
13702 (Kind : Entity_Kind;
13703 Scope_Id : Entity_Id;
13704 Sloc_Value : Source_Ptr;
13705 Id_Char : Character) return Entity_Id
13707 N : constant Entity_Id := Make_Temporary (Sloc_Value, Id_Char);
13710 Set_Ekind (N, Kind);
13711 Set_Is_Internal (N, True);
13712 Append_Entity (N, Scope_Id);
13714 if Kind in Type_Kind then
13715 Init_Size_Align (N);
13719 end New_Internal_Entity;
13725 function Next_Actual (Actual_Id : Node_Id) return Node_Id is
13729 -- If we are pointing at a positional parameter, it is a member of a
13730 -- node list (the list of parameters), and the next parameter is the
13731 -- next node on the list, unless we hit a parameter association, then
13732 -- we shift to using the chain whose head is the First_Named_Actual in
13733 -- the parent, and then is threaded using the Next_Named_Actual of the
13734 -- Parameter_Association. All this fiddling is because the original node
13735 -- list is in the textual call order, and what we need is the
13736 -- declaration order.
13738 if Is_List_Member (Actual_Id) then
13739 N := Next (Actual_Id);
13741 if Nkind (N) = N_Parameter_Association then
13742 return First_Named_Actual (Parent (Actual_Id));
13748 return Next_Named_Actual (Parent (Actual_Id));
13752 procedure Next_Actual (Actual_Id : in out Node_Id) is
13754 Actual_Id := Next_Actual (Actual_Id);
13757 ---------------------
13758 -- No_Scalar_Parts --
13759 ---------------------
13761 function No_Scalar_Parts (T : Entity_Id) return Boolean is
13765 if Is_Scalar_Type (T) then
13768 elsif Is_Array_Type (T) then
13769 return No_Scalar_Parts (Component_Type (T));
13771 elsif Is_Record_Type (T) or else Has_Discriminants (T) then
13772 C := First_Component_Or_Discriminant (T);
13773 while Present (C) loop
13774 if not No_Scalar_Parts (Etype (C)) then
13777 Next_Component_Or_Discriminant (C);
13783 end No_Scalar_Parts;
13785 -----------------------
13786 -- Normalize_Actuals --
13787 -----------------------
13789 -- Chain actuals according to formals of subprogram. If there are no named
13790 -- associations, the chain is simply the list of Parameter Associations,
13791 -- since the order is the same as the declaration order. If there are named
13792 -- associations, then the First_Named_Actual field in the N_Function_Call
13793 -- or N_Procedure_Call_Statement node points to the Parameter_Association
13794 -- node for the parameter that comes first in declaration order. The
13795 -- remaining named parameters are then chained in declaration order using
13796 -- Next_Named_Actual.
13798 -- This routine also verifies that the number of actuals is compatible with
13799 -- the number and default values of formals, but performs no type checking
13800 -- (type checking is done by the caller).
13802 -- If the matching succeeds, Success is set to True and the caller proceeds
13803 -- with type-checking. If the match is unsuccessful, then Success is set to
13804 -- False, and the caller attempts a different interpretation, if there is
13807 -- If the flag Report is on, the call is not overloaded, and a failure to
13808 -- match can be reported here, rather than in the caller.
13810 procedure Normalize_Actuals
13814 Success : out Boolean)
13816 Actuals : constant List_Id := Parameter_Associations (N);
13817 Actual : Node_Id := Empty;
13818 Formal : Entity_Id;
13819 Last : Node_Id := Empty;
13820 First_Named : Node_Id := Empty;
13823 Formals_To_Match : Integer := 0;
13824 Actuals_To_Match : Integer := 0;
13826 procedure Chain (A : Node_Id);
13827 -- Add named actual at the proper place in the list, using the
13828 -- Next_Named_Actual link.
13830 function Reporting return Boolean;
13831 -- Determines if an error is to be reported. To report an error, we
13832 -- need Report to be True, and also we do not report errors caused
13833 -- by calls to init procs that occur within other init procs. Such
13834 -- errors must always be cascaded errors, since if all the types are
13835 -- declared correctly, the compiler will certainly build decent calls.
13841 procedure Chain (A : Node_Id) is
13845 -- Call node points to first actual in list
13847 Set_First_Named_Actual (N, Explicit_Actual_Parameter (A));
13850 Set_Next_Named_Actual (Last, Explicit_Actual_Parameter (A));
13854 Set_Next_Named_Actual (Last, Empty);
13861 function Reporting return Boolean is
13866 elsif not Within_Init_Proc then
13869 elsif Is_Init_Proc (Entity (Name (N))) then
13877 -- Start of processing for Normalize_Actuals
13880 if Is_Access_Type (S) then
13882 -- The name in the call is a function call that returns an access
13883 -- to subprogram. The designated type has the list of formals.
13885 Formal := First_Formal (Designated_Type (S));
13887 Formal := First_Formal (S);
13890 while Present (Formal) loop
13891 Formals_To_Match := Formals_To_Match + 1;
13892 Next_Formal (Formal);
13895 -- Find if there is a named association, and verify that no positional
13896 -- associations appear after named ones.
13898 if Present (Actuals) then
13899 Actual := First (Actuals);
13902 while Present (Actual)
13903 and then Nkind (Actual) /= N_Parameter_Association
13905 Actuals_To_Match := Actuals_To_Match + 1;
13909 if No (Actual) and Actuals_To_Match = Formals_To_Match then
13911 -- Most common case: positional notation, no defaults
13916 elsif Actuals_To_Match > Formals_To_Match then
13918 -- Too many actuals: will not work
13921 if Is_Entity_Name (Name (N)) then
13922 Error_Msg_N ("too many arguments in call to&", Name (N));
13924 Error_Msg_N ("too many arguments in call", N);
13932 First_Named := Actual;
13934 while Present (Actual) loop
13935 if Nkind (Actual) /= N_Parameter_Association then
13937 ("positional parameters not allowed after named ones", Actual);
13942 Actuals_To_Match := Actuals_To_Match + 1;
13948 if Present (Actuals) then
13949 Actual := First (Actuals);
13952 Formal := First_Formal (S);
13953 while Present (Formal) loop
13955 -- Match the formals in order. If the corresponding actual is
13956 -- positional, nothing to do. Else scan the list of named actuals
13957 -- to find the one with the right name.
13959 if Present (Actual)
13960 and then Nkind (Actual) /= N_Parameter_Association
13963 Actuals_To_Match := Actuals_To_Match - 1;
13964 Formals_To_Match := Formals_To_Match - 1;
13967 -- For named parameters, search the list of actuals to find
13968 -- one that matches the next formal name.
13970 Actual := First_Named;
13972 while Present (Actual) loop
13973 if Chars (Selector_Name (Actual)) = Chars (Formal) then
13976 Actuals_To_Match := Actuals_To_Match - 1;
13977 Formals_To_Match := Formals_To_Match - 1;
13985 if Ekind (Formal) /= E_In_Parameter
13986 or else No (Default_Value (Formal))
13989 if (Comes_From_Source (S)
13990 or else Sloc (S) = Standard_Location)
13991 and then Is_Overloadable (S)
13995 (Nkind (Parent (N)) = N_Procedure_Call_Statement
13997 (Nkind (Parent (N)) = N_Function_Call
13999 Nkind (Parent (N)) = N_Parameter_Association))
14000 and then Ekind (S) /= E_Function
14002 Set_Etype (N, Etype (S));
14004 Error_Msg_Name_1 := Chars (S);
14005 Error_Msg_Sloc := Sloc (S);
14007 ("missing argument for parameter & " &
14008 "in call to % declared #", N, Formal);
14011 elsif Is_Overloadable (S) then
14012 Error_Msg_Name_1 := Chars (S);
14014 -- Point to type derivation that generated the
14017 Error_Msg_Sloc := Sloc (Parent (S));
14020 ("missing argument for parameter & " &
14021 "in call to % (inherited) #", N, Formal);
14025 ("missing argument for parameter &", N, Formal);
14033 Formals_To_Match := Formals_To_Match - 1;
14038 Next_Formal (Formal);
14041 if Formals_To_Match = 0 and then Actuals_To_Match = 0 then
14048 -- Find some superfluous named actual that did not get
14049 -- attached to the list of associations.
14051 Actual := First (Actuals);
14052 while Present (Actual) loop
14053 if Nkind (Actual) = N_Parameter_Association
14054 and then Actual /= Last
14055 and then No (Next_Named_Actual (Actual))
14057 Error_Msg_N ("unmatched actual & in call",
14058 Selector_Name (Actual));
14069 end Normalize_Actuals;
14071 --------------------------------
14072 -- Note_Possible_Modification --
14073 --------------------------------
14075 procedure Note_Possible_Modification (N : Node_Id; Sure : Boolean) is
14076 Modification_Comes_From_Source : constant Boolean :=
14077 Comes_From_Source (Parent (N));
14083 -- Loop to find referenced entity, if there is one
14089 if Is_Entity_Name (Exp) then
14090 Ent := Entity (Exp);
14092 -- If the entity is missing, it is an undeclared identifier,
14093 -- and there is nothing to annotate.
14099 elsif Nkind (Exp) = N_Explicit_Dereference then
14101 P : constant Node_Id := Prefix (Exp);
14104 -- In formal verification mode, keep track of all reads and
14105 -- writes through explicit dereferences.
14107 if GNATprove_Mode then
14108 SPARK_Specific.Generate_Dereference (N, 'm');
14111 if Nkind (P) = N_Selected_Component
14112 and then Present (Entry_Formal (Entity (Selector_Name (P))))
14114 -- Case of a reference to an entry formal
14116 Ent := Entry_Formal (Entity (Selector_Name (P)));
14118 elsif Nkind (P) = N_Identifier
14119 and then Nkind (Parent (Entity (P))) = N_Object_Declaration
14120 and then Present (Expression (Parent (Entity (P))))
14121 and then Nkind (Expression (Parent (Entity (P)))) =
14124 -- Case of a reference to a value on which side effects have
14127 Exp := Prefix (Expression (Parent (Entity (P))));
14135 elsif Nkind_In (Exp, N_Type_Conversion,
14136 N_Unchecked_Type_Conversion)
14138 Exp := Expression (Exp);
14141 elsif Nkind_In (Exp, N_Slice,
14142 N_Indexed_Component,
14143 N_Selected_Component)
14145 -- Special check, if the prefix is an access type, then return
14146 -- since we are modifying the thing pointed to, not the prefix.
14147 -- When we are expanding, most usually the prefix is replaced
14148 -- by an explicit dereference, and this test is not needed, but
14149 -- in some cases (notably -gnatc mode and generics) when we do
14150 -- not do full expansion, we need this special test.
14152 if Is_Access_Type (Etype (Prefix (Exp))) then
14155 -- Otherwise go to prefix and keep going
14158 Exp := Prefix (Exp);
14162 -- All other cases, not a modification
14168 -- Now look for entity being referenced
14170 if Present (Ent) then
14171 if Is_Object (Ent) then
14172 if Comes_From_Source (Exp)
14173 or else Modification_Comes_From_Source
14175 -- Give warning if pragma unmodified given and we are
14176 -- sure this is a modification.
14178 if Has_Pragma_Unmodified (Ent) and then Sure then
14180 ("??pragma Unmodified given for &!", N, Ent);
14183 Set_Never_Set_In_Source (Ent, False);
14186 Set_Is_True_Constant (Ent, False);
14187 Set_Current_Value (Ent, Empty);
14188 Set_Is_Known_Null (Ent, False);
14190 if not Can_Never_Be_Null (Ent) then
14191 Set_Is_Known_Non_Null (Ent, False);
14194 -- Follow renaming chain
14196 if (Ekind (Ent) = E_Variable or else Ekind (Ent) = E_Constant)
14197 and then Present (Renamed_Object (Ent))
14199 Exp := Renamed_Object (Ent);
14201 -- If the entity is the loop variable in an iteration over
14202 -- a container, retrieve container expression to indicate
14203 -- possible modificastion.
14205 if Present (Related_Expression (Ent))
14206 and then Nkind (Parent (Related_Expression (Ent))) =
14207 N_Iterator_Specification
14209 Exp := Original_Node (Related_Expression (Ent));
14214 -- The expression may be the renaming of a subcomponent of an
14215 -- array or container. The assignment to the subcomponent is
14216 -- a modification of the container.
14218 elsif Comes_From_Source (Original_Node (Exp))
14219 and then Nkind_In (Original_Node (Exp), N_Selected_Component,
14220 N_Indexed_Component)
14222 Exp := Prefix (Original_Node (Exp));
14226 -- Generate a reference only if the assignment comes from
14227 -- source. This excludes, for example, calls to a dispatching
14228 -- assignment operation when the left-hand side is tagged. In
14229 -- GNATprove mode, we need those references also on generated
14230 -- code, as these are used to compute the local effects of
14233 if Modification_Comes_From_Source or GNATprove_Mode then
14234 Generate_Reference (Ent, Exp, 'm');
14236 -- If the target of the assignment is the bound variable
14237 -- in an iterator, indicate that the corresponding array
14238 -- or container is also modified.
14240 if Ada_Version >= Ada_2012
14242 Nkind (Parent (Ent)) = N_Iterator_Specification
14245 Domain : constant Node_Id := Name (Parent (Ent));
14248 -- TBD : in the full version of the construct, the
14249 -- domain of iteration can be given by an expression.
14251 if Is_Entity_Name (Domain) then
14252 Generate_Reference (Entity (Domain), Exp, 'm');
14253 Set_Is_True_Constant (Entity (Domain), False);
14254 Set_Never_Set_In_Source (Entity (Domain), False);
14260 Check_Nested_Access (Ent);
14265 -- If we are sure this is a modification from source, and we know
14266 -- this modifies a constant, then give an appropriate warning.
14268 if Overlays_Constant (Ent)
14269 and then Modification_Comes_From_Source
14273 A : constant Node_Id := Address_Clause (Ent);
14275 if Present (A) then
14277 Exp : constant Node_Id := Expression (A);
14279 if Nkind (Exp) = N_Attribute_Reference
14280 and then Attribute_Name (Exp) = Name_Address
14281 and then Is_Entity_Name (Prefix (Exp))
14283 Error_Msg_Sloc := Sloc (A);
14285 ("constant& may be modified via address "
14286 & "clause#??", N, Entity (Prefix (Exp)));
14299 end Note_Possible_Modification;
14301 -------------------------
14302 -- Object_Access_Level --
14303 -------------------------
14305 -- Returns the static accessibility level of the view denoted by Obj. Note
14306 -- that the value returned is the result of a call to Scope_Depth. Only
14307 -- scope depths associated with dynamic scopes can actually be returned.
14308 -- Since only relative levels matter for accessibility checking, the fact
14309 -- that the distance between successive levels of accessibility is not
14310 -- always one is immaterial (invariant: if level(E2) is deeper than
14311 -- level(E1), then Scope_Depth(E1) < Scope_Depth(E2)).
14313 function Object_Access_Level (Obj : Node_Id) return Uint is
14314 function Is_Interface_Conversion (N : Node_Id) return Boolean;
14315 -- Determine whether N is a construct of the form
14316 -- Some_Type (Operand._tag'Address)
14317 -- This construct appears in the context of dispatching calls.
14319 function Reference_To (Obj : Node_Id) return Node_Id;
14320 -- An explicit dereference is created when removing side-effects from
14321 -- expressions for constraint checking purposes. In this case a local
14322 -- access type is created for it. The correct access level is that of
14323 -- the original source node. We detect this case by noting that the
14324 -- prefix of the dereference is created by an object declaration whose
14325 -- initial expression is a reference.
14327 -----------------------------
14328 -- Is_Interface_Conversion --
14329 -----------------------------
14331 function Is_Interface_Conversion (N : Node_Id) return Boolean is
14334 Nkind (N) = N_Unchecked_Type_Conversion
14335 and then Nkind (Expression (N)) = N_Attribute_Reference
14336 and then Attribute_Name (Expression (N)) = Name_Address;
14337 end Is_Interface_Conversion;
14343 function Reference_To (Obj : Node_Id) return Node_Id is
14344 Pref : constant Node_Id := Prefix (Obj);
14346 if Is_Entity_Name (Pref)
14347 and then Nkind (Parent (Entity (Pref))) = N_Object_Declaration
14348 and then Present (Expression (Parent (Entity (Pref))))
14349 and then Nkind (Expression (Parent (Entity (Pref)))) = N_Reference
14351 return (Prefix (Expression (Parent (Entity (Pref)))));
14361 -- Start of processing for Object_Access_Level
14364 if Nkind (Obj) = N_Defining_Identifier
14365 or else Is_Entity_Name (Obj)
14367 if Nkind (Obj) = N_Defining_Identifier then
14373 if Is_Prival (E) then
14374 E := Prival_Link (E);
14377 -- If E is a type then it denotes a current instance. For this case
14378 -- we add one to the normal accessibility level of the type to ensure
14379 -- that current instances are treated as always being deeper than
14380 -- than the level of any visible named access type (see 3.10.2(21)).
14382 if Is_Type (E) then
14383 return Type_Access_Level (E) + 1;
14385 elsif Present (Renamed_Object (E)) then
14386 return Object_Access_Level (Renamed_Object (E));
14388 -- Similarly, if E is a component of the current instance of a
14389 -- protected type, any instance of it is assumed to be at a deeper
14390 -- level than the type. For a protected object (whose type is an
14391 -- anonymous protected type) its components are at the same level
14392 -- as the type itself.
14394 elsif not Is_Overloadable (E)
14395 and then Ekind (Scope (E)) = E_Protected_Type
14396 and then Comes_From_Source (Scope (E))
14398 return Type_Access_Level (Scope (E)) + 1;
14401 return Scope_Depth (Enclosing_Dynamic_Scope (E));
14404 elsif Nkind (Obj) = N_Selected_Component then
14405 if Is_Access_Type (Etype (Prefix (Obj))) then
14406 return Type_Access_Level (Etype (Prefix (Obj)));
14408 return Object_Access_Level (Prefix (Obj));
14411 elsif Nkind (Obj) = N_Indexed_Component then
14412 if Is_Access_Type (Etype (Prefix (Obj))) then
14413 return Type_Access_Level (Etype (Prefix (Obj)));
14415 return Object_Access_Level (Prefix (Obj));
14418 elsif Nkind (Obj) = N_Explicit_Dereference then
14420 -- If the prefix is a selected access discriminant then we make a
14421 -- recursive call on the prefix, which will in turn check the level
14422 -- of the prefix object of the selected discriminant.
14424 if Nkind (Prefix (Obj)) = N_Selected_Component
14425 and then Ekind (Etype (Prefix (Obj))) = E_Anonymous_Access_Type
14427 Ekind (Entity (Selector_Name (Prefix (Obj)))) = E_Discriminant
14429 return Object_Access_Level (Prefix (Obj));
14431 -- Detect an interface conversion in the context of a dispatching
14432 -- call. Use the original form of the conversion to find the access
14433 -- level of the operand.
14435 elsif Is_Interface (Etype (Obj))
14436 and then Is_Interface_Conversion (Prefix (Obj))
14437 and then Nkind (Original_Node (Obj)) = N_Type_Conversion
14439 return Object_Access_Level (Original_Node (Obj));
14441 elsif not Comes_From_Source (Obj) then
14443 Ref : constant Node_Id := Reference_To (Obj);
14445 if Present (Ref) then
14446 return Object_Access_Level (Ref);
14448 return Type_Access_Level (Etype (Prefix (Obj)));
14453 return Type_Access_Level (Etype (Prefix (Obj)));
14456 elsif Nkind_In (Obj, N_Type_Conversion, N_Unchecked_Type_Conversion) then
14457 return Object_Access_Level (Expression (Obj));
14459 elsif Nkind (Obj) = N_Function_Call then
14461 -- Function results are objects, so we get either the access level of
14462 -- the function or, in the case of an indirect call, the level of the
14463 -- access-to-subprogram type. (This code is used for Ada 95, but it
14464 -- looks wrong, because it seems that we should be checking the level
14465 -- of the call itself, even for Ada 95. However, using the Ada 2005
14466 -- version of the code causes regressions in several tests that are
14467 -- compiled with -gnat95. ???)
14469 if Ada_Version < Ada_2005 then
14470 if Is_Entity_Name (Name (Obj)) then
14471 return Subprogram_Access_Level (Entity (Name (Obj)));
14473 return Type_Access_Level (Etype (Prefix (Name (Obj))));
14476 -- For Ada 2005, the level of the result object of a function call is
14477 -- defined to be the level of the call's innermost enclosing master.
14478 -- We determine that by querying the depth of the innermost enclosing
14482 Return_Master_Scope_Depth_Of_Call : declare
14484 function Innermost_Master_Scope_Depth
14485 (N : Node_Id) return Uint;
14486 -- Returns the scope depth of the given node's innermost
14487 -- enclosing dynamic scope (effectively the accessibility
14488 -- level of the innermost enclosing master).
14490 ----------------------------------
14491 -- Innermost_Master_Scope_Depth --
14492 ----------------------------------
14494 function Innermost_Master_Scope_Depth
14495 (N : Node_Id) return Uint
14497 Node_Par : Node_Id := Parent (N);
14500 -- Locate the nearest enclosing node (by traversing Parents)
14501 -- that Defining_Entity can be applied to, and return the
14502 -- depth of that entity's nearest enclosing dynamic scope.
14504 while Present (Node_Par) loop
14505 case Nkind (Node_Par) is
14506 when N_Component_Declaration |
14507 N_Entry_Declaration |
14508 N_Formal_Object_Declaration |
14509 N_Formal_Type_Declaration |
14510 N_Full_Type_Declaration |
14511 N_Incomplete_Type_Declaration |
14512 N_Loop_Parameter_Specification |
14513 N_Object_Declaration |
14514 N_Protected_Type_Declaration |
14515 N_Private_Extension_Declaration |
14516 N_Private_Type_Declaration |
14517 N_Subtype_Declaration |
14518 N_Function_Specification |
14519 N_Procedure_Specification |
14520 N_Task_Type_Declaration |
14522 N_Generic_Instantiation |
14524 N_Implicit_Label_Declaration |
14525 N_Package_Declaration |
14526 N_Single_Task_Declaration |
14527 N_Subprogram_Declaration |
14528 N_Generic_Declaration |
14529 N_Renaming_Declaration |
14530 N_Block_Statement |
14531 N_Formal_Subprogram_Declaration |
14532 N_Abstract_Subprogram_Declaration |
14534 N_Exception_Declaration |
14535 N_Formal_Package_Declaration |
14536 N_Number_Declaration |
14537 N_Package_Specification |
14538 N_Parameter_Specification |
14539 N_Single_Protected_Declaration |
14543 (Nearest_Dynamic_Scope
14544 (Defining_Entity (Node_Par)));
14550 Node_Par := Parent (Node_Par);
14553 pragma Assert (False);
14555 -- Should never reach the following return
14557 return Scope_Depth (Current_Scope) + 1;
14558 end Innermost_Master_Scope_Depth;
14560 -- Start of processing for Return_Master_Scope_Depth_Of_Call
14563 return Innermost_Master_Scope_Depth (Obj);
14564 end Return_Master_Scope_Depth_Of_Call;
14567 -- For convenience we handle qualified expressions, even though they
14568 -- aren't technically object names.
14570 elsif Nkind (Obj) = N_Qualified_Expression then
14571 return Object_Access_Level (Expression (Obj));
14573 -- Otherwise return the scope level of Standard. (If there are cases
14574 -- that fall through to this point they will be treated as having
14575 -- global accessibility for now. ???)
14578 return Scope_Depth (Standard_Standard);
14580 end Object_Access_Level;
14582 --------------------------
14583 -- Original_Aspect_Name --
14584 --------------------------
14586 function Original_Aspect_Name (N : Node_Id) return Name_Id is
14591 pragma Assert (Nkind_In (N, N_Aspect_Specification, N_Pragma));
14594 if Is_Rewrite_Substitution (Pras)
14595 and then Nkind (Original_Node (Pras)) = N_Pragma
14597 Pras := Original_Node (Pras);
14600 -- Case where we came from aspect specication
14602 if Nkind (Pras) = N_Pragma and then From_Aspect_Specification (Pras) then
14603 Pras := Corresponding_Aspect (Pras);
14606 -- Get name from aspect or pragma
14608 if Nkind (Pras) = N_Pragma then
14609 Name := Pragma_Name (Pras);
14611 Name := Chars (Identifier (Pras));
14614 -- Deal with 'Class
14616 if Class_Present (Pras) then
14619 -- Names that need converting to special _xxx form
14627 Name := Name_uPost;
14629 when Name_Invariant =>
14630 Name := Name_uInvariant;
14632 when Name_Type_Invariant |
14633 Name_Type_Invariant_Class =>
14634 Name := Name_uType_Invariant;
14636 -- Nothing to do for other cases (e.g. a Check that derived
14637 -- from Pre_Class and has the flag set). Also we do nothing
14638 -- if the name is already in special _xxx form.
14646 end Original_Aspect_Name;
14647 --------------------------------------
14648 -- Original_Corresponding_Operation --
14649 --------------------------------------
14651 function Original_Corresponding_Operation (S : Entity_Id) return Entity_Id
14653 Typ : constant Entity_Id := Find_Dispatching_Type (S);
14656 -- If S is an inherited primitive S2 the original corresponding
14657 -- operation of S is the original corresponding operation of S2
14659 if Present (Alias (S))
14660 and then Find_Dispatching_Type (Alias (S)) /= Typ
14662 return Original_Corresponding_Operation (Alias (S));
14664 -- If S overrides an inherited subprogram S2 the original corresponding
14665 -- operation of S is the original corresponding operation of S2
14667 elsif Present (Overridden_Operation (S)) then
14668 return Original_Corresponding_Operation (Overridden_Operation (S));
14670 -- otherwise it is S itself
14675 end Original_Corresponding_Operation;
14677 -----------------------
14678 -- Private_Component --
14679 -----------------------
14681 function Private_Component (Type_Id : Entity_Id) return Entity_Id is
14682 Ancestor : constant Entity_Id := Base_Type (Type_Id);
14684 function Trace_Components
14686 Check : Boolean) return Entity_Id;
14687 -- Recursive function that does the work, and checks against circular
14688 -- definition for each subcomponent type.
14690 ----------------------
14691 -- Trace_Components --
14692 ----------------------
14694 function Trace_Components
14696 Check : Boolean) return Entity_Id
14698 Btype : constant Entity_Id := Base_Type (T);
14699 Component : Entity_Id;
14701 Candidate : Entity_Id := Empty;
14704 if Check and then Btype = Ancestor then
14705 Error_Msg_N ("circular type definition", Type_Id);
14709 if Is_Private_Type (Btype)
14710 and then not Is_Generic_Type (Btype)
14712 if Present (Full_View (Btype))
14713 and then Is_Record_Type (Full_View (Btype))
14714 and then not Is_Frozen (Btype)
14716 -- To indicate that the ancestor depends on a private type, the
14717 -- current Btype is sufficient. However, to check for circular
14718 -- definition we must recurse on the full view.
14720 Candidate := Trace_Components (Full_View (Btype), True);
14722 if Candidate = Any_Type then
14732 elsif Is_Array_Type (Btype) then
14733 return Trace_Components (Component_Type (Btype), True);
14735 elsif Is_Record_Type (Btype) then
14736 Component := First_Entity (Btype);
14737 while Present (Component)
14738 and then Comes_From_Source (Component)
14740 -- Skip anonymous types generated by constrained components
14742 if not Is_Type (Component) then
14743 P := Trace_Components (Etype (Component), True);
14745 if Present (P) then
14746 if P = Any_Type then
14754 Next_Entity (Component);
14762 end Trace_Components;
14764 -- Start of processing for Private_Component
14767 return Trace_Components (Type_Id, False);
14768 end Private_Component;
14770 ---------------------------
14771 -- Primitive_Names_Match --
14772 ---------------------------
14774 function Primitive_Names_Match (E1, E2 : Entity_Id) return Boolean is
14776 function Non_Internal_Name (E : Entity_Id) return Name_Id;
14777 -- Given an internal name, returns the corresponding non-internal name
14779 ------------------------
14780 -- Non_Internal_Name --
14781 ------------------------
14783 function Non_Internal_Name (E : Entity_Id) return Name_Id is
14785 Get_Name_String (Chars (E));
14786 Name_Len := Name_Len - 1;
14788 end Non_Internal_Name;
14790 -- Start of processing for Primitive_Names_Match
14793 pragma Assert (Present (E1) and then Present (E2));
14795 return Chars (E1) = Chars (E2)
14797 (not Is_Internal_Name (Chars (E1))
14798 and then Is_Internal_Name (Chars (E2))
14799 and then Non_Internal_Name (E2) = Chars (E1))
14801 (not Is_Internal_Name (Chars (E2))
14802 and then Is_Internal_Name (Chars (E1))
14803 and then Non_Internal_Name (E1) = Chars (E2))
14805 (Is_Predefined_Dispatching_Operation (E1)
14806 and then Is_Predefined_Dispatching_Operation (E2)
14807 and then Same_TSS (E1, E2))
14809 (Is_Init_Proc (E1) and then Is_Init_Proc (E2));
14810 end Primitive_Names_Match;
14812 -----------------------
14813 -- Process_End_Label --
14814 -----------------------
14816 procedure Process_End_Label
14825 Label_Ref : Boolean;
14826 -- Set True if reference to end label itself is required
14829 -- Gets set to the operator symbol or identifier that references the
14830 -- entity Ent. For the child unit case, this is the identifier from the
14831 -- designator. For other cases, this is simply Endl.
14833 procedure Generate_Parent_Ref (N : Node_Id; E : Entity_Id);
14834 -- N is an identifier node that appears as a parent unit reference in
14835 -- the case where Ent is a child unit. This procedure generates an
14836 -- appropriate cross-reference entry. E is the corresponding entity.
14838 -------------------------
14839 -- Generate_Parent_Ref --
14840 -------------------------
14842 procedure Generate_Parent_Ref (N : Node_Id; E : Entity_Id) is
14844 -- If names do not match, something weird, skip reference
14846 if Chars (E) = Chars (N) then
14848 -- Generate the reference. We do NOT consider this as a reference
14849 -- for unreferenced symbol purposes.
14851 Generate_Reference (E, N, 'r', Set_Ref => False, Force => True);
14853 if Style_Check then
14854 Style.Check_Identifier (N, E);
14857 end Generate_Parent_Ref;
14859 -- Start of processing for Process_End_Label
14862 -- If no node, ignore. This happens in some error situations, and
14863 -- also for some internally generated structures where no end label
14864 -- references are required in any case.
14870 -- Nothing to do if no End_Label, happens for internally generated
14871 -- constructs where we don't want an end label reference anyway. Also
14872 -- nothing to do if Endl is a string literal, which means there was
14873 -- some prior error (bad operator symbol)
14875 Endl := End_Label (N);
14877 if No (Endl) or else Nkind (Endl) = N_String_Literal then
14881 -- Reference node is not in extended main source unit
14883 if not In_Extended_Main_Source_Unit (N) then
14885 -- Generally we do not collect references except for the extended
14886 -- main source unit. The one exception is the 'e' entry for a
14887 -- package spec, where it is useful for a client to have the
14888 -- ending information to define scopes.
14894 Label_Ref := False;
14896 -- For this case, we can ignore any parent references, but we
14897 -- need the package name itself for the 'e' entry.
14899 if Nkind (Endl) = N_Designator then
14900 Endl := Identifier (Endl);
14904 -- Reference is in extended main source unit
14909 -- For designator, generate references for the parent entries
14911 if Nkind (Endl) = N_Designator then
14913 -- Generate references for the prefix if the END line comes from
14914 -- source (otherwise we do not need these references) We climb the
14915 -- scope stack to find the expected entities.
14917 if Comes_From_Source (Endl) then
14918 Nam := Name (Endl);
14919 Scop := Current_Scope;
14920 while Nkind (Nam) = N_Selected_Component loop
14921 Scop := Scope (Scop);
14922 exit when No (Scop);
14923 Generate_Parent_Ref (Selector_Name (Nam), Scop);
14924 Nam := Prefix (Nam);
14927 if Present (Scop) then
14928 Generate_Parent_Ref (Nam, Scope (Scop));
14932 Endl := Identifier (Endl);
14936 -- If the end label is not for the given entity, then either we have
14937 -- some previous error, or this is a generic instantiation for which
14938 -- we do not need to make a cross-reference in this case anyway. In
14939 -- either case we simply ignore the call.
14941 if Chars (Ent) /= Chars (Endl) then
14945 -- If label was really there, then generate a normal reference and then
14946 -- adjust the location in the end label to point past the name (which
14947 -- should almost always be the semicolon).
14949 Loc := Sloc (Endl);
14951 if Comes_From_Source (Endl) then
14953 -- If a label reference is required, then do the style check and
14954 -- generate an l-type cross-reference entry for the label
14957 if Style_Check then
14958 Style.Check_Identifier (Endl, Ent);
14961 Generate_Reference (Ent, Endl, 'l', Set_Ref => False);
14964 -- Set the location to point past the label (normally this will
14965 -- mean the semicolon immediately following the label). This is
14966 -- done for the sake of the 'e' or 't' entry generated below.
14968 Get_Decoded_Name_String (Chars (Endl));
14969 Set_Sloc (Endl, Sloc (Endl) + Source_Ptr (Name_Len));
14972 -- In SPARK mode, no missing label is allowed for packages and
14973 -- subprogram bodies. Detect those cases by testing whether
14974 -- Process_End_Label was called for a body (Typ = 't') or a package.
14976 if Restriction_Check_Required (SPARK_05)
14977 and then (Typ = 't' or else Ekind (Ent) = E_Package)
14979 Error_Msg_Node_1 := Endl;
14980 Check_SPARK_Restriction ("`END &` required", Endl, Force => True);
14984 -- Now generate the e/t reference
14986 Generate_Reference (Ent, Endl, Typ, Set_Ref => False, Force => True);
14988 -- Restore Sloc, in case modified above, since we have an identifier
14989 -- and the normal Sloc should be left set in the tree.
14991 Set_Sloc (Endl, Loc);
14992 end Process_End_Label;
14998 function Referenced (Id : Entity_Id; Expr : Node_Id) return Boolean is
14999 Seen : Boolean := False;
15001 function Is_Reference (N : Node_Id) return Traverse_Result;
15002 -- Determine whether node N denotes a reference to Id. If this is the
15003 -- case, set global flag Seen to True and stop the traversal.
15009 function Is_Reference (N : Node_Id) return Traverse_Result is
15011 if Is_Entity_Name (N)
15012 and then Present (Entity (N))
15013 and then Entity (N) = Id
15022 procedure Inspect_Expression is new Traverse_Proc (Is_Reference);
15024 -- Start of processing for Referenced
15027 Inspect_Expression (Expr);
15031 ------------------------------------
15032 -- References_Generic_Formal_Type --
15033 ------------------------------------
15035 function References_Generic_Formal_Type (N : Node_Id) return Boolean is
15037 function Process (N : Node_Id) return Traverse_Result;
15038 -- Process one node in search for generic formal type
15044 function Process (N : Node_Id) return Traverse_Result is
15046 if Nkind (N) in N_Has_Entity then
15048 E : constant Entity_Id := Entity (N);
15050 if Present (E) then
15051 if Is_Generic_Type (E) then
15053 elsif Present (Etype (E))
15054 and then Is_Generic_Type (Etype (E))
15065 function Traverse is new Traverse_Func (Process);
15066 -- Traverse tree to look for generic type
15069 if Inside_A_Generic then
15070 return Traverse (N) = Abandon;
15074 end References_Generic_Formal_Type;
15076 --------------------
15077 -- Remove_Homonym --
15078 --------------------
15080 procedure Remove_Homonym (E : Entity_Id) is
15081 Prev : Entity_Id := Empty;
15085 if E = Current_Entity (E) then
15086 if Present (Homonym (E)) then
15087 Set_Current_Entity (Homonym (E));
15089 Set_Name_Entity_Id (Chars (E), Empty);
15093 H := Current_Entity (E);
15094 while Present (H) and then H /= E loop
15099 -- If E is not on the homonym chain, nothing to do
15101 if Present (H) then
15102 Set_Homonym (Prev, Homonym (E));
15105 end Remove_Homonym;
15107 ---------------------
15108 -- Rep_To_Pos_Flag --
15109 ---------------------
15111 function Rep_To_Pos_Flag (E : Entity_Id; Loc : Source_Ptr) return Node_Id is
15113 return New_Occurrence_Of
15114 (Boolean_Literals (not Range_Checks_Suppressed (E)), Loc);
15115 end Rep_To_Pos_Flag;
15117 --------------------
15118 -- Require_Entity --
15119 --------------------
15121 procedure Require_Entity (N : Node_Id) is
15123 if Is_Entity_Name (N) and then No (Entity (N)) then
15124 if Total_Errors_Detected /= 0 then
15125 Set_Entity (N, Any_Id);
15127 raise Program_Error;
15130 end Require_Entity;
15132 -------------------------------
15133 -- Requires_State_Refinement --
15134 -------------------------------
15136 function Requires_State_Refinement
15137 (Spec_Id : Entity_Id;
15138 Body_Id : Entity_Id) return Boolean
15140 function Mode_Is_Off (Prag : Node_Id) return Boolean;
15141 -- Given pragma SPARK_Mode, determine whether the mode is Off
15147 function Mode_Is_Off (Prag : Node_Id) return Boolean is
15151 -- The default SPARK mode is On
15157 Mode := Get_Pragma_Arg (First (Pragma_Argument_Associations (Prag)));
15159 -- Then the pragma lacks an argument, the default mode is On
15164 return Chars (Mode) = Name_Off;
15168 -- Start of processing for Requires_State_Refinement
15171 -- A package that does not define at least one abstract state cannot
15172 -- possibly require refinement.
15174 if No (Abstract_States (Spec_Id)) then
15177 -- The package instroduces a single null state which does not merit
15180 elsif Has_Null_Abstract_State (Spec_Id) then
15183 -- Check whether the package body is subject to pragma SPARK_Mode. If
15184 -- it is and the mode is Off, the package body is considered to be in
15185 -- regular Ada and does not require refinement.
15187 elsif Mode_Is_Off (SPARK_Pragma (Body_Id)) then
15190 -- The body's SPARK_Mode may be inherited from a similar pragma that
15191 -- appears in the private declarations of the spec. The pragma we are
15192 -- interested appears as the second entry in SPARK_Pragma.
15194 elsif Present (SPARK_Pragma (Spec_Id))
15195 and then Mode_Is_Off (Next_Pragma (SPARK_Pragma (Spec_Id)))
15199 -- The spec defines at least one abstract state and the body has no way
15200 -- of circumventing the refinement.
15205 end Requires_State_Refinement;
15207 ------------------------------
15208 -- Requires_Transient_Scope --
15209 ------------------------------
15211 -- A transient scope is required when variable-sized temporaries are
15212 -- allocated in the primary or secondary stack, or when finalization
15213 -- actions must be generated before the next instruction.
15215 function Requires_Transient_Scope (Id : Entity_Id) return Boolean is
15216 Typ : constant Entity_Id := Underlying_Type (Id);
15218 -- Start of processing for Requires_Transient_Scope
15221 -- This is a private type which is not completed yet. This can only
15222 -- happen in a default expression (of a formal parameter or of a
15223 -- record component). Do not expand transient scope in this case
15228 -- Do not expand transient scope for non-existent procedure return
15230 elsif Typ = Standard_Void_Type then
15233 -- Elementary types do not require a transient scope
15235 elsif Is_Elementary_Type (Typ) then
15238 -- Generally, indefinite subtypes require a transient scope, since the
15239 -- back end cannot generate temporaries, since this is not a valid type
15240 -- for declaring an object. It might be possible to relax this in the
15241 -- future, e.g. by declaring the maximum possible space for the type.
15243 elsif Is_Indefinite_Subtype (Typ) then
15246 -- Functions returning tagged types may dispatch on result so their
15247 -- returned value is allocated on the secondary stack. Controlled
15248 -- type temporaries need finalization.
15250 elsif Is_Tagged_Type (Typ)
15251 or else Has_Controlled_Component (Typ)
15253 return not Is_Value_Type (Typ);
15257 elsif Is_Record_Type (Typ) then
15261 Comp := First_Entity (Typ);
15262 while Present (Comp) loop
15263 if Ekind (Comp) = E_Component
15264 and then Requires_Transient_Scope (Etype (Comp))
15268 Next_Entity (Comp);
15275 -- String literal types never require transient scope
15277 elsif Ekind (Typ) = E_String_Literal_Subtype then
15280 -- Array type. Note that we already know that this is a constrained
15281 -- array, since unconstrained arrays will fail the indefinite test.
15283 elsif Is_Array_Type (Typ) then
15285 -- If component type requires a transient scope, the array does too
15287 if Requires_Transient_Scope (Component_Type (Typ)) then
15290 -- Otherwise, we only need a transient scope if the size depends on
15291 -- the value of one or more discriminants.
15294 return Size_Depends_On_Discriminant (Typ);
15297 -- All other cases do not require a transient scope
15302 end Requires_Transient_Scope;
15304 --------------------------
15305 -- Reset_Analyzed_Flags --
15306 --------------------------
15308 procedure Reset_Analyzed_Flags (N : Node_Id) is
15310 function Clear_Analyzed (N : Node_Id) return Traverse_Result;
15311 -- Function used to reset Analyzed flags in tree. Note that we do
15312 -- not reset Analyzed flags in entities, since there is no need to
15313 -- reanalyze entities, and indeed, it is wrong to do so, since it
15314 -- can result in generating auxiliary stuff more than once.
15316 --------------------
15317 -- Clear_Analyzed --
15318 --------------------
15320 function Clear_Analyzed (N : Node_Id) return Traverse_Result is
15322 if not Has_Extension (N) then
15323 Set_Analyzed (N, False);
15327 end Clear_Analyzed;
15329 procedure Reset_Analyzed is new Traverse_Proc (Clear_Analyzed);
15331 -- Start of processing for Reset_Analyzed_Flags
15334 Reset_Analyzed (N);
15335 end Reset_Analyzed_Flags;
15337 ------------------------
15338 -- Restore_SPARK_Mode --
15339 ------------------------
15341 procedure Restore_SPARK_Mode (Mode : SPARK_Mode_Type) is
15343 SPARK_Mode := Mode;
15344 end Restore_SPARK_Mode;
15346 --------------------------------
15347 -- Returns_Unconstrained_Type --
15348 --------------------------------
15350 function Returns_Unconstrained_Type (Subp : Entity_Id) return Boolean is
15352 return Ekind (Subp) = E_Function
15353 and then not Is_Scalar_Type (Etype (Subp))
15354 and then not Is_Access_Type (Etype (Subp))
15355 and then not Is_Constrained (Etype (Subp));
15356 end Returns_Unconstrained_Type;
15358 ---------------------------
15359 -- Safe_To_Capture_Value --
15360 ---------------------------
15362 function Safe_To_Capture_Value
15365 Cond : Boolean := False) return Boolean
15368 -- The only entities for which we track constant values are variables
15369 -- which are not renamings, constants, out parameters, and in out
15370 -- parameters, so check if we have this case.
15372 -- Note: it may seem odd to track constant values for constants, but in
15373 -- fact this routine is used for other purposes than simply capturing
15374 -- the value. In particular, the setting of Known[_Non]_Null.
15376 if (Ekind (Ent) = E_Variable and then No (Renamed_Object (Ent)))
15378 Ekind (Ent) = E_Constant
15380 Ekind (Ent) = E_Out_Parameter
15382 Ekind (Ent) = E_In_Out_Parameter
15386 -- For conditionals, we also allow loop parameters and all formals,
15387 -- including in parameters.
15391 (Ekind (Ent) = E_Loop_Parameter
15393 Ekind (Ent) = E_In_Parameter)
15397 -- For all other cases, not just unsafe, but impossible to capture
15398 -- Current_Value, since the above are the only entities which have
15399 -- Current_Value fields.
15405 -- Skip if volatile or aliased, since funny things might be going on in
15406 -- these cases which we cannot necessarily track. Also skip any variable
15407 -- for which an address clause is given, or whose address is taken. Also
15408 -- never capture value of library level variables (an attempt to do so
15409 -- can occur in the case of package elaboration code).
15411 if Treat_As_Volatile (Ent)
15412 or else Is_Aliased (Ent)
15413 or else Present (Address_Clause (Ent))
15414 or else Address_Taken (Ent)
15415 or else (Is_Library_Level_Entity (Ent)
15416 and then Ekind (Ent) = E_Variable)
15421 -- OK, all above conditions are met. We also require that the scope of
15422 -- the reference be the same as the scope of the entity, not counting
15423 -- packages and blocks and loops.
15426 E_Scope : constant Entity_Id := Scope (Ent);
15427 R_Scope : Entity_Id;
15430 R_Scope := Current_Scope;
15431 while R_Scope /= Standard_Standard loop
15432 exit when R_Scope = E_Scope;
15434 if not Ekind_In (R_Scope, E_Package, E_Block, E_Loop) then
15437 R_Scope := Scope (R_Scope);
15442 -- We also require that the reference does not appear in a context
15443 -- where it is not sure to be executed (i.e. a conditional context
15444 -- or an exception handler). We skip this if Cond is True, since the
15445 -- capturing of values from conditional tests handles this ok.
15458 -- Seems dubious that case expressions are not handled here ???
15461 while Present (P) loop
15462 if Nkind (P) = N_If_Statement
15463 or else Nkind (P) = N_Case_Statement
15464 or else (Nkind (P) in N_Short_Circuit
15465 and then Desc = Right_Opnd (P))
15466 or else (Nkind (P) = N_If_Expression
15467 and then Desc /= First (Expressions (P)))
15468 or else Nkind (P) = N_Exception_Handler
15469 or else Nkind (P) = N_Selective_Accept
15470 or else Nkind (P) = N_Conditional_Entry_Call
15471 or else Nkind (P) = N_Timed_Entry_Call
15472 or else Nkind (P) = N_Asynchronous_Select
15479 -- A special Ada 2012 case: the original node may be part
15480 -- of the else_actions of a conditional expression, in which
15481 -- case it might not have been expanded yet, and appears in
15482 -- a non-syntactic list of actions. In that case it is clearly
15483 -- not safe to save a value.
15486 and then Is_List_Member (Desc)
15487 and then No (Parent (List_Containing (Desc)))
15495 -- OK, looks safe to set value
15498 end Safe_To_Capture_Value;
15504 function Same_Name (N1, N2 : Node_Id) return Boolean is
15505 K1 : constant Node_Kind := Nkind (N1);
15506 K2 : constant Node_Kind := Nkind (N2);
15509 if (K1 = N_Identifier or else K1 = N_Defining_Identifier)
15510 and then (K2 = N_Identifier or else K2 = N_Defining_Identifier)
15512 return Chars (N1) = Chars (N2);
15514 elsif (K1 = N_Selected_Component or else K1 = N_Expanded_Name)
15515 and then (K2 = N_Selected_Component or else K2 = N_Expanded_Name)
15517 return Same_Name (Selector_Name (N1), Selector_Name (N2))
15518 and then Same_Name (Prefix (N1), Prefix (N2));
15529 function Same_Object (Node1, Node2 : Node_Id) return Boolean is
15530 N1 : constant Node_Id := Original_Node (Node1);
15531 N2 : constant Node_Id := Original_Node (Node2);
15532 -- We do the tests on original nodes, since we are most interested
15533 -- in the original source, not any expansion that got in the way.
15535 K1 : constant Node_Kind := Nkind (N1);
15536 K2 : constant Node_Kind := Nkind (N2);
15539 -- First case, both are entities with same entity
15541 if K1 in N_Has_Entity and then K2 in N_Has_Entity then
15543 EN1 : constant Entity_Id := Entity (N1);
15544 EN2 : constant Entity_Id := Entity (N2);
15546 if Present (EN1) and then Present (EN2)
15547 and then (Ekind_In (EN1, E_Variable, E_Constant)
15548 or else Is_Formal (EN1))
15556 -- Second case, selected component with same selector, same record
15558 if K1 = N_Selected_Component
15559 and then K2 = N_Selected_Component
15560 and then Chars (Selector_Name (N1)) = Chars (Selector_Name (N2))
15562 return Same_Object (Prefix (N1), Prefix (N2));
15564 -- Third case, indexed component with same subscripts, same array
15566 elsif K1 = N_Indexed_Component
15567 and then K2 = N_Indexed_Component
15568 and then Same_Object (Prefix (N1), Prefix (N2))
15573 E1 := First (Expressions (N1));
15574 E2 := First (Expressions (N2));
15575 while Present (E1) loop
15576 if not Same_Value (E1, E2) then
15587 -- Fourth case, slice of same array with same bounds
15590 and then K2 = N_Slice
15591 and then Nkind (Discrete_Range (N1)) = N_Range
15592 and then Nkind (Discrete_Range (N2)) = N_Range
15593 and then Same_Value (Low_Bound (Discrete_Range (N1)),
15594 Low_Bound (Discrete_Range (N2)))
15595 and then Same_Value (High_Bound (Discrete_Range (N1)),
15596 High_Bound (Discrete_Range (N2)))
15598 return Same_Name (Prefix (N1), Prefix (N2));
15600 -- All other cases, not clearly the same object
15611 function Same_Type (T1, T2 : Entity_Id) return Boolean is
15616 elsif not Is_Constrained (T1)
15617 and then not Is_Constrained (T2)
15618 and then Base_Type (T1) = Base_Type (T2)
15622 -- For now don't bother with case of identical constraints, to be
15623 -- fiddled with later on perhaps (this is only used for optimization
15624 -- purposes, so it is not critical to do a best possible job)
15635 function Same_Value (Node1, Node2 : Node_Id) return Boolean is
15637 if Compile_Time_Known_Value (Node1)
15638 and then Compile_Time_Known_Value (Node2)
15639 and then Expr_Value (Node1) = Expr_Value (Node2)
15642 elsif Same_Object (Node1, Node2) then
15649 -----------------------------
15650 -- Save_SPARK_Mode_And_Set --
15651 -----------------------------
15653 procedure Save_SPARK_Mode_And_Set
15654 (Context : Entity_Id;
15655 Mode : out SPARK_Mode_Type)
15657 Prag : constant Node_Id := SPARK_Pragma (Context);
15660 -- Save the current mode in effect
15662 Mode := SPARK_Mode;
15664 -- Set the mode of the context as the current SPARK mode
15666 if Present (Prag) then
15667 SPARK_Mode := Get_SPARK_Mode_From_Pragma (Prag);
15669 end Save_SPARK_Mode_And_Set;
15671 ------------------------
15672 -- Scope_Is_Transient --
15673 ------------------------
15675 function Scope_Is_Transient return Boolean is
15677 return Scope_Stack.Table (Scope_Stack.Last).Is_Transient;
15678 end Scope_Is_Transient;
15684 function Scope_Within (Scope1, Scope2 : Entity_Id) return Boolean is
15689 while Scop /= Standard_Standard loop
15690 Scop := Scope (Scop);
15692 if Scop = Scope2 then
15700 --------------------------
15701 -- Scope_Within_Or_Same --
15702 --------------------------
15704 function Scope_Within_Or_Same (Scope1, Scope2 : Entity_Id) return Boolean is
15709 while Scop /= Standard_Standard loop
15710 if Scop = Scope2 then
15713 Scop := Scope (Scop);
15718 end Scope_Within_Or_Same;
15720 --------------------
15721 -- Set_Convention --
15722 --------------------
15724 procedure Set_Convention (E : Entity_Id; Val : Snames.Convention_Id) is
15726 Basic_Set_Convention (E, Val);
15729 and then Is_Access_Subprogram_Type (Base_Type (E))
15730 and then Has_Foreign_Convention (E)
15732 Set_Can_Use_Internal_Rep (E, False);
15735 -- If E is an object or component, and the type of E is an anonymous
15736 -- access type with no convention set, then also set the convention of
15737 -- the anonymous access type. We do not do this for anonymous protected
15738 -- types, since protected types always have the default convention.
15740 if Present (Etype (E))
15741 and then (Is_Object (E)
15742 or else Ekind (E) = E_Component
15744 -- Allow E_Void (happens for pragma Convention appearing
15745 -- in the middle of a record applying to a component)
15747 or else Ekind (E) = E_Void)
15750 Typ : constant Entity_Id := Etype (E);
15753 if Ekind_In (Typ, E_Anonymous_Access_Type,
15754 E_Anonymous_Access_Subprogram_Type)
15755 and then not Has_Convention_Pragma (Typ)
15757 Basic_Set_Convention (Typ, Val);
15758 Set_Has_Convention_Pragma (Typ);
15760 -- And for the access subprogram type, deal similarly with the
15761 -- designated E_Subprogram_Type if it is also internal (which
15764 if Ekind (Typ) = E_Anonymous_Access_Subprogram_Type then
15766 Dtype : constant Entity_Id := Designated_Type (Typ);
15768 if Ekind (Dtype) = E_Subprogram_Type
15769 and then Is_Itype (Dtype)
15770 and then not Has_Convention_Pragma (Dtype)
15772 Basic_Set_Convention (Dtype, Val);
15773 Set_Has_Convention_Pragma (Dtype);
15780 end Set_Convention;
15782 ------------------------
15783 -- Set_Current_Entity --
15784 ------------------------
15786 -- The given entity is to be set as the currently visible definition of its
15787 -- associated name (i.e. the Node_Id associated with its name). All we have
15788 -- to do is to get the name from the identifier, and then set the
15789 -- associated Node_Id to point to the given entity.
15791 procedure Set_Current_Entity (E : Entity_Id) is
15793 Set_Name_Entity_Id (Chars (E), E);
15794 end Set_Current_Entity;
15796 ---------------------------
15797 -- Set_Debug_Info_Needed --
15798 ---------------------------
15800 procedure Set_Debug_Info_Needed (T : Entity_Id) is
15802 procedure Set_Debug_Info_Needed_If_Not_Set (E : Entity_Id);
15803 pragma Inline (Set_Debug_Info_Needed_If_Not_Set);
15804 -- Used to set debug info in a related node if not set already
15806 --------------------------------------
15807 -- Set_Debug_Info_Needed_If_Not_Set --
15808 --------------------------------------
15810 procedure Set_Debug_Info_Needed_If_Not_Set (E : Entity_Id) is
15813 and then not Needs_Debug_Info (E)
15815 Set_Debug_Info_Needed (E);
15817 -- For a private type, indicate that the full view also needs
15818 -- debug information.
15821 and then Is_Private_Type (E)
15822 and then Present (Full_View (E))
15824 Set_Debug_Info_Needed (Full_View (E));
15827 end Set_Debug_Info_Needed_If_Not_Set;
15829 -- Start of processing for Set_Debug_Info_Needed
15832 -- Nothing to do if argument is Empty or has Debug_Info_Off set, which
15833 -- indicates that Debug_Info_Needed is never required for the entity.
15836 or else Debug_Info_Off (T)
15841 -- Set flag in entity itself. Note that we will go through the following
15842 -- circuitry even if the flag is already set on T. That's intentional,
15843 -- it makes sure that the flag will be set in subsidiary entities.
15845 Set_Needs_Debug_Info (T);
15847 -- Set flag on subsidiary entities if not set already
15849 if Is_Object (T) then
15850 Set_Debug_Info_Needed_If_Not_Set (Etype (T));
15852 elsif Is_Type (T) then
15853 Set_Debug_Info_Needed_If_Not_Set (Etype (T));
15855 if Is_Record_Type (T) then
15857 Ent : Entity_Id := First_Entity (T);
15859 while Present (Ent) loop
15860 Set_Debug_Info_Needed_If_Not_Set (Ent);
15865 -- For a class wide subtype, we also need debug information
15866 -- for the equivalent type.
15868 if Ekind (T) = E_Class_Wide_Subtype then
15869 Set_Debug_Info_Needed_If_Not_Set (Equivalent_Type (T));
15872 elsif Is_Array_Type (T) then
15873 Set_Debug_Info_Needed_If_Not_Set (Component_Type (T));
15876 Indx : Node_Id := First_Index (T);
15878 while Present (Indx) loop
15879 Set_Debug_Info_Needed_If_Not_Set (Etype (Indx));
15880 Indx := Next_Index (Indx);
15884 -- For a packed array type, we also need debug information for
15885 -- the type used to represent the packed array. Conversely, we
15886 -- also need it for the former if we need it for the latter.
15888 if Is_Packed (T) then
15889 Set_Debug_Info_Needed_If_Not_Set (Packed_Array_Type (T));
15892 if Is_Packed_Array_Type (T) then
15893 Set_Debug_Info_Needed_If_Not_Set (Original_Array_Type (T));
15896 elsif Is_Access_Type (T) then
15897 Set_Debug_Info_Needed_If_Not_Set (Directly_Designated_Type (T));
15899 elsif Is_Private_Type (T) then
15900 Set_Debug_Info_Needed_If_Not_Set (Full_View (T));
15902 elsif Is_Protected_Type (T) then
15903 Set_Debug_Info_Needed_If_Not_Set (Corresponding_Record_Type (T));
15906 end Set_Debug_Info_Needed;
15908 ----------------------------
15909 -- Set_Entity_With_Checks --
15910 ----------------------------
15912 procedure Set_Entity_With_Checks (N : Node_Id; Val : Entity_Id) is
15913 Val_Actual : Entity_Id;
15915 Post_Node : Node_Id;
15918 -- Unconditionally set the entity
15920 Set_Entity (N, Val);
15922 -- The node to post on is the selector in the case of an expanded name,
15923 -- and otherwise the node itself.
15925 if Nkind (N) = N_Expanded_Name then
15926 Post_Node := Selector_Name (N);
15931 -- Check for violation of No_Fixed_IO
15933 if Restriction_Check_Required (No_Fixed_IO)
15935 ((RTU_Loaded (Ada_Text_IO)
15936 and then (Is_RTE (Val, RE_Decimal_IO)
15938 Is_RTE (Val, RE_Fixed_IO)))
15941 (RTU_Loaded (Ada_Wide_Text_IO)
15942 and then (Is_RTE (Val, RO_WT_Decimal_IO)
15944 Is_RTE (Val, RO_WT_Fixed_IO)))
15947 (RTU_Loaded (Ada_Wide_Wide_Text_IO)
15948 and then (Is_RTE (Val, RO_WW_Decimal_IO)
15950 Is_RTE (Val, RO_WW_Fixed_IO))))
15952 -- A special extra check, don't complain about a reference from within
15953 -- the Ada.Interrupts package itself!
15955 and then not In_Same_Extended_Unit (N, Val)
15957 Check_Restriction (No_Fixed_IO, Post_Node);
15960 -- Remaining checks are only done on source nodes. Note that we test
15961 -- for violation of No_Fixed_IO even on non-source nodes, because the
15962 -- cases for checking violations of this restriction are instantiations
15963 -- where the reference in the instance has Comes_From_Source False.
15965 if not Comes_From_Source (N) then
15969 -- Check for violation of No_Abort_Statements, which is triggered by
15970 -- call to Ada.Task_Identification.Abort_Task.
15972 if Restriction_Check_Required (No_Abort_Statements)
15973 and then (Is_RTE (Val, RE_Abort_Task))
15975 -- A special extra check, don't complain about a reference from within
15976 -- the Ada.Task_Identification package itself!
15978 and then not In_Same_Extended_Unit (N, Val)
15980 Check_Restriction (No_Abort_Statements, Post_Node);
15983 if Val = Standard_Long_Long_Integer then
15984 Check_Restriction (No_Long_Long_Integers, Post_Node);
15987 -- Check for violation of No_Dynamic_Attachment
15989 if Restriction_Check_Required (No_Dynamic_Attachment)
15990 and then RTU_Loaded (Ada_Interrupts)
15991 and then (Is_RTE (Val, RE_Is_Reserved) or else
15992 Is_RTE (Val, RE_Is_Attached) or else
15993 Is_RTE (Val, RE_Current_Handler) or else
15994 Is_RTE (Val, RE_Attach_Handler) or else
15995 Is_RTE (Val, RE_Exchange_Handler) or else
15996 Is_RTE (Val, RE_Detach_Handler) or else
15997 Is_RTE (Val, RE_Reference))
15999 -- A special extra check, don't complain about a reference from within
16000 -- the Ada.Interrupts package itself!
16002 and then not In_Same_Extended_Unit (N, Val)
16004 Check_Restriction (No_Dynamic_Attachment, Post_Node);
16007 -- Check for No_Implementation_Identifiers
16009 if Restriction_Check_Required (No_Implementation_Identifiers) then
16011 -- We have an implementation defined entity if it is marked as
16012 -- implementation defined, or is defined in a package marked as
16013 -- implementation defined. However, library packages themselves
16014 -- are excluded (we don't want to flag Interfaces itself, just
16015 -- the entities within it).
16017 if (Is_Implementation_Defined (Val)
16019 Is_Implementation_Defined (Scope (Val)))
16020 and then not (Ekind_In (Val, E_Package, E_Generic_Package)
16021 and then Is_Library_Level_Entity (Val))
16023 Check_Restriction (No_Implementation_Identifiers, Post_Node);
16027 -- Do the style check
16030 and then not Suppress_Style_Checks (Val)
16031 and then not In_Instance
16033 if Nkind (N) = N_Identifier then
16035 elsif Nkind (N) = N_Expanded_Name then
16036 Nod := Selector_Name (N);
16041 -- A special situation arises for derived operations, where we want
16042 -- to do the check against the parent (since the Sloc of the derived
16043 -- operation points to the derived type declaration itself).
16046 while not Comes_From_Source (Val_Actual)
16047 and then Nkind (Val_Actual) in N_Entity
16048 and then (Ekind (Val_Actual) = E_Enumeration_Literal
16049 or else Is_Subprogram (Val_Actual)
16050 or else Is_Generic_Subprogram (Val_Actual))
16051 and then Present (Alias (Val_Actual))
16053 Val_Actual := Alias (Val_Actual);
16056 -- Renaming declarations for generic actuals do not come from source,
16057 -- and have a different name from that of the entity they rename, so
16058 -- there is no style check to perform here.
16060 if Chars (Nod) = Chars (Val_Actual) then
16061 Style.Check_Identifier (Nod, Val_Actual);
16065 Set_Entity (N, Val);
16066 end Set_Entity_With_Checks;
16068 ------------------------
16069 -- Set_Name_Entity_Id --
16070 ------------------------
16072 procedure Set_Name_Entity_Id (Id : Name_Id; Val : Entity_Id) is
16074 Set_Name_Table_Info (Id, Int (Val));
16075 end Set_Name_Entity_Id;
16077 ---------------------
16078 -- Set_Next_Actual --
16079 ---------------------
16081 procedure Set_Next_Actual (Ass1_Id : Node_Id; Ass2_Id : Node_Id) is
16083 if Nkind (Parent (Ass1_Id)) = N_Parameter_Association then
16084 Set_First_Named_Actual (Parent (Ass1_Id), Ass2_Id);
16086 end Set_Next_Actual;
16088 ----------------------------------
16089 -- Set_Optimize_Alignment_Flags --
16090 ----------------------------------
16092 procedure Set_Optimize_Alignment_Flags (E : Entity_Id) is
16094 if Optimize_Alignment = 'S' then
16095 Set_Optimize_Alignment_Space (E);
16096 elsif Optimize_Alignment = 'T' then
16097 Set_Optimize_Alignment_Time (E);
16099 end Set_Optimize_Alignment_Flags;
16101 -----------------------
16102 -- Set_Public_Status --
16103 -----------------------
16105 procedure Set_Public_Status (Id : Entity_Id) is
16106 S : constant Entity_Id := Current_Scope;
16108 function Within_HSS_Or_If (E : Entity_Id) return Boolean;
16109 -- Determines if E is defined within handled statement sequence or
16110 -- an if statement, returns True if so, False otherwise.
16112 ----------------------
16113 -- Within_HSS_Or_If --
16114 ----------------------
16116 function Within_HSS_Or_If (E : Entity_Id) return Boolean is
16119 N := Declaration_Node (E);
16126 elsif Nkind_In (N, N_Handled_Sequence_Of_Statements,
16132 end Within_HSS_Or_If;
16134 -- Start of processing for Set_Public_Status
16137 -- Everything in the scope of Standard is public
16139 if S = Standard_Standard then
16140 Set_Is_Public (Id);
16142 -- Entity is definitely not public if enclosing scope is not public
16144 elsif not Is_Public (S) then
16147 -- An object or function declaration that occurs in a handled sequence
16148 -- of statements or within an if statement is the declaration for a
16149 -- temporary object or local subprogram generated by the expander. It
16150 -- never needs to be made public and furthermore, making it public can
16151 -- cause back end problems.
16153 elsif Nkind_In (Parent (Id), N_Object_Declaration,
16154 N_Function_Specification)
16155 and then Within_HSS_Or_If (Id)
16159 -- Entities in public packages or records are public
16161 elsif Ekind (S) = E_Package or Is_Record_Type (S) then
16162 Set_Is_Public (Id);
16164 -- The bounds of an entry family declaration can generate object
16165 -- declarations that are visible to the back-end, e.g. in the
16166 -- the declaration of a composite type that contains tasks.
16168 elsif Is_Concurrent_Type (S)
16169 and then not Has_Completion (S)
16170 and then Nkind (Parent (Id)) = N_Object_Declaration
16172 Set_Is_Public (Id);
16174 end Set_Public_Status;
16176 -----------------------------
16177 -- Set_Referenced_Modified --
16178 -----------------------------
16180 procedure Set_Referenced_Modified (N : Node_Id; Out_Param : Boolean) is
16184 -- Deal with indexed or selected component where prefix is modified
16186 if Nkind_In (N, N_Indexed_Component, N_Selected_Component) then
16187 Pref := Prefix (N);
16189 -- If prefix is access type, then it is the designated object that is
16190 -- being modified, which means we have no entity to set the flag on.
16192 if No (Etype (Pref)) or else Is_Access_Type (Etype (Pref)) then
16195 -- Otherwise chase the prefix
16198 Set_Referenced_Modified (Pref, Out_Param);
16201 -- Otherwise see if we have an entity name (only other case to process)
16203 elsif Is_Entity_Name (N) and then Present (Entity (N)) then
16204 Set_Referenced_As_LHS (Entity (N), not Out_Param);
16205 Set_Referenced_As_Out_Parameter (Entity (N), Out_Param);
16207 end Set_Referenced_Modified;
16209 ----------------------------
16210 -- Set_Scope_Is_Transient --
16211 ----------------------------
16213 procedure Set_Scope_Is_Transient (V : Boolean := True) is
16215 Scope_Stack.Table (Scope_Stack.Last).Is_Transient := V;
16216 end Set_Scope_Is_Transient;
16218 -------------------
16219 -- Set_Size_Info --
16220 -------------------
16222 procedure Set_Size_Info (T1, T2 : Entity_Id) is
16224 -- We copy Esize, but not RM_Size, since in general RM_Size is
16225 -- subtype specific and does not get inherited by all subtypes.
16227 Set_Esize (T1, Esize (T2));
16228 Set_Has_Biased_Representation (T1, Has_Biased_Representation (T2));
16230 if Is_Discrete_Or_Fixed_Point_Type (T1)
16232 Is_Discrete_Or_Fixed_Point_Type (T2)
16234 Set_Is_Unsigned_Type (T1, Is_Unsigned_Type (T2));
16237 Set_Alignment (T1, Alignment (T2));
16240 --------------------
16241 -- Static_Boolean --
16242 --------------------
16244 function Static_Boolean (N : Node_Id) return Uint is
16246 Analyze_And_Resolve (N, Standard_Boolean);
16249 or else Error_Posted (N)
16250 or else Etype (N) = Any_Type
16255 if Is_Static_Expression (N) then
16256 if not Raises_Constraint_Error (N) then
16257 return Expr_Value (N);
16262 elsif Etype (N) = Any_Type then
16266 Flag_Non_Static_Expr
16267 ("static boolean expression required here", N);
16270 end Static_Boolean;
16272 --------------------
16273 -- Static_Integer --
16274 --------------------
16276 function Static_Integer (N : Node_Id) return Uint is
16278 Analyze_And_Resolve (N, Any_Integer);
16281 or else Error_Posted (N)
16282 or else Etype (N) = Any_Type
16287 if Is_Static_Expression (N) then
16288 if not Raises_Constraint_Error (N) then
16289 return Expr_Value (N);
16294 elsif Etype (N) = Any_Type then
16298 Flag_Non_Static_Expr
16299 ("static integer expression required here", N);
16302 end Static_Integer;
16304 --------------------------
16305 -- Statically_Different --
16306 --------------------------
16308 function Statically_Different (E1, E2 : Node_Id) return Boolean is
16309 R1 : constant Node_Id := Get_Referenced_Object (E1);
16310 R2 : constant Node_Id := Get_Referenced_Object (E2);
16312 return Is_Entity_Name (R1)
16313 and then Is_Entity_Name (R2)
16314 and then Entity (R1) /= Entity (R2)
16315 and then not Is_Formal (Entity (R1))
16316 and then not Is_Formal (Entity (R2));
16317 end Statically_Different;
16319 --------------------------------------
16320 -- Subject_To_Loop_Entry_Attributes --
16321 --------------------------------------
16323 function Subject_To_Loop_Entry_Attributes (N : Node_Id) return Boolean is
16329 -- The expansion mechanism transform a loop subject to at least one
16330 -- 'Loop_Entry attribute into a conditional block. Infinite loops lack
16331 -- the conditional part.
16333 if Nkind_In (Stmt, N_Block_Statement, N_If_Statement)
16334 and then Nkind (Original_Node (N)) = N_Loop_Statement
16336 Stmt := Original_Node (N);
16340 Nkind (Stmt) = N_Loop_Statement
16341 and then Present (Identifier (Stmt))
16342 and then Present (Entity (Identifier (Stmt)))
16343 and then Has_Loop_Entry_Attributes (Entity (Identifier (Stmt)));
16344 end Subject_To_Loop_Entry_Attributes;
16346 -----------------------------
16347 -- Subprogram_Access_Level --
16348 -----------------------------
16350 function Subprogram_Access_Level (Subp : Entity_Id) return Uint is
16352 if Present (Alias (Subp)) then
16353 return Subprogram_Access_Level (Alias (Subp));
16355 return Scope_Depth (Enclosing_Dynamic_Scope (Subp));
16357 end Subprogram_Access_Level;
16359 -------------------------------
16360 -- Support_Atomic_Primitives --
16361 -------------------------------
16363 function Support_Atomic_Primitives (Typ : Entity_Id) return Boolean is
16367 -- Verify the alignment of Typ is known
16369 if not Known_Alignment (Typ) then
16373 if Known_Static_Esize (Typ) then
16374 Size := UI_To_Int (Esize (Typ));
16376 -- If the Esize (Object_Size) is unknown at compile time, look at the
16377 -- RM_Size (Value_Size) which may have been set by an explicit rep item.
16379 elsif Known_Static_RM_Size (Typ) then
16380 Size := UI_To_Int (RM_Size (Typ));
16382 -- Otherwise, the size is considered to be unknown.
16388 -- Check that the size of the component is 8, 16, 32 or 64 bits and that
16389 -- Typ is properly aligned.
16392 when 8 | 16 | 32 | 64 =>
16393 return Size = UI_To_Int (Alignment (Typ)) * 8;
16397 end Support_Atomic_Primitives;
16403 procedure Trace_Scope (N : Node_Id; E : Entity_Id; Msg : String) is
16405 if Debug_Flag_W then
16406 for J in 0 .. Scope_Stack.Last loop
16411 Write_Name (Chars (E));
16412 Write_Str (" from ");
16413 Write_Location (Sloc (N));
16418 -----------------------
16419 -- Transfer_Entities --
16420 -----------------------
16422 procedure Transfer_Entities (From : Entity_Id; To : Entity_Id) is
16423 Ent : Entity_Id := First_Entity (From);
16430 if (Last_Entity (To)) = Empty then
16431 Set_First_Entity (To, Ent);
16433 Set_Next_Entity (Last_Entity (To), Ent);
16436 Set_Last_Entity (To, Last_Entity (From));
16438 while Present (Ent) loop
16439 Set_Scope (Ent, To);
16441 if not Is_Public (Ent) then
16442 Set_Public_Status (Ent);
16445 and then Ekind (Ent) = E_Record_Subtype
16448 -- The components of the propagated Itype must be public
16454 Comp := First_Entity (Ent);
16455 while Present (Comp) loop
16456 Set_Is_Public (Comp);
16457 Next_Entity (Comp);
16466 Set_First_Entity (From, Empty);
16467 Set_Last_Entity (From, Empty);
16468 end Transfer_Entities;
16470 -----------------------
16471 -- Type_Access_Level --
16472 -----------------------
16474 function Type_Access_Level (Typ : Entity_Id) return Uint is
16478 Btyp := Base_Type (Typ);
16480 -- Ada 2005 (AI-230): For most cases of anonymous access types, we
16481 -- simply use the level where the type is declared. This is true for
16482 -- stand-alone object declarations, and for anonymous access types
16483 -- associated with components the level is the same as that of the
16484 -- enclosing composite type. However, special treatment is needed for
16485 -- the cases of access parameters, return objects of an anonymous access
16486 -- type, and, in Ada 95, access discriminants of limited types.
16488 if Is_Access_Type (Btyp) then
16489 if Ekind (Btyp) = E_Anonymous_Access_Type then
16491 -- If the type is a nonlocal anonymous access type (such as for
16492 -- an access parameter) we treat it as being declared at the
16493 -- library level to ensure that names such as X.all'access don't
16494 -- fail static accessibility checks.
16496 if not Is_Local_Anonymous_Access (Typ) then
16497 return Scope_Depth (Standard_Standard);
16499 -- If this is a return object, the accessibility level is that of
16500 -- the result subtype of the enclosing function. The test here is
16501 -- little complicated, because we have to account for extended
16502 -- return statements that have been rewritten as blocks, in which
16503 -- case we have to find and the Is_Return_Object attribute of the
16504 -- itype's associated object. It would be nice to find a way to
16505 -- simplify this test, but it doesn't seem worthwhile to add a new
16506 -- flag just for purposes of this test. ???
16508 elsif Ekind (Scope (Btyp)) = E_Return_Statement
16511 and then Nkind (Associated_Node_For_Itype (Btyp)) =
16512 N_Object_Declaration
16513 and then Is_Return_Object
16514 (Defining_Identifier
16515 (Associated_Node_For_Itype (Btyp))))
16521 Scop := Scope (Scope (Btyp));
16522 while Present (Scop) loop
16523 exit when Ekind (Scop) = E_Function;
16524 Scop := Scope (Scop);
16527 -- Treat the return object's type as having the level of the
16528 -- function's result subtype (as per RM05-6.5(5.3/2)).
16530 return Type_Access_Level (Etype (Scop));
16535 Btyp := Root_Type (Btyp);
16537 -- The accessibility level of anonymous access types associated with
16538 -- discriminants is that of the current instance of the type, and
16539 -- that's deeper than the type itself (AARM 3.10.2 (12.3.21)).
16541 -- AI-402: access discriminants have accessibility based on the
16542 -- object rather than the type in Ada 2005, so the above paragraph
16545 -- ??? Needs completion with rules from AI-416
16547 if Ada_Version <= Ada_95
16548 and then Ekind (Typ) = E_Anonymous_Access_Type
16549 and then Present (Associated_Node_For_Itype (Typ))
16550 and then Nkind (Associated_Node_For_Itype (Typ)) =
16551 N_Discriminant_Specification
16553 return Scope_Depth (Enclosing_Dynamic_Scope (Btyp)) + 1;
16557 -- Return library level for a generic formal type. This is done because
16558 -- RM(10.3.2) says that "The statically deeper relationship does not
16559 -- apply to ... a descendant of a generic formal type". Rather than
16560 -- checking at each point where a static accessibility check is
16561 -- performed to see if we are dealing with a formal type, this rule is
16562 -- implemented by having Type_Access_Level and Deepest_Type_Access_Level
16563 -- return extreme values for a formal type; Deepest_Type_Access_Level
16564 -- returns Int'Last. By calling the appropriate function from among the
16565 -- two, we ensure that the static accessibility check will pass if we
16566 -- happen to run into a formal type. More specifically, we should call
16567 -- Deepest_Type_Access_Level instead of Type_Access_Level whenever the
16568 -- call occurs as part of a static accessibility check and the error
16569 -- case is the case where the type's level is too shallow (as opposed
16572 if Is_Generic_Type (Root_Type (Btyp)) then
16573 return Scope_Depth (Standard_Standard);
16576 return Scope_Depth (Enclosing_Dynamic_Scope (Btyp));
16577 end Type_Access_Level;
16579 ------------------------------------
16580 -- Type_Without_Stream_Operation --
16581 ------------------------------------
16583 function Type_Without_Stream_Operation
16585 Op : TSS_Name_Type := TSS_Null) return Entity_Id
16587 BT : constant Entity_Id := Base_Type (T);
16588 Op_Missing : Boolean;
16591 if not Restriction_Active (No_Default_Stream_Attributes) then
16595 if Is_Elementary_Type (T) then
16596 if Op = TSS_Null then
16598 No (TSS (BT, TSS_Stream_Read))
16599 or else No (TSS (BT, TSS_Stream_Write));
16602 Op_Missing := No (TSS (BT, Op));
16611 elsif Is_Array_Type (T) then
16612 return Type_Without_Stream_Operation (Component_Type (T), Op);
16614 elsif Is_Record_Type (T) then
16620 Comp := First_Component (T);
16621 while Present (Comp) loop
16622 C_Typ := Type_Without_Stream_Operation (Etype (Comp), Op);
16624 if Present (C_Typ) then
16628 Next_Component (Comp);
16634 elsif Is_Private_Type (T)
16635 and then Present (Full_View (T))
16637 return Type_Without_Stream_Operation (Full_View (T), Op);
16641 end Type_Without_Stream_Operation;
16643 ----------------------------
16644 -- Unique_Defining_Entity --
16645 ----------------------------
16647 function Unique_Defining_Entity (N : Node_Id) return Entity_Id is
16649 return Unique_Entity (Defining_Entity (N));
16650 end Unique_Defining_Entity;
16652 -------------------
16653 -- Unique_Entity --
16654 -------------------
16656 function Unique_Entity (E : Entity_Id) return Entity_Id is
16657 U : Entity_Id := E;
16663 if Present (Full_View (E)) then
16664 U := Full_View (E);
16668 if Present (Full_View (E)) then
16669 U := Full_View (E);
16672 when E_Package_Body =>
16675 if Nkind (P) = N_Defining_Program_Unit_Name then
16679 U := Corresponding_Spec (P);
16681 when E_Subprogram_Body =>
16684 if Nkind (P) = N_Defining_Program_Unit_Name then
16690 if Nkind (P) = N_Subprogram_Body_Stub then
16691 if Present (Library_Unit (P)) then
16693 -- Get to the function or procedure (generic) entity through
16694 -- the body entity.
16697 Unique_Entity (Defining_Entity (Get_Body_From_Stub (P)));
16700 U := Corresponding_Spec (P);
16703 when Formal_Kind =>
16704 if Present (Spec_Entity (E)) then
16705 U := Spec_Entity (E);
16719 function Unique_Name (E : Entity_Id) return String is
16721 -- Names of E_Subprogram_Body or E_Package_Body entities are not
16722 -- reliable, as they may not include the overloading suffix. Instead,
16723 -- when looking for the name of E or one of its enclosing scope, we get
16724 -- the name of the corresponding Unique_Entity.
16726 function Get_Scoped_Name (E : Entity_Id) return String;
16727 -- Return the name of E prefixed by all the names of the scopes to which
16728 -- E belongs, except for Standard.
16730 ---------------------
16731 -- Get_Scoped_Name --
16732 ---------------------
16734 function Get_Scoped_Name (E : Entity_Id) return String is
16735 Name : constant String := Get_Name_String (Chars (E));
16737 if Has_Fully_Qualified_Name (E)
16738 or else Scope (E) = Standard_Standard
16742 return Get_Scoped_Name (Unique_Entity (Scope (E))) & "__" & Name;
16744 end Get_Scoped_Name;
16746 -- Start of processing for Unique_Name
16749 if E = Standard_Standard then
16750 return Get_Name_String (Name_Standard);
16752 elsif Scope (E) = Standard_Standard
16753 and then not (Ekind (E) = E_Package or else Is_Subprogram (E))
16755 return Get_Name_String (Name_Standard) & "__" &
16756 Get_Name_String (Chars (E));
16758 elsif Ekind (E) = E_Enumeration_Literal then
16759 return Unique_Name (Etype (E)) & "__" & Get_Name_String (Chars (E));
16762 return Get_Scoped_Name (Unique_Entity (E));
16766 ---------------------
16767 -- Unit_Is_Visible --
16768 ---------------------
16770 function Unit_Is_Visible (U : Entity_Id) return Boolean is
16771 Curr : constant Node_Id := Cunit (Current_Sem_Unit);
16772 Curr_Entity : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
16774 function Unit_In_Parent_Context (Par_Unit : Node_Id) return Boolean;
16775 -- For a child unit, check whether unit appears in a with_clause
16778 function Unit_In_Context (Comp_Unit : Node_Id) return Boolean;
16779 -- Scan the context clause of one compilation unit looking for a
16780 -- with_clause for the unit in question.
16782 ----------------------------
16783 -- Unit_In_Parent_Context --
16784 ----------------------------
16786 function Unit_In_Parent_Context (Par_Unit : Node_Id) return Boolean is
16788 if Unit_In_Context (Par_Unit) then
16791 elsif Is_Child_Unit (Defining_Entity (Unit (Par_Unit))) then
16792 return Unit_In_Parent_Context (Parent_Spec (Unit (Par_Unit)));
16797 end Unit_In_Parent_Context;
16799 ---------------------
16800 -- Unit_In_Context --
16801 ---------------------
16803 function Unit_In_Context (Comp_Unit : Node_Id) return Boolean is
16807 Clause := First (Context_Items (Comp_Unit));
16808 while Present (Clause) loop
16809 if Nkind (Clause) = N_With_Clause then
16810 if Library_Unit (Clause) = U then
16813 -- The with_clause may denote a renaming of the unit we are
16814 -- looking for, eg. Text_IO which renames Ada.Text_IO.
16817 Renamed_Entity (Entity (Name (Clause))) =
16818 Defining_Entity (Unit (U))
16828 end Unit_In_Context;
16830 -- Start of processing for Unit_Is_Visible
16833 -- The currrent unit is directly visible
16838 elsif Unit_In_Context (Curr) then
16841 -- If the current unit is a body, check the context of the spec
16843 elsif Nkind (Unit (Curr)) = N_Package_Body
16845 (Nkind (Unit (Curr)) = N_Subprogram_Body
16846 and then not Acts_As_Spec (Unit (Curr)))
16848 if Unit_In_Context (Library_Unit (Curr)) then
16853 -- If the spec is a child unit, examine the parents
16855 if Is_Child_Unit (Curr_Entity) then
16856 if Nkind (Unit (Curr)) in N_Unit_Body then
16858 Unit_In_Parent_Context
16859 (Parent_Spec (Unit (Library_Unit (Curr))));
16861 return Unit_In_Parent_Context (Parent_Spec (Unit (Curr)));
16867 end Unit_Is_Visible;
16869 ------------------------------
16870 -- Universal_Interpretation --
16871 ------------------------------
16873 function Universal_Interpretation (Opnd : Node_Id) return Entity_Id is
16874 Index : Interp_Index;
16878 -- The argument may be a formal parameter of an operator or subprogram
16879 -- with multiple interpretations, or else an expression for an actual.
16881 if Nkind (Opnd) = N_Defining_Identifier
16882 or else not Is_Overloaded (Opnd)
16884 if Etype (Opnd) = Universal_Integer
16885 or else Etype (Opnd) = Universal_Real
16887 return Etype (Opnd);
16893 Get_First_Interp (Opnd, Index, It);
16894 while Present (It.Typ) loop
16895 if It.Typ = Universal_Integer
16896 or else It.Typ = Universal_Real
16901 Get_Next_Interp (Index, It);
16906 end Universal_Interpretation;
16912 function Unqualify (Expr : Node_Id) return Node_Id is
16914 -- Recurse to handle unlikely case of multiple levels of qualification
16916 if Nkind (Expr) = N_Qualified_Expression then
16917 return Unqualify (Expression (Expr));
16919 -- Normal case, not a qualified expression
16926 -----------------------
16927 -- Visible_Ancestors --
16928 -----------------------
16930 function Visible_Ancestors (Typ : Entity_Id) return Elist_Id is
16936 pragma Assert (Is_Record_Type (Typ)
16937 and then Is_Tagged_Type (Typ));
16939 -- Collect all the parents and progenitors of Typ. If the full-view of
16940 -- private parents and progenitors is available then it is used to
16941 -- generate the list of visible ancestors; otherwise their partial
16942 -- view is added to the resulting list.
16947 Use_Full_View => True);
16951 Ifaces_List => List_2,
16952 Exclude_Parents => True,
16953 Use_Full_View => True);
16955 -- Join the two lists. Avoid duplications because an interface may
16956 -- simultaneously be parent and progenitor of a type.
16958 Elmt := First_Elmt (List_2);
16959 while Present (Elmt) loop
16960 Append_Unique_Elmt (Node (Elmt), List_1);
16965 end Visible_Ancestors;
16967 ----------------------
16968 -- Within_Init_Proc --
16969 ----------------------
16971 function Within_Init_Proc return Boolean is
16975 S := Current_Scope;
16976 while not Is_Overloadable (S) loop
16977 if S = Standard_Standard then
16984 return Is_Init_Proc (S);
16985 end Within_Init_Proc;
16991 function Within_Scope (E : Entity_Id; S : Entity_Id) return Boolean is
16998 elsif SE = Standard_Standard then
17010 procedure Wrong_Type (Expr : Node_Id; Expected_Type : Entity_Id) is
17011 Found_Type : constant Entity_Id := First_Subtype (Etype (Expr));
17012 Expec_Type : constant Entity_Id := First_Subtype (Expected_Type);
17014 Matching_Field : Entity_Id;
17015 -- Entity to give a more precise suggestion on how to write a one-
17016 -- element positional aggregate.
17018 function Has_One_Matching_Field return Boolean;
17019 -- Determines if Expec_Type is a record type with a single component or
17020 -- discriminant whose type matches the found type or is one dimensional
17021 -- array whose component type matches the found type. In the case of
17022 -- one discriminant, we ignore the variant parts. That's not accurate,
17023 -- but good enough for the warning.
17025 ----------------------------
17026 -- Has_One_Matching_Field --
17027 ----------------------------
17029 function Has_One_Matching_Field return Boolean is
17033 Matching_Field := Empty;
17035 if Is_Array_Type (Expec_Type)
17036 and then Number_Dimensions (Expec_Type) = 1
17038 Covers (Etype (Component_Type (Expec_Type)), Found_Type)
17040 -- Use type name if available. This excludes multidimensional
17041 -- arrays and anonymous arrays.
17043 if Comes_From_Source (Expec_Type) then
17044 Matching_Field := Expec_Type;
17046 -- For an assignment, use name of target
17048 elsif Nkind (Parent (Expr)) = N_Assignment_Statement
17049 and then Is_Entity_Name (Name (Parent (Expr)))
17051 Matching_Field := Entity (Name (Parent (Expr)));
17056 elsif not Is_Record_Type (Expec_Type) then
17060 E := First_Entity (Expec_Type);
17065 elsif not Ekind_In (E, E_Discriminant, E_Component)
17066 or else Nam_In (Chars (E), Name_uTag, Name_uParent)
17075 if not Covers (Etype (E), Found_Type) then
17078 elsif Present (Next_Entity (E))
17079 and then (Ekind (E) = E_Component
17080 or else Ekind (Next_Entity (E)) = E_Discriminant)
17085 Matching_Field := E;
17089 end Has_One_Matching_Field;
17091 -- Start of processing for Wrong_Type
17094 -- Don't output message if either type is Any_Type, or if a message
17095 -- has already been posted for this node. We need to do the latter
17096 -- check explicitly (it is ordinarily done in Errout), because we
17097 -- are using ! to force the output of the error messages.
17099 if Expec_Type = Any_Type
17100 or else Found_Type = Any_Type
17101 or else Error_Posted (Expr)
17105 -- If one of the types is a Taft-Amendment type and the other it its
17106 -- completion, it must be an illegal use of a TAT in the spec, for
17107 -- which an error was already emitted. Avoid cascaded errors.
17109 elsif Is_Incomplete_Type (Expec_Type)
17110 and then Has_Completion_In_Body (Expec_Type)
17111 and then Full_View (Expec_Type) = Etype (Expr)
17115 elsif Is_Incomplete_Type (Etype (Expr))
17116 and then Has_Completion_In_Body (Etype (Expr))
17117 and then Full_View (Etype (Expr)) = Expec_Type
17121 -- In an instance, there is an ongoing problem with completion of
17122 -- type derived from private types. Their structure is what Gigi
17123 -- expects, but the Etype is the parent type rather than the
17124 -- derived private type itself. Do not flag error in this case. The
17125 -- private completion is an entity without a parent, like an Itype.
17126 -- Similarly, full and partial views may be incorrect in the instance.
17127 -- There is no simple way to insure that it is consistent ???
17129 elsif In_Instance then
17130 if Etype (Etype (Expr)) = Etype (Expected_Type)
17132 (Has_Private_Declaration (Expected_Type)
17133 or else Has_Private_Declaration (Etype (Expr)))
17134 and then No (Parent (Expected_Type))
17140 -- An interesting special check. If the expression is parenthesized
17141 -- and its type corresponds to the type of the sole component of the
17142 -- expected record type, or to the component type of the expected one
17143 -- dimensional array type, then assume we have a bad aggregate attempt.
17145 if Nkind (Expr) in N_Subexpr
17146 and then Paren_Count (Expr) /= 0
17147 and then Has_One_Matching_Field
17149 Error_Msg_N ("positional aggregate cannot have one component", Expr);
17150 if Present (Matching_Field) then
17151 if Is_Array_Type (Expec_Type) then
17153 ("\write instead `&''First ='> ...`", Expr, Matching_Field);
17157 ("\write instead `& ='> ...`", Expr, Matching_Field);
17161 -- Another special check, if we are looking for a pool-specific access
17162 -- type and we found an E_Access_Attribute_Type, then we have the case
17163 -- of an Access attribute being used in a context which needs a pool-
17164 -- specific type, which is never allowed. The one extra check we make
17165 -- is that the expected designated type covers the Found_Type.
17167 elsif Is_Access_Type (Expec_Type)
17168 and then Ekind (Found_Type) = E_Access_Attribute_Type
17169 and then Ekind (Base_Type (Expec_Type)) /= E_General_Access_Type
17170 and then Ekind (Base_Type (Expec_Type)) /= E_Anonymous_Access_Type
17172 (Designated_Type (Expec_Type), Designated_Type (Found_Type))
17174 Error_Msg_N -- CODEFIX
17175 ("result must be general access type!", Expr);
17176 Error_Msg_NE -- CODEFIX
17177 ("add ALL to }!", Expr, Expec_Type);
17179 -- Another special check, if the expected type is an integer type,
17180 -- but the expression is of type System.Address, and the parent is
17181 -- an addition or subtraction operation whose left operand is the
17182 -- expression in question and whose right operand is of an integral
17183 -- type, then this is an attempt at address arithmetic, so give
17184 -- appropriate message.
17186 elsif Is_Integer_Type (Expec_Type)
17187 and then Is_RTE (Found_Type, RE_Address)
17188 and then (Nkind (Parent (Expr)) = N_Op_Add
17190 Nkind (Parent (Expr)) = N_Op_Subtract)
17191 and then Expr = Left_Opnd (Parent (Expr))
17192 and then Is_Integer_Type (Etype (Right_Opnd (Parent (Expr))))
17195 ("address arithmetic not predefined in package System",
17198 ("\possible missing with/use of System.Storage_Elements",
17202 -- If the expected type is an anonymous access type, as for access
17203 -- parameters and discriminants, the error is on the designated types.
17205 elsif Ekind (Expec_Type) = E_Anonymous_Access_Type then
17206 if Comes_From_Source (Expec_Type) then
17207 Error_Msg_NE ("expected}!", Expr, Expec_Type);
17210 ("expected an access type with designated}",
17211 Expr, Designated_Type (Expec_Type));
17214 if Is_Access_Type (Found_Type)
17215 and then not Comes_From_Source (Found_Type)
17218 ("\\found an access type with designated}!",
17219 Expr, Designated_Type (Found_Type));
17221 if From_Limited_With (Found_Type) then
17222 Error_Msg_NE ("\\found incomplete}!", Expr, Found_Type);
17223 Error_Msg_Qual_Level := 99;
17224 Error_Msg_NE -- CODEFIX
17225 ("\\missing `WITH &;", Expr, Scope (Found_Type));
17226 Error_Msg_Qual_Level := 0;
17228 Error_Msg_NE ("found}!", Expr, Found_Type);
17232 -- Normal case of one type found, some other type expected
17235 -- If the names of the two types are the same, see if some number
17236 -- of levels of qualification will help. Don't try more than three
17237 -- levels, and if we get to standard, it's no use (and probably
17238 -- represents an error in the compiler) Also do not bother with
17239 -- internal scope names.
17242 Expec_Scope : Entity_Id;
17243 Found_Scope : Entity_Id;
17246 Expec_Scope := Expec_Type;
17247 Found_Scope := Found_Type;
17249 for Levels in Int range 0 .. 3 loop
17250 if Chars (Expec_Scope) /= Chars (Found_Scope) then
17251 Error_Msg_Qual_Level := Levels;
17255 Expec_Scope := Scope (Expec_Scope);
17256 Found_Scope := Scope (Found_Scope);
17258 exit when Expec_Scope = Standard_Standard
17259 or else Found_Scope = Standard_Standard
17260 or else not Comes_From_Source (Expec_Scope)
17261 or else not Comes_From_Source (Found_Scope);
17265 if Is_Record_Type (Expec_Type)
17266 and then Present (Corresponding_Remote_Type (Expec_Type))
17268 Error_Msg_NE ("expected}!", Expr,
17269 Corresponding_Remote_Type (Expec_Type));
17271 Error_Msg_NE ("expected}!", Expr, Expec_Type);
17274 if Is_Entity_Name (Expr)
17275 and then Is_Package_Or_Generic_Package (Entity (Expr))
17277 Error_Msg_N ("\\found package name!", Expr);
17279 elsif Is_Entity_Name (Expr)
17281 (Ekind (Entity (Expr)) = E_Procedure
17283 Ekind (Entity (Expr)) = E_Generic_Procedure)
17285 if Ekind (Expec_Type) = E_Access_Subprogram_Type then
17287 ("found procedure name, possibly missing Access attribute!",
17291 ("\\found procedure name instead of function!", Expr);
17294 elsif Nkind (Expr) = N_Function_Call
17295 and then Ekind (Expec_Type) = E_Access_Subprogram_Type
17296 and then Etype (Designated_Type (Expec_Type)) = Etype (Expr)
17297 and then No (Parameter_Associations (Expr))
17300 ("found function name, possibly missing Access attribute!",
17303 -- Catch common error: a prefix or infix operator which is not
17304 -- directly visible because the type isn't.
17306 elsif Nkind (Expr) in N_Op
17307 and then Is_Overloaded (Expr)
17308 and then not Is_Immediately_Visible (Expec_Type)
17309 and then not Is_Potentially_Use_Visible (Expec_Type)
17310 and then not In_Use (Expec_Type)
17311 and then Has_Compatible_Type (Right_Opnd (Expr), Expec_Type)
17314 ("operator of the type is not directly visible!", Expr);
17316 elsif Ekind (Found_Type) = E_Void
17317 and then Present (Parent (Found_Type))
17318 and then Nkind (Parent (Found_Type)) = N_Full_Type_Declaration
17320 Error_Msg_NE ("\\found premature usage of}!", Expr, Found_Type);
17323 Error_Msg_NE ("\\found}!", Expr, Found_Type);
17326 -- A special check for cases like M1 and M2 = 0 where M1 and M2 are
17327 -- of the same modular type, and (M1 and M2) = 0 was intended.
17329 if Expec_Type = Standard_Boolean
17330 and then Is_Modular_Integer_Type (Found_Type)
17331 and then Nkind_In (Parent (Expr), N_Op_And, N_Op_Or, N_Op_Xor)
17332 and then Nkind (Right_Opnd (Parent (Expr))) in N_Op_Compare
17335 Op : constant Node_Id := Right_Opnd (Parent (Expr));
17336 L : constant Node_Id := Left_Opnd (Op);
17337 R : constant Node_Id := Right_Opnd (Op);
17339 -- The case for the message is when the left operand of the
17340 -- comparison is the same modular type, or when it is an
17341 -- integer literal (or other universal integer expression),
17342 -- which would have been typed as the modular type if the
17343 -- parens had been there.
17345 if (Etype (L) = Found_Type
17347 Etype (L) = Universal_Integer)
17348 and then Is_Integer_Type (Etype (R))
17351 ("\\possible missing parens for modular operation", Expr);
17356 -- Reset error message qualification indication
17358 Error_Msg_Qual_Level := 0;