1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2015, 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 Treepr; -- ???For debugging code below
28 with Aspects; use Aspects;
29 with Atree; use Atree;
30 with Casing; use Casing;
31 with Checks; use Checks;
32 with Debug; use Debug;
33 with Elists; use Elists;
34 with Errout; use Errout;
35 with Exp_Ch11; use Exp_Ch11;
36 with Exp_Disp; use Exp_Disp;
37 with Exp_Util; use Exp_Util;
38 with Fname; use Fname;
39 with Freeze; use Freeze;
40 with Ghost; use Ghost;
42 with Lib.Xref; use Lib.Xref;
43 with Namet.Sp; use Namet.Sp;
44 with Nlists; use Nlists;
45 with Nmake; use Nmake;
46 with Output; use Output;
47 with Restrict; use Restrict;
48 with Rident; use Rident;
49 with Rtsfind; use Rtsfind;
51 with Sem_Aux; use Sem_Aux;
52 with Sem_Attr; use Sem_Attr;
53 with Sem_Ch6; use Sem_Ch6;
54 with Sem_Ch8; use Sem_Ch8;
55 with Sem_Ch12; use Sem_Ch12;
56 with Sem_Ch13; use Sem_Ch13;
57 with Sem_Disp; use Sem_Disp;
58 with Sem_Eval; use Sem_Eval;
59 with Sem_Prag; use Sem_Prag;
60 with Sem_Res; use Sem_Res;
61 with Sem_Warn; use Sem_Warn;
62 with Sem_Type; use Sem_Type;
63 with Sinfo; use Sinfo;
64 with Sinput; use Sinput;
65 with Stand; use Stand;
67 with Stringt; use Stringt;
68 with Targparm; use Targparm;
69 with Tbuild; use Tbuild;
70 with Ttypes; use Ttypes;
71 with Uname; use Uname;
73 with GNAT.HTable; use GNAT.HTable;
75 package body Sem_Util is
77 ----------------------------------------
78 -- Global Variables for New_Copy_Tree --
79 ----------------------------------------
81 -- These global variables are used by New_Copy_Tree. See description of the
82 -- body of this subprogram for details. Global variables can be safely used
83 -- by New_Copy_Tree, since there is no case of a recursive call from the
84 -- processing inside New_Copy_Tree.
86 NCT_Hash_Threshold : constant := 20;
87 -- If there are more than this number of pairs of entries in the map, then
88 -- Hash_Tables_Used will be set, and the hash tables will be initialized
89 -- and used for the searches.
91 NCT_Hash_Tables_Used : Boolean := False;
92 -- Set to True if hash tables are in use
94 NCT_Table_Entries : Nat := 0;
95 -- Count entries in table to see if threshold is reached
97 NCT_Hash_Table_Setup : Boolean := False;
98 -- Set to True if hash table contains data. We set this True if we setup
99 -- the hash table with data, and leave it set permanently from then on,
100 -- this is a signal that second and subsequent users of the hash table
101 -- must clear the old entries before reuse.
103 subtype NCT_Header_Num is Int range 0 .. 511;
104 -- Defines range of headers in hash tables (512 headers)
106 -----------------------
107 -- Local Subprograms --
108 -----------------------
110 function Build_Component_Subtype
113 T : Entity_Id) return Node_Id;
114 -- This function builds the subtype for Build_Actual_Subtype_Of_Component
115 -- and Build_Discriminal_Subtype_Of_Component. C is a list of constraints,
116 -- Loc is the source location, T is the original subtype.
118 function Has_Enabled_Property
119 (Item_Id : Entity_Id;
120 Property : Name_Id) return Boolean;
121 -- Subsidiary to routines Async_xxx_Enabled and Effective_xxx_Enabled.
122 -- Determine whether an abstract state or a variable denoted by entity
123 -- Item_Id has enabled property Property.
125 function Has_Null_Extension (T : Entity_Id) return Boolean;
126 -- T is a derived tagged type. Check whether the type extension is null.
127 -- If the parent type is fully initialized, T can be treated as such.
129 function Is_Fully_Initialized_Variant (Typ : Entity_Id) return Boolean;
130 -- Subsidiary to Is_Fully_Initialized_Type. For an unconstrained type
131 -- with discriminants whose default values are static, examine only the
132 -- components in the selected variant to determine whether all of them
135 ------------------------------
136 -- Abstract_Interface_List --
137 ------------------------------
139 function Abstract_Interface_List (Typ : Entity_Id) return List_Id is
143 if Is_Concurrent_Type (Typ) then
145 -- If we are dealing with a synchronized subtype, go to the base
146 -- type, whose declaration has the interface list.
148 -- Shouldn't this be Declaration_Node???
150 Nod := Parent (Base_Type (Typ));
152 if Nkind (Nod) = N_Full_Type_Declaration then
156 elsif Ekind (Typ) = E_Record_Type_With_Private then
157 if Nkind (Parent (Typ)) = N_Full_Type_Declaration then
158 Nod := Type_Definition (Parent (Typ));
160 elsif Nkind (Parent (Typ)) = N_Private_Type_Declaration then
161 if Present (Full_View (Typ))
163 Nkind (Parent (Full_View (Typ))) = N_Full_Type_Declaration
165 Nod := Type_Definition (Parent (Full_View (Typ)));
167 -- If the full-view is not available we cannot do anything else
168 -- here (the source has errors).
174 -- Support for generic formals with interfaces is still missing ???
176 elsif Nkind (Parent (Typ)) = N_Formal_Type_Declaration then
181 (Nkind (Parent (Typ)) = N_Private_Extension_Declaration);
185 elsif Ekind (Typ) = E_Record_Subtype then
186 Nod := Type_Definition (Parent (Etype (Typ)));
188 elsif Ekind (Typ) = E_Record_Subtype_With_Private then
190 -- Recurse, because parent may still be a private extension. Also
191 -- note that the full view of the subtype or the full view of its
192 -- base type may (both) be unavailable.
194 return Abstract_Interface_List (Etype (Typ));
196 else pragma Assert ((Ekind (Typ)) = E_Record_Type);
197 if Nkind (Parent (Typ)) = N_Formal_Type_Declaration then
198 Nod := Formal_Type_Definition (Parent (Typ));
200 Nod := Type_Definition (Parent (Typ));
204 return Interface_List (Nod);
205 end Abstract_Interface_List;
207 --------------------------------
208 -- Add_Access_Type_To_Process --
209 --------------------------------
211 procedure Add_Access_Type_To_Process (E : Entity_Id; A : Entity_Id) is
215 Ensure_Freeze_Node (E);
216 L := Access_Types_To_Process (Freeze_Node (E));
220 Set_Access_Types_To_Process (Freeze_Node (E), L);
224 end Add_Access_Type_To_Process;
226 --------------------------
227 -- Add_Block_Identifier --
228 --------------------------
230 procedure Add_Block_Identifier (N : Node_Id; Id : out Entity_Id) is
231 Loc : constant Source_Ptr := Sloc (N);
234 pragma Assert (Nkind (N) = N_Block_Statement);
236 -- The block already has a label, return its entity
238 if Present (Identifier (N)) then
239 Id := Entity (Identifier (N));
241 -- Create a new block label and set its attributes
244 Id := New_Internal_Entity (E_Block, Current_Scope, Loc, 'B');
245 Set_Etype (Id, Standard_Void_Type);
248 Set_Identifier (N, New_Occurrence_Of (Id, Loc));
249 Set_Block_Node (Id, Identifier (N));
251 end Add_Block_Identifier;
253 -----------------------
254 -- Add_Contract_Item --
255 -----------------------
257 procedure Add_Contract_Item (Prag : Node_Id; Id : Entity_Id) is
258 Items : Node_Id := Contract (Id);
260 procedure Add_Classification;
261 -- Prepend Prag to the list of classifications
263 procedure Add_Contract_Test_Case;
264 -- Prepend Prag to the list of contract and test cases
266 procedure Add_Pre_Post_Condition;
267 -- Prepend Prag to the list of pre- and postconditions
269 ------------------------
270 -- Add_Classification --
271 ------------------------
273 procedure Add_Classification is
275 Set_Next_Pragma (Prag, Classifications (Items));
276 Set_Classifications (Items, Prag);
277 end Add_Classification;
279 ----------------------------
280 -- Add_Contract_Test_Case --
281 ----------------------------
283 procedure Add_Contract_Test_Case is
285 Set_Next_Pragma (Prag, Contract_Test_Cases (Items));
286 Set_Contract_Test_Cases (Items, Prag);
287 end Add_Contract_Test_Case;
289 ----------------------------
290 -- Add_Pre_Post_Condition --
291 ----------------------------
293 procedure Add_Pre_Post_Condition is
295 Set_Next_Pragma (Prag, Pre_Post_Conditions (Items));
296 Set_Pre_Post_Conditions (Items, Prag);
297 end Add_Pre_Post_Condition;
303 -- Start of processing for Add_Contract_Item
306 -- A contract must contain only pragmas
308 pragma Assert (Nkind (Prag) = N_Pragma);
309 Prag_Nam := Pragma_Name (Prag);
311 -- Create a new contract when adding the first item
314 Items := Make_Contract (Sloc (Id));
315 Set_Contract (Id, Items);
318 -- Contract items related to constants. Applicable pragmas are:
321 if Ekind (Id) = E_Constant then
322 if Prag_Nam = Name_Part_Of then
325 -- The pragma is not a proper contract item
331 -- Contract items related to [generic] packages or instantiations. The
332 -- applicable pragmas are:
336 -- Part_Of (instantiation only)
338 elsif Ekind_In (Id, E_Generic_Package, E_Package) then
339 if Nam_In (Prag_Nam, Name_Abstract_State,
340 Name_Initial_Condition,
345 -- Indicator Part_Of must be associated with a package instantiation
347 elsif Prag_Nam = Name_Part_Of and then Is_Generic_Instance (Id) then
350 -- The pragma is not a proper contract item
356 -- Contract items related to package bodies. The applicable pragmas are:
359 elsif Ekind (Id) = E_Package_Body then
360 if Prag_Nam = Name_Refined_State then
363 -- The pragma is not a proper contract item
369 -- Contract items related to subprogram or entry declarations. The
370 -- applicable pragmas are:
373 -- Extensions_Visible
379 elsif Ekind_In (Id, E_Entry, E_Entry_Family)
380 or else Is_Generic_Subprogram (Id)
381 or else Is_Subprogram (Id)
383 if Nam_In (Prag_Nam, Name_Postcondition, Name_Precondition) then
384 Add_Pre_Post_Condition;
386 elsif Nam_In (Prag_Nam, Name_Contract_Cases, Name_Test_Case) then
387 Add_Contract_Test_Case;
389 elsif Nam_In (Prag_Nam, Name_Depends,
390 Name_Extensions_Visible,
395 -- The pragma is not a proper contract item
401 -- Contract items related to subprogram bodies. Applicable pragmas are:
408 elsif Ekind (Id) = E_Subprogram_Body then
409 if Nam_In (Prag_Nam, Name_Refined_Depends, Name_Refined_Global) then
412 elsif Nam_In (Prag_Nam, Name_Postcondition,
416 Add_Pre_Post_Condition;
418 -- The pragma is not a proper contract item
424 -- Contract items related to variables. Applicable pragmas are:
431 elsif Ekind (Id) = E_Variable then
432 if Nam_In (Prag_Nam, Name_Async_Readers,
434 Name_Effective_Reads,
435 Name_Effective_Writes,
440 -- The pragma is not a proper contract item
446 end Add_Contract_Item;
448 ----------------------------
449 -- Add_Global_Declaration --
450 ----------------------------
452 procedure Add_Global_Declaration (N : Node_Id) is
453 Aux_Node : constant Node_Id := Aux_Decls_Node (Cunit (Current_Sem_Unit));
456 if No (Declarations (Aux_Node)) then
457 Set_Declarations (Aux_Node, New_List);
460 Append_To (Declarations (Aux_Node), N);
462 end Add_Global_Declaration;
464 --------------------------------
465 -- Address_Integer_Convert_OK --
466 --------------------------------
468 function Address_Integer_Convert_OK (T1, T2 : Entity_Id) return Boolean is
470 if Allow_Integer_Address
471 and then ((Is_Descendent_Of_Address (T1)
472 and then Is_Private_Type (T1)
473 and then Is_Integer_Type (T2))
475 (Is_Descendent_Of_Address (T2)
476 and then Is_Private_Type (T2)
477 and then Is_Integer_Type (T1)))
483 end Address_Integer_Convert_OK;
489 -- For now, just 8/16/32/64. but analyze later if AAMP is special???
491 function Addressable (V : Uint) return Boolean is
493 return V = Uint_8 or else
499 function Addressable (V : Int) return Boolean is
507 ---------------------------------
508 -- Aggregate_Constraint_Checks --
509 ---------------------------------
511 procedure Aggregate_Constraint_Checks
513 Check_Typ : Entity_Id)
515 Exp_Typ : constant Entity_Id := Etype (Exp);
518 if Raises_Constraint_Error (Exp) then
522 -- Ada 2005 (AI-230): Generate a conversion to an anonymous access
523 -- component's type to force the appropriate accessibility checks.
525 -- Ada 2005 (AI-231): Generate conversion to the null-excluding
526 -- type to force the corresponding run-time check
528 if Is_Access_Type (Check_Typ)
529 and then ((Is_Local_Anonymous_Access (Check_Typ))
530 or else (Can_Never_Be_Null (Check_Typ)
531 and then not Can_Never_Be_Null (Exp_Typ)))
533 Rewrite (Exp, Convert_To (Check_Typ, Relocate_Node (Exp)));
534 Analyze_And_Resolve (Exp, Check_Typ);
535 Check_Unset_Reference (Exp);
538 -- This is really expansion activity, so make sure that expansion is
539 -- on and is allowed. In GNATprove mode, we also want check flags to
540 -- be added in the tree, so that the formal verification can rely on
541 -- those to be present. In GNATprove mode for formal verification, some
542 -- treatment typically only done during expansion needs to be performed
543 -- on the tree, but it should not be applied inside generics. Otherwise,
544 -- this breaks the name resolution mechanism for generic instances.
546 if not Expander_Active
547 and (Inside_A_Generic or not Full_Analysis or not GNATprove_Mode)
552 -- First check if we have to insert discriminant checks
554 if Has_Discriminants (Exp_Typ) then
555 Apply_Discriminant_Check (Exp, Check_Typ);
557 -- Next emit length checks for array aggregates
559 elsif Is_Array_Type (Exp_Typ) then
560 Apply_Length_Check (Exp, Check_Typ);
562 -- Finally emit scalar and string checks. If we are dealing with a
563 -- scalar literal we need to check by hand because the Etype of
564 -- literals is not necessarily correct.
566 elsif Is_Scalar_Type (Exp_Typ)
567 and then Compile_Time_Known_Value (Exp)
569 if Is_Out_Of_Range (Exp, Base_Type (Check_Typ)) then
570 Apply_Compile_Time_Constraint_Error
571 (Exp, "value not in range of}??", CE_Range_Check_Failed,
572 Ent => Base_Type (Check_Typ),
573 Typ => Base_Type (Check_Typ));
575 elsif Is_Out_Of_Range (Exp, Check_Typ) then
576 Apply_Compile_Time_Constraint_Error
577 (Exp, "value not in range of}??", CE_Range_Check_Failed,
581 elsif not Range_Checks_Suppressed (Check_Typ) then
582 Apply_Scalar_Range_Check (Exp, Check_Typ);
585 -- Verify that target type is also scalar, to prevent view anomalies
586 -- in instantiations.
588 elsif (Is_Scalar_Type (Exp_Typ)
589 or else Nkind (Exp) = N_String_Literal)
590 and then Is_Scalar_Type (Check_Typ)
591 and then Exp_Typ /= Check_Typ
593 if Is_Entity_Name (Exp)
594 and then Ekind (Entity (Exp)) = E_Constant
596 -- If expression is a constant, it is worthwhile checking whether
597 -- it is a bound of the type.
599 if (Is_Entity_Name (Type_Low_Bound (Check_Typ))
600 and then Entity (Exp) = Entity (Type_Low_Bound (Check_Typ)))
602 (Is_Entity_Name (Type_High_Bound (Check_Typ))
603 and then Entity (Exp) = Entity (Type_High_Bound (Check_Typ)))
608 Rewrite (Exp, Convert_To (Check_Typ, Relocate_Node (Exp)));
609 Analyze_And_Resolve (Exp, Check_Typ);
610 Check_Unset_Reference (Exp);
613 -- Could use a comment on this case ???
616 Rewrite (Exp, Convert_To (Check_Typ, Relocate_Node (Exp)));
617 Analyze_And_Resolve (Exp, Check_Typ);
618 Check_Unset_Reference (Exp);
622 end Aggregate_Constraint_Checks;
624 -----------------------
625 -- Alignment_In_Bits --
626 -----------------------
628 function Alignment_In_Bits (E : Entity_Id) return Uint is
630 return Alignment (E) * System_Storage_Unit;
631 end Alignment_In_Bits;
633 ---------------------------------
634 -- Append_Inherited_Subprogram --
635 ---------------------------------
637 procedure Append_Inherited_Subprogram (S : Entity_Id) is
638 Par : constant Entity_Id := Alias (S);
639 -- The parent subprogram
641 Scop : constant Entity_Id := Scope (Par);
642 -- The scope of definition of the parent subprogram
644 Typ : constant Entity_Id := Defining_Entity (Parent (S));
645 -- The derived type of which S is a primitive operation
651 if Ekind (Current_Scope) = E_Package
652 and then In_Private_Part (Current_Scope)
653 and then Has_Private_Declaration (Typ)
654 and then Is_Tagged_Type (Typ)
655 and then Scop = Current_Scope
657 -- The inherited operation is available at the earliest place after
658 -- the derived type declaration ( RM 7.3.1 (6/1)). This is only
659 -- relevant for type extensions. If the parent operation appears
660 -- after the type extension, the operation is not visible.
663 (Visible_Declarations
664 (Package_Specification (Current_Scope)));
665 while Present (Decl) loop
666 if Nkind (Decl) = N_Private_Extension_Declaration
667 and then Defining_Entity (Decl) = Typ
669 if Sloc (Decl) > Sloc (Par) then
670 Next_E := Next_Entity (Par);
671 Set_Next_Entity (Par, S);
672 Set_Next_Entity (S, Next_E);
684 -- If partial view is not a type extension, or it appears before the
685 -- subprogram declaration, insert normally at end of entity list.
687 Append_Entity (S, Current_Scope);
688 end Append_Inherited_Subprogram;
690 -----------------------------------------
691 -- Apply_Compile_Time_Constraint_Error --
692 -----------------------------------------
694 procedure Apply_Compile_Time_Constraint_Error
697 Reason : RT_Exception_Code;
698 Ent : Entity_Id := Empty;
699 Typ : Entity_Id := Empty;
700 Loc : Source_Ptr := No_Location;
701 Rep : Boolean := True;
702 Warn : Boolean := False)
704 Stat : constant Boolean := Is_Static_Expression (N);
705 R_Stat : constant Node_Id :=
706 Make_Raise_Constraint_Error (Sloc (N), Reason => Reason);
717 (Compile_Time_Constraint_Error (N, Msg, Ent, Loc, Warn => Warn));
723 -- Now we replace the node by an N_Raise_Constraint_Error node
724 -- This does not need reanalyzing, so set it as analyzed now.
727 Set_Analyzed (N, True);
730 Set_Raises_Constraint_Error (N);
732 -- Now deal with possible local raise handling
734 Possible_Local_Raise (N, Standard_Constraint_Error);
736 -- If the original expression was marked as static, the result is
737 -- still marked as static, but the Raises_Constraint_Error flag is
738 -- always set so that further static evaluation is not attempted.
741 Set_Is_Static_Expression (N);
743 end Apply_Compile_Time_Constraint_Error;
745 ---------------------------
746 -- Async_Readers_Enabled --
747 ---------------------------
749 function Async_Readers_Enabled (Id : Entity_Id) return Boolean is
751 return Has_Enabled_Property (Id, Name_Async_Readers);
752 end Async_Readers_Enabled;
754 ---------------------------
755 -- Async_Writers_Enabled --
756 ---------------------------
758 function Async_Writers_Enabled (Id : Entity_Id) return Boolean is
760 return Has_Enabled_Property (Id, Name_Async_Writers);
761 end Async_Writers_Enabled;
763 --------------------------------------
764 -- Available_Full_View_Of_Component --
765 --------------------------------------
767 function Available_Full_View_Of_Component (T : Entity_Id) return Boolean is
768 ST : constant Entity_Id := Scope (T);
769 SCT : constant Entity_Id := Scope (Component_Type (T));
771 return In_Open_Scopes (ST)
772 and then In_Open_Scopes (SCT)
773 and then Scope_Depth (ST) >= Scope_Depth (SCT);
774 end Available_Full_View_Of_Component;
780 procedure Bad_Attribute
783 Warn : Boolean := False)
786 Error_Msg_Warn := Warn;
787 Error_Msg_N ("unrecognized attribute&<<", N);
789 -- Check for possible misspelling
791 Error_Msg_Name_1 := First_Attribute_Name;
792 while Error_Msg_Name_1 <= Last_Attribute_Name loop
793 if Is_Bad_Spelling_Of (Nam, Error_Msg_Name_1) then
794 Error_Msg_N -- CODEFIX
795 ("\possible misspelling of %<<", N);
799 Error_Msg_Name_1 := Error_Msg_Name_1 + 1;
803 --------------------------------
804 -- Bad_Predicated_Subtype_Use --
805 --------------------------------
807 procedure Bad_Predicated_Subtype_Use
811 Suggest_Static : Boolean := False)
816 -- Avoid cascaded errors
818 if Error_Posted (N) then
822 if Inside_A_Generic then
823 Gen := Current_Scope;
824 while Present (Gen) and then Ekind (Gen) /= E_Generic_Package loop
832 if Is_Generic_Formal (Typ) and then Is_Discrete_Type (Typ) then
833 Set_No_Predicate_On_Actual (Typ);
836 elsif Has_Predicates (Typ) then
837 if Is_Generic_Actual_Type (Typ) then
839 -- The restriction on loop parameters is only that the type
840 -- should have no dynamic predicates.
842 if Nkind (Parent (N)) = N_Loop_Parameter_Specification
843 and then not Has_Dynamic_Predicate_Aspect (Typ)
844 and then Is_OK_Static_Subtype (Typ)
849 Gen := Current_Scope;
850 while not Is_Generic_Instance (Gen) loop
854 pragma Assert (Present (Gen));
856 if Ekind (Gen) = E_Package and then In_Package_Body (Gen) then
857 Error_Msg_Warn := SPARK_Mode /= On;
858 Error_Msg_FE (Msg & "<<", N, Typ);
859 Error_Msg_F ("\Program_Error [<<", N);
862 Make_Raise_Program_Error (Sloc (N),
863 Reason => PE_Bad_Predicated_Generic_Type));
866 Error_Msg_FE (Msg & "<<", N, Typ);
870 Error_Msg_FE (Msg, N, Typ);
873 -- Emit an optional suggestion on how to remedy the error if the
874 -- context warrants it.
876 if Suggest_Static and then Has_Static_Predicate (Typ) then
877 Error_Msg_FE ("\predicate of & should be marked static", N, Typ);
880 end Bad_Predicated_Subtype_Use;
882 -----------------------------------------
883 -- Bad_Unordered_Enumeration_Reference --
884 -----------------------------------------
886 function Bad_Unordered_Enumeration_Reference
888 T : Entity_Id) return Boolean
891 return Is_Enumeration_Type (T)
892 and then Warn_On_Unordered_Enumeration_Type
893 and then not Is_Generic_Type (T)
894 and then Comes_From_Source (N)
895 and then not Has_Pragma_Ordered (T)
896 and then not In_Same_Extended_Unit (N, T);
897 end Bad_Unordered_Enumeration_Reference;
899 --------------------------
900 -- Build_Actual_Subtype --
901 --------------------------
903 function Build_Actual_Subtype
905 N : Node_Or_Entity_Id) return Node_Id
908 -- Normally Sloc (N), but may point to corresponding body in some cases
910 Constraints : List_Id;
916 Disc_Type : Entity_Id;
922 if Nkind (N) = N_Defining_Identifier then
923 Obj := New_Occurrence_Of (N, Loc);
925 -- If this is a formal parameter of a subprogram declaration, and
926 -- we are compiling the body, we want the declaration for the
927 -- actual subtype to carry the source position of the body, to
928 -- prevent anomalies in gdb when stepping through the code.
930 if Is_Formal (N) then
932 Decl : constant Node_Id := Unit_Declaration_Node (Scope (N));
934 if Nkind (Decl) = N_Subprogram_Declaration
935 and then Present (Corresponding_Body (Decl))
937 Loc := Sloc (Corresponding_Body (Decl));
946 if Is_Array_Type (T) then
947 Constraints := New_List;
948 for J in 1 .. Number_Dimensions (T) loop
950 -- Build an array subtype declaration with the nominal subtype and
951 -- the bounds of the actual. Add the declaration in front of the
952 -- local declarations for the subprogram, for analysis before any
953 -- reference to the formal in the body.
956 Make_Attribute_Reference (Loc,
958 Duplicate_Subexpr_No_Checks (Obj, Name_Req => True),
959 Attribute_Name => Name_First,
960 Expressions => New_List (
961 Make_Integer_Literal (Loc, J)));
964 Make_Attribute_Reference (Loc,
966 Duplicate_Subexpr_No_Checks (Obj, Name_Req => True),
967 Attribute_Name => Name_Last,
968 Expressions => New_List (
969 Make_Integer_Literal (Loc, J)));
971 Append (Make_Range (Loc, Lo, Hi), Constraints);
974 -- If the type has unknown discriminants there is no constrained
975 -- subtype to build. This is never called for a formal or for a
976 -- lhs, so returning the type is ok ???
978 elsif Has_Unknown_Discriminants (T) then
982 Constraints := New_List;
984 -- Type T is a generic derived type, inherit the discriminants from
987 if Is_Private_Type (T)
988 and then No (Full_View (T))
990 -- T was flagged as an error if it was declared as a formal
991 -- derived type with known discriminants. In this case there
992 -- is no need to look at the parent type since T already carries
993 -- its own discriminants.
995 and then not Error_Posted (T)
997 Disc_Type := Etype (Base_Type (T));
1002 Discr := First_Discriminant (Disc_Type);
1003 while Present (Discr) loop
1004 Append_To (Constraints,
1005 Make_Selected_Component (Loc,
1007 Duplicate_Subexpr_No_Checks (Obj),
1008 Selector_Name => New_Occurrence_Of (Discr, Loc)));
1009 Next_Discriminant (Discr);
1013 Subt := Make_Temporary (Loc, 'S', Related_Node => N);
1014 Set_Is_Internal (Subt);
1017 Make_Subtype_Declaration (Loc,
1018 Defining_Identifier => Subt,
1019 Subtype_Indication =>
1020 Make_Subtype_Indication (Loc,
1021 Subtype_Mark => New_Occurrence_Of (T, Loc),
1023 Make_Index_Or_Discriminant_Constraint (Loc,
1024 Constraints => Constraints)));
1026 Mark_Rewrite_Insertion (Decl);
1028 end Build_Actual_Subtype;
1030 ---------------------------------------
1031 -- Build_Actual_Subtype_Of_Component --
1032 ---------------------------------------
1034 function Build_Actual_Subtype_Of_Component
1036 N : Node_Id) return Node_Id
1038 Loc : constant Source_Ptr := Sloc (N);
1039 P : constant Node_Id := Prefix (N);
1042 Index_Typ : Entity_Id;
1044 Desig_Typ : Entity_Id;
1045 -- This is either a copy of T, or if T is an access type, then it is
1046 -- the directly designated type of this access type.
1048 function Build_Actual_Array_Constraint return List_Id;
1049 -- If one or more of the bounds of the component depends on
1050 -- discriminants, build actual constraint using the discriminants
1053 function Build_Actual_Record_Constraint return List_Id;
1054 -- Similar to previous one, for discriminated components constrained
1055 -- by the discriminant of the enclosing object.
1057 -----------------------------------
1058 -- Build_Actual_Array_Constraint --
1059 -----------------------------------
1061 function Build_Actual_Array_Constraint return List_Id is
1062 Constraints : constant List_Id := New_List;
1070 Indx := First_Index (Desig_Typ);
1071 while Present (Indx) loop
1072 Old_Lo := Type_Low_Bound (Etype (Indx));
1073 Old_Hi := Type_High_Bound (Etype (Indx));
1075 if Denotes_Discriminant (Old_Lo) then
1077 Make_Selected_Component (Loc,
1078 Prefix => New_Copy_Tree (P),
1079 Selector_Name => New_Occurrence_Of (Entity (Old_Lo), Loc));
1082 Lo := New_Copy_Tree (Old_Lo);
1084 -- The new bound will be reanalyzed in the enclosing
1085 -- declaration. For literal bounds that come from a type
1086 -- declaration, the type of the context must be imposed, so
1087 -- insure that analysis will take place. For non-universal
1088 -- types this is not strictly necessary.
1090 Set_Analyzed (Lo, False);
1093 if Denotes_Discriminant (Old_Hi) then
1095 Make_Selected_Component (Loc,
1096 Prefix => New_Copy_Tree (P),
1097 Selector_Name => New_Occurrence_Of (Entity (Old_Hi), Loc));
1100 Hi := New_Copy_Tree (Old_Hi);
1101 Set_Analyzed (Hi, False);
1104 Append (Make_Range (Loc, Lo, Hi), Constraints);
1109 end Build_Actual_Array_Constraint;
1111 ------------------------------------
1112 -- Build_Actual_Record_Constraint --
1113 ------------------------------------
1115 function Build_Actual_Record_Constraint return List_Id is
1116 Constraints : constant List_Id := New_List;
1121 D := First_Elmt (Discriminant_Constraint (Desig_Typ));
1122 while Present (D) loop
1123 if Denotes_Discriminant (Node (D)) then
1124 D_Val := Make_Selected_Component (Loc,
1125 Prefix => New_Copy_Tree (P),
1126 Selector_Name => New_Occurrence_Of (Entity (Node (D)), Loc));
1129 D_Val := New_Copy_Tree (Node (D));
1132 Append (D_Val, Constraints);
1137 end Build_Actual_Record_Constraint;
1139 -- Start of processing for Build_Actual_Subtype_Of_Component
1142 -- Why the test for Spec_Expression mode here???
1144 if In_Spec_Expression then
1147 -- More comments for the rest of this body would be good ???
1149 elsif Nkind (N) = N_Explicit_Dereference then
1150 if Is_Composite_Type (T)
1151 and then not Is_Constrained (T)
1152 and then not (Is_Class_Wide_Type (T)
1153 and then Is_Constrained (Root_Type (T)))
1154 and then not Has_Unknown_Discriminants (T)
1156 -- If the type of the dereference is already constrained, it is an
1159 if Is_Array_Type (Etype (N))
1160 and then Is_Constrained (Etype (N))
1164 Remove_Side_Effects (P);
1165 return Build_Actual_Subtype (T, N);
1172 if Ekind (T) = E_Access_Subtype then
1173 Desig_Typ := Designated_Type (T);
1178 if Ekind (Desig_Typ) = E_Array_Subtype then
1179 Id := First_Index (Desig_Typ);
1180 while Present (Id) loop
1181 Index_Typ := Underlying_Type (Etype (Id));
1183 if Denotes_Discriminant (Type_Low_Bound (Index_Typ))
1185 Denotes_Discriminant (Type_High_Bound (Index_Typ))
1187 Remove_Side_Effects (P);
1189 Build_Component_Subtype
1190 (Build_Actual_Array_Constraint, Loc, Base_Type (T));
1196 elsif Is_Composite_Type (Desig_Typ)
1197 and then Has_Discriminants (Desig_Typ)
1198 and then not Has_Unknown_Discriminants (Desig_Typ)
1200 if Is_Private_Type (Desig_Typ)
1201 and then No (Discriminant_Constraint (Desig_Typ))
1203 Desig_Typ := Full_View (Desig_Typ);
1206 D := First_Elmt (Discriminant_Constraint (Desig_Typ));
1207 while Present (D) loop
1208 if Denotes_Discriminant (Node (D)) then
1209 Remove_Side_Effects (P);
1211 Build_Component_Subtype (
1212 Build_Actual_Record_Constraint, Loc, Base_Type (T));
1219 -- If none of the above, the actual and nominal subtypes are the same
1222 end Build_Actual_Subtype_Of_Component;
1224 -----------------------------
1225 -- Build_Component_Subtype --
1226 -----------------------------
1228 function Build_Component_Subtype
1231 T : Entity_Id) return Node_Id
1237 -- Unchecked_Union components do not require component subtypes
1239 if Is_Unchecked_Union (T) then
1243 Subt := Make_Temporary (Loc, 'S');
1244 Set_Is_Internal (Subt);
1247 Make_Subtype_Declaration (Loc,
1248 Defining_Identifier => Subt,
1249 Subtype_Indication =>
1250 Make_Subtype_Indication (Loc,
1251 Subtype_Mark => New_Occurrence_Of (Base_Type (T), Loc),
1253 Make_Index_Or_Discriminant_Constraint (Loc,
1254 Constraints => C)));
1256 Mark_Rewrite_Insertion (Decl);
1258 end Build_Component_Subtype;
1260 ----------------------------------
1261 -- Build_Default_Init_Cond_Call --
1262 ----------------------------------
1264 function Build_Default_Init_Cond_Call
1267 Typ : Entity_Id) return Node_Id
1269 Proc_Id : constant Entity_Id := Default_Init_Cond_Procedure (Typ);
1270 Formal_Typ : constant Entity_Id := Etype (First_Formal (Proc_Id));
1274 Make_Procedure_Call_Statement (Loc,
1275 Name => New_Occurrence_Of (Proc_Id, Loc),
1276 Parameter_Associations => New_List (
1277 Make_Unchecked_Type_Conversion (Loc,
1278 Subtype_Mark => New_Occurrence_Of (Formal_Typ, Loc),
1279 Expression => New_Occurrence_Of (Obj_Id, Loc))));
1280 end Build_Default_Init_Cond_Call;
1282 ----------------------------------------------
1283 -- Build_Default_Init_Cond_Procedure_Bodies --
1284 ----------------------------------------------
1286 procedure Build_Default_Init_Cond_Procedure_Bodies (Priv_Decls : List_Id) is
1287 procedure Build_Default_Init_Cond_Procedure_Body (Typ : Entity_Id);
1288 -- If type Typ is subject to pragma Default_Initial_Condition, build the
1289 -- body of the procedure which verifies the assumption of the pragma at
1290 -- run time. The generated body is added after the type declaration.
1292 --------------------------------------------
1293 -- Build_Default_Init_Cond_Procedure_Body --
1294 --------------------------------------------
1296 procedure Build_Default_Init_Cond_Procedure_Body (Typ : Entity_Id) is
1297 Param_Id : Entity_Id;
1298 -- The entity of the sole formal parameter of the default initial
1299 -- condition procedure.
1301 procedure Replace_Type_Reference (N : Node_Id);
1302 -- Replace a single reference to type Typ with a reference to formal
1303 -- parameter Param_Id.
1305 ----------------------------
1306 -- Replace_Type_Reference --
1307 ----------------------------
1309 procedure Replace_Type_Reference (N : Node_Id) is
1311 Rewrite (N, New_Occurrence_Of (Param_Id, Sloc (N)));
1312 end Replace_Type_Reference;
1314 procedure Replace_Type_References is
1315 new Replace_Type_References_Generic (Replace_Type_Reference);
1319 Loc : constant Source_Ptr := Sloc (Typ);
1320 Prag : constant Node_Id :=
1321 Get_Pragma (Typ, Pragma_Default_Initial_Condition);
1322 Proc_Id : constant Entity_Id := Default_Init_Cond_Procedure (Typ);
1323 Spec_Decl : constant Node_Id := Unit_Declaration_Node (Proc_Id);
1324 Body_Decl : Node_Id;
1328 Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
1330 -- Start of processing for Build_Default_Init_Cond_Procedure_Body
1333 -- The procedure should be generated only for [sub]types subject to
1334 -- pragma Default_Initial_Condition. Types that inherit the pragma do
1335 -- not get this specialized procedure.
1337 pragma Assert (Has_Default_Init_Cond (Typ));
1338 pragma Assert (Present (Prag));
1339 pragma Assert (Present (Proc_Id));
1341 -- Nothing to do if the body was already built
1343 if Present (Corresponding_Body (Spec_Decl)) then
1347 -- The related type may be subject to pragma Ghost. Set the mode now
1348 -- to ensure that the analysis and expansion produce Ghost nodes.
1350 Set_Ghost_Mode_From_Entity (Typ);
1352 Param_Id := First_Formal (Proc_Id);
1354 -- The pragma has an argument. Note that the argument is analyzed
1355 -- after all references to the current instance of the type are
1358 if Present (Pragma_Argument_Associations (Prag)) then
1360 Get_Pragma_Arg (First (Pragma_Argument_Associations (Prag)));
1362 if Nkind (Expr) = N_Null then
1363 Stmt := Make_Null_Statement (Loc);
1365 -- Preserve the original argument of the pragma by replicating it.
1366 -- Replace all references to the current instance of the type with
1367 -- references to the formal parameter.
1370 Expr := New_Copy_Tree (Expr);
1371 Replace_Type_References (Expr, Typ);
1374 -- pragma Check (Default_Initial_Condition, <Expr>);
1378 Pragma_Identifier =>
1379 Make_Identifier (Loc, Name_Check),
1381 Pragma_Argument_Associations => New_List (
1382 Make_Pragma_Argument_Association (Loc,
1384 Make_Identifier (Loc,
1385 Chars => Name_Default_Initial_Condition)),
1386 Make_Pragma_Argument_Association (Loc,
1387 Expression => Expr)));
1390 -- Otherwise the pragma appears without an argument
1393 Stmt := Make_Null_Statement (Loc);
1397 -- procedure <Typ>Default_Init_Cond (I : <Typ>) is
1400 -- end <Typ>Default_Init_Cond;
1403 Make_Subprogram_Body (Loc,
1405 Copy_Separate_Tree (Specification (Spec_Decl)),
1406 Declarations => Empty_List,
1407 Handled_Statement_Sequence =>
1408 Make_Handled_Sequence_Of_Statements (Loc,
1409 Statements => New_List (Stmt)));
1411 -- Link the spec and body of the default initial condition procedure
1412 -- to prevent the generation of a duplicate body.
1414 Set_Corresponding_Body (Spec_Decl, Defining_Entity (Body_Decl));
1415 Set_Corresponding_Spec (Body_Decl, Proc_Id);
1417 Insert_After_And_Analyze (Declaration_Node (Typ), Body_Decl);
1418 Ghost_Mode := Save_Ghost_Mode;
1419 end Build_Default_Init_Cond_Procedure_Body;
1426 -- Start of processing for Build_Default_Init_Cond_Procedure_Bodies
1429 -- Inspect the private declarations looking for [sub]type declarations
1431 Decl := First (Priv_Decls);
1432 while Present (Decl) loop
1433 if Nkind_In (Decl, N_Full_Type_Declaration,
1434 N_Subtype_Declaration)
1436 Typ := Defining_Entity (Decl);
1438 -- Guard against partially decorate types due to previous errors
1440 if Is_Type (Typ) then
1442 -- If the type is subject to pragma Default_Initial_Condition,
1443 -- generate the body of the internal procedure which verifies
1444 -- the assertion of the pragma at run time.
1446 if Has_Default_Init_Cond (Typ) then
1447 Build_Default_Init_Cond_Procedure_Body (Typ);
1449 -- A derived type inherits the default initial condition
1450 -- procedure from its parent type.
1452 elsif Has_Inherited_Default_Init_Cond (Typ) then
1453 Inherit_Default_Init_Cond_Procedure (Typ);
1460 end Build_Default_Init_Cond_Procedure_Bodies;
1462 ---------------------------------------------------
1463 -- Build_Default_Init_Cond_Procedure_Declaration --
1464 ---------------------------------------------------
1466 procedure Build_Default_Init_Cond_Procedure_Declaration (Typ : Entity_Id) is
1467 Loc : constant Source_Ptr := Sloc (Typ);
1468 Prag : constant Node_Id :=
1469 Get_Pragma (Typ, Pragma_Default_Initial_Condition);
1471 Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
1473 Proc_Id : Entity_Id;
1476 -- The procedure should be generated only for types subject to pragma
1477 -- Default_Initial_Condition. Types that inherit the pragma do not get
1478 -- this specialized procedure.
1480 pragma Assert (Has_Default_Init_Cond (Typ));
1481 pragma Assert (Present (Prag));
1483 -- Nothing to do if default initial condition procedure already built
1485 if Present (Default_Init_Cond_Procedure (Typ)) then
1489 -- The related type may be subject to pragma Ghost. Set the mode now to
1490 -- ensure that the analysis and expansion produce Ghost nodes.
1492 Set_Ghost_Mode_From_Entity (Typ);
1495 Make_Defining_Identifier (Loc,
1496 Chars => New_External_Name (Chars (Typ), "Default_Init_Cond"));
1498 -- Associate default initial condition procedure with the private type
1500 Set_Ekind (Proc_Id, E_Procedure);
1501 Set_Is_Default_Init_Cond_Procedure (Proc_Id);
1502 Set_Default_Init_Cond_Procedure (Typ, Proc_Id);
1504 -- Mark the default initial condition procedure explicitly as Ghost
1505 -- because it does not come from source.
1507 if Ghost_Mode > None then
1508 Set_Is_Ghost_Entity (Proc_Id);
1512 -- procedure <Typ>Default_Init_Cond (Inn : <Typ>);
1514 Insert_After_And_Analyze (Prag,
1515 Make_Subprogram_Declaration (Loc,
1517 Make_Procedure_Specification (Loc,
1518 Defining_Unit_Name => Proc_Id,
1519 Parameter_Specifications => New_List (
1520 Make_Parameter_Specification (Loc,
1521 Defining_Identifier => Make_Temporary (Loc, 'I'),
1522 Parameter_Type => New_Occurrence_Of (Typ, Loc))))));
1524 Ghost_Mode := Save_Ghost_Mode;
1525 end Build_Default_Init_Cond_Procedure_Declaration;
1527 ---------------------------
1528 -- Build_Default_Subtype --
1529 ---------------------------
1531 function Build_Default_Subtype
1533 N : Node_Id) return Entity_Id
1535 Loc : constant Source_Ptr := Sloc (N);
1539 -- The base type that is to be constrained by the defaults
1542 if not Has_Discriminants (T) or else Is_Constrained (T) then
1546 Bas := Base_Type (T);
1548 -- If T is non-private but its base type is private, this is the
1549 -- completion of a subtype declaration whose parent type is private
1550 -- (see Complete_Private_Subtype in Sem_Ch3). The proper discriminants
1551 -- are to be found in the full view of the base. Check that the private
1552 -- status of T and its base differ.
1554 if Is_Private_Type (Bas)
1555 and then not Is_Private_Type (T)
1556 and then Present (Full_View (Bas))
1558 Bas := Full_View (Bas);
1561 Disc := First_Discriminant (T);
1563 if No (Discriminant_Default_Value (Disc)) then
1568 Act : constant Entity_Id := Make_Temporary (Loc, 'S');
1569 Constraints : constant List_Id := New_List;
1573 while Present (Disc) loop
1574 Append_To (Constraints,
1575 New_Copy_Tree (Discriminant_Default_Value (Disc)));
1576 Next_Discriminant (Disc);
1580 Make_Subtype_Declaration (Loc,
1581 Defining_Identifier => Act,
1582 Subtype_Indication =>
1583 Make_Subtype_Indication (Loc,
1584 Subtype_Mark => New_Occurrence_Of (Bas, Loc),
1586 Make_Index_Or_Discriminant_Constraint (Loc,
1587 Constraints => Constraints)));
1589 Insert_Action (N, Decl);
1591 -- If the context is a component declaration the subtype declaration
1592 -- will be analyzed when the enclosing type is frozen, otherwise do
1595 if Ekind (Current_Scope) /= E_Record_Type then
1601 end Build_Default_Subtype;
1603 --------------------------------------------
1604 -- Build_Discriminal_Subtype_Of_Component --
1605 --------------------------------------------
1607 function Build_Discriminal_Subtype_Of_Component
1608 (T : Entity_Id) return Node_Id
1610 Loc : constant Source_Ptr := Sloc (T);
1614 function Build_Discriminal_Array_Constraint return List_Id;
1615 -- If one or more of the bounds of the component depends on
1616 -- discriminants, build actual constraint using the discriminants
1619 function Build_Discriminal_Record_Constraint return List_Id;
1620 -- Similar to previous one, for discriminated components constrained by
1621 -- the discriminant of the enclosing object.
1623 ----------------------------------------
1624 -- Build_Discriminal_Array_Constraint --
1625 ----------------------------------------
1627 function Build_Discriminal_Array_Constraint return List_Id is
1628 Constraints : constant List_Id := New_List;
1636 Indx := First_Index (T);
1637 while Present (Indx) loop
1638 Old_Lo := Type_Low_Bound (Etype (Indx));
1639 Old_Hi := Type_High_Bound (Etype (Indx));
1641 if Denotes_Discriminant (Old_Lo) then
1642 Lo := New_Occurrence_Of (Discriminal (Entity (Old_Lo)), Loc);
1645 Lo := New_Copy_Tree (Old_Lo);
1648 if Denotes_Discriminant (Old_Hi) then
1649 Hi := New_Occurrence_Of (Discriminal (Entity (Old_Hi)), Loc);
1652 Hi := New_Copy_Tree (Old_Hi);
1655 Append (Make_Range (Loc, Lo, Hi), Constraints);
1660 end Build_Discriminal_Array_Constraint;
1662 -----------------------------------------
1663 -- Build_Discriminal_Record_Constraint --
1664 -----------------------------------------
1666 function Build_Discriminal_Record_Constraint return List_Id is
1667 Constraints : constant List_Id := New_List;
1672 D := First_Elmt (Discriminant_Constraint (T));
1673 while Present (D) loop
1674 if Denotes_Discriminant (Node (D)) then
1676 New_Occurrence_Of (Discriminal (Entity (Node (D))), Loc);
1678 D_Val := New_Copy_Tree (Node (D));
1681 Append (D_Val, Constraints);
1686 end Build_Discriminal_Record_Constraint;
1688 -- Start of processing for Build_Discriminal_Subtype_Of_Component
1691 if Ekind (T) = E_Array_Subtype then
1692 Id := First_Index (T);
1693 while Present (Id) loop
1694 if Denotes_Discriminant (Type_Low_Bound (Etype (Id)))
1696 Denotes_Discriminant (Type_High_Bound (Etype (Id)))
1698 return Build_Component_Subtype
1699 (Build_Discriminal_Array_Constraint, Loc, T);
1705 elsif Ekind (T) = E_Record_Subtype
1706 and then Has_Discriminants (T)
1707 and then not Has_Unknown_Discriminants (T)
1709 D := First_Elmt (Discriminant_Constraint (T));
1710 while Present (D) loop
1711 if Denotes_Discriminant (Node (D)) then
1712 return Build_Component_Subtype
1713 (Build_Discriminal_Record_Constraint, Loc, T);
1720 -- If none of the above, the actual and nominal subtypes are the same
1723 end Build_Discriminal_Subtype_Of_Component;
1725 ------------------------------
1726 -- Build_Elaboration_Entity --
1727 ------------------------------
1729 procedure Build_Elaboration_Entity (N : Node_Id; Spec_Id : Entity_Id) is
1730 Loc : constant Source_Ptr := Sloc (N);
1732 Elab_Ent : Entity_Id;
1734 procedure Set_Package_Name (Ent : Entity_Id);
1735 -- Given an entity, sets the fully qualified name of the entity in
1736 -- Name_Buffer, with components separated by double underscores. This
1737 -- is a recursive routine that climbs the scope chain to Standard.
1739 ----------------------
1740 -- Set_Package_Name --
1741 ----------------------
1743 procedure Set_Package_Name (Ent : Entity_Id) is
1745 if Scope (Ent) /= Standard_Standard then
1746 Set_Package_Name (Scope (Ent));
1749 Nam : constant String := Get_Name_String (Chars (Ent));
1751 Name_Buffer (Name_Len + 1) := '_';
1752 Name_Buffer (Name_Len + 2) := '_';
1753 Name_Buffer (Name_Len + 3 .. Name_Len + Nam'Length + 2) := Nam;
1754 Name_Len := Name_Len + Nam'Length + 2;
1758 Get_Name_String (Chars (Ent));
1760 end Set_Package_Name;
1762 -- Start of processing for Build_Elaboration_Entity
1765 -- Ignore call if already constructed
1767 if Present (Elaboration_Entity (Spec_Id)) then
1770 -- Ignore in ASIS mode, elaboration entity is not in source and plays
1771 -- no role in analysis.
1773 elsif ASIS_Mode then
1776 -- See if we need elaboration entity. We always need it for the dynamic
1777 -- elaboration model, since it is needed to properly generate the PE
1778 -- exception for access before elaboration.
1780 elsif Dynamic_Elaboration_Checks then
1783 -- For the static model, we don't need the elaboration counter if this
1784 -- unit is sure to have no elaboration code, since that means there
1785 -- is no elaboration unit to be called. Note that we can't just decide
1786 -- after the fact by looking to see whether there was elaboration code,
1787 -- because that's too late to make this decision.
1789 elsif Restriction_Active (No_Elaboration_Code) then
1792 -- Similarly, for the static model, we can skip the elaboration counter
1793 -- if we have the No_Multiple_Elaboration restriction, since for the
1794 -- static model, that's the only purpose of the counter (to avoid
1795 -- multiple elaboration).
1797 elsif Restriction_Active (No_Multiple_Elaboration) then
1801 -- Here we need the elaboration entity
1803 -- Construct name of elaboration entity as xxx_E, where xxx is the unit
1804 -- name with dots replaced by double underscore. We have to manually
1805 -- construct this name, since it will be elaborated in the outer scope,
1806 -- and thus will not have the unit name automatically prepended.
1808 Set_Package_Name (Spec_Id);
1809 Add_Str_To_Name_Buffer ("_E");
1811 -- Create elaboration counter
1813 Elab_Ent := Make_Defining_Identifier (Loc, Chars => Name_Find);
1814 Set_Elaboration_Entity (Spec_Id, Elab_Ent);
1817 Make_Object_Declaration (Loc,
1818 Defining_Identifier => Elab_Ent,
1819 Object_Definition =>
1820 New_Occurrence_Of (Standard_Short_Integer, Loc),
1821 Expression => Make_Integer_Literal (Loc, Uint_0));
1823 Push_Scope (Standard_Standard);
1824 Add_Global_Declaration (Decl);
1827 -- Reset True_Constant indication, since we will indeed assign a value
1828 -- to the variable in the binder main. We also kill the Current_Value
1829 -- and Last_Assignment fields for the same reason.
1831 Set_Is_True_Constant (Elab_Ent, False);
1832 Set_Current_Value (Elab_Ent, Empty);
1833 Set_Last_Assignment (Elab_Ent, Empty);
1835 -- We do not want any further qualification of the name (if we did not
1836 -- do this, we would pick up the name of the generic package in the case
1837 -- of a library level generic instantiation).
1839 Set_Has_Qualified_Name (Elab_Ent);
1840 Set_Has_Fully_Qualified_Name (Elab_Ent);
1841 end Build_Elaboration_Entity;
1843 --------------------------------
1844 -- Build_Explicit_Dereference --
1845 --------------------------------
1847 procedure Build_Explicit_Dereference
1851 Loc : constant Source_Ptr := Sloc (Expr);
1854 -- An entity of a type with a reference aspect is overloaded with
1855 -- both interpretations: with and without the dereference. Now that
1856 -- the dereference is made explicit, set the type of the node properly,
1857 -- to prevent anomalies in the backend. Same if the expression is an
1858 -- overloaded function call whose return type has a reference aspect.
1860 if Is_Entity_Name (Expr) then
1861 Set_Etype (Expr, Etype (Entity (Expr)));
1863 elsif Nkind (Expr) = N_Function_Call then
1864 Set_Etype (Expr, Etype (Name (Expr)));
1867 Set_Is_Overloaded (Expr, False);
1869 -- The expression will often be a generalized indexing that yields a
1870 -- container element that is then dereferenced, in which case the
1871 -- generalized indexing call is also non-overloaded.
1873 if Nkind (Expr) = N_Indexed_Component
1874 and then Present (Generalized_Indexing (Expr))
1876 Set_Is_Overloaded (Generalized_Indexing (Expr), False);
1880 Make_Explicit_Dereference (Loc,
1882 Make_Selected_Component (Loc,
1883 Prefix => Relocate_Node (Expr),
1884 Selector_Name => New_Occurrence_Of (Disc, Loc))));
1885 Set_Etype (Prefix (Expr), Etype (Disc));
1886 Set_Etype (Expr, Designated_Type (Etype (Disc)));
1887 end Build_Explicit_Dereference;
1889 -----------------------------------
1890 -- Cannot_Raise_Constraint_Error --
1891 -----------------------------------
1893 function Cannot_Raise_Constraint_Error (Expr : Node_Id) return Boolean is
1895 if Compile_Time_Known_Value (Expr) then
1898 elsif Do_Range_Check (Expr) then
1901 elsif Raises_Constraint_Error (Expr) then
1905 case Nkind (Expr) is
1906 when N_Identifier =>
1909 when N_Expanded_Name =>
1912 when N_Selected_Component =>
1913 return not Do_Discriminant_Check (Expr);
1915 when N_Attribute_Reference =>
1916 if Do_Overflow_Check (Expr) then
1919 elsif No (Expressions (Expr)) then
1927 N := First (Expressions (Expr));
1928 while Present (N) loop
1929 if Cannot_Raise_Constraint_Error (N) then
1940 when N_Type_Conversion =>
1941 if Do_Overflow_Check (Expr)
1942 or else Do_Length_Check (Expr)
1943 or else Do_Tag_Check (Expr)
1947 return Cannot_Raise_Constraint_Error (Expression (Expr));
1950 when N_Unchecked_Type_Conversion =>
1951 return Cannot_Raise_Constraint_Error (Expression (Expr));
1954 if Do_Overflow_Check (Expr) then
1957 return Cannot_Raise_Constraint_Error (Right_Opnd (Expr));
1964 if Do_Division_Check (Expr)
1966 Do_Overflow_Check (Expr)
1971 Cannot_Raise_Constraint_Error (Left_Opnd (Expr))
1973 Cannot_Raise_Constraint_Error (Right_Opnd (Expr));
1992 N_Op_Shift_Right_Arithmetic |
1996 if Do_Overflow_Check (Expr) then
2000 Cannot_Raise_Constraint_Error (Left_Opnd (Expr))
2002 Cannot_Raise_Constraint_Error (Right_Opnd (Expr));
2009 end Cannot_Raise_Constraint_Error;
2011 -----------------------------------------
2012 -- Check_Dynamically_Tagged_Expression --
2013 -----------------------------------------
2015 procedure Check_Dynamically_Tagged_Expression
2018 Related_Nod : Node_Id)
2021 pragma Assert (Is_Tagged_Type (Typ));
2023 -- In order to avoid spurious errors when analyzing the expanded code,
2024 -- this check is done only for nodes that come from source and for
2025 -- actuals of generic instantiations.
2027 if (Comes_From_Source (Related_Nod)
2028 or else In_Generic_Actual (Expr))
2029 and then (Is_Class_Wide_Type (Etype (Expr))
2030 or else Is_Dynamically_Tagged (Expr))
2031 and then Is_Tagged_Type (Typ)
2032 and then not Is_Class_Wide_Type (Typ)
2034 Error_Msg_N ("dynamically tagged expression not allowed!", Expr);
2036 end Check_Dynamically_Tagged_Expression;
2038 --------------------------
2039 -- Check_Fully_Declared --
2040 --------------------------
2042 procedure Check_Fully_Declared (T : Entity_Id; N : Node_Id) is
2044 if Ekind (T) = E_Incomplete_Type then
2046 -- Ada 2005 (AI-50217): If the type is available through a limited
2047 -- with_clause, verify that its full view has been analyzed.
2049 if From_Limited_With (T)
2050 and then Present (Non_Limited_View (T))
2051 and then Ekind (Non_Limited_View (T)) /= E_Incomplete_Type
2053 -- The non-limited view is fully declared
2059 ("premature usage of incomplete}", N, First_Subtype (T));
2062 -- Need comments for these tests ???
2064 elsif Has_Private_Component (T)
2065 and then not Is_Generic_Type (Root_Type (T))
2066 and then not In_Spec_Expression
2068 -- Special case: if T is the anonymous type created for a single
2069 -- task or protected object, use the name of the source object.
2071 if Is_Concurrent_Type (T)
2072 and then not Comes_From_Source (T)
2073 and then Nkind (N) = N_Object_Declaration
2076 ("type of& has incomplete component",
2077 N, Defining_Identifier (N));
2080 ("premature usage of incomplete}",
2081 N, First_Subtype (T));
2084 end Check_Fully_Declared;
2086 -------------------------------------
2087 -- Check_Function_Writable_Actuals --
2088 -------------------------------------
2090 procedure Check_Function_Writable_Actuals (N : Node_Id) is
2091 Writable_Actuals_List : Elist_Id := No_Elist;
2092 Identifiers_List : Elist_Id := No_Elist;
2093 Aggr_Error_Node : Node_Id := Empty;
2094 Error_Node : Node_Id := Empty;
2096 procedure Collect_Identifiers (N : Node_Id);
2097 -- In a single traversal of subtree N collect in Writable_Actuals_List
2098 -- all the actuals of functions with writable actuals, and in the list
2099 -- Identifiers_List collect all the identifiers that are not actuals of
2100 -- functions with writable actuals. If a writable actual is referenced
2101 -- twice as writable actual then Error_Node is set to reference its
2102 -- second occurrence, the error is reported, and the tree traversal
2105 function Get_Function_Id (Call : Node_Id) return Entity_Id;
2106 -- Return the entity associated with the function call
2108 procedure Preanalyze_Without_Errors (N : Node_Id);
2109 -- Preanalyze N without reporting errors. Very dubious, you can't just
2110 -- go analyzing things more than once???
2112 -------------------------
2113 -- Collect_Identifiers --
2114 -------------------------
2116 procedure Collect_Identifiers (N : Node_Id) is
2118 function Check_Node (N : Node_Id) return Traverse_Result;
2119 -- Process a single node during the tree traversal to collect the
2120 -- writable actuals of functions and all the identifiers which are
2121 -- not writable actuals of functions.
2123 function Contains (List : Elist_Id; N : Node_Id) return Boolean;
2124 -- Returns True if List has a node whose Entity is Entity (N)
2126 -------------------------
2127 -- Check_Function_Call --
2128 -------------------------
2130 function Check_Node (N : Node_Id) return Traverse_Result is
2131 Is_Writable_Actual : Boolean := False;
2135 if Nkind (N) = N_Identifier then
2137 -- No analysis possible if the entity is not decorated
2139 if No (Entity (N)) then
2142 -- Don't collect identifiers of packages, called functions, etc
2144 elsif Ekind_In (Entity (N), E_Package,
2151 -- For rewritten nodes, continue the traversal in the original
2152 -- subtree. Needed to handle aggregates in original expressions
2153 -- extracted from the tree by Remove_Side_Effects.
2155 elsif Is_Rewrite_Substitution (N) then
2156 Collect_Identifiers (Original_Node (N));
2159 -- For now we skip aggregate discriminants, since they require
2160 -- performing the analysis in two phases to identify conflicts:
2161 -- first one analyzing discriminants and second one analyzing
2162 -- the rest of components (since at run time, discriminants are
2163 -- evaluated prior to components): too much computation cost
2164 -- to identify a corner case???
2166 elsif Nkind (Parent (N)) = N_Component_Association
2167 and then Nkind_In (Parent (Parent (N)),
2169 N_Extension_Aggregate)
2172 Choice : constant Node_Id := First (Choices (Parent (N)));
2175 if Ekind (Entity (N)) = E_Discriminant then
2178 elsif Expression (Parent (N)) = N
2179 and then Nkind (Choice) = N_Identifier
2180 and then Ekind (Entity (Choice)) = E_Discriminant
2186 -- Analyze if N is a writable actual of a function
2188 elsif Nkind (Parent (N)) = N_Function_Call then
2190 Call : constant Node_Id := Parent (N);
2195 Id := Get_Function_Id (Call);
2197 -- In case of previous error, no check is possible
2203 if Ekind_In (Id, E_Function, E_Generic_Function)
2204 and then Has_Out_Or_In_Out_Parameter (Id)
2206 Formal := First_Formal (Id);
2207 Actual := First_Actual (Call);
2208 while Present (Actual) and then Present (Formal) loop
2210 if Ekind_In (Formal, E_Out_Parameter,
2213 Is_Writable_Actual := True;
2219 Next_Formal (Formal);
2220 Next_Actual (Actual);
2226 if Is_Writable_Actual then
2227 if Contains (Writable_Actuals_List, N) then
2229 -- Report the error on the second occurrence of the
2230 -- identifier. We cannot assume that N is the second
2231 -- occurrence, since Traverse_Func walks through Field2
2232 -- last (see comment in the body of Traverse_Func).
2238 Elmt := First_Elmt (Writable_Actuals_List);
2239 while Present (Elmt)
2240 and then Entity (Node (Elmt)) /= Entity (N)
2245 if Sloc (N) > Sloc (Node (Elmt)) then
2248 Error_Node := Node (Elmt);
2252 ("value may be affected by call to & "
2253 & "because order of evaluation is arbitrary",
2259 Append_New_Elmt (N, To => Writable_Actuals_List);
2262 if Identifiers_List = No_Elist then
2263 Identifiers_List := New_Elmt_List;
2266 Append_Unique_Elmt (N, Identifiers_List);
2279 N : Node_Id) return Boolean
2281 pragma Assert (Nkind (N) in N_Has_Entity);
2286 if List = No_Elist then
2290 Elmt := First_Elmt (List);
2291 while Present (Elmt) loop
2292 if Entity (Node (Elmt)) = Entity (N) then
2306 procedure Do_Traversal is new Traverse_Proc (Check_Node);
2307 -- The traversal procedure
2309 -- Start of processing for Collect_Identifiers
2312 if Present (Error_Node) then
2316 if Nkind (N) in N_Subexpr and then Is_OK_Static_Expression (N) then
2321 end Collect_Identifiers;
2323 ---------------------
2324 -- Get_Function_Id --
2325 ---------------------
2327 function Get_Function_Id (Call : Node_Id) return Entity_Id is
2328 Nam : constant Node_Id := Name (Call);
2332 if Nkind (Nam) = N_Explicit_Dereference then
2334 pragma Assert (Ekind (Id) = E_Subprogram_Type);
2336 elsif Nkind (Nam) = N_Selected_Component then
2337 Id := Entity (Selector_Name (Nam));
2339 elsif Nkind (Nam) = N_Indexed_Component then
2340 Id := Entity (Selector_Name (Prefix (Nam)));
2347 end Get_Function_Id;
2349 ---------------------------
2350 -- Preanalyze_Expression --
2351 ---------------------------
2353 procedure Preanalyze_Without_Errors (N : Node_Id) is
2354 Status : constant Boolean := Get_Ignore_Errors;
2356 Set_Ignore_Errors (True);
2358 Set_Ignore_Errors (Status);
2359 end Preanalyze_Without_Errors;
2361 -- Start of processing for Check_Function_Writable_Actuals
2364 -- The check only applies to Ada 2012 code on which Check_Actuals has
2365 -- been set, and only to constructs that have multiple constituents
2366 -- whose order of evaluation is not specified by the language.
2368 if Ada_Version < Ada_2012
2369 or else not Check_Actuals (N)
2370 or else (not (Nkind (N) in N_Op)
2371 and then not (Nkind (N) in N_Membership_Test)
2372 and then not Nkind_In (N, N_Range,
2374 N_Extension_Aggregate,
2375 N_Full_Type_Declaration,
2377 N_Procedure_Call_Statement,
2378 N_Entry_Call_Statement))
2379 or else (Nkind (N) = N_Full_Type_Declaration
2380 and then not Is_Record_Type (Defining_Identifier (N)))
2382 -- In addition, this check only applies to source code, not to code
2383 -- generated by constraint checks.
2385 or else not Comes_From_Source (N)
2390 -- If a construct C has two or more direct constituents that are names
2391 -- or expressions whose evaluation may occur in an arbitrary order, at
2392 -- least one of which contains a function call with an in out or out
2393 -- parameter, then the construct is legal only if: for each name N that
2394 -- is passed as a parameter of mode in out or out to some inner function
2395 -- call C2 (not including the construct C itself), there is no other
2396 -- name anywhere within a direct constituent of the construct C other
2397 -- than the one containing C2, that is known to refer to the same
2398 -- object (RM 6.4.1(6.17/3)).
2402 Collect_Identifiers (Low_Bound (N));
2403 Collect_Identifiers (High_Bound (N));
2405 when N_Op | N_Membership_Test =>
2410 Collect_Identifiers (Left_Opnd (N));
2412 if Present (Right_Opnd (N)) then
2413 Collect_Identifiers (Right_Opnd (N));
2416 if Nkind_In (N, N_In, N_Not_In)
2417 and then Present (Alternatives (N))
2419 Expr := First (Alternatives (N));
2420 while Present (Expr) loop
2421 Collect_Identifiers (Expr);
2428 when N_Full_Type_Declaration =>
2430 function Get_Record_Part (N : Node_Id) return Node_Id;
2431 -- Return the record part of this record type definition
2433 function Get_Record_Part (N : Node_Id) return Node_Id is
2434 Type_Def : constant Node_Id := Type_Definition (N);
2436 if Nkind (Type_Def) = N_Derived_Type_Definition then
2437 return Record_Extension_Part (Type_Def);
2441 end Get_Record_Part;
2444 Def_Id : Entity_Id := Defining_Identifier (N);
2445 Rec : Node_Id := Get_Record_Part (N);
2448 -- No need to perform any analysis if the record has no
2451 if No (Rec) or else No (Component_List (Rec)) then
2455 -- Collect the identifiers starting from the deepest
2456 -- derivation. Done to report the error in the deepest
2460 if Present (Component_List (Rec)) then
2461 Comp := First (Component_Items (Component_List (Rec)));
2462 while Present (Comp) loop
2463 if Nkind (Comp) = N_Component_Declaration
2464 and then Present (Expression (Comp))
2466 Collect_Identifiers (Expression (Comp));
2473 exit when No (Underlying_Type (Etype (Def_Id)))
2474 or else Base_Type (Underlying_Type (Etype (Def_Id)))
2477 Def_Id := Base_Type (Underlying_Type (Etype (Def_Id)));
2478 Rec := Get_Record_Part (Parent (Def_Id));
2482 when N_Subprogram_Call |
2483 N_Entry_Call_Statement =>
2485 Id : constant Entity_Id := Get_Function_Id (N);
2490 Formal := First_Formal (Id);
2491 Actual := First_Actual (N);
2492 while Present (Actual) and then Present (Formal) loop
2493 if Ekind_In (Formal, E_Out_Parameter,
2496 Collect_Identifiers (Actual);
2499 Next_Formal (Formal);
2500 Next_Actual (Actual);
2505 N_Extension_Aggregate =>
2509 Comp_Expr : Node_Id;
2512 -- Handle the N_Others_Choice of array aggregates with static
2513 -- bounds. There is no need to perform this analysis in
2514 -- aggregates without static bounds since we cannot evaluate
2515 -- if the N_Others_Choice covers several elements. There is
2516 -- no need to handle the N_Others choice of record aggregates
2517 -- since at this stage it has been already expanded by
2518 -- Resolve_Record_Aggregate.
2520 if Is_Array_Type (Etype (N))
2521 and then Nkind (N) = N_Aggregate
2522 and then Present (Aggregate_Bounds (N))
2523 and then Compile_Time_Known_Bounds (Etype (N))
2524 and then Expr_Value (High_Bound (Aggregate_Bounds (N)))
2526 Expr_Value (Low_Bound (Aggregate_Bounds (N)))
2529 Count_Components : Uint := Uint_0;
2530 Num_Components : Uint;
2531 Others_Assoc : Node_Id;
2532 Others_Choice : Node_Id := Empty;
2533 Others_Box_Present : Boolean := False;
2536 -- Count positional associations
2538 if Present (Expressions (N)) then
2539 Comp_Expr := First (Expressions (N));
2540 while Present (Comp_Expr) loop
2541 Count_Components := Count_Components + 1;
2546 -- Count the rest of elements and locate the N_Others
2549 Assoc := First (Component_Associations (N));
2550 while Present (Assoc) loop
2551 Choice := First (Choices (Assoc));
2552 while Present (Choice) loop
2553 if Nkind (Choice) = N_Others_Choice then
2554 Others_Assoc := Assoc;
2555 Others_Choice := Choice;
2556 Others_Box_Present := Box_Present (Assoc);
2558 -- Count several components
2560 elsif Nkind_In (Choice, N_Range,
2561 N_Subtype_Indication)
2562 or else (Is_Entity_Name (Choice)
2563 and then Is_Type (Entity (Choice)))
2568 Get_Index_Bounds (Choice, L, H);
2570 (Compile_Time_Known_Value (L)
2571 and then Compile_Time_Known_Value (H));
2574 + Expr_Value (H) - Expr_Value (L) + 1;
2577 -- Count single component. No other case available
2578 -- since we are handling an aggregate with static
2582 pragma Assert (Is_OK_Static_Expression (Choice)
2583 or else Nkind (Choice) = N_Identifier
2584 or else Nkind (Choice) = N_Integer_Literal);
2586 Count_Components := Count_Components + 1;
2596 Expr_Value (High_Bound (Aggregate_Bounds (N))) -
2597 Expr_Value (Low_Bound (Aggregate_Bounds (N))) + 1;
2599 pragma Assert (Count_Components <= Num_Components);
2601 -- Handle the N_Others choice if it covers several
2604 if Present (Others_Choice)
2605 and then (Num_Components - Count_Components) > 1
2607 if not Others_Box_Present then
2609 -- At this stage, if expansion is active, the
2610 -- expression of the others choice has not been
2611 -- analyzed. Hence we generate a duplicate and
2612 -- we analyze it silently to have available the
2613 -- minimum decoration required to collect the
2616 if not Expander_Active then
2617 Comp_Expr := Expression (Others_Assoc);
2620 New_Copy_Tree (Expression (Others_Assoc));
2621 Preanalyze_Without_Errors (Comp_Expr);
2624 Collect_Identifiers (Comp_Expr);
2626 if Writable_Actuals_List /= No_Elist then
2628 -- As suggested by Robert, at current stage we
2629 -- report occurrences of this case as warnings.
2632 ("writable function parameter may affect "
2633 & "value in other component because order "
2634 & "of evaluation is unspecified??",
2635 Node (First_Elmt (Writable_Actuals_List)));
2641 -- For an array aggregate, a discrete_choice_list that has
2642 -- a nonstatic range is considered as two or more separate
2643 -- occurrences of the expression (RM 6.4.1(20/3)).
2645 elsif Is_Array_Type (Etype (N))
2646 and then Nkind (N) = N_Aggregate
2647 and then Present (Aggregate_Bounds (N))
2648 and then not Compile_Time_Known_Bounds (Etype (N))
2650 -- Collect identifiers found in the dynamic bounds
2653 Count_Components : Natural := 0;
2654 Low, High : Node_Id;
2657 Assoc := First (Component_Associations (N));
2658 while Present (Assoc) loop
2659 Choice := First (Choices (Assoc));
2660 while Present (Choice) loop
2661 if Nkind_In (Choice, N_Range,
2662 N_Subtype_Indication)
2663 or else (Is_Entity_Name (Choice)
2664 and then Is_Type (Entity (Choice)))
2666 Get_Index_Bounds (Choice, Low, High);
2668 if not Compile_Time_Known_Value (Low) then
2669 Collect_Identifiers (Low);
2671 if No (Aggr_Error_Node) then
2672 Aggr_Error_Node := Low;
2676 if not Compile_Time_Known_Value (High) then
2677 Collect_Identifiers (High);
2679 if No (Aggr_Error_Node) then
2680 Aggr_Error_Node := High;
2684 -- The RM rule is violated if there is more than
2685 -- a single choice in a component association.
2688 Count_Components := Count_Components + 1;
2690 if No (Aggr_Error_Node)
2691 and then Count_Components > 1
2693 Aggr_Error_Node := Choice;
2696 if not Compile_Time_Known_Value (Choice) then
2697 Collect_Identifiers (Choice);
2709 -- Handle ancestor part of extension aggregates
2711 if Nkind (N) = N_Extension_Aggregate then
2712 Collect_Identifiers (Ancestor_Part (N));
2715 -- Handle positional associations
2717 if Present (Expressions (N)) then
2718 Comp_Expr := First (Expressions (N));
2719 while Present (Comp_Expr) loop
2720 if not Is_OK_Static_Expression (Comp_Expr) then
2721 Collect_Identifiers (Comp_Expr);
2728 -- Handle discrete associations
2730 if Present (Component_Associations (N)) then
2731 Assoc := First (Component_Associations (N));
2732 while Present (Assoc) loop
2734 if not Box_Present (Assoc) then
2735 Choice := First (Choices (Assoc));
2736 while Present (Choice) loop
2738 -- For now we skip discriminants since it requires
2739 -- performing the analysis in two phases: first one
2740 -- analyzing discriminants and second one analyzing
2741 -- the rest of components since discriminants are
2742 -- evaluated prior to components: too much extra
2743 -- work to detect a corner case???
2745 if Nkind (Choice) in N_Has_Entity
2746 and then Present (Entity (Choice))
2747 and then Ekind (Entity (Choice)) = E_Discriminant
2751 elsif Box_Present (Assoc) then
2755 if not Analyzed (Expression (Assoc)) then
2757 New_Copy_Tree (Expression (Assoc));
2758 Set_Parent (Comp_Expr, Parent (N));
2759 Preanalyze_Without_Errors (Comp_Expr);
2761 Comp_Expr := Expression (Assoc);
2764 Collect_Identifiers (Comp_Expr);
2780 -- No further action needed if we already reported an error
2782 if Present (Error_Node) then
2786 -- Check violation of RM 6.20/3 in aggregates
2788 if Present (Aggr_Error_Node)
2789 and then Writable_Actuals_List /= No_Elist
2792 ("value may be affected by call in other component because they "
2793 & "are evaluated in unspecified order",
2794 Node (First_Elmt (Writable_Actuals_List)));
2798 -- Check if some writable argument of a function is referenced
2800 if Writable_Actuals_List /= No_Elist
2801 and then Identifiers_List /= No_Elist
2808 Elmt_1 := First_Elmt (Writable_Actuals_List);
2809 while Present (Elmt_1) loop
2810 Elmt_2 := First_Elmt (Identifiers_List);
2811 while Present (Elmt_2) loop
2812 if Entity (Node (Elmt_1)) = Entity (Node (Elmt_2)) then
2813 case Nkind (Parent (Node (Elmt_2))) is
2815 N_Component_Association |
2816 N_Component_Declaration =>
2818 ("value may be affected by call in other "
2819 & "component because they are evaluated "
2820 & "in unspecified order",
2823 when N_In | N_Not_In =>
2825 ("value may be affected by call in other "
2826 & "alternative because they are evaluated "
2827 & "in unspecified order",
2832 ("value of actual may be affected by call in "
2833 & "other actual because they are evaluated "
2834 & "in unspecified order",
2846 end Check_Function_Writable_Actuals;
2848 --------------------------------
2849 -- Check_Implicit_Dereference --
2850 --------------------------------
2852 procedure Check_Implicit_Dereference (N : Node_Id; Typ : Entity_Id) is
2858 if Nkind (N) = N_Indexed_Component
2859 and then Present (Generalized_Indexing (N))
2861 Nam := Generalized_Indexing (N);
2866 if Ada_Version < Ada_2012
2867 or else not Has_Implicit_Dereference (Base_Type (Typ))
2871 elsif not Comes_From_Source (N)
2872 and then Nkind (N) /= N_Indexed_Component
2876 elsif Is_Entity_Name (Nam) and then Is_Type (Entity (Nam)) then
2880 Disc := First_Discriminant (Typ);
2881 while Present (Disc) loop
2882 if Has_Implicit_Dereference (Disc) then
2883 Desig := Designated_Type (Etype (Disc));
2884 Add_One_Interp (Nam, Disc, Desig);
2886 -- If the node is a generalized indexing, add interpretation
2887 -- to that node as well, for subsequent resolution.
2889 if Nkind (N) = N_Indexed_Component then
2890 Add_One_Interp (N, Disc, Desig);
2893 -- If the operation comes from a generic unit and the context
2894 -- is a selected component, the selector name may be global
2895 -- and set in the instance already. Remove the entity to
2896 -- force resolution of the selected component, and the
2897 -- generation of an explicit dereference if needed.
2900 and then Nkind (Parent (Nam)) = N_Selected_Component
2902 Set_Entity (Selector_Name (Parent (Nam)), Empty);
2908 Next_Discriminant (Disc);
2911 end Check_Implicit_Dereference;
2913 ----------------------------------
2914 -- Check_Internal_Protected_Use --
2915 ----------------------------------
2917 procedure Check_Internal_Protected_Use (N : Node_Id; Nam : Entity_Id) is
2923 while Present (S) loop
2924 if S = Standard_Standard then
2927 elsif Ekind (S) = E_Function
2928 and then Ekind (Scope (S)) = E_Protected_Type
2937 if Scope (Nam) = Prot and then Ekind (Nam) /= E_Function then
2939 -- An indirect function call (e.g. a callback within a protected
2940 -- function body) is not statically illegal. If the access type is
2941 -- anonymous and is the type of an access parameter, the scope of Nam
2942 -- will be the protected type, but it is not a protected operation.
2944 if Ekind (Nam) = E_Subprogram_Type
2946 Nkind (Associated_Node_For_Itype (Nam)) = N_Function_Specification
2950 elsif Nkind (N) = N_Subprogram_Renaming_Declaration then
2952 ("within protected function cannot use protected "
2953 & "procedure in renaming or as generic actual", N);
2955 elsif Nkind (N) = N_Attribute_Reference then
2957 ("within protected function cannot take access of "
2958 & " protected procedure", N);
2962 ("within protected function, protected object is constant", N);
2964 ("\cannot call operation that may modify it", N);
2967 end Check_Internal_Protected_Use;
2969 ---------------------------------------
2970 -- Check_Later_Vs_Basic_Declarations --
2971 ---------------------------------------
2973 procedure Check_Later_Vs_Basic_Declarations
2975 During_Parsing : Boolean)
2977 Body_Sloc : Source_Ptr;
2980 function Is_Later_Declarative_Item (Decl : Node_Id) return Boolean;
2981 -- Return whether Decl is considered as a declarative item.
2982 -- When During_Parsing is True, the semantics of Ada 83 is followed.
2983 -- When During_Parsing is False, the semantics of SPARK is followed.
2985 -------------------------------
2986 -- Is_Later_Declarative_Item --
2987 -------------------------------
2989 function Is_Later_Declarative_Item (Decl : Node_Id) return Boolean is
2991 if Nkind (Decl) in N_Later_Decl_Item then
2994 elsif Nkind (Decl) = N_Pragma then
2997 elsif During_Parsing then
3000 -- In SPARK, a package declaration is not considered as a later
3001 -- declarative item.
3003 elsif Nkind (Decl) = N_Package_Declaration then
3006 -- In SPARK, a renaming is considered as a later declarative item
3008 elsif Nkind (Decl) in N_Renaming_Declaration then
3014 end Is_Later_Declarative_Item;
3016 -- Start of Check_Later_Vs_Basic_Declarations
3019 Decl := First (Decls);
3021 -- Loop through sequence of basic declarative items
3023 Outer : while Present (Decl) loop
3024 if not Nkind_In (Decl, N_Subprogram_Body, N_Package_Body, N_Task_Body)
3025 and then Nkind (Decl) not in N_Body_Stub
3029 -- Once a body is encountered, we only allow later declarative
3030 -- items. The inner loop checks the rest of the list.
3033 Body_Sloc := Sloc (Decl);
3035 Inner : while Present (Decl) loop
3036 if not Is_Later_Declarative_Item (Decl) then
3037 if During_Parsing then
3038 if Ada_Version = Ada_83 then
3039 Error_Msg_Sloc := Body_Sloc;
3041 ("(Ada 83) decl cannot appear after body#", Decl);
3044 Error_Msg_Sloc := Body_Sloc;
3045 Check_SPARK_05_Restriction
3046 ("decl cannot appear after body#", Decl);
3054 end Check_Later_Vs_Basic_Declarations;
3056 ---------------------------
3057 -- Check_No_Hidden_State --
3058 ---------------------------
3060 procedure Check_No_Hidden_State (Id : Entity_Id) is
3061 function Has_Null_Abstract_State (Pkg : Entity_Id) return Boolean;
3062 -- Determine whether the entity of a package denoted by Pkg has a null
3065 -----------------------------
3066 -- Has_Null_Abstract_State --
3067 -----------------------------
3069 function Has_Null_Abstract_State (Pkg : Entity_Id) return Boolean is
3070 States : constant Elist_Id := Abstract_States (Pkg);
3073 -- Check first available state of related package. A null abstract
3074 -- state always appears as the sole element of the state list.
3078 and then Is_Null_State (Node (First_Elmt (States)));
3079 end Has_Null_Abstract_State;
3083 Context : Entity_Id := Empty;
3084 Not_Visible : Boolean := False;
3087 -- Start of processing for Check_No_Hidden_State
3090 pragma Assert (Ekind_In (Id, E_Abstract_State, E_Variable));
3092 -- Find the proper context where the object or state appears
3095 while Present (Scop) loop
3098 -- Keep track of the context's visibility
3100 Not_Visible := Not_Visible or else In_Private_Part (Context);
3102 -- Prevent the search from going too far
3104 if Context = Standard_Standard then
3107 -- Objects and states that appear immediately within a subprogram or
3108 -- inside a construct nested within a subprogram do not introduce a
3109 -- hidden state. They behave as local variable declarations.
3111 elsif Is_Subprogram (Context) then
3114 -- When examining a package body, use the entity of the spec as it
3115 -- carries the abstract state declarations.
3117 elsif Ekind (Context) = E_Package_Body then
3118 Context := Spec_Entity (Context);
3121 -- Stop the traversal when a package subject to a null abstract state
3124 if Ekind_In (Context, E_Generic_Package, E_Package)
3125 and then Has_Null_Abstract_State (Context)
3130 Scop := Scope (Scop);
3133 -- At this point we know that there is at least one package with a null
3134 -- abstract state in visibility. Emit an error message unconditionally
3135 -- if the entity being processed is a state because the placement of the
3136 -- related package is irrelevant. This is not the case for objects as
3137 -- the intermediate context matters.
3139 if Present (Context)
3140 and then (Ekind (Id) = E_Abstract_State or else Not_Visible)
3142 Error_Msg_N ("cannot introduce hidden state &", Id);
3143 Error_Msg_NE ("\package & has null abstract state", Id, Context);
3145 end Check_No_Hidden_State;
3147 ------------------------------------------
3148 -- Check_Potentially_Blocking_Operation --
3149 ------------------------------------------
3151 procedure Check_Potentially_Blocking_Operation (N : Node_Id) is
3155 -- N is one of the potentially blocking operations listed in 9.5.1(8).
3156 -- When pragma Detect_Blocking is active, the run time will raise
3157 -- Program_Error. Here we only issue a warning, since we generally
3158 -- support the use of potentially blocking operations in the absence
3161 -- Indirect blocking through a subprogram call cannot be diagnosed
3162 -- statically without interprocedural analysis, so we do not attempt
3165 S := Scope (Current_Scope);
3166 while Present (S) and then S /= Standard_Standard loop
3167 if Is_Protected_Type (S) then
3169 ("potentially blocking operation in protected operation??", N);
3175 end Check_Potentially_Blocking_Operation;
3177 ---------------------------------
3178 -- Check_Result_And_Post_State --
3179 ---------------------------------
3181 procedure Check_Result_And_Post_State (Subp_Id : Entity_Id) is
3182 procedure Check_Result_And_Post_State_In_Pragma
3184 Result_Seen : in out Boolean);
3185 -- Determine whether pragma Prag mentions attribute 'Result and whether
3186 -- the pragma contains an expression that evaluates differently in pre-
3187 -- and post-state. Prag is a [refined] postcondition or a contract-cases
3188 -- pragma. Result_Seen is set when the pragma mentions attribute 'Result
3190 function Has_In_Out_Parameter (Subp_Id : Entity_Id) return Boolean;
3191 -- Determine whether subprogram Subp_Id contains at least one IN OUT
3192 -- formal parameter.
3194 -------------------------------------------
3195 -- Check_Result_And_Post_State_In_Pragma --
3196 -------------------------------------------
3198 procedure Check_Result_And_Post_State_In_Pragma
3200 Result_Seen : in out Boolean)
3202 procedure Check_Expression (Expr : Node_Id);
3203 -- Perform the 'Result and post-state checks on a given expression
3205 function Is_Function_Result (N : Node_Id) return Traverse_Result;
3206 -- Attempt to find attribute 'Result in a subtree denoted by N
3208 function Is_Trivial_Boolean (N : Node_Id) return Boolean;
3209 -- Determine whether source node N denotes "True" or "False"
3211 function Mentions_Post_State (N : Node_Id) return Boolean;
3212 -- Determine whether a subtree denoted by N mentions any construct
3213 -- that denotes a post-state.
3215 procedure Check_Function_Result is
3216 new Traverse_Proc (Is_Function_Result);
3218 ----------------------
3219 -- Check_Expression --
3220 ----------------------
3222 procedure Check_Expression (Expr : Node_Id) is
3224 if not Is_Trivial_Boolean (Expr) then
3225 Check_Function_Result (Expr);
3227 if not Mentions_Post_State (Expr) then
3228 if Pragma_Name (Prag) = Name_Contract_Cases then
3230 ("contract case does not check the outcome of calling "
3231 & "&?T?", Expr, Subp_Id);
3233 elsif Pragma_Name (Prag) = Name_Refined_Post then
3235 ("refined postcondition does not check the outcome of "
3236 & "calling &?T?", Prag, Subp_Id);
3240 ("postcondition does not check the outcome of calling "
3241 & "&?T?", Prag, Subp_Id);
3245 end Check_Expression;
3247 ------------------------
3248 -- Is_Function_Result --
3249 ------------------------
3251 function Is_Function_Result (N : Node_Id) return Traverse_Result is
3253 if Is_Attribute_Result (N) then
3254 Result_Seen := True;
3257 -- Continue the traversal
3262 end Is_Function_Result;
3264 ------------------------
3265 -- Is_Trivial_Boolean --
3266 ------------------------
3268 function Is_Trivial_Boolean (N : Node_Id) return Boolean is
3271 Comes_From_Source (N)
3272 and then Is_Entity_Name (N)
3273 and then (Entity (N) = Standard_True
3275 Entity (N) = Standard_False);
3276 end Is_Trivial_Boolean;
3278 -------------------------
3279 -- Mentions_Post_State --
3280 -------------------------
3282 function Mentions_Post_State (N : Node_Id) return Boolean is
3283 Post_State_Seen : Boolean := False;
3285 function Is_Post_State (N : Node_Id) return Traverse_Result;
3286 -- Attempt to find a construct that denotes a post-state. If this
3287 -- is the case, set flag Post_State_Seen.
3293 function Is_Post_State (N : Node_Id) return Traverse_Result is
3297 if Nkind_In (N, N_Explicit_Dereference, N_Function_Call) then
3298 Post_State_Seen := True;
3301 elsif Nkind_In (N, N_Expanded_Name, N_Identifier) then
3304 -- The entity may be modifiable through an implicit
3308 or else Ekind (Ent) in Assignable_Kind
3309 or else (Is_Access_Type (Etype (Ent))
3310 and then Nkind (Parent (N)) =
3311 N_Selected_Component)
3313 Post_State_Seen := True;
3317 elsif Nkind (N) = N_Attribute_Reference then
3318 if Attribute_Name (N) = Name_Old then
3321 elsif Attribute_Name (N) = Name_Result then
3322 Post_State_Seen := True;
3330 procedure Find_Post_State is new Traverse_Proc (Is_Post_State);
3332 -- Start of processing for Mentions_Post_State
3335 Find_Post_State (N);
3337 return Post_State_Seen;
3338 end Mentions_Post_State;
3342 Expr : constant Node_Id :=
3344 (First (Pragma_Argument_Associations (Prag)));
3345 Nam : constant Name_Id := Pragma_Name (Prag);
3348 -- Start of processing for Check_Result_And_Post_State_In_Pragma
3351 -- Examine all consequences
3353 if Nam = Name_Contract_Cases then
3354 CCase := First (Component_Associations (Expr));
3355 while Present (CCase) loop
3356 Check_Expression (Expression (CCase));
3361 -- Examine the expression of a postcondition
3363 else pragma Assert (Nam_In (Nam, Name_Postcondition,
3364 Name_Refined_Post));
3365 Check_Expression (Expr);
3367 end Check_Result_And_Post_State_In_Pragma;
3369 --------------------------
3370 -- Has_In_Out_Parameter --
3371 --------------------------
3373 function Has_In_Out_Parameter (Subp_Id : Entity_Id) return Boolean is
3377 -- Traverse the formals looking for an IN OUT parameter
3379 Formal := First_Formal (Subp_Id);
3380 while Present (Formal) loop
3381 if Ekind (Formal) = E_In_Out_Parameter then
3385 Next_Formal (Formal);
3389 end Has_In_Out_Parameter;
3393 Items : constant Node_Id := Contract (Subp_Id);
3394 Subp_Decl : constant Node_Id := Unit_Declaration_Node (Subp_Id);
3395 Case_Prag : Node_Id := Empty;
3396 Post_Prag : Node_Id := Empty;
3398 Seen_In_Case : Boolean := False;
3399 Seen_In_Post : Boolean := False;
3400 Spec_Id : Entity_Id;
3402 -- Start of processing for Check_Result_And_Post_State
3405 -- The lack of attribute 'Result or a post-state is classified as a
3406 -- suspicious contract. Do not perform the check if the corresponding
3407 -- swich is not set.
3409 if not Warn_On_Suspicious_Contract then
3412 -- Nothing to do if there is no contract
3414 elsif No (Items) then
3418 -- Retrieve the entity of the subprogram spec (if any)
3420 if Nkind (Subp_Decl) = N_Subprogram_Body
3421 and then Present (Corresponding_Spec (Subp_Decl))
3423 Spec_Id := Corresponding_Spec (Subp_Decl);
3425 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
3426 and then Present (Corresponding_Spec_Of_Stub (Subp_Decl))
3428 Spec_Id := Corresponding_Spec_Of_Stub (Subp_Decl);
3434 -- Examine all postconditions for attribute 'Result and a post-state
3436 Prag := Pre_Post_Conditions (Items);
3437 while Present (Prag) loop
3438 if Nam_In (Pragma_Name (Prag), Name_Postcondition,
3440 and then not Error_Posted (Prag)
3443 Check_Result_And_Post_State_In_Pragma (Prag, Seen_In_Post);
3446 Prag := Next_Pragma (Prag);
3449 -- Examine the contract cases of the subprogram for attribute 'Result
3450 -- and a post-state.
3452 Prag := Contract_Test_Cases (Items);
3453 while Present (Prag) loop
3454 if Pragma_Name (Prag) = Name_Contract_Cases
3455 and then not Error_Posted (Prag)
3458 Check_Result_And_Post_State_In_Pragma (Prag, Seen_In_Case);
3461 Prag := Next_Pragma (Prag);
3464 -- Do not emit any errors if the subprogram is not a function
3466 if not Ekind_In (Spec_Id, E_Function, E_Generic_Function) then
3469 -- Regardless of whether the function has postconditions or contract
3470 -- cases, or whether they mention attribute 'Result, an IN OUT formal
3471 -- parameter is always treated as a result.
3473 elsif Has_In_Out_Parameter (Spec_Id) then
3476 -- The function has both a postcondition and contract cases and they do
3477 -- not mention attribute 'Result.
3479 elsif Present (Case_Prag)
3480 and then not Seen_In_Case
3481 and then Present (Post_Prag)
3482 and then not Seen_In_Post
3485 ("neither postcondition nor contract cases mention function "
3486 & "result?T?", Post_Prag);
3488 -- The function has contract cases only and they do not mention
3489 -- attribute 'Result.
3491 elsif Present (Case_Prag) and then not Seen_In_Case then
3492 Error_Msg_N ("contract cases do not mention result?T?", Case_Prag);
3494 -- The function has postconditions only and they do not mention
3495 -- attribute 'Result.
3497 elsif Present (Post_Prag) and then not Seen_In_Post then
3499 ("postcondition does not mention function result?T?", Post_Prag);
3501 end Check_Result_And_Post_State;
3503 ------------------------------
3504 -- Check_Unprotected_Access --
3505 ------------------------------
3507 procedure Check_Unprotected_Access
3511 Cont_Encl_Typ : Entity_Id;
3512 Pref_Encl_Typ : Entity_Id;
3514 function Enclosing_Protected_Type (Obj : Node_Id) return Entity_Id;
3515 -- Check whether Obj is a private component of a protected object.
3516 -- Return the protected type where the component resides, Empty
3519 function Is_Public_Operation return Boolean;
3520 -- Verify that the enclosing operation is callable from outside the
3521 -- protected object, to minimize false positives.
3523 ------------------------------
3524 -- Enclosing_Protected_Type --
3525 ------------------------------
3527 function Enclosing_Protected_Type (Obj : Node_Id) return Entity_Id is
3529 if Is_Entity_Name (Obj) then
3531 Ent : Entity_Id := Entity (Obj);
3534 -- The object can be a renaming of a private component, use
3535 -- the original record component.
3537 if Is_Prival (Ent) then
3538 Ent := Prival_Link (Ent);
3541 if Is_Protected_Type (Scope (Ent)) then
3547 -- For indexed and selected components, recursively check the prefix
3549 if Nkind_In (Obj, N_Indexed_Component, N_Selected_Component) then
3550 return Enclosing_Protected_Type (Prefix (Obj));
3552 -- The object does not denote a protected component
3557 end Enclosing_Protected_Type;
3559 -------------------------
3560 -- Is_Public_Operation --
3561 -------------------------
3563 function Is_Public_Operation return Boolean is
3569 while Present (S) and then S /= Pref_Encl_Typ loop
3570 if Scope (S) = Pref_Encl_Typ then
3571 E := First_Entity (Pref_Encl_Typ);
3573 and then E /= First_Private_Entity (Pref_Encl_Typ)
3587 end Is_Public_Operation;
3589 -- Start of processing for Check_Unprotected_Access
3592 if Nkind (Expr) = N_Attribute_Reference
3593 and then Attribute_Name (Expr) = Name_Unchecked_Access
3595 Cont_Encl_Typ := Enclosing_Protected_Type (Context);
3596 Pref_Encl_Typ := Enclosing_Protected_Type (Prefix (Expr));
3598 -- Check whether we are trying to export a protected component to a
3599 -- context with an equal or lower access level.
3601 if Present (Pref_Encl_Typ)
3602 and then No (Cont_Encl_Typ)
3603 and then Is_Public_Operation
3604 and then Scope_Depth (Pref_Encl_Typ) >=
3605 Object_Access_Level (Context)
3608 ("??possible unprotected access to protected data", Expr);
3611 end Check_Unprotected_Access;
3613 ------------------------
3614 -- Collect_Interfaces --
3615 ------------------------
3617 procedure Collect_Interfaces
3619 Ifaces_List : out Elist_Id;
3620 Exclude_Parents : Boolean := False;
3621 Use_Full_View : Boolean := True)
3623 procedure Collect (Typ : Entity_Id);
3624 -- Subsidiary subprogram used to traverse the whole list
3625 -- of directly and indirectly implemented interfaces
3631 procedure Collect (Typ : Entity_Id) is
3632 Ancestor : Entity_Id;
3640 -- Handle private types and subtypes
3643 and then Is_Private_Type (Typ)
3644 and then Present (Full_View (Typ))
3646 Full_T := Full_View (Typ);
3648 if Ekind (Full_T) = E_Record_Subtype then
3649 Full_T := Full_View (Etype (Typ));
3653 -- Include the ancestor if we are generating the whole list of
3654 -- abstract interfaces.
3656 if Etype (Full_T) /= Typ
3658 -- Protect the frontend against wrong sources. For example:
3661 -- type A is tagged null record;
3662 -- type B is new A with private;
3663 -- type C is new A with private;
3665 -- type B is new C with null record;
3666 -- type C is new B with null record;
3669 and then Etype (Full_T) /= T
3671 Ancestor := Etype (Full_T);
3674 if Is_Interface (Ancestor) and then not Exclude_Parents then
3675 Append_Unique_Elmt (Ancestor, Ifaces_List);
3679 -- Traverse the graph of ancestor interfaces
3681 if Is_Non_Empty_List (Abstract_Interface_List (Full_T)) then
3682 Id := First (Abstract_Interface_List (Full_T));
3683 while Present (Id) loop
3684 Iface := Etype (Id);
3686 -- Protect against wrong uses. For example:
3687 -- type I is interface;
3688 -- type O is tagged null record;
3689 -- type Wrong is new I and O with null record; -- ERROR
3691 if Is_Interface (Iface) then
3693 and then Etype (T) /= T
3694 and then Interface_Present_In_Ancestor (Etype (T), Iface)
3699 Append_Unique_Elmt (Iface, Ifaces_List);
3708 -- Start of processing for Collect_Interfaces
3711 pragma Assert (Is_Tagged_Type (T) or else Is_Concurrent_Type (T));
3712 Ifaces_List := New_Elmt_List;
3714 end Collect_Interfaces;
3716 ----------------------------------
3717 -- Collect_Interface_Components --
3718 ----------------------------------
3720 procedure Collect_Interface_Components
3721 (Tagged_Type : Entity_Id;
3722 Components_List : out Elist_Id)
3724 procedure Collect (Typ : Entity_Id);
3725 -- Subsidiary subprogram used to climb to the parents
3731 procedure Collect (Typ : Entity_Id) is
3732 Tag_Comp : Entity_Id;
3733 Parent_Typ : Entity_Id;
3736 -- Handle private types
3738 if Present (Full_View (Etype (Typ))) then
3739 Parent_Typ := Full_View (Etype (Typ));
3741 Parent_Typ := Etype (Typ);
3744 if Parent_Typ /= Typ
3746 -- Protect the frontend against wrong sources. For example:
3749 -- type A is tagged null record;
3750 -- type B is new A with private;
3751 -- type C is new A with private;
3753 -- type B is new C with null record;
3754 -- type C is new B with null record;
3757 and then Parent_Typ /= Tagged_Type
3759 Collect (Parent_Typ);
3762 -- Collect the components containing tags of secondary dispatch
3765 Tag_Comp := Next_Tag_Component (First_Tag_Component (Typ));
3766 while Present (Tag_Comp) loop
3767 pragma Assert (Present (Related_Type (Tag_Comp)));
3768 Append_Elmt (Tag_Comp, Components_List);
3770 Tag_Comp := Next_Tag_Component (Tag_Comp);
3774 -- Start of processing for Collect_Interface_Components
3777 pragma Assert (Ekind (Tagged_Type) = E_Record_Type
3778 and then Is_Tagged_Type (Tagged_Type));
3780 Components_List := New_Elmt_List;
3781 Collect (Tagged_Type);
3782 end Collect_Interface_Components;
3784 -----------------------------
3785 -- Collect_Interfaces_Info --
3786 -----------------------------
3788 procedure Collect_Interfaces_Info
3790 Ifaces_List : out Elist_Id;
3791 Components_List : out Elist_Id;
3792 Tags_List : out Elist_Id)
3794 Comps_List : Elist_Id;
3795 Comp_Elmt : Elmt_Id;
3796 Comp_Iface : Entity_Id;
3797 Iface_Elmt : Elmt_Id;
3800 function Search_Tag (Iface : Entity_Id) return Entity_Id;
3801 -- Search for the secondary tag associated with the interface type
3802 -- Iface that is implemented by T.
3808 function Search_Tag (Iface : Entity_Id) return Entity_Id is
3811 if not Is_CPP_Class (T) then
3812 ADT := Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (T))));
3814 ADT := Next_Elmt (First_Elmt (Access_Disp_Table (T)));
3818 and then Is_Tag (Node (ADT))
3819 and then Related_Type (Node (ADT)) /= Iface
3821 -- Skip secondary dispatch table referencing thunks to user
3822 -- defined primitives covered by this interface.
3824 pragma Assert (Has_Suffix (Node (ADT), 'P'));
3827 -- Skip secondary dispatch tables of Ada types
3829 if not Is_CPP_Class (T) then
3831 -- Skip secondary dispatch table referencing thunks to
3832 -- predefined primitives.
3834 pragma Assert (Has_Suffix (Node (ADT), 'Y'));
3837 -- Skip secondary dispatch table referencing user-defined
3838 -- primitives covered by this interface.
3840 pragma Assert (Has_Suffix (Node (ADT), 'D'));
3843 -- Skip secondary dispatch table referencing predefined
3846 pragma Assert (Has_Suffix (Node (ADT), 'Z'));
3851 pragma Assert (Is_Tag (Node (ADT)));
3855 -- Start of processing for Collect_Interfaces_Info
3858 Collect_Interfaces (T, Ifaces_List);
3859 Collect_Interface_Components (T, Comps_List);
3861 -- Search for the record component and tag associated with each
3862 -- interface type of T.
3864 Components_List := New_Elmt_List;
3865 Tags_List := New_Elmt_List;
3867 Iface_Elmt := First_Elmt (Ifaces_List);
3868 while Present (Iface_Elmt) loop
3869 Iface := Node (Iface_Elmt);
3871 -- Associate the primary tag component and the primary dispatch table
3872 -- with all the interfaces that are parents of T
3874 if Is_Ancestor (Iface, T, Use_Full_View => True) then
3875 Append_Elmt (First_Tag_Component (T), Components_List);
3876 Append_Elmt (Node (First_Elmt (Access_Disp_Table (T))), Tags_List);
3878 -- Otherwise search for the tag component and secondary dispatch
3882 Comp_Elmt := First_Elmt (Comps_List);
3883 while Present (Comp_Elmt) loop
3884 Comp_Iface := Related_Type (Node (Comp_Elmt));
3886 if Comp_Iface = Iface
3887 or else Is_Ancestor (Iface, Comp_Iface, Use_Full_View => True)
3889 Append_Elmt (Node (Comp_Elmt), Components_List);
3890 Append_Elmt (Search_Tag (Comp_Iface), Tags_List);
3894 Next_Elmt (Comp_Elmt);
3896 pragma Assert (Present (Comp_Elmt));
3899 Next_Elmt (Iface_Elmt);
3901 end Collect_Interfaces_Info;
3903 ---------------------
3904 -- Collect_Parents --
3905 ---------------------
3907 procedure Collect_Parents
3909 List : out Elist_Id;
3910 Use_Full_View : Boolean := True)
3912 Current_Typ : Entity_Id := T;
3913 Parent_Typ : Entity_Id;
3916 List := New_Elmt_List;
3918 -- No action if the if the type has no parents
3920 if T = Etype (T) then
3925 Parent_Typ := Etype (Current_Typ);
3927 if Is_Private_Type (Parent_Typ)
3928 and then Present (Full_View (Parent_Typ))
3929 and then Use_Full_View
3931 Parent_Typ := Full_View (Base_Type (Parent_Typ));
3934 Append_Elmt (Parent_Typ, List);
3936 exit when Parent_Typ = Current_Typ;
3937 Current_Typ := Parent_Typ;
3939 end Collect_Parents;
3941 ----------------------------------
3942 -- Collect_Primitive_Operations --
3943 ----------------------------------
3945 function Collect_Primitive_Operations (T : Entity_Id) return Elist_Id is
3946 B_Type : constant Entity_Id := Base_Type (T);
3947 B_Decl : constant Node_Id := Original_Node (Parent (B_Type));
3948 B_Scope : Entity_Id := Scope (B_Type);
3952 Is_Type_In_Pkg : Boolean;
3953 Formal_Derived : Boolean := False;
3956 function Match (E : Entity_Id) return Boolean;
3957 -- True if E's base type is B_Type, or E is of an anonymous access type
3958 -- and the base type of its designated type is B_Type.
3964 function Match (E : Entity_Id) return Boolean is
3965 Etyp : Entity_Id := Etype (E);
3968 if Ekind (Etyp) = E_Anonymous_Access_Type then
3969 Etyp := Designated_Type (Etyp);
3972 -- In Ada 2012 a primitive operation may have a formal of an
3973 -- incomplete view of the parent type.
3975 return Base_Type (Etyp) = B_Type
3977 (Ada_Version >= Ada_2012
3978 and then Ekind (Etyp) = E_Incomplete_Type
3979 and then Full_View (Etyp) = B_Type);
3982 -- Start of processing for Collect_Primitive_Operations
3985 -- For tagged types, the primitive operations are collected as they
3986 -- are declared, and held in an explicit list which is simply returned.
3988 if Is_Tagged_Type (B_Type) then
3989 return Primitive_Operations (B_Type);
3991 -- An untagged generic type that is a derived type inherits the
3992 -- primitive operations of its parent type. Other formal types only
3993 -- have predefined operators, which are not explicitly represented.
3995 elsif Is_Generic_Type (B_Type) then
3996 if Nkind (B_Decl) = N_Formal_Type_Declaration
3997 and then Nkind (Formal_Type_Definition (B_Decl)) =
3998 N_Formal_Derived_Type_Definition
4000 Formal_Derived := True;
4002 return New_Elmt_List;
4006 Op_List := New_Elmt_List;
4008 if B_Scope = Standard_Standard then
4009 if B_Type = Standard_String then
4010 Append_Elmt (Standard_Op_Concat, Op_List);
4012 elsif B_Type = Standard_Wide_String then
4013 Append_Elmt (Standard_Op_Concatw, Op_List);
4019 -- Locate the primitive subprograms of the type
4022 -- The primitive operations appear after the base type, except
4023 -- if the derivation happens within the private part of B_Scope
4024 -- and the type is a private type, in which case both the type
4025 -- and some primitive operations may appear before the base
4026 -- type, and the list of candidates starts after the type.
4028 if In_Open_Scopes (B_Scope)
4029 and then Scope (T) = B_Scope
4030 and then In_Private_Part (B_Scope)
4032 Id := Next_Entity (T);
4034 -- In Ada 2012, If the type has an incomplete partial view, there
4035 -- may be primitive operations declared before the full view, so
4036 -- we need to start scanning from the incomplete view, which is
4037 -- earlier on the entity chain.
4039 elsif Nkind (Parent (B_Type)) = N_Full_Type_Declaration
4040 and then Present (Incomplete_View (Parent (B_Type)))
4042 Id := Defining_Entity (Incomplete_View (Parent (B_Type)));
4045 Id := Next_Entity (B_Type);
4048 -- Set flag if this is a type in a package spec
4051 Is_Package_Or_Generic_Package (B_Scope)
4053 Nkind (Parent (Declaration_Node (First_Subtype (T)))) /=
4056 while Present (Id) loop
4058 -- Test whether the result type or any of the parameter types of
4059 -- each subprogram following the type match that type when the
4060 -- type is declared in a package spec, is a derived type, or the
4061 -- subprogram is marked as primitive. (The Is_Primitive test is
4062 -- needed to find primitives of nonderived types in declarative
4063 -- parts that happen to override the predefined "=" operator.)
4065 -- Note that generic formal subprograms are not considered to be
4066 -- primitive operations and thus are never inherited.
4068 if Is_Overloadable (Id)
4069 and then (Is_Type_In_Pkg
4070 or else Is_Derived_Type (B_Type)
4071 or else Is_Primitive (Id))
4072 and then Nkind (Parent (Parent (Id)))
4073 not in N_Formal_Subprogram_Declaration
4081 Formal := First_Formal (Id);
4082 while Present (Formal) loop
4083 if Match (Formal) then
4088 Next_Formal (Formal);
4092 -- For a formal derived type, the only primitives are the ones
4093 -- inherited from the parent type. Operations appearing in the
4094 -- package declaration are not primitive for it.
4097 and then (not Formal_Derived or else Present (Alias (Id)))
4099 -- In the special case of an equality operator aliased to
4100 -- an overriding dispatching equality belonging to the same
4101 -- type, we don't include it in the list of primitives.
4102 -- This avoids inheriting multiple equality operators when
4103 -- deriving from untagged private types whose full type is
4104 -- tagged, which can otherwise cause ambiguities. Note that
4105 -- this should only happen for this kind of untagged parent
4106 -- type, since normally dispatching operations are inherited
4107 -- using the type's Primitive_Operations list.
4109 if Chars (Id) = Name_Op_Eq
4110 and then Is_Dispatching_Operation (Id)
4111 and then Present (Alias (Id))
4112 and then Present (Overridden_Operation (Alias (Id)))
4113 and then Base_Type (Etype (First_Entity (Id))) =
4114 Base_Type (Etype (First_Entity (Alias (Id))))
4118 -- Include the subprogram in the list of primitives
4121 Append_Elmt (Id, Op_List);
4128 -- For a type declared in System, some of its operations may
4129 -- appear in the target-specific extension to System.
4132 and then B_Scope = RTU_Entity (System)
4133 and then Present_System_Aux
4135 B_Scope := System_Aux_Id;
4136 Id := First_Entity (System_Aux_Id);
4142 end Collect_Primitive_Operations;
4144 -----------------------------------
4145 -- Compile_Time_Constraint_Error --
4146 -----------------------------------
4148 function Compile_Time_Constraint_Error
4151 Ent : Entity_Id := Empty;
4152 Loc : Source_Ptr := No_Location;
4153 Warn : Boolean := False) return Node_Id
4155 Msgc : String (1 .. Msg'Length + 3);
4156 -- Copy of message, with room for possible ?? or << and ! at end
4162 -- Start of processing for Compile_Time_Constraint_Error
4165 -- If this is a warning, convert it into an error if we are in code
4166 -- subject to SPARK_Mode being set ON.
4168 Error_Msg_Warn := SPARK_Mode /= On;
4170 -- A static constraint error in an instance body is not a fatal error.
4171 -- we choose to inhibit the message altogether, because there is no
4172 -- obvious node (for now) on which to post it. On the other hand the
4173 -- offending node must be replaced with a constraint_error in any case.
4175 -- No messages are generated if we already posted an error on this node
4177 if not Error_Posted (N) then
4178 if Loc /= No_Location then
4184 -- Copy message to Msgc, converting any ? in the message into
4185 -- < instead, so that we have an error in GNATprove mode.
4189 for J in 1 .. Msgl loop
4190 if Msg (J) = '?' and then (J = 1 or else Msg (J) /= ''') then
4193 Msgc (J) := Msg (J);
4197 -- Message is a warning, even in Ada 95 case
4199 if Msg (Msg'Last) = '?' or else Msg (Msg'Last) = '<' then
4202 -- In Ada 83, all messages are warnings. In the private part and
4203 -- the body of an instance, constraint_checks are only warnings.
4204 -- We also make this a warning if the Warn parameter is set.
4207 or else (Ada_Version = Ada_83 and then Comes_From_Source (N))
4215 elsif In_Instance_Not_Visible then
4222 -- Otherwise we have a real error message (Ada 95 static case)
4223 -- and we make this an unconditional message. Note that in the
4224 -- warning case we do not make the message unconditional, it seems
4225 -- quite reasonable to delete messages like this (about exceptions
4226 -- that will be raised) in dead code.
4234 -- One more test, skip the warning if the related expression is
4235 -- statically unevaluated, since we don't want to warn about what
4236 -- will happen when something is evaluated if it never will be
4239 if not Is_Statically_Unevaluated (N) then
4240 Error_Msg_Warn := SPARK_Mode /= On;
4242 if Present (Ent) then
4243 Error_Msg_NEL (Msgc (1 .. Msgl), N, Ent, Eloc);
4245 Error_Msg_NEL (Msgc (1 .. Msgl), N, Etype (N), Eloc);
4250 -- Check whether the context is an Init_Proc
4252 if Inside_Init_Proc then
4254 Conc_Typ : constant Entity_Id :=
4255 Corresponding_Concurrent_Type
4256 (Entity (Parameter_Type (First
4257 (Parameter_Specifications
4258 (Parent (Current_Scope))))));
4261 -- Don't complain if the corresponding concurrent type
4262 -- doesn't come from source (i.e. a single task/protected
4265 if Present (Conc_Typ)
4266 and then not Comes_From_Source (Conc_Typ)
4269 ("\& [<<", N, Standard_Constraint_Error, Eloc);
4272 if GNATprove_Mode then
4274 ("\& would have been raised for objects of this "
4275 & "type", N, Standard_Constraint_Error, Eloc);
4278 ("\& will be raised for objects of this type??",
4279 N, Standard_Constraint_Error, Eloc);
4285 Error_Msg_NEL ("\& [<<", N, Standard_Constraint_Error, Eloc);
4289 Error_Msg ("\static expression fails Constraint_Check", Eloc);
4290 Set_Error_Posted (N);
4296 end Compile_Time_Constraint_Error;
4298 -----------------------
4299 -- Conditional_Delay --
4300 -----------------------
4302 procedure Conditional_Delay (New_Ent, Old_Ent : Entity_Id) is
4304 if Has_Delayed_Freeze (Old_Ent) and then not Is_Frozen (Old_Ent) then
4305 Set_Has_Delayed_Freeze (New_Ent);
4307 end Conditional_Delay;
4309 ----------------------------
4310 -- Contains_Refined_State --
4311 ----------------------------
4313 function Contains_Refined_State (Prag : Node_Id) return Boolean is
4314 function Has_State_In_Dependency (List : Node_Id) return Boolean;
4315 -- Determine whether a dependency list mentions a state with a visible
4318 function Has_State_In_Global (List : Node_Id) return Boolean;
4319 -- Determine whether a global list mentions a state with a visible
4322 function Is_Refined_State (Item : Node_Id) return Boolean;
4323 -- Determine whether Item is a reference to an abstract state with a
4324 -- visible refinement.
4326 -----------------------------
4327 -- Has_State_In_Dependency --
4328 -----------------------------
4330 function Has_State_In_Dependency (List : Node_Id) return Boolean is
4335 -- A null dependency list does not mention any states
4337 if Nkind (List) = N_Null then
4340 -- Dependency clauses appear as component associations of an
4343 elsif Nkind (List) = N_Aggregate
4344 and then Present (Component_Associations (List))
4346 Clause := First (Component_Associations (List));
4347 while Present (Clause) loop
4349 -- Inspect the outputs of a dependency clause
4351 Output := First (Choices (Clause));
4352 while Present (Output) loop
4353 if Is_Refined_State (Output) then
4360 -- Inspect the outputs of a dependency clause
4362 if Is_Refined_State (Expression (Clause)) then
4369 -- If we get here, then none of the dependency clauses mention a
4370 -- state with visible refinement.
4374 -- An illegal pragma managed to sneak in
4377 raise Program_Error;
4379 end Has_State_In_Dependency;
4381 -------------------------
4382 -- Has_State_In_Global --
4383 -------------------------
4385 function Has_State_In_Global (List : Node_Id) return Boolean is
4389 -- A null global list does not mention any states
4391 if Nkind (List) = N_Null then
4394 -- Simple global list or moded global list declaration
4396 elsif Nkind (List) = N_Aggregate then
4398 -- The declaration of a simple global list appear as a collection
4401 if Present (Expressions (List)) then
4402 Item := First (Expressions (List));
4403 while Present (Item) loop
4404 if Is_Refined_State (Item) then
4411 -- The declaration of a moded global list appears as a collection
4412 -- of component associations where individual choices denote
4416 Item := First (Component_Associations (List));
4417 while Present (Item) loop
4418 if Has_State_In_Global (Expression (Item)) then
4426 -- If we get here, then the simple/moded global list did not
4427 -- mention any states with a visible refinement.
4431 -- Single global item declaration
4433 elsif Is_Entity_Name (List) then
4434 return Is_Refined_State (List);
4436 -- An illegal pragma managed to sneak in
4439 raise Program_Error;
4441 end Has_State_In_Global;
4443 ----------------------
4444 -- Is_Refined_State --
4445 ----------------------
4447 function Is_Refined_State (Item : Node_Id) return Boolean is
4449 Item_Id : Entity_Id;
4452 if Nkind (Item) = N_Null then
4455 -- States cannot be subject to attribute 'Result. This case arises
4456 -- in dependency relations.
4458 elsif Nkind (Item) = N_Attribute_Reference
4459 and then Attribute_Name (Item) = Name_Result
4463 -- Multiple items appear as an aggregate. This case arises in
4464 -- dependency relations.
4466 elsif Nkind (Item) = N_Aggregate
4467 and then Present (Expressions (Item))
4469 Elmt := First (Expressions (Item));
4470 while Present (Elmt) loop
4471 if Is_Refined_State (Elmt) then
4478 -- If we get here, then none of the inputs or outputs reference a
4479 -- state with visible refinement.
4486 Item_Id := Entity_Of (Item);
4490 and then Ekind (Item_Id) = E_Abstract_State
4491 and then Has_Visible_Refinement (Item_Id);
4493 end Is_Refined_State;
4497 Arg : constant Node_Id :=
4498 Get_Pragma_Arg (First (Pragma_Argument_Associations (Prag)));
4499 Nam : constant Name_Id := Pragma_Name (Prag);
4501 -- Start of processing for Contains_Refined_State
4504 if Nam = Name_Depends then
4505 return Has_State_In_Dependency (Arg);
4507 else pragma Assert (Nam = Name_Global);
4508 return Has_State_In_Global (Arg);
4510 end Contains_Refined_State;
4512 -------------------------
4513 -- Copy_Component_List --
4514 -------------------------
4516 function Copy_Component_List
4518 Loc : Source_Ptr) return List_Id
4521 Comps : constant List_Id := New_List;
4524 Comp := First_Component (Underlying_Type (R_Typ));
4525 while Present (Comp) loop
4526 if Comes_From_Source (Comp) then
4528 Comp_Decl : constant Node_Id := Declaration_Node (Comp);
4531 Make_Component_Declaration (Loc,
4532 Defining_Identifier =>
4533 Make_Defining_Identifier (Loc, Chars (Comp)),
4534 Component_Definition =>
4536 (Component_Definition (Comp_Decl), New_Sloc => Loc)));
4540 Next_Component (Comp);
4544 end Copy_Component_List;
4546 -------------------------
4547 -- Copy_Parameter_List --
4548 -------------------------
4550 function Copy_Parameter_List (Subp_Id : Entity_Id) return List_Id is
4551 Loc : constant Source_Ptr := Sloc (Subp_Id);
4556 if No (First_Formal (Subp_Id)) then
4560 Formal := First_Formal (Subp_Id);
4561 while Present (Formal) loop
4563 Make_Parameter_Specification (Loc,
4564 Defining_Identifier =>
4565 Make_Defining_Identifier (Sloc (Formal), Chars (Formal)),
4566 In_Present => In_Present (Parent (Formal)),
4567 Out_Present => Out_Present (Parent (Formal)),
4569 New_Occurrence_Of (Etype (Formal), Loc),
4571 New_Copy_Tree (Expression (Parent (Formal)))));
4573 Next_Formal (Formal);
4578 end Copy_Parameter_List;
4580 --------------------------
4581 -- Copy_Subprogram_Spec --
4582 --------------------------
4584 function Copy_Subprogram_Spec (Spec : Node_Id) return Node_Id is
4586 Formal_Spec : Node_Id;
4590 -- The structure of the original tree must be replicated without any
4591 -- alterations. Use New_Copy_Tree for this purpose.
4593 Result := New_Copy_Tree (Spec);
4595 -- Create a new entity for the defining unit name
4597 Def_Id := Defining_Unit_Name (Result);
4598 Set_Defining_Unit_Name (Result,
4599 Make_Defining_Identifier (Sloc (Def_Id), Chars (Def_Id)));
4601 -- Create new entities for the formal parameters
4603 if Present (Parameter_Specifications (Result)) then
4604 Formal_Spec := First (Parameter_Specifications (Result));
4605 while Present (Formal_Spec) loop
4606 Def_Id := Defining_Identifier (Formal_Spec);
4607 Set_Defining_Identifier (Formal_Spec,
4608 Make_Defining_Identifier (Sloc (Def_Id), Chars (Def_Id)));
4615 end Copy_Subprogram_Spec;
4617 --------------------------------
4618 -- Corresponding_Generic_Type --
4619 --------------------------------
4621 function Corresponding_Generic_Type (T : Entity_Id) return Entity_Id is
4627 if not Is_Generic_Actual_Type (T) then
4630 -- If the actual is the actual of an enclosing instance, resolution
4631 -- was correct in the generic.
4633 elsif Nkind (Parent (T)) = N_Subtype_Declaration
4634 and then Is_Entity_Name (Subtype_Indication (Parent (T)))
4636 Is_Generic_Actual_Type (Entity (Subtype_Indication (Parent (T))))
4643 if Is_Wrapper_Package (Inst) then
4644 Inst := Related_Instance (Inst);
4649 (Specification (Unit_Declaration_Node (Inst)));
4651 -- Generic actual has the same name as the corresponding formal
4653 Typ := First_Entity (Gen);
4654 while Present (Typ) loop
4655 if Chars (Typ) = Chars (T) then
4664 end Corresponding_Generic_Type;
4666 ---------------------------
4667 -- Corresponding_Spec_Of --
4668 ---------------------------
4670 function Corresponding_Spec_Of (Decl : Node_Id) return Entity_Id is
4672 if Nkind_In (Decl, N_Package_Body, N_Subprogram_Body)
4673 and then Present (Corresponding_Spec (Decl))
4675 return Corresponding_Spec (Decl);
4677 elsif Nkind_In (Decl, N_Package_Body_Stub, N_Subprogram_Body_Stub)
4678 and then Present (Corresponding_Spec_Of_Stub (Decl))
4680 return Corresponding_Spec_Of_Stub (Decl);
4683 return Defining_Entity (Decl);
4685 end Corresponding_Spec_Of;
4687 -----------------------------
4688 -- Create_Generic_Contract --
4689 -----------------------------
4691 procedure Create_Generic_Contract (Unit : Node_Id) is
4692 Templ : constant Node_Id := Original_Node (Unit);
4693 Templ_Id : constant Entity_Id := Defining_Entity (Templ);
4695 procedure Add_Generic_Contract_Pragma (Prag : Node_Id);
4696 -- Add a single contract-related source pragma Prag to the contract of
4697 -- generic template Templ_Id.
4699 ---------------------------------
4700 -- Add_Generic_Contract_Pragma --
4701 ---------------------------------
4703 procedure Add_Generic_Contract_Pragma (Prag : Node_Id) is
4704 Prag_Templ : Node_Id;
4707 -- Mark the pragma to prevent the premature capture of global
4708 -- references when capturing global references of the context
4709 -- (see Save_References_In_Pragma).
4711 Set_Is_Generic_Contract_Pragma (Prag);
4713 -- Pragmas that apply to a generic subprogram declaration are not
4714 -- part of the semantic structure of the generic template:
4717 -- procedure Example (Formal : Integer);
4718 -- pragma Precondition (Formal > 0);
4720 -- Create a generic template for such pragmas and link the template
4721 -- of the pragma with the generic template.
4723 if Nkind (Templ) = N_Generic_Subprogram_Declaration then
4725 (Prag, Copy_Generic_Node (Prag, Empty, Instantiating => False));
4726 Prag_Templ := Original_Node (Prag);
4728 Set_Is_Generic_Contract_Pragma (Prag_Templ);
4729 Add_Contract_Item (Prag_Templ, Templ_Id);
4731 -- Otherwise link the pragma with the generic template
4734 Add_Contract_Item (Prag, Templ_Id);
4736 end Add_Generic_Contract_Pragma;
4740 Context : constant Node_Id := Parent (Unit);
4741 Decl : Node_Id := Empty;
4743 -- Start of processing for Create_Generic_Contract
4746 -- A generic package declaration carries contract-related source pragmas
4747 -- in its visible declarations.
4749 if Nkind (Templ) = N_Generic_Package_Declaration then
4750 Set_Ekind (Templ_Id, E_Generic_Package);
4752 if Present (Visible_Declarations (Specification (Templ))) then
4753 Decl := First (Visible_Declarations (Specification (Templ)));
4756 -- A generic package body carries contract-related source pragmas in its
4759 elsif Nkind (Templ) = N_Package_Body then
4760 Set_Ekind (Templ_Id, E_Package_Body);
4762 if Present (Declarations (Templ)) then
4763 Decl := First (Declarations (Templ));
4766 -- Generic subprogram declaration
4768 elsif Nkind (Templ) = N_Generic_Subprogram_Declaration then
4769 if Nkind (Specification (Templ)) = N_Function_Specification then
4770 Set_Ekind (Templ_Id, E_Generic_Function);
4772 Set_Ekind (Templ_Id, E_Generic_Procedure);
4775 -- When the generic subprogram acts as a compilation unit, inspect
4776 -- the Pragmas_After list for contract-related source pragmas.
4778 if Nkind (Context) = N_Compilation_Unit then
4779 if Present (Aux_Decls_Node (Context))
4780 and then Present (Pragmas_After (Aux_Decls_Node (Context)))
4782 Decl := First (Pragmas_After (Aux_Decls_Node (Context)));
4785 -- Otherwise inspect the successive declarations for contract-related
4789 Decl := Next (Unit);
4792 -- A generic subprogram body carries contract-related source pragmas in
4793 -- its declarations.
4795 elsif Nkind (Templ) = N_Subprogram_Body then
4796 Set_Ekind (Templ_Id, E_Subprogram_Body);
4798 if Present (Declarations (Templ)) then
4799 Decl := First (Declarations (Templ));
4803 -- Inspect the relevant declarations looking for contract-related source
4804 -- pragmas and add them to the contract of the generic unit.
4806 while Present (Decl) loop
4807 if Comes_From_Source (Decl) then
4808 if Nkind (Decl) = N_Pragma then
4810 -- The source pragma is a contract annotation
4812 if Is_Contract_Annotation (Decl) then
4813 Add_Generic_Contract_Pragma (Decl);
4816 -- The region where a contract-related source pragma may appear
4817 -- ends with the first source non-pragma declaration or statement.
4826 end Create_Generic_Contract;
4828 --------------------
4829 -- Current_Entity --
4830 --------------------
4832 -- The currently visible definition for a given identifier is the
4833 -- one most chained at the start of the visibility chain, i.e. the
4834 -- one that is referenced by the Node_Id value of the name of the
4835 -- given identifier.
4837 function Current_Entity (N : Node_Id) return Entity_Id is
4839 return Get_Name_Entity_Id (Chars (N));
4842 -----------------------------
4843 -- Current_Entity_In_Scope --
4844 -----------------------------
4846 function Current_Entity_In_Scope (N : Node_Id) return Entity_Id is
4848 CS : constant Entity_Id := Current_Scope;
4850 Transient_Case : constant Boolean := Scope_Is_Transient;
4853 E := Get_Name_Entity_Id (Chars (N));
4855 and then Scope (E) /= CS
4856 and then (not Transient_Case or else Scope (E) /= Scope (CS))
4862 end Current_Entity_In_Scope;
4868 function Current_Scope return Entity_Id is
4870 if Scope_Stack.Last = -1 then
4871 return Standard_Standard;
4874 C : constant Entity_Id :=
4875 Scope_Stack.Table (Scope_Stack.Last).Entity;
4880 return Standard_Standard;
4886 ------------------------
4887 -- Current_Subprogram --
4888 ------------------------
4890 function Current_Subprogram return Entity_Id is
4891 Scop : constant Entity_Id := Current_Scope;
4893 if Is_Subprogram_Or_Generic_Subprogram (Scop) then
4896 return Enclosing_Subprogram (Scop);
4898 end Current_Subprogram;
4900 ----------------------------------
4901 -- Deepest_Type_Access_Level --
4902 ----------------------------------
4904 function Deepest_Type_Access_Level (Typ : Entity_Id) return Uint is
4906 if Ekind (Typ) = E_Anonymous_Access_Type
4907 and then not Is_Local_Anonymous_Access (Typ)
4908 and then Nkind (Associated_Node_For_Itype (Typ)) = N_Object_Declaration
4910 -- Typ is the type of an Ada 2012 stand-alone object of an anonymous
4914 Scope_Depth (Enclosing_Dynamic_Scope
4915 (Defining_Identifier
4916 (Associated_Node_For_Itype (Typ))));
4918 -- For generic formal type, return Int'Last (infinite).
4919 -- See comment preceding Is_Generic_Type call in Type_Access_Level.
4921 elsif Is_Generic_Type (Root_Type (Typ)) then
4922 return UI_From_Int (Int'Last);
4925 return Type_Access_Level (Typ);
4927 end Deepest_Type_Access_Level;
4929 ---------------------
4930 -- Defining_Entity --
4931 ---------------------
4933 function Defining_Entity (N : Node_Id) return Entity_Id is
4934 K : constant Node_Kind := Nkind (N);
4935 Err : Entity_Id := Empty;
4940 N_Subprogram_Declaration |
4941 N_Abstract_Subprogram_Declaration |
4943 N_Package_Declaration |
4944 N_Subprogram_Renaming_Declaration |
4945 N_Subprogram_Body_Stub |
4946 N_Generic_Subprogram_Declaration |
4947 N_Generic_Package_Declaration |
4948 N_Formal_Subprogram_Declaration |
4949 N_Expression_Function
4951 return Defining_Entity (Specification (N));
4954 N_Component_Declaration |
4955 N_Defining_Program_Unit_Name |
4956 N_Discriminant_Specification |
4958 N_Entry_Declaration |
4959 N_Entry_Index_Specification |
4960 N_Exception_Declaration |
4961 N_Exception_Renaming_Declaration |
4962 N_Formal_Object_Declaration |
4963 N_Formal_Package_Declaration |
4964 N_Formal_Type_Declaration |
4965 N_Full_Type_Declaration |
4966 N_Implicit_Label_Declaration |
4967 N_Incomplete_Type_Declaration |
4968 N_Loop_Parameter_Specification |
4969 N_Number_Declaration |
4970 N_Object_Declaration |
4971 N_Object_Renaming_Declaration |
4972 N_Package_Body_Stub |
4973 N_Parameter_Specification |
4974 N_Private_Extension_Declaration |
4975 N_Private_Type_Declaration |
4977 N_Protected_Body_Stub |
4978 N_Protected_Type_Declaration |
4979 N_Single_Protected_Declaration |
4980 N_Single_Task_Declaration |
4981 N_Subtype_Declaration |
4984 N_Task_Type_Declaration
4986 return Defining_Identifier (N);
4989 return Defining_Entity (Proper_Body (N));
4992 N_Function_Instantiation |
4993 N_Function_Specification |
4994 N_Generic_Function_Renaming_Declaration |
4995 N_Generic_Package_Renaming_Declaration |
4996 N_Generic_Procedure_Renaming_Declaration |
4998 N_Package_Instantiation |
4999 N_Package_Renaming_Declaration |
5000 N_Package_Specification |
5001 N_Procedure_Instantiation |
5002 N_Procedure_Specification
5005 Nam : constant Node_Id := Defining_Unit_Name (N);
5008 if Nkind (Nam) in N_Entity then
5011 -- For Error, make up a name and attach to declaration
5012 -- so we can continue semantic analysis
5014 elsif Nam = Error then
5015 Err := Make_Temporary (Sloc (N), 'T');
5016 Set_Defining_Unit_Name (N, Err);
5020 -- If not an entity, get defining identifier
5023 return Defining_Identifier (Nam);
5031 return Entity (Identifier (N));
5034 raise Program_Error;
5037 end Defining_Entity;
5039 --------------------------
5040 -- Denotes_Discriminant --
5041 --------------------------
5043 function Denotes_Discriminant
5045 Check_Concurrent : Boolean := False) return Boolean
5050 if not Is_Entity_Name (N) or else No (Entity (N)) then
5056 -- If we are checking for a protected type, the discriminant may have
5057 -- been rewritten as the corresponding discriminal of the original type
5058 -- or of the corresponding concurrent record, depending on whether we
5059 -- are in the spec or body of the protected type.
5061 return Ekind (E) = E_Discriminant
5064 and then Ekind (E) = E_In_Parameter
5065 and then Present (Discriminal_Link (E))
5067 (Is_Concurrent_Type (Scope (Discriminal_Link (E)))
5069 Is_Concurrent_Record_Type (Scope (Discriminal_Link (E)))));
5071 end Denotes_Discriminant;
5073 -------------------------
5074 -- Denotes_Same_Object --
5075 -------------------------
5077 function Denotes_Same_Object (A1, A2 : Node_Id) return Boolean is
5078 Obj1 : Node_Id := A1;
5079 Obj2 : Node_Id := A2;
5081 function Has_Prefix (N : Node_Id) return Boolean;
5082 -- Return True if N has attribute Prefix
5084 function Is_Renaming (N : Node_Id) return Boolean;
5085 -- Return true if N names a renaming entity
5087 function Is_Valid_Renaming (N : Node_Id) return Boolean;
5088 -- For renamings, return False if the prefix of any dereference within
5089 -- the renamed object_name is a variable, or any expression within the
5090 -- renamed object_name contains references to variables or calls on
5091 -- nonstatic functions; otherwise return True (RM 6.4.1(6.10/3))
5097 function Has_Prefix (N : Node_Id) return Boolean is
5101 N_Attribute_Reference,
5103 N_Explicit_Dereference,
5104 N_Indexed_Component,
5106 N_Selected_Component,
5114 function Is_Renaming (N : Node_Id) return Boolean is
5116 return Is_Entity_Name (N)
5117 and then Present (Renamed_Entity (Entity (N)));
5120 -----------------------
5121 -- Is_Valid_Renaming --
5122 -----------------------
5124 function Is_Valid_Renaming (N : Node_Id) return Boolean is
5126 function Check_Renaming (N : Node_Id) return Boolean;
5127 -- Recursive function used to traverse all the prefixes of N
5129 function Check_Renaming (N : Node_Id) return Boolean is
5132 and then not Check_Renaming (Renamed_Entity (Entity (N)))
5137 if Nkind (N) = N_Indexed_Component then
5142 Indx := First (Expressions (N));
5143 while Present (Indx) loop
5144 if not Is_OK_Static_Expression (Indx) then
5153 if Has_Prefix (N) then
5155 P : constant Node_Id := Prefix (N);
5158 if Nkind (N) = N_Explicit_Dereference
5159 and then Is_Variable (P)
5163 elsif Is_Entity_Name (P)
5164 and then Ekind (Entity (P)) = E_Function
5168 elsif Nkind (P) = N_Function_Call then
5172 -- Recursion to continue traversing the prefix of the
5173 -- renaming expression
5175 return Check_Renaming (P);
5182 -- Start of processing for Is_Valid_Renaming
5185 return Check_Renaming (N);
5186 end Is_Valid_Renaming;
5188 -- Start of processing for Denotes_Same_Object
5191 -- Both names statically denote the same stand-alone object or parameter
5192 -- (RM 6.4.1(6.5/3))
5194 if Is_Entity_Name (Obj1)
5195 and then Is_Entity_Name (Obj2)
5196 and then Entity (Obj1) = Entity (Obj2)
5201 -- For renamings, the prefix of any dereference within the renamed
5202 -- object_name is not a variable, and any expression within the
5203 -- renamed object_name contains no references to variables nor
5204 -- calls on nonstatic functions (RM 6.4.1(6.10/3)).
5206 if Is_Renaming (Obj1) then
5207 if Is_Valid_Renaming (Obj1) then
5208 Obj1 := Renamed_Entity (Entity (Obj1));
5214 if Is_Renaming (Obj2) then
5215 if Is_Valid_Renaming (Obj2) then
5216 Obj2 := Renamed_Entity (Entity (Obj2));
5222 -- No match if not same node kind (such cases are handled by
5223 -- Denotes_Same_Prefix)
5225 if Nkind (Obj1) /= Nkind (Obj2) then
5228 -- After handling valid renamings, one of the two names statically
5229 -- denoted a renaming declaration whose renamed object_name is known
5230 -- to denote the same object as the other (RM 6.4.1(6.10/3))
5232 elsif Is_Entity_Name (Obj1) then
5233 if Is_Entity_Name (Obj2) then
5234 return Entity (Obj1) = Entity (Obj2);
5239 -- Both names are selected_components, their prefixes are known to
5240 -- denote the same object, and their selector_names denote the same
5241 -- component (RM 6.4.1(6.6/3)).
5243 elsif Nkind (Obj1) = N_Selected_Component then
5244 return Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2))
5246 Entity (Selector_Name (Obj1)) = Entity (Selector_Name (Obj2));
5248 -- Both names are dereferences and the dereferenced names are known to
5249 -- denote the same object (RM 6.4.1(6.7/3))
5251 elsif Nkind (Obj1) = N_Explicit_Dereference then
5252 return Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2));
5254 -- Both names are indexed_components, their prefixes are known to denote
5255 -- the same object, and each of the pairs of corresponding index values
5256 -- are either both static expressions with the same static value or both
5257 -- names that are known to denote the same object (RM 6.4.1(6.8/3))
5259 elsif Nkind (Obj1) = N_Indexed_Component then
5260 if not Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2)) then
5268 Indx1 := First (Expressions (Obj1));
5269 Indx2 := First (Expressions (Obj2));
5270 while Present (Indx1) loop
5272 -- Indexes must denote the same static value or same object
5274 if Is_OK_Static_Expression (Indx1) then
5275 if not Is_OK_Static_Expression (Indx2) then
5278 elsif Expr_Value (Indx1) /= Expr_Value (Indx2) then
5282 elsif not Denotes_Same_Object (Indx1, Indx2) then
5294 -- Both names are slices, their prefixes are known to denote the same
5295 -- object, and the two slices have statically matching index constraints
5296 -- (RM 6.4.1(6.9/3))
5298 elsif Nkind (Obj1) = N_Slice
5299 and then Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2))
5302 Lo1, Lo2, Hi1, Hi2 : Node_Id;
5305 Get_Index_Bounds (Etype (Obj1), Lo1, Hi1);
5306 Get_Index_Bounds (Etype (Obj2), Lo2, Hi2);
5308 -- Check whether bounds are statically identical. There is no
5309 -- attempt to detect partial overlap of slices.
5311 return Denotes_Same_Object (Lo1, Lo2)
5313 Denotes_Same_Object (Hi1, Hi2);
5316 -- In the recursion, literals appear as indexes
5318 elsif Nkind (Obj1) = N_Integer_Literal
5320 Nkind (Obj2) = N_Integer_Literal
5322 return Intval (Obj1) = Intval (Obj2);
5327 end Denotes_Same_Object;
5329 -------------------------
5330 -- Denotes_Same_Prefix --
5331 -------------------------
5333 function Denotes_Same_Prefix (A1, A2 : Node_Id) return Boolean is
5336 if Is_Entity_Name (A1) then
5337 if Nkind_In (A2, N_Selected_Component, N_Indexed_Component)
5338 and then not Is_Access_Type (Etype (A1))
5340 return Denotes_Same_Object (A1, Prefix (A2))
5341 or else Denotes_Same_Prefix (A1, Prefix (A2));
5346 elsif Is_Entity_Name (A2) then
5347 return Denotes_Same_Prefix (A1 => A2, A2 => A1);
5349 elsif Nkind_In (A1, N_Selected_Component, N_Indexed_Component, N_Slice)
5351 Nkind_In (A2, N_Selected_Component, N_Indexed_Component, N_Slice)
5354 Root1, Root2 : Node_Id;
5355 Depth1, Depth2 : Int := 0;
5358 Root1 := Prefix (A1);
5359 while not Is_Entity_Name (Root1) loop
5361 (Root1, N_Selected_Component, N_Indexed_Component)
5365 Root1 := Prefix (Root1);
5368 Depth1 := Depth1 + 1;
5371 Root2 := Prefix (A2);
5372 while not Is_Entity_Name (Root2) loop
5373 if not Nkind_In (Root2, N_Selected_Component,
5374 N_Indexed_Component)
5378 Root2 := Prefix (Root2);
5381 Depth2 := Depth2 + 1;
5384 -- If both have the same depth and they do not denote the same
5385 -- object, they are disjoint and no warning is needed.
5387 if Depth1 = Depth2 then
5390 elsif Depth1 > Depth2 then
5391 Root1 := Prefix (A1);
5392 for J in 1 .. Depth1 - Depth2 - 1 loop
5393 Root1 := Prefix (Root1);
5396 return Denotes_Same_Object (Root1, A2);
5399 Root2 := Prefix (A2);
5400 for J in 1 .. Depth2 - Depth1 - 1 loop
5401 Root2 := Prefix (Root2);
5404 return Denotes_Same_Object (A1, Root2);
5411 end Denotes_Same_Prefix;
5413 ----------------------
5414 -- Denotes_Variable --
5415 ----------------------
5417 function Denotes_Variable (N : Node_Id) return Boolean is
5419 return Is_Variable (N) and then Paren_Count (N) = 0;
5420 end Denotes_Variable;
5422 -----------------------------
5423 -- Depends_On_Discriminant --
5424 -----------------------------
5426 function Depends_On_Discriminant (N : Node_Id) return Boolean is
5431 Get_Index_Bounds (N, L, H);
5432 return Denotes_Discriminant (L) or else Denotes_Discriminant (H);
5433 end Depends_On_Discriminant;
5435 -------------------------
5436 -- Designate_Same_Unit --
5437 -------------------------
5439 function Designate_Same_Unit
5441 Name2 : Node_Id) return Boolean
5443 K1 : constant Node_Kind := Nkind (Name1);
5444 K2 : constant Node_Kind := Nkind (Name2);
5446 function Prefix_Node (N : Node_Id) return Node_Id;
5447 -- Returns the parent unit name node of a defining program unit name
5448 -- or the prefix if N is a selected component or an expanded name.
5450 function Select_Node (N : Node_Id) return Node_Id;
5451 -- Returns the defining identifier node of a defining program unit
5452 -- name or the selector node if N is a selected component or an
5459 function Prefix_Node (N : Node_Id) return Node_Id is
5461 if Nkind (N) = N_Defining_Program_Unit_Name then
5472 function Select_Node (N : Node_Id) return Node_Id is
5474 if Nkind (N) = N_Defining_Program_Unit_Name then
5475 return Defining_Identifier (N);
5477 return Selector_Name (N);
5481 -- Start of processing for Designate_Same_Unit
5484 if Nkind_In (K1, N_Identifier, N_Defining_Identifier)
5486 Nkind_In (K2, N_Identifier, N_Defining_Identifier)
5488 return Chars (Name1) = Chars (Name2);
5490 elsif Nkind_In (K1, N_Expanded_Name,
5491 N_Selected_Component,
5492 N_Defining_Program_Unit_Name)
5494 Nkind_In (K2, N_Expanded_Name,
5495 N_Selected_Component,
5496 N_Defining_Program_Unit_Name)
5499 (Chars (Select_Node (Name1)) = Chars (Select_Node (Name2)))
5501 Designate_Same_Unit (Prefix_Node (Name1), Prefix_Node (Name2));
5506 end Designate_Same_Unit;
5508 ------------------------------------------
5509 -- function Dynamic_Accessibility_Level --
5510 ------------------------------------------
5512 function Dynamic_Accessibility_Level (Expr : Node_Id) return Node_Id is
5514 Loc : constant Source_Ptr := Sloc (Expr);
5516 function Make_Level_Literal (Level : Uint) return Node_Id;
5517 -- Construct an integer literal representing an accessibility level
5518 -- with its type set to Natural.
5520 ------------------------
5521 -- Make_Level_Literal --
5522 ------------------------
5524 function Make_Level_Literal (Level : Uint) return Node_Id is
5525 Result : constant Node_Id := Make_Integer_Literal (Loc, Level);
5527 Set_Etype (Result, Standard_Natural);
5529 end Make_Level_Literal;
5531 -- Start of processing for Dynamic_Accessibility_Level
5534 if Is_Entity_Name (Expr) then
5537 if Present (Renamed_Object (E)) then
5538 return Dynamic_Accessibility_Level (Renamed_Object (E));
5541 if Is_Formal (E) or else Ekind_In (E, E_Variable, E_Constant) then
5542 if Present (Extra_Accessibility (E)) then
5543 return New_Occurrence_Of (Extra_Accessibility (E), Loc);
5548 -- Unimplemented: Ptr.all'Access, where Ptr has Extra_Accessibility ???
5550 case Nkind (Expr) is
5552 -- For access discriminant, the level of the enclosing object
5554 when N_Selected_Component =>
5555 if Ekind (Entity (Selector_Name (Expr))) = E_Discriminant
5556 and then Ekind (Etype (Entity (Selector_Name (Expr)))) =
5557 E_Anonymous_Access_Type
5559 return Make_Level_Literal (Object_Access_Level (Expr));
5562 when N_Attribute_Reference =>
5563 case Get_Attribute_Id (Attribute_Name (Expr)) is
5565 -- For X'Access, the level of the prefix X
5567 when Attribute_Access =>
5568 return Make_Level_Literal
5569 (Object_Access_Level (Prefix (Expr)));
5571 -- Treat the unchecked attributes as library-level
5573 when Attribute_Unchecked_Access |
5574 Attribute_Unrestricted_Access =>
5575 return Make_Level_Literal (Scope_Depth (Standard_Standard));
5577 -- No other access-valued attributes
5580 raise Program_Error;
5585 -- Unimplemented: depends on context. As an actual parameter where
5586 -- formal type is anonymous, use
5587 -- Scope_Depth (Current_Scope) + 1.
5588 -- For other cases, see 3.10.2(14/3) and following. ???
5592 when N_Type_Conversion =>
5593 if not Is_Local_Anonymous_Access (Etype (Expr)) then
5595 -- Handle type conversions introduced for a rename of an
5596 -- Ada 2012 stand-alone object of an anonymous access type.
5598 return Dynamic_Accessibility_Level (Expression (Expr));
5605 return Make_Level_Literal (Type_Access_Level (Etype (Expr)));
5606 end Dynamic_Accessibility_Level;
5608 -----------------------------------
5609 -- Effective_Extra_Accessibility --
5610 -----------------------------------
5612 function Effective_Extra_Accessibility (Id : Entity_Id) return Entity_Id is
5614 if Present (Renamed_Object (Id))
5615 and then Is_Entity_Name (Renamed_Object (Id))
5617 return Effective_Extra_Accessibility (Entity (Renamed_Object (Id)));
5619 return Extra_Accessibility (Id);
5621 end Effective_Extra_Accessibility;
5623 -----------------------------
5624 -- Effective_Reads_Enabled --
5625 -----------------------------
5627 function Effective_Reads_Enabled (Id : Entity_Id) return Boolean is
5629 return Has_Enabled_Property (Id, Name_Effective_Reads);
5630 end Effective_Reads_Enabled;
5632 ------------------------------
5633 -- Effective_Writes_Enabled --
5634 ------------------------------
5636 function Effective_Writes_Enabled (Id : Entity_Id) return Boolean is
5638 return Has_Enabled_Property (Id, Name_Effective_Writes);
5639 end Effective_Writes_Enabled;
5641 ------------------------------
5642 -- Enclosing_Comp_Unit_Node --
5643 ------------------------------
5645 function Enclosing_Comp_Unit_Node (N : Node_Id) return Node_Id is
5646 Current_Node : Node_Id;
5650 while Present (Current_Node)
5651 and then Nkind (Current_Node) /= N_Compilation_Unit
5653 Current_Node := Parent (Current_Node);
5656 if Nkind (Current_Node) /= N_Compilation_Unit then
5659 return Current_Node;
5661 end Enclosing_Comp_Unit_Node;
5663 --------------------------
5664 -- Enclosing_CPP_Parent --
5665 --------------------------
5667 function Enclosing_CPP_Parent (Typ : Entity_Id) return Entity_Id is
5668 Parent_Typ : Entity_Id := Typ;
5671 while not Is_CPP_Class (Parent_Typ)
5672 and then Etype (Parent_Typ) /= Parent_Typ
5674 Parent_Typ := Etype (Parent_Typ);
5676 if Is_Private_Type (Parent_Typ) then
5677 Parent_Typ := Full_View (Base_Type (Parent_Typ));
5681 pragma Assert (Is_CPP_Class (Parent_Typ));
5683 end Enclosing_CPP_Parent;
5685 ---------------------------
5686 -- Enclosing_Declaration --
5687 ---------------------------
5689 function Enclosing_Declaration (N : Node_Id) return Node_Id is
5690 Decl : Node_Id := N;
5693 while Present (Decl)
5694 and then not (Nkind (Decl) in N_Declaration
5696 Nkind (Decl) in N_Later_Decl_Item)
5698 Decl := Parent (Decl);
5702 end Enclosing_Declaration;
5704 ----------------------------
5705 -- Enclosing_Generic_Body --
5706 ----------------------------
5708 function Enclosing_Generic_Body
5709 (N : Node_Id) return Node_Id
5717 while Present (P) loop
5718 if Nkind (P) = N_Package_Body
5719 or else Nkind (P) = N_Subprogram_Body
5721 Spec := Corresponding_Spec (P);
5723 if Present (Spec) then
5724 Decl := Unit_Declaration_Node (Spec);
5726 if Nkind (Decl) = N_Generic_Package_Declaration
5727 or else Nkind (Decl) = N_Generic_Subprogram_Declaration
5738 end Enclosing_Generic_Body;
5740 ----------------------------
5741 -- Enclosing_Generic_Unit --
5742 ----------------------------
5744 function Enclosing_Generic_Unit
5745 (N : Node_Id) return Node_Id
5753 while Present (P) loop
5754 if Nkind (P) = N_Generic_Package_Declaration
5755 or else Nkind (P) = N_Generic_Subprogram_Declaration
5759 elsif Nkind (P) = N_Package_Body
5760 or else Nkind (P) = N_Subprogram_Body
5762 Spec := Corresponding_Spec (P);
5764 if Present (Spec) then
5765 Decl := Unit_Declaration_Node (Spec);
5767 if Nkind (Decl) = N_Generic_Package_Declaration
5768 or else Nkind (Decl) = N_Generic_Subprogram_Declaration
5779 end Enclosing_Generic_Unit;
5781 -------------------------------
5782 -- Enclosing_Lib_Unit_Entity --
5783 -------------------------------
5785 function Enclosing_Lib_Unit_Entity
5786 (E : Entity_Id := Current_Scope) return Entity_Id
5788 Unit_Entity : Entity_Id;
5791 -- Look for enclosing library unit entity by following scope links.
5792 -- Equivalent to, but faster than indexing through the scope stack.
5795 while (Present (Scope (Unit_Entity))
5796 and then Scope (Unit_Entity) /= Standard_Standard)
5797 and not Is_Child_Unit (Unit_Entity)
5799 Unit_Entity := Scope (Unit_Entity);
5803 end Enclosing_Lib_Unit_Entity;
5805 -----------------------------
5806 -- Enclosing_Lib_Unit_Node --
5807 -----------------------------
5809 function Enclosing_Lib_Unit_Node (N : Node_Id) return Node_Id is
5810 Encl_Unit : Node_Id;
5813 Encl_Unit := Enclosing_Comp_Unit_Node (N);
5814 while Present (Encl_Unit)
5815 and then Nkind (Unit (Encl_Unit)) = N_Subunit
5817 Encl_Unit := Library_Unit (Encl_Unit);
5821 end Enclosing_Lib_Unit_Node;
5823 -----------------------
5824 -- Enclosing_Package --
5825 -----------------------
5827 function Enclosing_Package (E : Entity_Id) return Entity_Id is
5828 Dynamic_Scope : constant Entity_Id := Enclosing_Dynamic_Scope (E);
5831 if Dynamic_Scope = Standard_Standard then
5832 return Standard_Standard;
5834 elsif Dynamic_Scope = Empty then
5837 elsif Ekind_In (Dynamic_Scope, E_Package, E_Package_Body,
5840 return Dynamic_Scope;
5843 return Enclosing_Package (Dynamic_Scope);
5845 end Enclosing_Package;
5847 -------------------------------------
5848 -- Enclosing_Package_Or_Subprogram --
5849 -------------------------------------
5851 function Enclosing_Package_Or_Subprogram (E : Entity_Id) return Entity_Id is
5856 while Present (S) loop
5857 if Is_Package_Or_Generic_Package (S)
5858 or else Ekind (S) = E_Package_Body
5862 elsif Is_Subprogram_Or_Generic_Subprogram (S)
5863 or else Ekind (S) = E_Subprogram_Body
5873 end Enclosing_Package_Or_Subprogram;
5875 --------------------------
5876 -- Enclosing_Subprogram --
5877 --------------------------
5879 function Enclosing_Subprogram (E : Entity_Id) return Entity_Id is
5880 Dynamic_Scope : constant Entity_Id := Enclosing_Dynamic_Scope (E);
5883 if Dynamic_Scope = Standard_Standard then
5886 elsif Dynamic_Scope = Empty then
5889 elsif Ekind (Dynamic_Scope) = E_Subprogram_Body then
5890 return Corresponding_Spec (Parent (Parent (Dynamic_Scope)));
5892 elsif Ekind (Dynamic_Scope) = E_Block
5893 or else Ekind (Dynamic_Scope) = E_Return_Statement
5895 return Enclosing_Subprogram (Dynamic_Scope);
5897 elsif Ekind (Dynamic_Scope) = E_Task_Type then
5898 return Get_Task_Body_Procedure (Dynamic_Scope);
5900 elsif Ekind (Dynamic_Scope) = E_Limited_Private_Type
5901 and then Present (Full_View (Dynamic_Scope))
5902 and then Ekind (Full_View (Dynamic_Scope)) = E_Task_Type
5904 return Get_Task_Body_Procedure (Full_View (Dynamic_Scope));
5906 -- No body is generated if the protected operation is eliminated
5908 elsif Convention (Dynamic_Scope) = Convention_Protected
5909 and then not Is_Eliminated (Dynamic_Scope)
5910 and then Present (Protected_Body_Subprogram (Dynamic_Scope))
5912 return Protected_Body_Subprogram (Dynamic_Scope);
5915 return Dynamic_Scope;
5917 end Enclosing_Subprogram;
5919 ------------------------
5920 -- Ensure_Freeze_Node --
5921 ------------------------
5923 procedure Ensure_Freeze_Node (E : Entity_Id) is
5926 if No (Freeze_Node (E)) then
5927 FN := Make_Freeze_Entity (Sloc (E));
5928 Set_Has_Delayed_Freeze (E);
5929 Set_Freeze_Node (E, FN);
5930 Set_Access_Types_To_Process (FN, No_Elist);
5931 Set_TSS_Elist (FN, No_Elist);
5934 end Ensure_Freeze_Node;
5940 procedure Enter_Name (Def_Id : Entity_Id) is
5941 C : constant Entity_Id := Current_Entity (Def_Id);
5942 E : constant Entity_Id := Current_Entity_In_Scope (Def_Id);
5943 S : constant Entity_Id := Current_Scope;
5946 Generate_Definition (Def_Id);
5948 -- Add new name to current scope declarations. Check for duplicate
5949 -- declaration, which may or may not be a genuine error.
5953 -- Case of previous entity entered because of a missing declaration
5954 -- or else a bad subtype indication. Best is to use the new entity,
5955 -- and make the previous one invisible.
5957 if Etype (E) = Any_Type then
5958 Set_Is_Immediately_Visible (E, False);
5960 -- Case of renaming declaration constructed for package instances.
5961 -- if there is an explicit declaration with the same identifier,
5962 -- the renaming is not immediately visible any longer, but remains
5963 -- visible through selected component notation.
5965 elsif Nkind (Parent (E)) = N_Package_Renaming_Declaration
5966 and then not Comes_From_Source (E)
5968 Set_Is_Immediately_Visible (E, False);
5970 -- The new entity may be the package renaming, which has the same
5971 -- same name as a generic formal which has been seen already.
5973 elsif Nkind (Parent (Def_Id)) = N_Package_Renaming_Declaration
5974 and then not Comes_From_Source (Def_Id)
5976 Set_Is_Immediately_Visible (E, False);
5978 -- For a fat pointer corresponding to a remote access to subprogram,
5979 -- we use the same identifier as the RAS type, so that the proper
5980 -- name appears in the stub. This type is only retrieved through
5981 -- the RAS type and never by visibility, and is not added to the
5982 -- visibility list (see below).
5984 elsif Nkind (Parent (Def_Id)) = N_Full_Type_Declaration
5985 and then Ekind (Def_Id) = E_Record_Type
5986 and then Present (Corresponding_Remote_Type (Def_Id))
5990 -- Case of an implicit operation or derived literal. The new entity
5991 -- hides the implicit one, which is removed from all visibility,
5992 -- i.e. the entity list of its scope, and homonym chain of its name.
5994 elsif (Is_Overloadable (E) and then Is_Inherited_Operation (E))
5995 or else Is_Internal (E)
5999 Prev_Vis : Entity_Id;
6000 Decl : constant Node_Id := Parent (E);
6003 -- If E is an implicit declaration, it cannot be the first
6004 -- entity in the scope.
6006 Prev := First_Entity (Current_Scope);
6007 while Present (Prev) and then Next_Entity (Prev) /= E loop
6013 -- If E is not on the entity chain of the current scope,
6014 -- it is an implicit declaration in the generic formal
6015 -- part of a generic subprogram. When analyzing the body,
6016 -- the generic formals are visible but not on the entity
6017 -- chain of the subprogram. The new entity will become
6018 -- the visible one in the body.
6021 (Nkind (Parent (Decl)) = N_Generic_Subprogram_Declaration);
6025 Set_Next_Entity (Prev, Next_Entity (E));
6027 if No (Next_Entity (Prev)) then
6028 Set_Last_Entity (Current_Scope, Prev);
6031 if E = Current_Entity (E) then
6035 Prev_Vis := Current_Entity (E);
6036 while Homonym (Prev_Vis) /= E loop
6037 Prev_Vis := Homonym (Prev_Vis);
6041 if Present (Prev_Vis) then
6043 -- Skip E in the visibility chain
6045 Set_Homonym (Prev_Vis, Homonym (E));
6048 Set_Name_Entity_Id (Chars (E), Homonym (E));
6053 -- This section of code could use a comment ???
6055 elsif Present (Etype (E))
6056 and then Is_Concurrent_Type (Etype (E))
6061 -- If the homograph is a protected component renaming, it should not
6062 -- be hiding the current entity. Such renamings are treated as weak
6065 elsif Is_Prival (E) then
6066 Set_Is_Immediately_Visible (E, False);
6068 -- In this case the current entity is a protected component renaming.
6069 -- Perform minimal decoration by setting the scope and return since
6070 -- the prival should not be hiding other visible entities.
6072 elsif Is_Prival (Def_Id) then
6073 Set_Scope (Def_Id, Current_Scope);
6076 -- Analogous to privals, the discriminal generated for an entry index
6077 -- parameter acts as a weak declaration. Perform minimal decoration
6078 -- to avoid bogus errors.
6080 elsif Is_Discriminal (Def_Id)
6081 and then Ekind (Discriminal_Link (Def_Id)) = E_Entry_Index_Parameter
6083 Set_Scope (Def_Id, Current_Scope);
6086 -- In the body or private part of an instance, a type extension may
6087 -- introduce a component with the same name as that of an actual. The
6088 -- legality rule is not enforced, but the semantics of the full type
6089 -- with two components of same name are not clear at this point???
6091 elsif In_Instance_Not_Visible then
6094 -- When compiling a package body, some child units may have become
6095 -- visible. They cannot conflict with local entities that hide them.
6097 elsif Is_Child_Unit (E)
6098 and then In_Open_Scopes (Scope (E))
6099 and then not Is_Immediately_Visible (E)
6103 -- Conversely, with front-end inlining we may compile the parent body
6104 -- first, and a child unit subsequently. The context is now the
6105 -- parent spec, and body entities are not visible.
6107 elsif Is_Child_Unit (Def_Id)
6108 and then Is_Package_Body_Entity (E)
6109 and then not In_Package_Body (Current_Scope)
6113 -- Case of genuine duplicate declaration
6116 Error_Msg_Sloc := Sloc (E);
6118 -- If the previous declaration is an incomplete type declaration
6119 -- this may be an attempt to complete it with a private type. The
6120 -- following avoids confusing cascaded errors.
6122 if Nkind (Parent (E)) = N_Incomplete_Type_Declaration
6123 and then Nkind (Parent (Def_Id)) = N_Private_Type_Declaration
6126 ("incomplete type cannot be completed with a private " &
6127 "declaration", Parent (Def_Id));
6128 Set_Is_Immediately_Visible (E, False);
6129 Set_Full_View (E, Def_Id);
6131 -- An inherited component of a record conflicts with a new
6132 -- discriminant. The discriminant is inserted first in the scope,
6133 -- but the error should be posted on it, not on the component.
6135 elsif Ekind (E) = E_Discriminant
6136 and then Present (Scope (Def_Id))
6137 and then Scope (Def_Id) /= Current_Scope
6139 Error_Msg_Sloc := Sloc (Def_Id);
6140 Error_Msg_N ("& conflicts with declaration#", E);
6143 -- If the name of the unit appears in its own context clause, a
6144 -- dummy package with the name has already been created, and the
6145 -- error emitted. Try to continue quietly.
6147 elsif Error_Posted (E)
6148 and then Sloc (E) = No_Location
6149 and then Nkind (Parent (E)) = N_Package_Specification
6150 and then Current_Scope = Standard_Standard
6152 Set_Scope (Def_Id, Current_Scope);
6156 Error_Msg_N ("& conflicts with declaration#", Def_Id);
6158 -- Avoid cascaded messages with duplicate components in
6161 if Ekind_In (E, E_Component, E_Discriminant) then
6166 if Nkind (Parent (Parent (Def_Id))) =
6167 N_Generic_Subprogram_Declaration
6169 Defining_Entity (Specification (Parent (Parent (Def_Id))))
6171 Error_Msg_N ("\generic units cannot be overloaded", Def_Id);
6174 -- If entity is in standard, then we are in trouble, because it
6175 -- means that we have a library package with a duplicated name.
6176 -- That's hard to recover from, so abort.
6178 if S = Standard_Standard then
6179 raise Unrecoverable_Error;
6181 -- Otherwise we continue with the declaration. Having two
6182 -- identical declarations should not cause us too much trouble.
6190 -- If we fall through, declaration is OK, at least OK enough to continue
6192 -- If Def_Id is a discriminant or a record component we are in the midst
6193 -- of inheriting components in a derived record definition. Preserve
6194 -- their Ekind and Etype.
6196 if Ekind_In (Def_Id, E_Discriminant, E_Component) then
6199 -- If a type is already set, leave it alone (happens when a type
6200 -- declaration is reanalyzed following a call to the optimizer).
6202 elsif Present (Etype (Def_Id)) then
6205 -- Otherwise, the kind E_Void insures that premature uses of the entity
6206 -- will be detected. Any_Type insures that no cascaded errors will occur
6209 Set_Ekind (Def_Id, E_Void);
6210 Set_Etype (Def_Id, Any_Type);
6213 -- Inherited discriminants and components in derived record types are
6214 -- immediately visible. Itypes are not.
6216 -- Unless the Itype is for a record type with a corresponding remote
6217 -- type (what is that about, it was not commented ???)
6219 if Ekind_In (Def_Id, E_Discriminant, E_Component)
6221 ((not Is_Record_Type (Def_Id)
6222 or else No (Corresponding_Remote_Type (Def_Id)))
6223 and then not Is_Itype (Def_Id))
6225 Set_Is_Immediately_Visible (Def_Id);
6226 Set_Current_Entity (Def_Id);
6229 Set_Homonym (Def_Id, C);
6230 Append_Entity (Def_Id, S);
6231 Set_Public_Status (Def_Id);
6233 -- Declaring a homonym is not allowed in SPARK ...
6235 if Present (C) and then Restriction_Check_Required (SPARK_05) then
6237 Enclosing_Subp : constant Node_Id := Enclosing_Subprogram (Def_Id);
6238 Enclosing_Pack : constant Node_Id := Enclosing_Package (Def_Id);
6239 Other_Scope : constant Node_Id := Enclosing_Dynamic_Scope (C);
6242 -- ... unless the new declaration is in a subprogram, and the
6243 -- visible declaration is a variable declaration or a parameter
6244 -- specification outside that subprogram.
6246 if Present (Enclosing_Subp)
6247 and then Nkind_In (Parent (C), N_Object_Declaration,
6248 N_Parameter_Specification)
6249 and then not Scope_Within_Or_Same (Other_Scope, Enclosing_Subp)
6253 -- ... or the new declaration is in a package, and the visible
6254 -- declaration occurs outside that package.
6256 elsif Present (Enclosing_Pack)
6257 and then not Scope_Within_Or_Same (Other_Scope, Enclosing_Pack)
6261 -- ... or the new declaration is a component declaration in a
6262 -- record type definition.
6264 elsif Nkind (Parent (Def_Id)) = N_Component_Declaration then
6267 -- Don't issue error for non-source entities
6269 elsif Comes_From_Source (Def_Id)
6270 and then Comes_From_Source (C)
6272 Error_Msg_Sloc := Sloc (C);
6273 Check_SPARK_05_Restriction
6274 ("redeclaration of identifier &#", Def_Id);
6279 -- Warn if new entity hides an old one
6281 if Warn_On_Hiding and then Present (C)
6283 -- Don't warn for record components since they always have a well
6284 -- defined scope which does not confuse other uses. Note that in
6285 -- some cases, Ekind has not been set yet.
6287 and then Ekind (C) /= E_Component
6288 and then Ekind (C) /= E_Discriminant
6289 and then Nkind (Parent (C)) /= N_Component_Declaration
6290 and then Ekind (Def_Id) /= E_Component
6291 and then Ekind (Def_Id) /= E_Discriminant
6292 and then Nkind (Parent (Def_Id)) /= N_Component_Declaration
6294 -- Don't warn for one character variables. It is too common to use
6295 -- such variables as locals and will just cause too many false hits.
6297 and then Length_Of_Name (Chars (C)) /= 1
6299 -- Don't warn for non-source entities
6301 and then Comes_From_Source (C)
6302 and then Comes_From_Source (Def_Id)
6304 -- Don't warn unless entity in question is in extended main source
6306 and then In_Extended_Main_Source_Unit (Def_Id)
6308 -- Finally, the hidden entity must be either immediately visible or
6309 -- use visible (i.e. from a used package).
6312 (Is_Immediately_Visible (C)
6314 Is_Potentially_Use_Visible (C))
6316 Error_Msg_Sloc := Sloc (C);
6317 Error_Msg_N ("declaration hides &#?h?", Def_Id);
6325 function Entity_Of (N : Node_Id) return Entity_Id is
6331 if Is_Entity_Name (N) then
6334 -- Follow a possible chain of renamings to reach the root renamed
6337 while Present (Id) and then Present (Renamed_Object (Id)) loop
6338 if Is_Entity_Name (Renamed_Object (Id)) then
6339 Id := Entity (Renamed_Object (Id));
6350 --------------------------
6351 -- Explain_Limited_Type --
6352 --------------------------
6354 procedure Explain_Limited_Type (T : Entity_Id; N : Node_Id) is
6358 -- For array, component type must be limited
6360 if Is_Array_Type (T) then
6361 Error_Msg_Node_2 := T;
6363 ("\component type& of type& is limited", N, Component_Type (T));
6364 Explain_Limited_Type (Component_Type (T), N);
6366 elsif Is_Record_Type (T) then
6368 -- No need for extra messages if explicit limited record
6370 if Is_Limited_Record (Base_Type (T)) then
6374 -- Otherwise find a limited component. Check only components that
6375 -- come from source, or inherited components that appear in the
6376 -- source of the ancestor.
6378 C := First_Component (T);
6379 while Present (C) loop
6380 if Is_Limited_Type (Etype (C))
6382 (Comes_From_Source (C)
6384 (Present (Original_Record_Component (C))
6386 Comes_From_Source (Original_Record_Component (C))))
6388 Error_Msg_Node_2 := T;
6389 Error_Msg_NE ("\component& of type& has limited type", N, C);
6390 Explain_Limited_Type (Etype (C), N);
6397 -- The type may be declared explicitly limited, even if no component
6398 -- of it is limited, in which case we fall out of the loop.
6401 end Explain_Limited_Type;
6403 -------------------------------
6404 -- Extensions_Visible_Status --
6405 -------------------------------
6407 function Extensions_Visible_Status
6408 (Id : Entity_Id) return Extensions_Visible_Mode
6417 -- When a formal parameter is subject to Extensions_Visible, the pragma
6418 -- is stored in the contract of related subprogram.
6420 if Is_Formal (Id) then
6423 elsif Is_Subprogram_Or_Generic_Subprogram (Id) then
6426 -- No other construct carries this pragma
6429 return Extensions_Visible_None;
6432 Prag := Get_Pragma (Subp, Pragma_Extensions_Visible);
6434 -- In certain cases analysis may request the Extensions_Visible status
6435 -- of an expression function before the pragma has been analyzed yet.
6436 -- Inspect the declarative items after the expression function looking
6437 -- for the pragma (if any).
6439 if No (Prag) and then Is_Expression_Function (Subp) then
6440 Decl := Next (Unit_Declaration_Node (Subp));
6441 while Present (Decl) loop
6442 if Nkind (Decl) = N_Pragma
6443 and then Pragma_Name (Decl) = Name_Extensions_Visible
6448 -- A source construct ends the region where Extensions_Visible may
6449 -- appear, stop the traversal. An expanded expression function is
6450 -- no longer a source construct, but it must still be recognized.
6452 elsif Comes_From_Source (Decl)
6454 (Nkind_In (Decl, N_Subprogram_Body,
6455 N_Subprogram_Declaration)
6456 and then Is_Expression_Function (Defining_Entity (Decl)))
6465 -- Extract the value from the Boolean expression (if any)
6467 if Present (Prag) then
6468 Arg := First (Pragma_Argument_Associations (Prag));
6470 if Present (Arg) then
6471 Expr := Get_Pragma_Arg (Arg);
6473 -- When the associated subprogram is an expression function, the
6474 -- argument of the pragma may not have been analyzed.
6476 if not Analyzed (Expr) then
6477 Preanalyze_And_Resolve (Expr, Standard_Boolean);
6480 -- Guard against cascading errors when the argument of pragma
6481 -- Extensions_Visible is not a valid static Boolean expression.
6483 if Error_Posted (Expr) then
6484 return Extensions_Visible_None;
6486 elsif Is_True (Expr_Value (Expr)) then
6487 return Extensions_Visible_True;
6490 return Extensions_Visible_False;
6493 -- Otherwise the aspect or pragma defaults to True
6496 return Extensions_Visible_True;
6499 -- Otherwise aspect or pragma Extensions_Visible is not inherited or
6500 -- directly specified. In SPARK code, its value defaults to "False".
6502 elsif SPARK_Mode = On then
6503 return Extensions_Visible_False;
6505 -- In non-SPARK code, aspect or pragma Extensions_Visible defaults to
6509 return Extensions_Visible_True;
6511 end Extensions_Visible_Status;
6517 procedure Find_Actual
6519 Formal : out Entity_Id;
6522 Parnt : constant Node_Id := Parent (N);
6526 if Nkind_In (Parnt, N_Indexed_Component, N_Selected_Component)
6527 and then N = Prefix (Parnt)
6529 Find_Actual (Parnt, Formal, Call);
6532 elsif Nkind (Parnt) = N_Parameter_Association
6533 and then N = Explicit_Actual_Parameter (Parnt)
6535 Call := Parent (Parnt);
6537 elsif Nkind (Parnt) in N_Subprogram_Call then
6546 -- If we have a call to a subprogram look for the parameter. Note that
6547 -- we exclude overloaded calls, since we don't know enough to be sure
6548 -- of giving the right answer in this case.
6550 if Nkind_In (Call, N_Function_Call, N_Procedure_Call_Statement)
6551 and then Is_Entity_Name (Name (Call))
6552 and then Present (Entity (Name (Call)))
6553 and then Is_Overloadable (Entity (Name (Call)))
6554 and then not Is_Overloaded (Name (Call))
6556 -- If node is name in call it is not an actual
6558 if N = Name (Call) then
6564 -- Fall here if we are definitely a parameter
6566 Actual := First_Actual (Call);
6567 Formal := First_Formal (Entity (Name (Call)));
6568 while Present (Formal) and then Present (Actual) loop
6572 -- An actual that is the prefix in a prefixed call may have
6573 -- been rewritten in the call, after the deferred reference
6574 -- was collected. Check if sloc and kinds and names match.
6576 elsif Sloc (Actual) = Sloc (N)
6577 and then Nkind (Actual) = N_Identifier
6578 and then Nkind (Actual) = Nkind (N)
6579 and then Chars (Actual) = Chars (N)
6584 Actual := Next_Actual (Actual);
6585 Formal := Next_Formal (Formal);
6590 -- Fall through here if we did not find matching actual
6596 ---------------------------
6597 -- Find_Body_Discriminal --
6598 ---------------------------
6600 function Find_Body_Discriminal
6601 (Spec_Discriminant : Entity_Id) return Entity_Id
6607 -- If expansion is suppressed, then the scope can be the concurrent type
6608 -- itself rather than a corresponding concurrent record type.
6610 if Is_Concurrent_Type (Scope (Spec_Discriminant)) then
6611 Tsk := Scope (Spec_Discriminant);
6614 pragma Assert (Is_Concurrent_Record_Type (Scope (Spec_Discriminant)));
6616 Tsk := Corresponding_Concurrent_Type (Scope (Spec_Discriminant));
6619 -- Find discriminant of original concurrent type, and use its current
6620 -- discriminal, which is the renaming within the task/protected body.
6622 Disc := First_Discriminant (Tsk);
6623 while Present (Disc) loop
6624 if Chars (Disc) = Chars (Spec_Discriminant) then
6625 return Discriminal (Disc);
6628 Next_Discriminant (Disc);
6631 -- That loop should always succeed in finding a matching entry and
6632 -- returning. Fatal error if not.
6634 raise Program_Error;
6635 end Find_Body_Discriminal;
6637 -------------------------------------
6638 -- Find_Corresponding_Discriminant --
6639 -------------------------------------
6641 function Find_Corresponding_Discriminant
6643 Typ : Entity_Id) return Entity_Id
6645 Par_Disc : Entity_Id;
6646 Old_Disc : Entity_Id;
6647 New_Disc : Entity_Id;
6650 Par_Disc := Original_Record_Component (Original_Discriminant (Id));
6652 -- The original type may currently be private, and the discriminant
6653 -- only appear on its full view.
6655 if Is_Private_Type (Scope (Par_Disc))
6656 and then not Has_Discriminants (Scope (Par_Disc))
6657 and then Present (Full_View (Scope (Par_Disc)))
6659 Old_Disc := First_Discriminant (Full_View (Scope (Par_Disc)));
6661 Old_Disc := First_Discriminant (Scope (Par_Disc));
6664 if Is_Class_Wide_Type (Typ) then
6665 New_Disc := First_Discriminant (Root_Type (Typ));
6667 New_Disc := First_Discriminant (Typ);
6670 while Present (Old_Disc) and then Present (New_Disc) loop
6671 if Old_Disc = Par_Disc then
6675 Next_Discriminant (Old_Disc);
6676 Next_Discriminant (New_Disc);
6679 -- Should always find it
6681 raise Program_Error;
6682 end Find_Corresponding_Discriminant;
6684 ----------------------------------
6685 -- Find_Enclosing_Iterator_Loop --
6686 ----------------------------------
6688 function Find_Enclosing_Iterator_Loop (Id : Entity_Id) return Entity_Id is
6693 -- Traverse the scope chain looking for an iterator loop. Such loops are
6694 -- usually transformed into blocks, hence the use of Original_Node.
6697 while Present (S) and then S /= Standard_Standard loop
6698 if Ekind (S) = E_Loop
6699 and then Nkind (Parent (S)) = N_Implicit_Label_Declaration
6701 Constr := Original_Node (Label_Construct (Parent (S)));
6703 if Nkind (Constr) = N_Loop_Statement
6704 and then Present (Iteration_Scheme (Constr))
6705 and then Nkind (Iterator_Specification
6706 (Iteration_Scheme (Constr))) =
6707 N_Iterator_Specification
6717 end Find_Enclosing_Iterator_Loop;
6719 ------------------------------------
6720 -- Find_Loop_In_Conditional_Block --
6721 ------------------------------------
6723 function Find_Loop_In_Conditional_Block (N : Node_Id) return Node_Id is
6729 if Nkind (Stmt) = N_If_Statement then
6730 Stmt := First (Then_Statements (Stmt));
6733 pragma Assert (Nkind (Stmt) = N_Block_Statement);
6735 -- Inspect the statements of the conditional block. In general the loop
6736 -- should be the first statement in the statement sequence of the block,
6737 -- but the finalization machinery may have introduced extra object
6740 Stmt := First (Statements (Handled_Statement_Sequence (Stmt)));
6741 while Present (Stmt) loop
6742 if Nkind (Stmt) = N_Loop_Statement then
6749 -- The expansion of attribute 'Loop_Entry produced a malformed block
6751 raise Program_Error;
6752 end Find_Loop_In_Conditional_Block;
6754 --------------------------
6755 -- Find_Overlaid_Entity --
6756 --------------------------
6758 procedure Find_Overlaid_Entity
6760 Ent : out Entity_Id;
6766 -- We are looking for one of the two following forms:
6768 -- for X'Address use Y'Address
6772 -- Const : constant Address := expr;
6774 -- for X'Address use Const;
6776 -- In the second case, the expr is either Y'Address, or recursively a
6777 -- constant that eventually references Y'Address.
6782 if Nkind (N) = N_Attribute_Definition_Clause
6783 and then Chars (N) = Name_Address
6785 Expr := Expression (N);
6787 -- This loop checks the form of the expression for Y'Address,
6788 -- using recursion to deal with intermediate constants.
6791 -- Check for Y'Address
6793 if Nkind (Expr) = N_Attribute_Reference
6794 and then Attribute_Name (Expr) = Name_Address
6796 Expr := Prefix (Expr);
6799 -- Check for Const where Const is a constant entity
6801 elsif Is_Entity_Name (Expr)
6802 and then Ekind (Entity (Expr)) = E_Constant
6804 Expr := Constant_Value (Entity (Expr));
6806 -- Anything else does not need checking
6813 -- This loop checks the form of the prefix for an entity, using
6814 -- recursion to deal with intermediate components.
6817 -- Check for Y where Y is an entity
6819 if Is_Entity_Name (Expr) then
6820 Ent := Entity (Expr);
6823 -- Check for components
6826 Nkind_In (Expr, N_Selected_Component, N_Indexed_Component)
6828 Expr := Prefix (Expr);
6831 -- Anything else does not need checking
6838 end Find_Overlaid_Entity;
6840 -------------------------
6841 -- Find_Parameter_Type --
6842 -------------------------
6844 function Find_Parameter_Type (Param : Node_Id) return Entity_Id is
6846 if Nkind (Param) /= N_Parameter_Specification then
6849 -- For an access parameter, obtain the type from the formal entity
6850 -- itself, because access to subprogram nodes do not carry a type.
6851 -- Shouldn't we always use the formal entity ???
6853 elsif Nkind (Parameter_Type (Param)) = N_Access_Definition then
6854 return Etype (Defining_Identifier (Param));
6857 return Etype (Parameter_Type (Param));
6859 end Find_Parameter_Type;
6861 -----------------------------------
6862 -- Find_Placement_In_State_Space --
6863 -----------------------------------
6865 procedure Find_Placement_In_State_Space
6866 (Item_Id : Entity_Id;
6867 Placement : out State_Space_Kind;
6868 Pack_Id : out Entity_Id)
6870 Context : Entity_Id;
6873 -- Assume that the item does not appear in the state space of a package
6875 Placement := Not_In_Package;
6878 -- Climb the scope stack and examine the enclosing context
6880 Context := Scope (Item_Id);
6881 while Present (Context) and then Context /= Standard_Standard loop
6882 if Ekind (Context) = E_Package then
6885 -- A package body is a cut off point for the traversal as the item
6886 -- cannot be visible to the outside from this point on. Note that
6887 -- this test must be done first as a body is also classified as a
6890 if In_Package_Body (Context) then
6891 Placement := Body_State_Space;
6894 -- The private part of a package is a cut off point for the
6895 -- traversal as the item cannot be visible to the outside from
6898 elsif In_Private_Part (Context) then
6899 Placement := Private_State_Space;
6902 -- When the item appears in the visible state space of a package,
6903 -- continue to climb the scope stack as this may not be the final
6907 Placement := Visible_State_Space;
6909 -- The visible state space of a child unit acts as the proper
6910 -- placement of an item.
6912 if Is_Child_Unit (Context) then
6917 -- The item or its enclosing package appear in a construct that has
6921 Placement := Not_In_Package;
6925 Context := Scope (Context);
6927 end Find_Placement_In_State_Space;
6929 ------------------------
6930 -- Find_Specific_Type --
6931 ------------------------
6933 function Find_Specific_Type (CW : Entity_Id) return Entity_Id is
6934 Typ : Entity_Id := Root_Type (CW);
6937 if Ekind (Typ) = E_Incomplete_Type then
6938 if From_Limited_With (Typ) then
6939 Typ := Non_Limited_View (Typ);
6941 Typ := Full_View (Typ);
6945 if Is_Private_Type (Typ)
6946 and then not Is_Tagged_Type (Typ)
6947 and then Present (Full_View (Typ))
6949 return Full_View (Typ);
6953 end Find_Specific_Type;
6955 -----------------------------
6956 -- Find_Static_Alternative --
6957 -----------------------------
6959 function Find_Static_Alternative (N : Node_Id) return Node_Id is
6960 Expr : constant Node_Id := Expression (N);
6961 Val : constant Uint := Expr_Value (Expr);
6966 Alt := First (Alternatives (N));
6969 if Nkind (Alt) /= N_Pragma then
6970 Choice := First (Discrete_Choices (Alt));
6971 while Present (Choice) loop
6973 -- Others choice, always matches
6975 if Nkind (Choice) = N_Others_Choice then
6978 -- Range, check if value is in the range
6980 elsif Nkind (Choice) = N_Range then
6982 Val >= Expr_Value (Low_Bound (Choice))
6984 Val <= Expr_Value (High_Bound (Choice));
6986 -- Choice is a subtype name. Note that we know it must
6987 -- be a static subtype, since otherwise it would have
6988 -- been diagnosed as illegal.
6990 elsif Is_Entity_Name (Choice)
6991 and then Is_Type (Entity (Choice))
6993 exit Search when Is_In_Range (Expr, Etype (Choice),
6994 Assume_Valid => False);
6996 -- Choice is a subtype indication
6998 elsif Nkind (Choice) = N_Subtype_Indication then
7000 C : constant Node_Id := Constraint (Choice);
7001 R : constant Node_Id := Range_Expression (C);
7005 Val >= Expr_Value (Low_Bound (R))
7007 Val <= Expr_Value (High_Bound (R));
7010 -- Choice is a simple expression
7013 exit Search when Val = Expr_Value (Choice);
7021 pragma Assert (Present (Alt));
7024 -- The above loop *must* terminate by finding a match, since
7025 -- we know the case statement is valid, and the value of the
7026 -- expression is known at compile time. When we fall out of
7027 -- the loop, Alt points to the alternative that we know will
7028 -- be selected at run time.
7031 end Find_Static_Alternative;
7037 function First_Actual (Node : Node_Id) return Node_Id is
7041 if No (Parameter_Associations (Node)) then
7045 N := First (Parameter_Associations (Node));
7047 if Nkind (N) = N_Parameter_Association then
7048 return First_Named_Actual (Node);
7054 -----------------------
7055 -- Gather_Components --
7056 -----------------------
7058 procedure Gather_Components
7060 Comp_List : Node_Id;
7061 Governed_By : List_Id;
7063 Report_Errors : out Boolean)
7067 Discrete_Choice : Node_Id;
7068 Comp_Item : Node_Id;
7070 Discrim : Entity_Id;
7071 Discrim_Name : Node_Id;
7072 Discrim_Value : Node_Id;
7075 Report_Errors := False;
7077 if No (Comp_List) or else Null_Present (Comp_List) then
7080 elsif Present (Component_Items (Comp_List)) then
7081 Comp_Item := First (Component_Items (Comp_List));
7087 while Present (Comp_Item) loop
7089 -- Skip the tag of a tagged record, the interface tags, as well
7090 -- as all items that are not user components (anonymous types,
7091 -- rep clauses, Parent field, controller field).
7093 if Nkind (Comp_Item) = N_Component_Declaration then
7095 Comp : constant Entity_Id := Defining_Identifier (Comp_Item);
7097 if not Is_Tag (Comp) and then Chars (Comp) /= Name_uParent then
7098 Append_Elmt (Comp, Into);
7106 if No (Variant_Part (Comp_List)) then
7109 Discrim_Name := Name (Variant_Part (Comp_List));
7110 Variant := First_Non_Pragma (Variants (Variant_Part (Comp_List)));
7113 -- Look for the discriminant that governs this variant part.
7114 -- The discriminant *must* be in the Governed_By List
7116 Assoc := First (Governed_By);
7117 Find_Constraint : loop
7118 Discrim := First (Choices (Assoc));
7119 exit Find_Constraint when Chars (Discrim_Name) = Chars (Discrim)
7120 or else (Present (Corresponding_Discriminant (Entity (Discrim)))
7122 Chars (Corresponding_Discriminant (Entity (Discrim))) =
7123 Chars (Discrim_Name))
7124 or else Chars (Original_Record_Component (Entity (Discrim)))
7125 = Chars (Discrim_Name);
7127 if No (Next (Assoc)) then
7128 if not Is_Constrained (Typ)
7129 and then Is_Derived_Type (Typ)
7130 and then Present (Stored_Constraint (Typ))
7132 -- If the type is a tagged type with inherited discriminants,
7133 -- use the stored constraint on the parent in order to find
7134 -- the values of discriminants that are otherwise hidden by an
7135 -- explicit constraint. Renamed discriminants are handled in
7138 -- If several parent discriminants are renamed by a single
7139 -- discriminant of the derived type, the call to obtain the
7140 -- Corresponding_Discriminant field only retrieves the last
7141 -- of them. We recover the constraint on the others from the
7142 -- Stored_Constraint as well.
7149 D := First_Discriminant (Etype (Typ));
7150 C := First_Elmt (Stored_Constraint (Typ));
7151 while Present (D) and then Present (C) loop
7152 if Chars (Discrim_Name) = Chars (D) then
7153 if Is_Entity_Name (Node (C))
7154 and then Entity (Node (C)) = Entity (Discrim)
7156 -- D is renamed by Discrim, whose value is given in
7163 Make_Component_Association (Sloc (Typ),
7165 (New_Occurrence_Of (D, Sloc (Typ))),
7166 Duplicate_Subexpr_No_Checks (Node (C)));
7168 exit Find_Constraint;
7171 Next_Discriminant (D);
7178 if No (Next (Assoc)) then
7179 Error_Msg_NE (" missing value for discriminant&",
7180 First (Governed_By), Discrim_Name);
7181 Report_Errors := True;
7186 end loop Find_Constraint;
7188 Discrim_Value := Expression (Assoc);
7190 if not Is_OK_Static_Expression (Discrim_Value) then
7192 -- If the variant part is governed by a discriminant of the type
7193 -- this is an error. If the variant part and the discriminant are
7194 -- inherited from an ancestor this is legal (AI05-120) unless the
7195 -- components are being gathered for an aggregate, in which case
7196 -- the caller must check Report_Errors.
7198 if Scope (Original_Record_Component
7199 ((Entity (First (Choices (Assoc)))))) = Typ
7202 ("value for discriminant & must be static!",
7203 Discrim_Value, Discrim);
7204 Why_Not_Static (Discrim_Value);
7207 Report_Errors := True;
7211 Search_For_Discriminant_Value : declare
7217 UI_Discrim_Value : constant Uint := Expr_Value (Discrim_Value);
7220 Find_Discrete_Value : while Present (Variant) loop
7221 Discrete_Choice := First (Discrete_Choices (Variant));
7222 while Present (Discrete_Choice) loop
7223 exit Find_Discrete_Value when
7224 Nkind (Discrete_Choice) = N_Others_Choice;
7226 Get_Index_Bounds (Discrete_Choice, Low, High);
7228 UI_Low := Expr_Value (Low);
7229 UI_High := Expr_Value (High);
7231 exit Find_Discrete_Value when
7232 UI_Low <= UI_Discrim_Value
7234 UI_High >= UI_Discrim_Value;
7236 Next (Discrete_Choice);
7239 Next_Non_Pragma (Variant);
7240 end loop Find_Discrete_Value;
7241 end Search_For_Discriminant_Value;
7243 if No (Variant) then
7245 ("value of discriminant & is out of range", Discrim_Value, Discrim);
7246 Report_Errors := True;
7250 -- If we have found the corresponding choice, recursively add its
7251 -- components to the Into list. The nested components are part of
7252 -- the same record type.
7255 (Typ, Component_List (Variant), Governed_By, Into, Report_Errors);
7256 end Gather_Components;
7258 ------------------------
7259 -- Get_Actual_Subtype --
7260 ------------------------
7262 function Get_Actual_Subtype (N : Node_Id) return Entity_Id is
7263 Typ : constant Entity_Id := Etype (N);
7264 Utyp : Entity_Id := Underlying_Type (Typ);
7273 -- If what we have is an identifier that references a subprogram
7274 -- formal, or a variable or constant object, then we get the actual
7275 -- subtype from the referenced entity if one has been built.
7277 if Nkind (N) = N_Identifier
7279 (Is_Formal (Entity (N))
7280 or else Ekind (Entity (N)) = E_Constant
7281 or else Ekind (Entity (N)) = E_Variable)
7282 and then Present (Actual_Subtype (Entity (N)))
7284 return Actual_Subtype (Entity (N));
7286 -- Actual subtype of unchecked union is always itself. We never need
7287 -- the "real" actual subtype. If we did, we couldn't get it anyway
7288 -- because the discriminant is not available. The restrictions on
7289 -- Unchecked_Union are designed to make sure that this is OK.
7291 elsif Is_Unchecked_Union (Base_Type (Utyp)) then
7294 -- Here for the unconstrained case, we must find actual subtype
7295 -- No actual subtype is available, so we must build it on the fly.
7297 -- Checking the type, not the underlying type, for constrainedness
7298 -- seems to be necessary. Maybe all the tests should be on the type???
7300 elsif (not Is_Constrained (Typ))
7301 and then (Is_Array_Type (Utyp)
7302 or else (Is_Record_Type (Utyp)
7303 and then Has_Discriminants (Utyp)))
7304 and then not Has_Unknown_Discriminants (Utyp)
7305 and then not (Ekind (Utyp) = E_String_Literal_Subtype)
7307 -- Nothing to do if in spec expression (why not???)
7309 if In_Spec_Expression then
7312 elsif Is_Private_Type (Typ) and then not Has_Discriminants (Typ) then
7314 -- If the type has no discriminants, there is no subtype to
7315 -- build, even if the underlying type is discriminated.
7319 -- Else build the actual subtype
7322 Decl := Build_Actual_Subtype (Typ, N);
7323 Atyp := Defining_Identifier (Decl);
7325 -- If Build_Actual_Subtype generated a new declaration then use it
7329 -- The actual subtype is an Itype, so analyze the declaration,
7330 -- but do not attach it to the tree, to get the type defined.
7332 Set_Parent (Decl, N);
7333 Set_Is_Itype (Atyp);
7334 Analyze (Decl, Suppress => All_Checks);
7335 Set_Associated_Node_For_Itype (Atyp, N);
7336 Set_Has_Delayed_Freeze (Atyp, False);
7338 -- We need to freeze the actual subtype immediately. This is
7339 -- needed, because otherwise this Itype will not get frozen
7340 -- at all, and it is always safe to freeze on creation because
7341 -- any associated types must be frozen at this point.
7343 Freeze_Itype (Atyp, N);
7346 -- Otherwise we did not build a declaration, so return original
7353 -- For all remaining cases, the actual subtype is the same as
7354 -- the nominal type.
7359 end Get_Actual_Subtype;
7361 -------------------------------------
7362 -- Get_Actual_Subtype_If_Available --
7363 -------------------------------------
7365 function Get_Actual_Subtype_If_Available (N : Node_Id) return Entity_Id is
7366 Typ : constant Entity_Id := Etype (N);
7369 -- If what we have is an identifier that references a subprogram
7370 -- formal, or a variable or constant object, then we get the actual
7371 -- subtype from the referenced entity if one has been built.
7373 if Nkind (N) = N_Identifier
7375 (Is_Formal (Entity (N))
7376 or else Ekind (Entity (N)) = E_Constant
7377 or else Ekind (Entity (N)) = E_Variable)
7378 and then Present (Actual_Subtype (Entity (N)))
7380 return Actual_Subtype (Entity (N));
7382 -- Otherwise the Etype of N is returned unchanged
7387 end Get_Actual_Subtype_If_Available;
7389 ------------------------
7390 -- Get_Body_From_Stub --
7391 ------------------------
7393 function Get_Body_From_Stub (N : Node_Id) return Node_Id is
7395 return Proper_Body (Unit (Library_Unit (N)));
7396 end Get_Body_From_Stub;
7398 ---------------------
7399 -- Get_Cursor_Type --
7400 ---------------------
7402 function Get_Cursor_Type
7404 Typ : Entity_Id) return Entity_Id
7408 First_Op : Entity_Id;
7412 -- If error already detected, return
7414 if Error_Posted (Aspect) then
7418 -- The cursor type for an Iterable aspect is the return type of a
7419 -- non-overloaded First primitive operation. Locate association for
7422 Assoc := First (Component_Associations (Expression (Aspect)));
7424 while Present (Assoc) loop
7425 if Chars (First (Choices (Assoc))) = Name_First then
7426 First_Op := Expression (Assoc);
7433 if First_Op = Any_Id then
7434 Error_Msg_N ("aspect Iterable must specify First operation", Aspect);
7440 -- Locate function with desired name and profile in scope of type
7442 Func := First_Entity (Scope (Typ));
7443 while Present (Func) loop
7444 if Chars (Func) = Chars (First_Op)
7445 and then Ekind (Func) = E_Function
7446 and then Present (First_Formal (Func))
7447 and then Etype (First_Formal (Func)) = Typ
7448 and then No (Next_Formal (First_Formal (Func)))
7450 if Cursor /= Any_Type then
7452 ("Operation First for iterable type must be unique", Aspect);
7455 Cursor := Etype (Func);
7462 -- If not found, no way to resolve remaining primitives.
7464 if Cursor = Any_Type then
7466 ("No legal primitive operation First for Iterable type", Aspect);
7470 end Get_Cursor_Type;
7472 function Get_Cursor_Type (Typ : Entity_Id) return Entity_Id is
7474 return Etype (Get_Iterable_Type_Primitive (Typ, Name_First));
7475 end Get_Cursor_Type;
7477 -------------------------------
7478 -- Get_Default_External_Name --
7479 -------------------------------
7481 function Get_Default_External_Name (E : Node_Or_Entity_Id) return Node_Id is
7483 Get_Decoded_Name_String (Chars (E));
7485 if Opt.External_Name_Imp_Casing = Uppercase then
7486 Set_Casing (All_Upper_Case);
7488 Set_Casing (All_Lower_Case);
7492 Make_String_Literal (Sloc (E),
7493 Strval => String_From_Name_Buffer);
7494 end Get_Default_External_Name;
7496 --------------------------
7497 -- Get_Enclosing_Object --
7498 --------------------------
7500 function Get_Enclosing_Object (N : Node_Id) return Entity_Id is
7502 if Is_Entity_Name (N) then
7506 when N_Indexed_Component |
7508 N_Selected_Component =>
7510 -- If not generating code, a dereference may be left implicit.
7511 -- In thoses cases, return Empty.
7513 if Is_Access_Type (Etype (Prefix (N))) then
7516 return Get_Enclosing_Object (Prefix (N));
7519 when N_Type_Conversion =>
7520 return Get_Enclosing_Object (Expression (N));
7526 end Get_Enclosing_Object;
7528 ---------------------------
7529 -- Get_Enum_Lit_From_Pos --
7530 ---------------------------
7532 function Get_Enum_Lit_From_Pos
7535 Loc : Source_Ptr) return Node_Id
7537 Btyp : Entity_Id := Base_Type (T);
7541 -- In the case where the literal is of type Character, Wide_Character
7542 -- or Wide_Wide_Character or of a type derived from them, there needs
7543 -- to be some special handling since there is no explicit chain of
7544 -- literals to search. Instead, an N_Character_Literal node is created
7545 -- with the appropriate Char_Code and Chars fields.
7547 if Is_Standard_Character_Type (T) then
7548 Set_Character_Literal_Name (UI_To_CC (Pos));
7550 Make_Character_Literal (Loc,
7552 Char_Literal_Value => Pos);
7554 -- For all other cases, we have a complete table of literals, and
7555 -- we simply iterate through the chain of literal until the one
7556 -- with the desired position value is found.
7559 if Is_Private_Type (Btyp) and then Present (Full_View (Btyp)) then
7560 Btyp := Full_View (Btyp);
7563 Lit := First_Literal (Btyp);
7564 for J in 1 .. UI_To_Int (Pos) loop
7568 return New_Occurrence_Of (Lit, Loc);
7570 end Get_Enum_Lit_From_Pos;
7572 ------------------------
7573 -- Get_Generic_Entity --
7574 ------------------------
7576 function Get_Generic_Entity (N : Node_Id) return Entity_Id is
7577 Ent : constant Entity_Id := Entity (Name (N));
7579 if Present (Renamed_Object (Ent)) then
7580 return Renamed_Object (Ent);
7584 end Get_Generic_Entity;
7586 -------------------------------------
7587 -- Get_Incomplete_View_Of_Ancestor --
7588 -------------------------------------
7590 function Get_Incomplete_View_Of_Ancestor (E : Entity_Id) return Entity_Id is
7591 Cur_Unit : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
7592 Par_Scope : Entity_Id;
7593 Par_Type : Entity_Id;
7596 -- The incomplete view of an ancestor is only relevant for private
7597 -- derived types in child units.
7599 if not Is_Derived_Type (E)
7600 or else not Is_Child_Unit (Cur_Unit)
7605 Par_Scope := Scope (Cur_Unit);
7606 if No (Par_Scope) then
7610 Par_Type := Etype (Base_Type (E));
7612 -- Traverse list of ancestor types until we find one declared in
7613 -- a parent or grandparent unit (two levels seem sufficient).
7615 while Present (Par_Type) loop
7616 if Scope (Par_Type) = Par_Scope
7617 or else Scope (Par_Type) = Scope (Par_Scope)
7621 elsif not Is_Derived_Type (Par_Type) then
7625 Par_Type := Etype (Base_Type (Par_Type));
7629 -- If none found, there is no relevant ancestor type.
7633 end Get_Incomplete_View_Of_Ancestor;
7635 ----------------------
7636 -- Get_Index_Bounds --
7637 ----------------------
7639 procedure Get_Index_Bounds (N : Node_Id; L, H : out Node_Id) is
7640 Kind : constant Node_Kind := Nkind (N);
7644 if Kind = N_Range then
7646 H := High_Bound (N);
7648 elsif Kind = N_Subtype_Indication then
7649 R := Range_Expression (Constraint (N));
7657 L := Low_Bound (Range_Expression (Constraint (N)));
7658 H := High_Bound (Range_Expression (Constraint (N)));
7661 elsif Is_Entity_Name (N) and then Is_Type (Entity (N)) then
7662 if Error_Posted (Scalar_Range (Entity (N))) then
7666 elsif Nkind (Scalar_Range (Entity (N))) = N_Subtype_Indication then
7667 Get_Index_Bounds (Scalar_Range (Entity (N)), L, H);
7670 L := Low_Bound (Scalar_Range (Entity (N)));
7671 H := High_Bound (Scalar_Range (Entity (N)));
7675 -- N is an expression, indicating a range with one value
7680 end Get_Index_Bounds;
7682 ---------------------------------
7683 -- Get_Iterable_Type_Primitive --
7684 ---------------------------------
7686 function Get_Iterable_Type_Primitive
7688 Nam : Name_Id) return Entity_Id
7690 Funcs : constant Node_Id := Find_Value_Of_Aspect (Typ, Aspect_Iterable);
7698 Assoc := First (Component_Associations (Funcs));
7699 while Present (Assoc) loop
7700 if Chars (First (Choices (Assoc))) = Nam then
7701 return Entity (Expression (Assoc));
7704 Assoc := Next (Assoc);
7709 end Get_Iterable_Type_Primitive;
7711 ----------------------------------
7712 -- Get_Library_Unit_Name_string --
7713 ----------------------------------
7715 procedure Get_Library_Unit_Name_String (Decl_Node : Node_Id) is
7716 Unit_Name_Id : constant Unit_Name_Type := Get_Unit_Name (Decl_Node);
7719 Get_Unit_Name_String (Unit_Name_Id);
7721 -- Remove seven last character (" (spec)" or " (body)")
7723 Name_Len := Name_Len - 7;
7724 pragma Assert (Name_Buffer (Name_Len + 1) = ' ');
7725 end Get_Library_Unit_Name_String;
7727 ------------------------
7728 -- Get_Name_Entity_Id --
7729 ------------------------
7731 function Get_Name_Entity_Id (Id : Name_Id) return Entity_Id is
7733 return Entity_Id (Get_Name_Table_Int (Id));
7734 end Get_Name_Entity_Id;
7736 ------------------------------
7737 -- Get_Name_From_CTC_Pragma --
7738 ------------------------------
7740 function Get_Name_From_CTC_Pragma (N : Node_Id) return String_Id is
7741 Arg : constant Node_Id :=
7742 Get_Pragma_Arg (First (Pragma_Argument_Associations (N)));
7744 return Strval (Expr_Value_S (Arg));
7745 end Get_Name_From_CTC_Pragma;
7747 -----------------------
7748 -- Get_Parent_Entity --
7749 -----------------------
7751 function Get_Parent_Entity (Unit : Node_Id) return Entity_Id is
7753 if Nkind (Unit) = N_Package_Body
7754 and then Nkind (Original_Node (Unit)) = N_Package_Instantiation
7756 return Defining_Entity
7757 (Specification (Instance_Spec (Original_Node (Unit))));
7758 elsif Nkind (Unit) = N_Package_Instantiation then
7759 return Defining_Entity (Specification (Instance_Spec (Unit)));
7761 return Defining_Entity (Unit);
7763 end Get_Parent_Entity;
7768 function Get_Pragma_Id (N : Node_Id) return Pragma_Id is
7770 return Get_Pragma_Id (Pragma_Name (N));
7773 -----------------------
7774 -- Get_Reason_String --
7775 -----------------------
7777 procedure Get_Reason_String (N : Node_Id) is
7779 if Nkind (N) = N_String_Literal then
7780 Store_String_Chars (Strval (N));
7782 elsif Nkind (N) = N_Op_Concat then
7783 Get_Reason_String (Left_Opnd (N));
7784 Get_Reason_String (Right_Opnd (N));
7786 -- If not of required form, error
7790 ("Reason for pragma Warnings has wrong form", N);
7792 ("\must be string literal or concatenation of string literals", N);
7795 end Get_Reason_String;
7797 --------------------------------
7798 -- Get_Reference_Discriminant --
7799 --------------------------------
7801 function Get_Reference_Discriminant (Typ : Entity_Id) return Entity_Id is
7805 D := First_Discriminant (Typ);
7806 while Present (D) loop
7807 if Has_Implicit_Dereference (D) then
7810 Next_Discriminant (D);
7813 -- Type must have a proper access discriminant.
7815 pragma Assert (False);
7816 end Get_Reference_Discriminant;
7818 ---------------------------
7819 -- Get_Referenced_Object --
7820 ---------------------------
7822 function Get_Referenced_Object (N : Node_Id) return Node_Id is
7827 while Is_Entity_Name (R)
7828 and then Present (Renamed_Object (Entity (R)))
7830 R := Renamed_Object (Entity (R));
7834 end Get_Referenced_Object;
7836 ------------------------
7837 -- Get_Renamed_Entity --
7838 ------------------------
7840 function Get_Renamed_Entity (E : Entity_Id) return Entity_Id is
7845 while Present (Renamed_Entity (R)) loop
7846 R := Renamed_Entity (R);
7850 end Get_Renamed_Entity;
7852 -----------------------
7853 -- Get_Return_Object --
7854 -----------------------
7856 function Get_Return_Object (N : Node_Id) return Entity_Id is
7860 Decl := First (Return_Object_Declarations (N));
7861 while Present (Decl) loop
7862 exit when Nkind (Decl) = N_Object_Declaration
7863 and then Is_Return_Object (Defining_Identifier (Decl));
7867 pragma Assert (Present (Decl));
7868 return Defining_Identifier (Decl);
7869 end Get_Return_Object;
7871 ---------------------------
7872 -- Get_Subprogram_Entity --
7873 ---------------------------
7875 function Get_Subprogram_Entity (Nod : Node_Id) return Entity_Id is
7877 Subp_Id : Entity_Id;
7880 if Nkind (Nod) = N_Accept_Statement then
7881 Subp := Entry_Direct_Name (Nod);
7883 elsif Nkind (Nod) = N_Slice then
7884 Subp := Prefix (Nod);
7890 -- Strip the subprogram call
7893 if Nkind_In (Subp, N_Explicit_Dereference,
7894 N_Indexed_Component,
7895 N_Selected_Component)
7897 Subp := Prefix (Subp);
7899 elsif Nkind_In (Subp, N_Type_Conversion,
7900 N_Unchecked_Type_Conversion)
7902 Subp := Expression (Subp);
7909 -- Extract the entity of the subprogram call
7911 if Is_Entity_Name (Subp) then
7912 Subp_Id := Entity (Subp);
7914 if Ekind (Subp_Id) = E_Access_Subprogram_Type then
7915 Subp_Id := Directly_Designated_Type (Subp_Id);
7918 if Is_Subprogram (Subp_Id) then
7924 -- The search did not find a construct that denotes a subprogram
7929 end Get_Subprogram_Entity;
7931 -----------------------------
7932 -- Get_Task_Body_Procedure --
7933 -----------------------------
7935 function Get_Task_Body_Procedure (E : Entity_Id) return Node_Id is
7937 -- Note: A task type may be the completion of a private type with
7938 -- discriminants. When performing elaboration checks on a task
7939 -- declaration, the current view of the type may be the private one,
7940 -- and the procedure that holds the body of the task is held in its
7943 -- This is an odd function, why not have Task_Body_Procedure do
7944 -- the following digging???
7946 return Task_Body_Procedure (Underlying_Type (Root_Type (E)));
7947 end Get_Task_Body_Procedure;
7949 -------------------------
7950 -- Get_User_Defined_Eq --
7951 -------------------------
7953 function Get_User_Defined_Eq (E : Entity_Id) return Entity_Id is
7958 Prim := First_Elmt (Collect_Primitive_Operations (E));
7959 while Present (Prim) loop
7962 if Chars (Op) = Name_Op_Eq
7963 and then Etype (Op) = Standard_Boolean
7964 and then Etype (First_Formal (Op)) = E
7965 and then Etype (Next_Formal (First_Formal (Op))) = E
7974 end Get_User_Defined_Eq;
7976 -----------------------
7977 -- Has_Access_Values --
7978 -----------------------
7980 function Has_Access_Values (T : Entity_Id) return Boolean is
7981 Typ : constant Entity_Id := Underlying_Type (T);
7984 -- Case of a private type which is not completed yet. This can only
7985 -- happen in the case of a generic format type appearing directly, or
7986 -- as a component of the type to which this function is being applied
7987 -- at the top level. Return False in this case, since we certainly do
7988 -- not know that the type contains access types.
7993 elsif Is_Access_Type (Typ) then
7996 elsif Is_Array_Type (Typ) then
7997 return Has_Access_Values (Component_Type (Typ));
7999 elsif Is_Record_Type (Typ) then
8004 -- Loop to Check components
8006 Comp := First_Component_Or_Discriminant (Typ);
8007 while Present (Comp) loop
8009 -- Check for access component, tag field does not count, even
8010 -- though it is implemented internally using an access type.
8012 if Has_Access_Values (Etype (Comp))
8013 and then Chars (Comp) /= Name_uTag
8018 Next_Component_Or_Discriminant (Comp);
8027 end Has_Access_Values;
8029 ------------------------------
8030 -- Has_Compatible_Alignment --
8031 ------------------------------
8033 function Has_Compatible_Alignment
8035 Expr : Node_Id) return Alignment_Result
8037 function Has_Compatible_Alignment_Internal
8040 Default : Alignment_Result) return Alignment_Result;
8041 -- This is the internal recursive function that actually does the work.
8042 -- There is one additional parameter, which says what the result should
8043 -- be if no alignment information is found, and there is no definite
8044 -- indication of compatible alignments. At the outer level, this is set
8045 -- to Unknown, but for internal recursive calls in the case where types
8046 -- are known to be correct, it is set to Known_Compatible.
8048 ---------------------------------------
8049 -- Has_Compatible_Alignment_Internal --
8050 ---------------------------------------
8052 function Has_Compatible_Alignment_Internal
8055 Default : Alignment_Result) return Alignment_Result
8057 Result : Alignment_Result := Known_Compatible;
8058 -- Holds the current status of the result. Note that once a value of
8059 -- Known_Incompatible is set, it is sticky and does not get changed
8060 -- to Unknown (the value in Result only gets worse as we go along,
8063 Offs : Uint := No_Uint;
8064 -- Set to a factor of the offset from the base object when Expr is a
8065 -- selected or indexed component, based on Component_Bit_Offset and
8066 -- Component_Size respectively. A negative value is used to represent
8067 -- a value which is not known at compile time.
8069 procedure Check_Prefix;
8070 -- Checks the prefix recursively in the case where the expression
8071 -- is an indexed or selected component.
8073 procedure Set_Result (R : Alignment_Result);
8074 -- If R represents a worse outcome (unknown instead of known
8075 -- compatible, or known incompatible), then set Result to R.
8081 procedure Check_Prefix is
8083 -- The subtlety here is that in doing a recursive call to check
8084 -- the prefix, we have to decide what to do in the case where we
8085 -- don't find any specific indication of an alignment problem.
8087 -- At the outer level, we normally set Unknown as the result in
8088 -- this case, since we can only set Known_Compatible if we really
8089 -- know that the alignment value is OK, but for the recursive
8090 -- call, in the case where the types match, and we have not
8091 -- specified a peculiar alignment for the object, we are only
8092 -- concerned about suspicious rep clauses, the default case does
8093 -- not affect us, since the compiler will, in the absence of such
8094 -- rep clauses, ensure that the alignment is correct.
8096 if Default = Known_Compatible
8098 (Etype (Obj) = Etype (Expr)
8099 and then (Unknown_Alignment (Obj)
8101 Alignment (Obj) = Alignment (Etype (Obj))))
8104 (Has_Compatible_Alignment_Internal
8105 (Obj, Prefix (Expr), Known_Compatible));
8107 -- In all other cases, we need a full check on the prefix
8111 (Has_Compatible_Alignment_Internal
8112 (Obj, Prefix (Expr), Unknown));
8120 procedure Set_Result (R : Alignment_Result) is
8127 -- Start of processing for Has_Compatible_Alignment_Internal
8130 -- If Expr is a selected component, we must make sure there is no
8131 -- potentially troublesome component clause, and that the record is
8134 if Nkind (Expr) = N_Selected_Component then
8136 -- Packed record always generate unknown alignment
8138 if Is_Packed (Etype (Prefix (Expr))) then
8139 Set_Result (Unknown);
8142 -- Check prefix and component offset
8145 Offs := Component_Bit_Offset (Entity (Selector_Name (Expr)));
8147 -- If Expr is an indexed component, we must make sure there is no
8148 -- potentially troublesome Component_Size clause and that the array
8149 -- is not bit-packed.
8151 elsif Nkind (Expr) = N_Indexed_Component then
8153 Typ : constant Entity_Id := Etype (Prefix (Expr));
8154 Ind : constant Node_Id := First_Index (Typ);
8157 -- Bit packed array always generates unknown alignment
8159 if Is_Bit_Packed_Array (Typ) then
8160 Set_Result (Unknown);
8163 -- Check prefix and component offset
8166 Offs := Component_Size (Typ);
8168 -- Small optimization: compute the full offset when possible
8171 and then Offs > Uint_0
8172 and then Present (Ind)
8173 and then Nkind (Ind) = N_Range
8174 and then Compile_Time_Known_Value (Low_Bound (Ind))
8175 and then Compile_Time_Known_Value (First (Expressions (Expr)))
8177 Offs := Offs * (Expr_Value (First (Expressions (Expr)))
8178 - Expr_Value (Low_Bound ((Ind))));
8183 -- If we have a null offset, the result is entirely determined by
8184 -- the base object and has already been computed recursively.
8186 if Offs = Uint_0 then
8189 -- Case where we know the alignment of the object
8191 elsif Known_Alignment (Obj) then
8193 ObjA : constant Uint := Alignment (Obj);
8194 ExpA : Uint := No_Uint;
8195 SizA : Uint := No_Uint;
8198 -- If alignment of Obj is 1, then we are always OK
8201 Set_Result (Known_Compatible);
8203 -- Alignment of Obj is greater than 1, so we need to check
8206 -- If we have an offset, see if it is compatible
8208 if Offs /= No_Uint and Offs > Uint_0 then
8209 if Offs mod (System_Storage_Unit * ObjA) /= 0 then
8210 Set_Result (Known_Incompatible);
8213 -- See if Expr is an object with known alignment
8215 elsif Is_Entity_Name (Expr)
8216 and then Known_Alignment (Entity (Expr))
8218 ExpA := Alignment (Entity (Expr));
8220 -- Otherwise, we can use the alignment of the type of
8221 -- Expr given that we already checked for
8222 -- discombobulating rep clauses for the cases of indexed
8223 -- and selected components above.
8225 elsif Known_Alignment (Etype (Expr)) then
8226 ExpA := Alignment (Etype (Expr));
8228 -- Otherwise the alignment is unknown
8231 Set_Result (Default);
8234 -- If we got an alignment, see if it is acceptable
8236 if ExpA /= No_Uint and then ExpA < ObjA then
8237 Set_Result (Known_Incompatible);
8240 -- If Expr is not a piece of a larger object, see if size
8241 -- is given. If so, check that it is not too small for the
8242 -- required alignment.
8244 if Offs /= No_Uint then
8247 -- See if Expr is an object with known size
8249 elsif Is_Entity_Name (Expr)
8250 and then Known_Static_Esize (Entity (Expr))
8252 SizA := Esize (Entity (Expr));
8254 -- Otherwise, we check the object size of the Expr type
8256 elsif Known_Static_Esize (Etype (Expr)) then
8257 SizA := Esize (Etype (Expr));
8260 -- If we got a size, see if it is a multiple of the Obj
8261 -- alignment, if not, then the alignment cannot be
8262 -- acceptable, since the size is always a multiple of the
8265 if SizA /= No_Uint then
8266 if SizA mod (ObjA * Ttypes.System_Storage_Unit) /= 0 then
8267 Set_Result (Known_Incompatible);
8273 -- If we do not know required alignment, any non-zero offset is a
8274 -- potential problem (but certainly may be OK, so result is unknown).
8276 elsif Offs /= No_Uint then
8277 Set_Result (Unknown);
8279 -- If we can't find the result by direct comparison of alignment
8280 -- values, then there is still one case that we can determine known
8281 -- result, and that is when we can determine that the types are the
8282 -- same, and no alignments are specified. Then we known that the
8283 -- alignments are compatible, even if we don't know the alignment
8284 -- value in the front end.
8286 elsif Etype (Obj) = Etype (Expr) then
8288 -- Types are the same, but we have to check for possible size
8289 -- and alignments on the Expr object that may make the alignment
8290 -- different, even though the types are the same.
8292 if Is_Entity_Name (Expr) then
8294 -- First check alignment of the Expr object. Any alignment less
8295 -- than Maximum_Alignment is worrisome since this is the case
8296 -- where we do not know the alignment of Obj.
8298 if Known_Alignment (Entity (Expr))
8299 and then UI_To_Int (Alignment (Entity (Expr))) <
8300 Ttypes.Maximum_Alignment
8302 Set_Result (Unknown);
8304 -- Now check size of Expr object. Any size that is not an
8305 -- even multiple of Maximum_Alignment is also worrisome
8306 -- since it may cause the alignment of the object to be less
8307 -- than the alignment of the type.
8309 elsif Known_Static_Esize (Entity (Expr))
8311 (UI_To_Int (Esize (Entity (Expr))) mod
8312 (Ttypes.Maximum_Alignment * Ttypes.System_Storage_Unit))
8315 Set_Result (Unknown);
8317 -- Otherwise same type is decisive
8320 Set_Result (Known_Compatible);
8324 -- Another case to deal with is when there is an explicit size or
8325 -- alignment clause when the types are not the same. If so, then the
8326 -- result is Unknown. We don't need to do this test if the Default is
8327 -- Unknown, since that result will be set in any case.
8329 elsif Default /= Unknown
8330 and then (Has_Size_Clause (Etype (Expr))
8332 Has_Alignment_Clause (Etype (Expr)))
8334 Set_Result (Unknown);
8336 -- If no indication found, set default
8339 Set_Result (Default);
8342 -- Return worst result found
8345 end Has_Compatible_Alignment_Internal;
8347 -- Start of processing for Has_Compatible_Alignment
8350 -- If Obj has no specified alignment, then set alignment from the type
8351 -- alignment. Perhaps we should always do this, but for sure we should
8352 -- do it when there is an address clause since we can do more if the
8353 -- alignment is known.
8355 if Unknown_Alignment (Obj) then
8356 Set_Alignment (Obj, Alignment (Etype (Obj)));
8359 -- Now do the internal call that does all the work
8361 return Has_Compatible_Alignment_Internal (Obj, Expr, Unknown);
8362 end Has_Compatible_Alignment;
8364 ----------------------
8365 -- Has_Declarations --
8366 ----------------------
8368 function Has_Declarations (N : Node_Id) return Boolean is
8370 return Nkind_In (Nkind (N), N_Accept_Statement,
8372 N_Compilation_Unit_Aux,
8378 N_Package_Specification);
8379 end Has_Declarations;
8381 ---------------------------------
8382 -- Has_Defaulted_Discriminants --
8383 ---------------------------------
8385 function Has_Defaulted_Discriminants (Typ : Entity_Id) return Boolean is
8387 return Has_Discriminants (Typ)
8388 and then Present (First_Discriminant (Typ))
8389 and then Present (Discriminant_Default_Value
8390 (First_Discriminant (Typ)));
8391 end Has_Defaulted_Discriminants;
8397 function Has_Denormals (E : Entity_Id) return Boolean is
8399 return Is_Floating_Point_Type (E) and then Denorm_On_Target;
8402 -------------------------------------------
8403 -- Has_Discriminant_Dependent_Constraint --
8404 -------------------------------------------
8406 function Has_Discriminant_Dependent_Constraint
8407 (Comp : Entity_Id) return Boolean
8409 Comp_Decl : constant Node_Id := Parent (Comp);
8410 Subt_Indic : Node_Id;
8415 -- Discriminants can't depend on discriminants
8417 if Ekind (Comp) = E_Discriminant then
8421 Subt_Indic := Subtype_Indication (Component_Definition (Comp_Decl));
8423 if Nkind (Subt_Indic) = N_Subtype_Indication then
8424 Constr := Constraint (Subt_Indic);
8426 if Nkind (Constr) = N_Index_Or_Discriminant_Constraint then
8427 Assn := First (Constraints (Constr));
8428 while Present (Assn) loop
8429 case Nkind (Assn) is
8430 when N_Subtype_Indication |
8434 if Depends_On_Discriminant (Assn) then
8438 when N_Discriminant_Association =>
8439 if Depends_On_Discriminant (Expression (Assn)) then
8454 end Has_Discriminant_Dependent_Constraint;
8456 --------------------------
8457 -- Has_Enabled_Property --
8458 --------------------------
8460 function Has_Enabled_Property
8461 (Item_Id : Entity_Id;
8462 Property : Name_Id) return Boolean
8464 function State_Has_Enabled_Property return Boolean;
8465 -- Determine whether a state denoted by Item_Id has the property enabled
8467 function Variable_Has_Enabled_Property return Boolean;
8468 -- Determine whether a variable denoted by Item_Id has the property
8471 --------------------------------
8472 -- State_Has_Enabled_Property --
8473 --------------------------------
8475 function State_Has_Enabled_Property return Boolean is
8476 Decl : constant Node_Id := Parent (Item_Id);
8484 -- The declaration of an external abstract state appears as an
8485 -- extension aggregate. If this is not the case, properties can never
8488 if Nkind (Decl) /= N_Extension_Aggregate then
8492 -- When External appears as a simple option, it automatically enables
8495 Opt := First (Expressions (Decl));
8496 while Present (Opt) loop
8497 if Nkind (Opt) = N_Identifier
8498 and then Chars (Opt) = Name_External
8506 -- When External specifies particular properties, inspect those and
8507 -- find the desired one (if any).
8509 Opt := First (Component_Associations (Decl));
8510 while Present (Opt) loop
8511 Opt_Nam := First (Choices (Opt));
8513 if Nkind (Opt_Nam) = N_Identifier
8514 and then Chars (Opt_Nam) = Name_External
8516 Props := Expression (Opt);
8518 -- Multiple properties appear as an aggregate
8520 if Nkind (Props) = N_Aggregate then
8522 -- Simple property form
8524 Prop := First (Expressions (Props));
8525 while Present (Prop) loop
8526 if Chars (Prop) = Property then
8533 -- Property with expression form
8535 Prop := First (Component_Associations (Props));
8536 while Present (Prop) loop
8537 Prop_Nam := First (Choices (Prop));
8539 -- The property can be represented in two ways:
8540 -- others => <value>
8541 -- <property> => <value>
8543 if Nkind (Prop_Nam) = N_Others_Choice
8544 or else (Nkind (Prop_Nam) = N_Identifier
8545 and then Chars (Prop_Nam) = Property)
8547 return Is_True (Expr_Value (Expression (Prop)));
8556 return Chars (Props) = Property;
8564 end State_Has_Enabled_Property;
8566 -----------------------------------
8567 -- Variable_Has_Enabled_Property --
8568 -----------------------------------
8570 function Variable_Has_Enabled_Property return Boolean is
8571 function Is_Enabled (Prag : Node_Id) return Boolean;
8572 -- Determine whether property pragma Prag (if present) denotes an
8573 -- enabled property.
8579 function Is_Enabled (Prag : Node_Id) return Boolean is
8583 if Present (Prag) then
8584 Arg2 := Next (First (Pragma_Argument_Associations (Prag)));
8586 -- The pragma has an optional Boolean expression, the related
8587 -- property is enabled only when the expression evaluates to
8590 if Present (Arg2) then
8591 return Is_True (Expr_Value (Get_Pragma_Arg (Arg2)));
8593 -- Otherwise the lack of expression enables the property by
8600 -- The property was never set in the first place
8609 AR : constant Node_Id :=
8610 Get_Pragma (Item_Id, Pragma_Async_Readers);
8611 AW : constant Node_Id :=
8612 Get_Pragma (Item_Id, Pragma_Async_Writers);
8613 ER : constant Node_Id :=
8614 Get_Pragma (Item_Id, Pragma_Effective_Reads);
8615 EW : constant Node_Id :=
8616 Get_Pragma (Item_Id, Pragma_Effective_Writes);
8618 -- Start of processing for Variable_Has_Enabled_Property
8621 -- A non-effectively volatile object can never possess external
8624 if not Is_Effectively_Volatile (Item_Id) then
8627 -- External properties related to variables come in two flavors -
8628 -- explicit and implicit. The explicit case is characterized by the
8629 -- presence of a property pragma with an optional Boolean flag. The
8630 -- property is enabled when the flag evaluates to True or the flag is
8631 -- missing altogether.
8633 elsif Property = Name_Async_Readers and then Is_Enabled (AR) then
8636 elsif Property = Name_Async_Writers and then Is_Enabled (AW) then
8639 elsif Property = Name_Effective_Reads and then Is_Enabled (ER) then
8642 elsif Property = Name_Effective_Writes and then Is_Enabled (EW) then
8645 -- The implicit case lacks all property pragmas
8647 elsif No (AR) and then No (AW) and then No (ER) and then No (EW) then
8653 end Variable_Has_Enabled_Property;
8655 -- Start of processing for Has_Enabled_Property
8658 -- Abstract states and variables have a flexible scheme of specifying
8659 -- external properties.
8661 if Ekind (Item_Id) = E_Abstract_State then
8662 return State_Has_Enabled_Property;
8664 elsif Ekind (Item_Id) = E_Variable then
8665 return Variable_Has_Enabled_Property;
8667 -- Otherwise a property is enabled when the related item is effectively
8671 return Is_Effectively_Volatile (Item_Id);
8673 end Has_Enabled_Property;
8675 --------------------
8676 -- Has_Infinities --
8677 --------------------
8679 function Has_Infinities (E : Entity_Id) return Boolean is
8682 Is_Floating_Point_Type (E)
8683 and then Nkind (Scalar_Range (E)) = N_Range
8684 and then Includes_Infinities (Scalar_Range (E));
8687 --------------------
8688 -- Has_Interfaces --
8689 --------------------
8691 function Has_Interfaces
8693 Use_Full_View : Boolean := True) return Boolean
8695 Typ : Entity_Id := Base_Type (T);
8698 -- Handle concurrent types
8700 if Is_Concurrent_Type (Typ) then
8701 Typ := Corresponding_Record_Type (Typ);
8704 if not Present (Typ)
8705 or else not Is_Record_Type (Typ)
8706 or else not Is_Tagged_Type (Typ)
8711 -- Handle private types
8713 if Use_Full_View and then Present (Full_View (Typ)) then
8714 Typ := Full_View (Typ);
8717 -- Handle concurrent record types
8719 if Is_Concurrent_Record_Type (Typ)
8720 and then Is_Non_Empty_List (Abstract_Interface_List (Typ))
8726 if Is_Interface (Typ)
8728 (Is_Record_Type (Typ)
8729 and then Present (Interfaces (Typ))
8730 and then not Is_Empty_Elmt_List (Interfaces (Typ)))
8735 exit when Etype (Typ) = Typ
8737 -- Handle private types
8739 or else (Present (Full_View (Etype (Typ)))
8740 and then Full_View (Etype (Typ)) = Typ)
8742 -- Protect frontend against wrong sources with cyclic derivations
8744 or else Etype (Typ) = T;
8746 -- Climb to the ancestor type handling private types
8748 if Present (Full_View (Etype (Typ))) then
8749 Typ := Full_View (Etype (Typ));
8758 ---------------------------------
8759 -- Has_No_Obvious_Side_Effects --
8760 ---------------------------------
8762 function Has_No_Obvious_Side_Effects (N : Node_Id) return Boolean is
8764 -- For now, just handle literals, constants, and non-volatile
8765 -- variables and expressions combining these with operators or
8766 -- short circuit forms.
8768 if Nkind (N) in N_Numeric_Or_String_Literal then
8771 elsif Nkind (N) = N_Character_Literal then
8774 elsif Nkind (N) in N_Unary_Op then
8775 return Has_No_Obvious_Side_Effects (Right_Opnd (N));
8777 elsif Nkind (N) in N_Binary_Op or else Nkind (N) in N_Short_Circuit then
8778 return Has_No_Obvious_Side_Effects (Left_Opnd (N))
8780 Has_No_Obvious_Side_Effects (Right_Opnd (N));
8782 elsif Nkind (N) = N_Expression_With_Actions
8783 and then Is_Empty_List (Actions (N))
8785 return Has_No_Obvious_Side_Effects (Expression (N));
8787 elsif Nkind (N) in N_Has_Entity then
8788 return Present (Entity (N))
8789 and then Ekind_In (Entity (N), E_Variable,
8791 E_Enumeration_Literal,
8795 and then not Is_Volatile (Entity (N));
8800 end Has_No_Obvious_Side_Effects;
8802 ------------------------
8803 -- Has_Null_Exclusion --
8804 ------------------------
8806 function Has_Null_Exclusion (N : Node_Id) return Boolean is
8809 when N_Access_Definition |
8810 N_Access_Function_Definition |
8811 N_Access_Procedure_Definition |
8812 N_Access_To_Object_Definition |
8814 N_Derived_Type_Definition |
8815 N_Function_Specification |
8816 N_Subtype_Declaration =>
8817 return Null_Exclusion_Present (N);
8819 when N_Component_Definition |
8820 N_Formal_Object_Declaration |
8821 N_Object_Renaming_Declaration =>
8822 if Present (Subtype_Mark (N)) then
8823 return Null_Exclusion_Present (N);
8824 else pragma Assert (Present (Access_Definition (N)));
8825 return Null_Exclusion_Present (Access_Definition (N));
8828 when N_Discriminant_Specification =>
8829 if Nkind (Discriminant_Type (N)) = N_Access_Definition then
8830 return Null_Exclusion_Present (Discriminant_Type (N));
8832 return Null_Exclusion_Present (N);
8835 when N_Object_Declaration =>
8836 if Nkind (Object_Definition (N)) = N_Access_Definition then
8837 return Null_Exclusion_Present (Object_Definition (N));
8839 return Null_Exclusion_Present (N);
8842 when N_Parameter_Specification =>
8843 if Nkind (Parameter_Type (N)) = N_Access_Definition then
8844 return Null_Exclusion_Present (Parameter_Type (N));
8846 return Null_Exclusion_Present (N);
8853 end Has_Null_Exclusion;
8855 ------------------------
8856 -- Has_Null_Extension --
8857 ------------------------
8859 function Has_Null_Extension (T : Entity_Id) return Boolean is
8860 B : constant Entity_Id := Base_Type (T);
8865 if Nkind (Parent (B)) = N_Full_Type_Declaration
8866 and then Present (Record_Extension_Part (Type_Definition (Parent (B))))
8868 Ext := Record_Extension_Part (Type_Definition (Parent (B)));
8870 if Present (Ext) then
8871 if Null_Present (Ext) then
8874 Comps := Component_List (Ext);
8876 -- The null component list is rewritten during analysis to
8877 -- include the parent component. Any other component indicates
8878 -- that the extension was not originally null.
8880 return Null_Present (Comps)
8881 or else No (Next (First (Component_Items (Comps))));
8890 end Has_Null_Extension;
8892 -------------------------------
8893 -- Has_Overriding_Initialize --
8894 -------------------------------
8896 function Has_Overriding_Initialize (T : Entity_Id) return Boolean is
8897 BT : constant Entity_Id := Base_Type (T);
8901 if Is_Controlled (BT) then
8902 if Is_RTU (Scope (BT), Ada_Finalization) then
8905 elsif Present (Primitive_Operations (BT)) then
8906 P := First_Elmt (Primitive_Operations (BT));
8907 while Present (P) loop
8909 Init : constant Entity_Id := Node (P);
8910 Formal : constant Entity_Id := First_Formal (Init);
8912 if Ekind (Init) = E_Procedure
8913 and then Chars (Init) = Name_Initialize
8914 and then Comes_From_Source (Init)
8915 and then Present (Formal)
8916 and then Etype (Formal) = BT
8917 and then No (Next_Formal (Formal))
8918 and then (Ada_Version < Ada_2012
8919 or else not Null_Present (Parent (Init)))
8929 -- Here if type itself does not have a non-null Initialize operation:
8930 -- check immediate ancestor.
8932 if Is_Derived_Type (BT)
8933 and then Has_Overriding_Initialize (Etype (BT))
8940 end Has_Overriding_Initialize;
8942 --------------------------------------
8943 -- Has_Preelaborable_Initialization --
8944 --------------------------------------
8946 function Has_Preelaborable_Initialization (E : Entity_Id) return Boolean is
8949 procedure Check_Components (E : Entity_Id);
8950 -- Check component/discriminant chain, sets Has_PE False if a component
8951 -- or discriminant does not meet the preelaborable initialization rules.
8953 ----------------------
8954 -- Check_Components --
8955 ----------------------
8957 procedure Check_Components (E : Entity_Id) is
8961 function Is_Preelaborable_Expression (N : Node_Id) return Boolean;
8962 -- Returns True if and only if the expression denoted by N does not
8963 -- violate restrictions on preelaborable constructs (RM-10.2.1(5-9)).
8965 ---------------------------------
8966 -- Is_Preelaborable_Expression --
8967 ---------------------------------
8969 function Is_Preelaborable_Expression (N : Node_Id) return Boolean is
8973 Comp_Type : Entity_Id;
8974 Is_Array_Aggr : Boolean;
8977 if Is_OK_Static_Expression (N) then
8980 elsif Nkind (N) = N_Null then
8983 -- Attributes are allowed in general, even if their prefix is a
8984 -- formal type. (It seems that certain attributes known not to be
8985 -- static might not be allowed, but there are no rules to prevent
8988 elsif Nkind (N) = N_Attribute_Reference then
8991 -- The name of a discriminant evaluated within its parent type is
8992 -- defined to be preelaborable (10.2.1(8)). Note that we test for
8993 -- names that denote discriminals as well as discriminants to
8994 -- catch references occurring within init procs.
8996 elsif Is_Entity_Name (N)
8998 (Ekind (Entity (N)) = E_Discriminant
8999 or else (Ekind_In (Entity (N), E_Constant, E_In_Parameter)
9000 and then Present (Discriminal_Link (Entity (N)))))
9004 elsif Nkind (N) = N_Qualified_Expression then
9005 return Is_Preelaborable_Expression (Expression (N));
9007 -- For aggregates we have to check that each of the associations
9008 -- is preelaborable.
9010 elsif Nkind_In (N, N_Aggregate, N_Extension_Aggregate) then
9011 Is_Array_Aggr := Is_Array_Type (Etype (N));
9013 if Is_Array_Aggr then
9014 Comp_Type := Component_Type (Etype (N));
9017 -- Check the ancestor part of extension aggregates, which must
9018 -- be either the name of a type that has preelaborable init or
9019 -- an expression that is preelaborable.
9021 if Nkind (N) = N_Extension_Aggregate then
9023 Anc_Part : constant Node_Id := Ancestor_Part (N);
9026 if Is_Entity_Name (Anc_Part)
9027 and then Is_Type (Entity (Anc_Part))
9029 if not Has_Preelaborable_Initialization
9035 elsif not Is_Preelaborable_Expression (Anc_Part) then
9041 -- Check positional associations
9043 Exp := First (Expressions (N));
9044 while Present (Exp) loop
9045 if not Is_Preelaborable_Expression (Exp) then
9052 -- Check named associations
9054 Assn := First (Component_Associations (N));
9055 while Present (Assn) loop
9056 Choice := First (Choices (Assn));
9057 while Present (Choice) loop
9058 if Is_Array_Aggr then
9059 if Nkind (Choice) = N_Others_Choice then
9062 elsif Nkind (Choice) = N_Range then
9063 if not Is_OK_Static_Range (Choice) then
9067 elsif not Is_OK_Static_Expression (Choice) then
9072 Comp_Type := Etype (Choice);
9078 -- If the association has a <> at this point, then we have
9079 -- to check whether the component's type has preelaborable
9080 -- initialization. Note that this only occurs when the
9081 -- association's corresponding component does not have a
9082 -- default expression, the latter case having already been
9083 -- expanded as an expression for the association.
9085 if Box_Present (Assn) then
9086 if not Has_Preelaborable_Initialization (Comp_Type) then
9090 -- In the expression case we check whether the expression
9091 -- is preelaborable.
9094 not Is_Preelaborable_Expression (Expression (Assn))
9102 -- If we get here then aggregate as a whole is preelaborable
9106 -- All other cases are not preelaborable
9111 end Is_Preelaborable_Expression;
9113 -- Start of processing for Check_Components
9116 -- Loop through entities of record or protected type
9119 while Present (Ent) loop
9121 -- We are interested only in components and discriminants
9128 -- Get default expression if any. If there is no declaration
9129 -- node, it means we have an internal entity. The parent and
9130 -- tag fields are examples of such entities. For such cases,
9131 -- we just test the type of the entity.
9133 if Present (Declaration_Node (Ent)) then
9134 Exp := Expression (Declaration_Node (Ent));
9137 when E_Discriminant =>
9139 -- Note: for a renamed discriminant, the Declaration_Node
9140 -- may point to the one from the ancestor, and have a
9141 -- different expression, so use the proper attribute to
9142 -- retrieve the expression from the derived constraint.
9144 Exp := Discriminant_Default_Value (Ent);
9147 goto Check_Next_Entity;
9150 -- A component has PI if it has no default expression and the
9151 -- component type has PI.
9154 if not Has_Preelaborable_Initialization (Etype (Ent)) then
9159 -- Require the default expression to be preelaborable
9161 elsif not Is_Preelaborable_Expression (Exp) then
9166 <<Check_Next_Entity>>
9169 end Check_Components;
9171 -- Start of processing for Has_Preelaborable_Initialization
9174 -- Immediate return if already marked as known preelaborable init. This
9175 -- covers types for which this function has already been called once
9176 -- and returned True (in which case the result is cached), and also
9177 -- types to which a pragma Preelaborable_Initialization applies.
9179 if Known_To_Have_Preelab_Init (E) then
9183 -- If the type is a subtype representing a generic actual type, then
9184 -- test whether its base type has preelaborable initialization since
9185 -- the subtype representing the actual does not inherit this attribute
9186 -- from the actual or formal. (but maybe it should???)
9188 if Is_Generic_Actual_Type (E) then
9189 return Has_Preelaborable_Initialization (Base_Type (E));
9192 -- All elementary types have preelaborable initialization
9194 if Is_Elementary_Type (E) then
9197 -- Array types have PI if the component type has PI
9199 elsif Is_Array_Type (E) then
9200 Has_PE := Has_Preelaborable_Initialization (Component_Type (E));
9202 -- A derived type has preelaborable initialization if its parent type
9203 -- has preelaborable initialization and (in the case of a derived record
9204 -- extension) if the non-inherited components all have preelaborable
9205 -- initialization. However, a user-defined controlled type with an
9206 -- overriding Initialize procedure does not have preelaborable
9209 elsif Is_Derived_Type (E) then
9211 -- If the derived type is a private extension then it doesn't have
9212 -- preelaborable initialization.
9214 if Ekind (Base_Type (E)) = E_Record_Type_With_Private then
9218 -- First check whether ancestor type has preelaborable initialization
9220 Has_PE := Has_Preelaborable_Initialization (Etype (Base_Type (E)));
9222 -- If OK, check extension components (if any)
9224 if Has_PE and then Is_Record_Type (E) then
9225 Check_Components (First_Entity (E));
9228 -- Check specifically for 10.2.1(11.4/2) exception: a controlled type
9229 -- with a user defined Initialize procedure does not have PI. If
9230 -- the type is untagged, the control primitives come from a component
9231 -- that has already been checked.
9234 and then Is_Controlled (E)
9235 and then Is_Tagged_Type (E)
9236 and then Has_Overriding_Initialize (E)
9241 -- Private types not derived from a type having preelaborable init and
9242 -- that are not marked with pragma Preelaborable_Initialization do not
9243 -- have preelaborable initialization.
9245 elsif Is_Private_Type (E) then
9248 -- Record type has PI if it is non private and all components have PI
9250 elsif Is_Record_Type (E) then
9252 Check_Components (First_Entity (E));
9254 -- Protected types must not have entries, and components must meet
9255 -- same set of rules as for record components.
9257 elsif Is_Protected_Type (E) then
9258 if Has_Entries (E) then
9262 Check_Components (First_Entity (E));
9263 Check_Components (First_Private_Entity (E));
9266 -- Type System.Address always has preelaborable initialization
9268 elsif Is_RTE (E, RE_Address) then
9271 -- In all other cases, type does not have preelaborable initialization
9277 -- If type has preelaborable initialization, cache result
9280 Set_Known_To_Have_Preelab_Init (E);
9284 end Has_Preelaborable_Initialization;
9286 ---------------------------
9287 -- Has_Private_Component --
9288 ---------------------------
9290 function Has_Private_Component (Type_Id : Entity_Id) return Boolean is
9291 Btype : Entity_Id := Base_Type (Type_Id);
9292 Component : Entity_Id;
9295 if Error_Posted (Type_Id)
9296 or else Error_Posted (Btype)
9301 if Is_Class_Wide_Type (Btype) then
9302 Btype := Root_Type (Btype);
9305 if Is_Private_Type (Btype) then
9307 UT : constant Entity_Id := Underlying_Type (Btype);
9310 if No (Full_View (Btype)) then
9311 return not Is_Generic_Type (Btype)
9313 not Is_Generic_Type (Root_Type (Btype));
9315 return not Is_Generic_Type (Root_Type (Full_View (Btype)));
9318 return not Is_Frozen (UT) and then Has_Private_Component (UT);
9322 elsif Is_Array_Type (Btype) then
9323 return Has_Private_Component (Component_Type (Btype));
9325 elsif Is_Record_Type (Btype) then
9326 Component := First_Component (Btype);
9327 while Present (Component) loop
9328 if Has_Private_Component (Etype (Component)) then
9332 Next_Component (Component);
9337 elsif Is_Protected_Type (Btype)
9338 and then Present (Corresponding_Record_Type (Btype))
9340 return Has_Private_Component (Corresponding_Record_Type (Btype));
9345 end Has_Private_Component;
9347 ----------------------
9348 -- Has_Signed_Zeros --
9349 ----------------------
9351 function Has_Signed_Zeros (E : Entity_Id) return Boolean is
9353 return Is_Floating_Point_Type (E) and then Signed_Zeros_On_Target;
9354 end Has_Signed_Zeros;
9356 ------------------------------
9357 -- Has_Significant_Contract --
9358 ------------------------------
9360 function Has_Significant_Contract (Subp_Id : Entity_Id) return Boolean is
9361 Subp_Nam : constant Name_Id := Chars (Subp_Id);
9364 -- _Finalizer procedure
9366 if Subp_Nam = Name_uFinalizer then
9369 -- _Postconditions procedure
9371 elsif Subp_Nam = Name_uPostconditions then
9374 -- Predicate function
9376 elsif Ekind (Subp_Id) = E_Function
9377 and then Is_Predicate_Function (Subp_Id)
9383 elsif Get_TSS_Name (Subp_Id) /= TSS_Null then
9389 end Has_Significant_Contract;
9391 -----------------------------
9392 -- Has_Static_Array_Bounds --
9393 -----------------------------
9395 function Has_Static_Array_Bounds (Typ : Node_Id) return Boolean is
9396 Ndims : constant Nat := Number_Dimensions (Typ);
9403 -- Unconstrained types do not have static bounds
9405 if not Is_Constrained (Typ) then
9409 -- First treat string literals specially, as the lower bound and length
9410 -- of string literals are not stored like those of arrays.
9412 -- A string literal always has static bounds
9414 if Ekind (Typ) = E_String_Literal_Subtype then
9418 -- Treat all dimensions in turn
9420 Index := First_Index (Typ);
9421 for Indx in 1 .. Ndims loop
9423 -- In case of an illegal index which is not a discrete type, return
9424 -- that the type is not static.
9426 if not Is_Discrete_Type (Etype (Index))
9427 or else Etype (Index) = Any_Type
9432 Get_Index_Bounds (Index, Low, High);
9434 if Error_Posted (Low) or else Error_Posted (High) then
9438 if Is_OK_Static_Expression (Low)
9440 Is_OK_Static_Expression (High)
9450 -- If we fall through the loop, all indexes matched
9453 end Has_Static_Array_Bounds;
9459 function Has_Stream (T : Entity_Id) return Boolean is
9466 elsif Is_RTE (Root_Type (T), RE_Root_Stream_Type) then
9469 elsif Is_Array_Type (T) then
9470 return Has_Stream (Component_Type (T));
9472 elsif Is_Record_Type (T) then
9473 E := First_Component (T);
9474 while Present (E) loop
9475 if Has_Stream (Etype (E)) then
9484 elsif Is_Private_Type (T) then
9485 return Has_Stream (Underlying_Type (T));
9496 function Has_Suffix (E : Entity_Id; Suffix : Character) return Boolean is
9498 Get_Name_String (Chars (E));
9499 return Name_Buffer (Name_Len) = Suffix;
9506 function Add_Suffix (E : Entity_Id; Suffix : Character) return Name_Id is
9508 Get_Name_String (Chars (E));
9509 Add_Char_To_Name_Buffer (Suffix);
9517 function Remove_Suffix (E : Entity_Id; Suffix : Character) return Name_Id is
9519 pragma Assert (Has_Suffix (E, Suffix));
9520 Get_Name_String (Chars (E));
9521 Name_Len := Name_Len - 1;
9525 --------------------------
9526 -- Has_Tagged_Component --
9527 --------------------------
9529 function Has_Tagged_Component (Typ : Entity_Id) return Boolean is
9533 if Is_Private_Type (Typ) and then Present (Underlying_Type (Typ)) then
9534 return Has_Tagged_Component (Underlying_Type (Typ));
9536 elsif Is_Array_Type (Typ) then
9537 return Has_Tagged_Component (Component_Type (Typ));
9539 elsif Is_Tagged_Type (Typ) then
9542 elsif Is_Record_Type (Typ) then
9543 Comp := First_Component (Typ);
9544 while Present (Comp) loop
9545 if Has_Tagged_Component (Etype (Comp)) then
9549 Next_Component (Comp);
9557 end Has_Tagged_Component;
9559 ----------------------------
9560 -- Has_Volatile_Component --
9561 ----------------------------
9563 function Has_Volatile_Component (Typ : Entity_Id) return Boolean is
9567 if Has_Volatile_Components (Typ) then
9570 elsif Is_Array_Type (Typ) then
9571 return Is_Volatile (Component_Type (Typ));
9573 elsif Is_Record_Type (Typ) then
9574 Comp := First_Component (Typ);
9575 while Present (Comp) loop
9576 if Is_Volatile_Object (Comp) then
9580 Comp := Next_Component (Comp);
9585 end Has_Volatile_Component;
9587 -------------------------
9588 -- Implementation_Kind --
9589 -------------------------
9591 function Implementation_Kind (Subp : Entity_Id) return Name_Id is
9592 Impl_Prag : constant Node_Id := Get_Rep_Pragma (Subp, Name_Implemented);
9595 pragma Assert (Present (Impl_Prag));
9596 Arg := Last (Pragma_Argument_Associations (Impl_Prag));
9597 return Chars (Get_Pragma_Arg (Arg));
9598 end Implementation_Kind;
9600 --------------------------
9601 -- Implements_Interface --
9602 --------------------------
9604 function Implements_Interface
9605 (Typ_Ent : Entity_Id;
9606 Iface_Ent : Entity_Id;
9607 Exclude_Parents : Boolean := False) return Boolean
9609 Ifaces_List : Elist_Id;
9611 Iface : Entity_Id := Base_Type (Iface_Ent);
9612 Typ : Entity_Id := Base_Type (Typ_Ent);
9615 if Is_Class_Wide_Type (Typ) then
9616 Typ := Root_Type (Typ);
9619 if not Has_Interfaces (Typ) then
9623 if Is_Class_Wide_Type (Iface) then
9624 Iface := Root_Type (Iface);
9627 Collect_Interfaces (Typ, Ifaces_List);
9629 Elmt := First_Elmt (Ifaces_List);
9630 while Present (Elmt) loop
9631 if Is_Ancestor (Node (Elmt), Typ, Use_Full_View => True)
9632 and then Exclude_Parents
9636 elsif Node (Elmt) = Iface then
9644 end Implements_Interface;
9646 ------------------------------------
9647 -- In_Assertion_Expression_Pragma --
9648 ------------------------------------
9650 function In_Assertion_Expression_Pragma (N : Node_Id) return Boolean is
9652 Prag : Node_Id := Empty;
9655 -- Climb the parent chain looking for an enclosing pragma
9658 while Present (Par) loop
9659 if Nkind (Par) = N_Pragma then
9663 -- Precondition-like pragmas are expanded into if statements, check
9664 -- the original node instead.
9666 elsif Nkind (Original_Node (Par)) = N_Pragma then
9667 Prag := Original_Node (Par);
9670 -- The expansion of attribute 'Old generates a constant to capture
9671 -- the result of the prefix. If the parent traversal reaches
9672 -- one of these constants, then the node technically came from a
9673 -- postcondition-like pragma. Note that the Ekind is not tested here
9674 -- because N may be the expression of an object declaration which is
9675 -- currently being analyzed. Such objects carry Ekind of E_Void.
9677 elsif Nkind (Par) = N_Object_Declaration
9678 and then Constant_Present (Par)
9679 and then Stores_Attribute_Old_Prefix (Defining_Entity (Par))
9683 -- Prevent the search from going too far
9685 elsif Is_Body_Or_Package_Declaration (Par) then
9689 Par := Parent (Par);
9694 and then Assertion_Expression_Pragma (Get_Pragma_Id (Prag));
9695 end In_Assertion_Expression_Pragma;
9701 function In_Instance return Boolean is
9702 Curr_Unit : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
9707 while Present (S) and then S /= Standard_Standard loop
9708 if Ekind_In (S, E_Function, E_Package, E_Procedure)
9709 and then Is_Generic_Instance (S)
9711 -- A child instance is always compiled in the context of a parent
9712 -- instance. Nevertheless, the actuals are not analyzed in an
9713 -- instance context. We detect this case by examining the current
9714 -- compilation unit, which must be a child instance, and checking
9715 -- that it is not currently on the scope stack.
9717 if Is_Child_Unit (Curr_Unit)
9718 and then Nkind (Unit (Cunit (Current_Sem_Unit))) =
9719 N_Package_Instantiation
9720 and then not In_Open_Scopes (Curr_Unit)
9734 ----------------------
9735 -- In_Instance_Body --
9736 ----------------------
9738 function In_Instance_Body return Boolean is
9743 while Present (S) and then S /= Standard_Standard loop
9744 if Ekind_In (S, E_Function, E_Procedure)
9745 and then Is_Generic_Instance (S)
9749 elsif Ekind (S) = E_Package
9750 and then In_Package_Body (S)
9751 and then Is_Generic_Instance (S)
9760 end In_Instance_Body;
9762 -----------------------------
9763 -- In_Instance_Not_Visible --
9764 -----------------------------
9766 function In_Instance_Not_Visible return Boolean is
9771 while Present (S) and then S /= Standard_Standard loop
9772 if Ekind_In (S, E_Function, E_Procedure)
9773 and then Is_Generic_Instance (S)
9777 elsif Ekind (S) = E_Package
9778 and then (In_Package_Body (S) or else In_Private_Part (S))
9779 and then Is_Generic_Instance (S)
9788 end In_Instance_Not_Visible;
9790 ------------------------------
9791 -- In_Instance_Visible_Part --
9792 ------------------------------
9794 function In_Instance_Visible_Part return Boolean is
9799 while Present (S) and then S /= Standard_Standard loop
9800 if Ekind (S) = E_Package
9801 and then Is_Generic_Instance (S)
9802 and then not In_Package_Body (S)
9803 and then not In_Private_Part (S)
9812 end In_Instance_Visible_Part;
9814 ---------------------
9815 -- In_Package_Body --
9816 ---------------------
9818 function In_Package_Body return Boolean is
9823 while Present (S) and then S /= Standard_Standard loop
9824 if Ekind (S) = E_Package and then In_Package_Body (S) then
9832 end In_Package_Body;
9834 --------------------------------
9835 -- In_Parameter_Specification --
9836 --------------------------------
9838 function In_Parameter_Specification (N : Node_Id) return Boolean is
9843 while Present (PN) loop
9844 if Nkind (PN) = N_Parameter_Specification then
9852 end In_Parameter_Specification;
9854 --------------------------
9855 -- In_Pragma_Expression --
9856 --------------------------
9858 function In_Pragma_Expression (N : Node_Id; Nam : Name_Id) return Boolean is
9865 elsif Nkind (P) = N_Pragma and then Pragma_Name (P) = Nam then
9871 end In_Pragma_Expression;
9873 -------------------------------------
9874 -- In_Reverse_Storage_Order_Object --
9875 -------------------------------------
9877 function In_Reverse_Storage_Order_Object (N : Node_Id) return Boolean is
9879 Btyp : Entity_Id := Empty;
9882 -- Climb up indexed components
9886 case Nkind (Pref) is
9887 when N_Selected_Component =>
9888 Pref := Prefix (Pref);
9891 when N_Indexed_Component =>
9892 Pref := Prefix (Pref);
9900 if Present (Pref) then
9901 Btyp := Base_Type (Etype (Pref));
9904 return Present (Btyp)
9905 and then (Is_Record_Type (Btyp) or else Is_Array_Type (Btyp))
9906 and then Reverse_Storage_Order (Btyp);
9907 end In_Reverse_Storage_Order_Object;
9909 --------------------------------------
9910 -- In_Subprogram_Or_Concurrent_Unit --
9911 --------------------------------------
9913 function In_Subprogram_Or_Concurrent_Unit return Boolean is
9918 -- Use scope chain to check successively outer scopes
9924 if K in Subprogram_Kind
9925 or else K in Concurrent_Kind
9926 or else K in Generic_Subprogram_Kind
9930 elsif E = Standard_Standard then
9936 end In_Subprogram_Or_Concurrent_Unit;
9938 ---------------------
9939 -- In_Visible_Part --
9940 ---------------------
9942 function In_Visible_Part (Scope_Id : Entity_Id) return Boolean is
9944 return Is_Package_Or_Generic_Package (Scope_Id)
9945 and then In_Open_Scopes (Scope_Id)
9946 and then not In_Package_Body (Scope_Id)
9947 and then not In_Private_Part (Scope_Id);
9948 end In_Visible_Part;
9950 --------------------------------
9951 -- Incomplete_Or_Partial_View --
9952 --------------------------------
9954 function Incomplete_Or_Partial_View (Id : Entity_Id) return Entity_Id is
9955 function Inspect_Decls
9957 Taft : Boolean := False) return Entity_Id;
9958 -- Check whether a declarative region contains the incomplete or partial
9965 function Inspect_Decls
9967 Taft : Boolean := False) return Entity_Id
9973 Decl := First (Decls);
9974 while Present (Decl) loop
9978 if Nkind (Decl) = N_Incomplete_Type_Declaration then
9979 Match := Defining_Identifier (Decl);
9983 if Nkind_In (Decl, N_Private_Extension_Declaration,
9984 N_Private_Type_Declaration)
9986 Match := Defining_Identifier (Decl);
9991 and then Present (Full_View (Match))
9992 and then Full_View (Match) = Id
10007 -- Start of processing for Incomplete_Or_Partial_View
10010 -- Deferred constant or incomplete type case
10012 Prev := Current_Entity_In_Scope (Id);
10015 and then (Is_Incomplete_Type (Prev) or else Ekind (Prev) = E_Constant)
10016 and then Present (Full_View (Prev))
10017 and then Full_View (Prev) = Id
10022 -- Private or Taft amendment type case
10025 Pkg : constant Entity_Id := Scope (Id);
10026 Pkg_Decl : Node_Id := Pkg;
10029 if Present (Pkg) and then Ekind (Pkg) = E_Package then
10030 while Nkind (Pkg_Decl) /= N_Package_Specification loop
10031 Pkg_Decl := Parent (Pkg_Decl);
10034 -- It is knows that Typ has a private view, look for it in the
10035 -- visible declarations of the enclosing scope. A special case
10036 -- of this is when the two views have been exchanged - the full
10037 -- appears earlier than the private.
10039 if Has_Private_Declaration (Id) then
10040 Prev := Inspect_Decls (Visible_Declarations (Pkg_Decl));
10042 -- Exchanged view case, look in the private declarations
10045 Prev := Inspect_Decls (Private_Declarations (Pkg_Decl));
10050 -- Otherwise if this is the package body, then Typ is a potential
10051 -- Taft amendment type. The incomplete view should be located in
10052 -- the private declarations of the enclosing scope.
10054 elsif In_Package_Body (Pkg) then
10055 return Inspect_Decls (Private_Declarations (Pkg_Decl), True);
10060 -- The type has no incomplete or private view
10063 end Incomplete_Or_Partial_View;
10065 -----------------------------------------
10066 -- Inherit_Default_Init_Cond_Procedure --
10067 -----------------------------------------
10069 procedure Inherit_Default_Init_Cond_Procedure (Typ : Entity_Id) is
10070 Par_Typ : constant Entity_Id := Etype (Typ);
10073 -- A derived type inherits the default initial condition procedure of
10074 -- its parent type.
10076 if No (Default_Init_Cond_Procedure (Typ)) then
10077 Set_Default_Init_Cond_Procedure
10078 (Typ, Default_Init_Cond_Procedure (Par_Typ));
10080 end Inherit_Default_Init_Cond_Procedure;
10082 ----------------------------
10083 -- Inherit_Rep_Item_Chain --
10084 ----------------------------
10086 procedure Inherit_Rep_Item_Chain (Typ : Entity_Id; From_Typ : Entity_Id) is
10087 From_Item : constant Node_Id := First_Rep_Item (From_Typ);
10088 Item : Node_Id := Empty;
10089 Last_Item : Node_Id := Empty;
10092 -- Reach the end of the destination type's chain (if any) and capture
10095 Item := First_Rep_Item (Typ);
10096 while Present (Item) loop
10098 -- Do not inherit a chain that has been inherited already
10100 if Item = From_Item then
10105 Item := Next_Rep_Item (Item);
10108 -- When the destination type has a rep item chain, the chain of the
10109 -- source type is appended to it.
10111 if Present (Last_Item) then
10112 Set_Next_Rep_Item (Last_Item, From_Item);
10114 -- Otherwise the destination type directly inherits the rep item chain
10115 -- of the source type (if any).
10118 Set_First_Rep_Item (Typ, From_Item);
10120 end Inherit_Rep_Item_Chain;
10122 ---------------------------------
10123 -- Inherit_Subprogram_Contract --
10124 ---------------------------------
10126 procedure Inherit_Subprogram_Contract
10128 From_Subp : Entity_Id)
10130 procedure Inherit_Pragma (Prag_Id : Pragma_Id);
10131 -- Propagate a pragma denoted by Prag_Id from From_Subp's contract to
10132 -- Subp's contract.
10134 --------------------
10135 -- Inherit_Pragma --
10136 --------------------
10138 procedure Inherit_Pragma (Prag_Id : Pragma_Id) is
10139 Prag : constant Node_Id := Get_Pragma (From_Subp, Prag_Id);
10140 New_Prag : Node_Id;
10143 -- A pragma cannot be part of more than one First_Pragma/Next_Pragma
10144 -- chains, therefore the node must be replicated. The new pragma is
10145 -- flagged is inherited for distrinction purposes.
10147 if Present (Prag) then
10148 New_Prag := New_Copy_Tree (Prag);
10149 Set_Is_Inherited (New_Prag);
10151 Add_Contract_Item (New_Prag, Subp);
10153 end Inherit_Pragma;
10155 -- Start of processing for Inherit_Subprogram_Contract
10158 -- Inheritance is carried out only when both entities are subprograms
10161 if Is_Subprogram_Or_Generic_Subprogram (Subp)
10162 and then Is_Subprogram_Or_Generic_Subprogram (From_Subp)
10163 and then Present (Contract (From_Subp))
10165 Inherit_Pragma (Pragma_Extensions_Visible);
10167 end Inherit_Subprogram_Contract;
10169 ---------------------------------
10170 -- Insert_Explicit_Dereference --
10171 ---------------------------------
10173 procedure Insert_Explicit_Dereference (N : Node_Id) is
10174 New_Prefix : constant Node_Id := Relocate_Node (N);
10175 Ent : Entity_Id := Empty;
10182 Save_Interps (N, New_Prefix);
10185 Make_Explicit_Dereference (Sloc (Parent (N)),
10186 Prefix => New_Prefix));
10188 Set_Etype (N, Designated_Type (Etype (New_Prefix)));
10190 if Is_Overloaded (New_Prefix) then
10192 -- The dereference is also overloaded, and its interpretations are
10193 -- the designated types of the interpretations of the original node.
10195 Set_Etype (N, Any_Type);
10197 Get_First_Interp (New_Prefix, I, It);
10198 while Present (It.Nam) loop
10201 if Is_Access_Type (T) then
10202 Add_One_Interp (N, Designated_Type (T), Designated_Type (T));
10205 Get_Next_Interp (I, It);
10211 -- Prefix is unambiguous: mark the original prefix (which might
10212 -- Come_From_Source) as a reference, since the new (relocated) one
10213 -- won't be taken into account.
10215 if Is_Entity_Name (New_Prefix) then
10216 Ent := Entity (New_Prefix);
10217 Pref := New_Prefix;
10219 -- For a retrieval of a subcomponent of some composite object,
10220 -- retrieve the ultimate entity if there is one.
10222 elsif Nkind_In (New_Prefix, N_Selected_Component,
10223 N_Indexed_Component)
10225 Pref := Prefix (New_Prefix);
10226 while Present (Pref)
10227 and then Nkind_In (Pref, N_Selected_Component,
10228 N_Indexed_Component)
10230 Pref := Prefix (Pref);
10233 if Present (Pref) and then Is_Entity_Name (Pref) then
10234 Ent := Entity (Pref);
10238 -- Place the reference on the entity node
10240 if Present (Ent) then
10241 Generate_Reference (Ent, Pref);
10244 end Insert_Explicit_Dereference;
10246 ------------------------------------------
10247 -- Inspect_Deferred_Constant_Completion --
10248 ------------------------------------------
10250 procedure Inspect_Deferred_Constant_Completion (Decls : List_Id) is
10254 Decl := First (Decls);
10255 while Present (Decl) loop
10257 -- Deferred constant signature
10259 if Nkind (Decl) = N_Object_Declaration
10260 and then Constant_Present (Decl)
10261 and then No (Expression (Decl))
10263 -- No need to check internally generated constants
10265 and then Comes_From_Source (Decl)
10267 -- The constant is not completed. A full object declaration or a
10268 -- pragma Import complete a deferred constant.
10270 and then not Has_Completion (Defining_Identifier (Decl))
10273 ("constant declaration requires initialization expression",
10274 Defining_Identifier (Decl));
10277 Decl := Next (Decl);
10279 end Inspect_Deferred_Constant_Completion;
10281 -----------------------------
10282 -- Install_Generic_Formals --
10283 -----------------------------
10285 procedure Install_Generic_Formals (Subp_Id : Entity_Id) is
10289 pragma Assert (Is_Generic_Subprogram (Subp_Id));
10291 E := First_Entity (Subp_Id);
10292 while Present (E) loop
10293 Install_Entity (E);
10296 end Install_Generic_Formals;
10298 -----------------------------
10299 -- Is_Actual_Out_Parameter --
10300 -----------------------------
10302 function Is_Actual_Out_Parameter (N : Node_Id) return Boolean is
10303 Formal : Entity_Id;
10306 Find_Actual (N, Formal, Call);
10307 return Present (Formal) and then Ekind (Formal) = E_Out_Parameter;
10308 end Is_Actual_Out_Parameter;
10310 -------------------------
10311 -- Is_Actual_Parameter --
10312 -------------------------
10314 function Is_Actual_Parameter (N : Node_Id) return Boolean is
10315 PK : constant Node_Kind := Nkind (Parent (N));
10319 when N_Parameter_Association =>
10320 return N = Explicit_Actual_Parameter (Parent (N));
10322 when N_Subprogram_Call =>
10323 return Is_List_Member (N)
10325 List_Containing (N) = Parameter_Associations (Parent (N));
10330 end Is_Actual_Parameter;
10332 --------------------------------
10333 -- Is_Actual_Tagged_Parameter --
10334 --------------------------------
10336 function Is_Actual_Tagged_Parameter (N : Node_Id) return Boolean is
10337 Formal : Entity_Id;
10340 Find_Actual (N, Formal, Call);
10341 return Present (Formal) and then Is_Tagged_Type (Etype (Formal));
10342 end Is_Actual_Tagged_Parameter;
10344 ---------------------
10345 -- Is_Aliased_View --
10346 ---------------------
10348 function Is_Aliased_View (Obj : Node_Id) return Boolean is
10352 if Is_Entity_Name (Obj) then
10359 or else (Present (Renamed_Object (E))
10360 and then Is_Aliased_View (Renamed_Object (E)))))
10362 or else ((Is_Formal (E)
10363 or else Ekind_In (E, E_Generic_In_Out_Parameter,
10364 E_Generic_In_Parameter))
10365 and then Is_Tagged_Type (Etype (E)))
10367 or else (Is_Concurrent_Type (E) and then In_Open_Scopes (E))
10369 -- Current instance of type, either directly or as rewritten
10370 -- reference to the current object.
10372 or else (Is_Entity_Name (Original_Node (Obj))
10373 and then Present (Entity (Original_Node (Obj)))
10374 and then Is_Type (Entity (Original_Node (Obj))))
10376 or else (Is_Type (E) and then E = Current_Scope)
10378 or else (Is_Incomplete_Or_Private_Type (E)
10379 and then Full_View (E) = Current_Scope)
10381 -- Ada 2012 AI05-0053: the return object of an extended return
10382 -- statement is aliased if its type is immutably limited.
10384 or else (Is_Return_Object (E)
10385 and then Is_Limited_View (Etype (E)));
10387 elsif Nkind (Obj) = N_Selected_Component then
10388 return Is_Aliased (Entity (Selector_Name (Obj)));
10390 elsif Nkind (Obj) = N_Indexed_Component then
10391 return Has_Aliased_Components (Etype (Prefix (Obj)))
10393 (Is_Access_Type (Etype (Prefix (Obj)))
10394 and then Has_Aliased_Components
10395 (Designated_Type (Etype (Prefix (Obj)))));
10397 elsif Nkind_In (Obj, N_Unchecked_Type_Conversion, N_Type_Conversion) then
10398 return Is_Tagged_Type (Etype (Obj))
10399 and then Is_Aliased_View (Expression (Obj));
10401 elsif Nkind (Obj) = N_Explicit_Dereference then
10402 return Nkind (Original_Node (Obj)) /= N_Function_Call;
10407 end Is_Aliased_View;
10409 -------------------------
10410 -- Is_Ancestor_Package --
10411 -------------------------
10413 function Is_Ancestor_Package
10415 E2 : Entity_Id) return Boolean
10421 while Present (Par) and then Par /= Standard_Standard loop
10426 Par := Scope (Par);
10430 end Is_Ancestor_Package;
10432 ----------------------
10433 -- Is_Atomic_Object --
10434 ----------------------
10436 function Is_Atomic_Object (N : Node_Id) return Boolean is
10438 function Object_Has_Atomic_Components (N : Node_Id) return Boolean;
10439 -- Determines if given object has atomic components
10441 function Is_Atomic_Prefix (N : Node_Id) return Boolean;
10442 -- If prefix is an implicit dereference, examine designated type
10444 ----------------------
10445 -- Is_Atomic_Prefix --
10446 ----------------------
10448 function Is_Atomic_Prefix (N : Node_Id) return Boolean is
10450 if Is_Access_Type (Etype (N)) then
10452 Has_Atomic_Components (Designated_Type (Etype (N)));
10454 return Object_Has_Atomic_Components (N);
10456 end Is_Atomic_Prefix;
10458 ----------------------------------
10459 -- Object_Has_Atomic_Components --
10460 ----------------------------------
10462 function Object_Has_Atomic_Components (N : Node_Id) return Boolean is
10464 if Has_Atomic_Components (Etype (N))
10465 or else Is_Atomic (Etype (N))
10469 elsif Is_Entity_Name (N)
10470 and then (Has_Atomic_Components (Entity (N))
10471 or else Is_Atomic (Entity (N)))
10475 elsif Nkind (N) = N_Selected_Component
10476 and then Is_Atomic (Entity (Selector_Name (N)))
10480 elsif Nkind (N) = N_Indexed_Component
10481 or else Nkind (N) = N_Selected_Component
10483 return Is_Atomic_Prefix (Prefix (N));
10488 end Object_Has_Atomic_Components;
10490 -- Start of processing for Is_Atomic_Object
10493 -- Predicate is not relevant to subprograms
10495 if Is_Entity_Name (N) and then Is_Overloadable (Entity (N)) then
10498 elsif Is_Atomic (Etype (N))
10499 or else (Is_Entity_Name (N) and then Is_Atomic (Entity (N)))
10503 elsif Nkind (N) = N_Selected_Component
10504 and then Is_Atomic (Entity (Selector_Name (N)))
10508 elsif Nkind (N) = N_Indexed_Component
10509 or else Nkind (N) = N_Selected_Component
10511 return Is_Atomic_Prefix (Prefix (N));
10516 end Is_Atomic_Object;
10518 -----------------------------
10519 -- Is_Atomic_Or_VFA_Object --
10520 -----------------------------
10522 function Is_Atomic_Or_VFA_Object (N : Node_Id) return Boolean is
10524 return Is_Atomic_Object (N)
10525 or else (Is_Object_Reference (N)
10526 and then Is_Entity_Name (N)
10527 and then (Is_Volatile_Full_Access (Entity (N))
10529 Is_Volatile_Full_Access (Etype (Entity (N)))));
10530 end Is_Atomic_Or_VFA_Object;
10532 -------------------------
10533 -- Is_Attribute_Result --
10534 -------------------------
10536 function Is_Attribute_Result (N : Node_Id) return Boolean is
10538 return Nkind (N) = N_Attribute_Reference
10539 and then Attribute_Name (N) = Name_Result;
10540 end Is_Attribute_Result;
10542 -------------------------
10543 -- Is_Attribute_Update --
10544 -------------------------
10546 function Is_Attribute_Update (N : Node_Id) return Boolean is
10548 return Nkind (N) = N_Attribute_Reference
10549 and then Attribute_Name (N) = Name_Update;
10550 end Is_Attribute_Update;
10552 ------------------------------------
10553 -- Is_Body_Or_Package_Declaration --
10554 ------------------------------------
10556 function Is_Body_Or_Package_Declaration (N : Node_Id) return Boolean is
10558 return Nkind_In (N, N_Entry_Body,
10560 N_Package_Declaration,
10564 end Is_Body_Or_Package_Declaration;
10566 -----------------------
10567 -- Is_Bounded_String --
10568 -----------------------
10570 function Is_Bounded_String (T : Entity_Id) return Boolean is
10571 Under : constant Entity_Id := Underlying_Type (Root_Type (T));
10574 -- Check whether T is ultimately derived from Ada.Strings.Superbounded.
10575 -- Super_String, or one of the [Wide_]Wide_ versions. This will
10576 -- be True for all the Bounded_String types in instances of the
10577 -- Generic_Bounded_Length generics, and for types derived from those.
10579 return Present (Under)
10580 and then (Is_RTE (Root_Type (Under), RO_SU_Super_String) or else
10581 Is_RTE (Root_Type (Under), RO_WI_Super_String) or else
10582 Is_RTE (Root_Type (Under), RO_WW_Super_String));
10583 end Is_Bounded_String;
10585 -------------------------
10586 -- Is_Child_Or_Sibling --
10587 -------------------------
10589 function Is_Child_Or_Sibling
10590 (Pack_1 : Entity_Id;
10591 Pack_2 : Entity_Id) return Boolean
10593 function Distance_From_Standard (Pack : Entity_Id) return Nat;
10594 -- Given an arbitrary package, return the number of "climbs" necessary
10595 -- to reach scope Standard_Standard.
10597 procedure Equalize_Depths
10598 (Pack : in out Entity_Id;
10599 Depth : in out Nat;
10600 Depth_To_Reach : Nat);
10601 -- Given an arbitrary package, its depth and a target depth to reach,
10602 -- climb the scope chain until the said depth is reached. The pointer
10603 -- to the package and its depth a modified during the climb.
10605 ----------------------------
10606 -- Distance_From_Standard --
10607 ----------------------------
10609 function Distance_From_Standard (Pack : Entity_Id) return Nat is
10616 while Present (Scop) and then Scop /= Standard_Standard loop
10618 Scop := Scope (Scop);
10622 end Distance_From_Standard;
10624 ---------------------
10625 -- Equalize_Depths --
10626 ---------------------
10628 procedure Equalize_Depths
10629 (Pack : in out Entity_Id;
10630 Depth : in out Nat;
10631 Depth_To_Reach : Nat)
10634 -- The package must be at a greater or equal depth
10636 if Depth < Depth_To_Reach then
10637 raise Program_Error;
10640 -- Climb the scope chain until the desired depth is reached
10642 while Present (Pack) and then Depth /= Depth_To_Reach loop
10643 Pack := Scope (Pack);
10644 Depth := Depth - 1;
10646 end Equalize_Depths;
10650 P_1 : Entity_Id := Pack_1;
10651 P_1_Child : Boolean := False;
10652 P_1_Depth : Nat := Distance_From_Standard (P_1);
10653 P_2 : Entity_Id := Pack_2;
10654 P_2_Child : Boolean := False;
10655 P_2_Depth : Nat := Distance_From_Standard (P_2);
10657 -- Start of processing for Is_Child_Or_Sibling
10661 (Ekind (Pack_1) = E_Package and then Ekind (Pack_2) = E_Package);
10663 -- Both packages denote the same entity, therefore they cannot be
10664 -- children or siblings.
10669 -- One of the packages is at a deeper level than the other. Note that
10670 -- both may still come from differen hierarchies.
10678 elsif P_1_Depth > P_2_Depth then
10681 Depth => P_1_Depth,
10682 Depth_To_Reach => P_2_Depth);
10691 elsif P_2_Depth > P_1_Depth then
10694 Depth => P_2_Depth,
10695 Depth_To_Reach => P_1_Depth);
10699 -- At this stage the package pointers have been elevated to the same
10700 -- depth. If the related entities are the same, then one package is a
10701 -- potential child of the other:
10705 -- X became P_1 P_2 or vica versa
10711 return Is_Child_Unit (Pack_1);
10713 else pragma Assert (P_2_Child);
10714 return Is_Child_Unit (Pack_2);
10717 -- The packages may come from the same package chain or from entirely
10718 -- different hierarcies. To determine this, climb the scope stack until
10719 -- a common root is found.
10721 -- (root) (root 1) (root 2)
10726 while Present (P_1) and then Present (P_2) loop
10728 -- The two packages may be siblings
10731 return Is_Child_Unit (Pack_1) and then Is_Child_Unit (Pack_2);
10734 P_1 := Scope (P_1);
10735 P_2 := Scope (P_2);
10740 end Is_Child_Or_Sibling;
10742 -----------------------------
10743 -- Is_Concurrent_Interface --
10744 -----------------------------
10746 function Is_Concurrent_Interface (T : Entity_Id) return Boolean is
10748 return Is_Interface (T)
10750 (Is_Protected_Interface (T)
10751 or else Is_Synchronized_Interface (T)
10752 or else Is_Task_Interface (T));
10753 end Is_Concurrent_Interface;
10755 -----------------------
10756 -- Is_Constant_Bound --
10757 -----------------------
10759 function Is_Constant_Bound (Exp : Node_Id) return Boolean is
10761 if Compile_Time_Known_Value (Exp) then
10764 elsif Is_Entity_Name (Exp) and then Present (Entity (Exp)) then
10765 return Is_Constant_Object (Entity (Exp))
10766 or else Ekind (Entity (Exp)) = E_Enumeration_Literal;
10768 elsif Nkind (Exp) in N_Binary_Op then
10769 return Is_Constant_Bound (Left_Opnd (Exp))
10770 and then Is_Constant_Bound (Right_Opnd (Exp))
10771 and then Scope (Entity (Exp)) = Standard_Standard;
10776 end Is_Constant_Bound;
10778 ---------------------------
10779 -- Is_Container_Element --
10780 ---------------------------
10782 function Is_Container_Element (Exp : Node_Id) return Boolean is
10783 Loc : constant Source_Ptr := Sloc (Exp);
10784 Pref : constant Node_Id := Prefix (Exp);
10787 -- Call to an indexing aspect
10789 Cont_Typ : Entity_Id;
10790 -- The type of the container being accessed
10792 Elem_Typ : Entity_Id;
10793 -- Its element type
10795 Indexing : Entity_Id;
10796 Is_Const : Boolean;
10797 -- Indicates that constant indexing is used, and the element is thus
10800 Ref_Typ : Entity_Id;
10801 -- The reference type returned by the indexing operation
10804 -- If C is a container, in a context that imposes the element type of
10805 -- that container, the indexing notation C (X) is rewritten as:
10807 -- Indexing (C, X).Discr.all
10809 -- where Indexing is one of the indexing aspects of the container.
10810 -- If the context does not require a reference, the construct can be
10815 -- First, verify that the construct has the proper form
10817 if not Expander_Active then
10820 elsif Nkind (Pref) /= N_Selected_Component then
10823 elsif Nkind (Prefix (Pref)) /= N_Function_Call then
10827 Call := Prefix (Pref);
10828 Ref_Typ := Etype (Call);
10831 if not Has_Implicit_Dereference (Ref_Typ)
10832 or else No (First (Parameter_Associations (Call)))
10833 or else not Is_Entity_Name (Name (Call))
10838 -- Retrieve type of container object, and its iterator aspects
10840 Cont_Typ := Etype (First (Parameter_Associations (Call)));
10841 Indexing := Find_Value_Of_Aspect (Cont_Typ, Aspect_Constant_Indexing);
10844 if No (Indexing) then
10846 -- Container should have at least one indexing operation
10850 elsif Entity (Name (Call)) /= Entity (Indexing) then
10852 -- This may be a variable indexing operation
10854 Indexing := Find_Value_Of_Aspect (Cont_Typ, Aspect_Variable_Indexing);
10857 or else Entity (Name (Call)) /= Entity (Indexing)
10866 Elem_Typ := Find_Value_Of_Aspect (Cont_Typ, Aspect_Iterator_Element);
10868 if No (Elem_Typ) or else Entity (Elem_Typ) /= Etype (Exp) then
10872 -- Check that the expression is not the target of an assignment, in
10873 -- which case the rewriting is not possible.
10875 if not Is_Const then
10881 while Present (Par)
10883 if Nkind (Parent (Par)) = N_Assignment_Statement
10884 and then Par = Name (Parent (Par))
10888 -- A renaming produces a reference, and the transformation
10891 elsif Nkind (Parent (Par)) = N_Object_Renaming_Declaration then
10895 (Nkind (Parent (Par)), N_Function_Call,
10896 N_Procedure_Call_Statement,
10897 N_Entry_Call_Statement)
10899 -- Check that the element is not part of an actual for an
10900 -- in-out parameter.
10907 F := First_Formal (Entity (Name (Parent (Par))));
10908 A := First (Parameter_Associations (Parent (Par)));
10909 while Present (F) loop
10910 if A = Par and then Ekind (F) /= E_In_Parameter then
10919 -- E_In_Parameter in a call: element is not modified.
10924 Par := Parent (Par);
10929 -- The expression has the proper form and the context requires the
10930 -- element type. Retrieve the Element function of the container and
10931 -- rewrite the construct as a call to it.
10937 Op := First_Elmt (Primitive_Operations (Cont_Typ));
10938 while Present (Op) loop
10939 exit when Chars (Node (Op)) = Name_Element;
10948 Make_Function_Call (Loc,
10949 Name => New_Occurrence_Of (Node (Op), Loc),
10950 Parameter_Associations => Parameter_Associations (Call)));
10951 Analyze_And_Resolve (Exp, Entity (Elem_Typ));
10955 end Is_Container_Element;
10957 ----------------------------
10958 -- Is_Contract_Annotation --
10959 ----------------------------
10961 function Is_Contract_Annotation (Item : Node_Id) return Boolean is
10963 return Is_Package_Contract_Annotation (Item)
10965 Is_Subprogram_Contract_Annotation (Item);
10966 end Is_Contract_Annotation;
10968 --------------------------------------
10969 -- Is_Controlling_Limited_Procedure --
10970 --------------------------------------
10972 function Is_Controlling_Limited_Procedure
10973 (Proc_Nam : Entity_Id) return Boolean
10975 Param_Typ : Entity_Id := Empty;
10978 if Ekind (Proc_Nam) = E_Procedure
10979 and then Present (Parameter_Specifications (Parent (Proc_Nam)))
10981 Param_Typ := Etype (Parameter_Type (First (
10982 Parameter_Specifications (Parent (Proc_Nam)))));
10984 -- In this case where an Itype was created, the procedure call has been
10987 elsif Present (Associated_Node_For_Itype (Proc_Nam))
10988 and then Present (Original_Node (Associated_Node_For_Itype (Proc_Nam)))
10990 Present (Parameter_Associations
10991 (Associated_Node_For_Itype (Proc_Nam)))
10994 Etype (First (Parameter_Associations
10995 (Associated_Node_For_Itype (Proc_Nam))));
10998 if Present (Param_Typ) then
11000 Is_Interface (Param_Typ)
11001 and then Is_Limited_Record (Param_Typ);
11005 end Is_Controlling_Limited_Procedure;
11007 -----------------------------
11008 -- Is_CPP_Constructor_Call --
11009 -----------------------------
11011 function Is_CPP_Constructor_Call (N : Node_Id) return Boolean is
11013 return Nkind (N) = N_Function_Call
11014 and then Is_CPP_Class (Etype (Etype (N)))
11015 and then Is_Constructor (Entity (Name (N)))
11016 and then Is_Imported (Entity (Name (N)));
11017 end Is_CPP_Constructor_Call;
11019 -------------------------
11020 -- Is_Current_Instance --
11021 -------------------------
11023 function Is_Current_Instance (N : Node_Id) return Boolean is
11024 Typ : constant Entity_Id := Entity (N);
11028 -- Simplest case: entity is a concurrent type and we are currently
11029 -- inside the body. This will eventually be expanded into a
11030 -- call to Self (for tasks) or _object (for protected objects).
11032 if Is_Concurrent_Type (Typ) and then In_Open_Scopes (Typ) then
11036 -- Check whether the context is a (sub)type declaration for the
11040 while Present (P) loop
11041 if Nkind_In (P, N_Full_Type_Declaration,
11042 N_Private_Type_Declaration,
11043 N_Subtype_Declaration)
11044 and then Comes_From_Source (P)
11045 and then Defining_Entity (P) = Typ
11054 -- In any other context this is not a current occurrence
11057 end Is_Current_Instance;
11059 --------------------
11060 -- Is_Declaration --
11061 --------------------
11063 function Is_Declaration (N : Node_Id) return Boolean is
11066 when N_Abstract_Subprogram_Declaration |
11067 N_Exception_Declaration |
11068 N_Exception_Renaming_Declaration |
11069 N_Full_Type_Declaration |
11070 N_Generic_Function_Renaming_Declaration |
11071 N_Generic_Package_Declaration |
11072 N_Generic_Package_Renaming_Declaration |
11073 N_Generic_Procedure_Renaming_Declaration |
11074 N_Generic_Subprogram_Declaration |
11075 N_Number_Declaration |
11076 N_Object_Declaration |
11077 N_Object_Renaming_Declaration |
11078 N_Package_Declaration |
11079 N_Package_Renaming_Declaration |
11080 N_Private_Extension_Declaration |
11081 N_Private_Type_Declaration |
11082 N_Subprogram_Declaration |
11083 N_Subprogram_Renaming_Declaration |
11084 N_Subtype_Declaration =>
11090 end Is_Declaration;
11092 ----------------------------------------------
11093 -- Is_Dependent_Component_Of_Mutable_Object --
11094 ----------------------------------------------
11096 function Is_Dependent_Component_Of_Mutable_Object
11097 (Object : Node_Id) return Boolean
11099 function Is_Declared_Within_Variant (Comp : Entity_Id) return Boolean;
11100 -- Returns True if and only if Comp is declared within a variant part
11102 --------------------------------
11103 -- Is_Declared_Within_Variant --
11104 --------------------------------
11106 function Is_Declared_Within_Variant (Comp : Entity_Id) return Boolean is
11107 Comp_Decl : constant Node_Id := Parent (Comp);
11108 Comp_List : constant Node_Id := Parent (Comp_Decl);
11110 return Nkind (Parent (Comp_List)) = N_Variant;
11111 end Is_Declared_Within_Variant;
11114 Prefix_Type : Entity_Id;
11115 P_Aliased : Boolean := False;
11118 Deref : Node_Id := Object;
11119 -- Dereference node, in something like X.all.Y(2)
11121 -- Start of processing for Is_Dependent_Component_Of_Mutable_Object
11124 -- Find the dereference node if any
11126 while Nkind_In (Deref, N_Indexed_Component,
11127 N_Selected_Component,
11130 Deref := Prefix (Deref);
11133 -- Ada 2005: If we have a component or slice of a dereference,
11134 -- something like X.all.Y (2), and the type of X is access-to-constant,
11135 -- Is_Variable will return False, because it is indeed a constant
11136 -- view. But it might be a view of a variable object, so we want the
11137 -- following condition to be True in that case.
11139 if Is_Variable (Object)
11140 or else (Ada_Version >= Ada_2005
11141 and then Nkind (Deref) = N_Explicit_Dereference)
11143 if Nkind (Object) = N_Selected_Component then
11144 P := Prefix (Object);
11145 Prefix_Type := Etype (P);
11147 if Is_Entity_Name (P) then
11148 if Ekind (Entity (P)) = E_Generic_In_Out_Parameter then
11149 Prefix_Type := Base_Type (Prefix_Type);
11152 if Is_Aliased (Entity (P)) then
11156 -- A discriminant check on a selected component may be expanded
11157 -- into a dereference when removing side-effects. Recover the
11158 -- original node and its type, which may be unconstrained.
11160 elsif Nkind (P) = N_Explicit_Dereference
11161 and then not (Comes_From_Source (P))
11163 P := Original_Node (P);
11164 Prefix_Type := Etype (P);
11167 -- Check for prefix being an aliased component???
11173 -- A heap object is constrained by its initial value
11175 -- Ada 2005 (AI-363): Always assume the object could be mutable in
11176 -- the dereferenced case, since the access value might denote an
11177 -- unconstrained aliased object, whereas in Ada 95 the designated
11178 -- object is guaranteed to be constrained. A worst-case assumption
11179 -- has to apply in Ada 2005 because we can't tell at compile
11180 -- time whether the object is "constrained by its initial value"
11181 -- (despite the fact that 3.10.2(26/2) and 8.5.1(5/2) are semantic
11182 -- rules (these rules are acknowledged to need fixing).
11184 if Ada_Version < Ada_2005 then
11185 if Is_Access_Type (Prefix_Type)
11186 or else Nkind (P) = N_Explicit_Dereference
11191 else pragma Assert (Ada_Version >= Ada_2005);
11192 if Is_Access_Type (Prefix_Type) then
11194 -- If the access type is pool-specific, and there is no
11195 -- constrained partial view of the designated type, then the
11196 -- designated object is known to be constrained.
11198 if Ekind (Prefix_Type) = E_Access_Type
11199 and then not Object_Type_Has_Constrained_Partial_View
11200 (Typ => Designated_Type (Prefix_Type),
11201 Scop => Current_Scope)
11205 -- Otherwise (general access type, or there is a constrained
11206 -- partial view of the designated type), we need to check
11207 -- based on the designated type.
11210 Prefix_Type := Designated_Type (Prefix_Type);
11216 Original_Record_Component (Entity (Selector_Name (Object)));
11218 -- As per AI-0017, the renaming is illegal in a generic body, even
11219 -- if the subtype is indefinite.
11221 -- Ada 2005 (AI-363): In Ada 2005 an aliased object can be mutable
11223 if not Is_Constrained (Prefix_Type)
11224 and then (Is_Definite_Subtype (Prefix_Type)
11226 (Is_Generic_Type (Prefix_Type)
11227 and then Ekind (Current_Scope) = E_Generic_Package
11228 and then In_Package_Body (Current_Scope)))
11230 and then (Is_Declared_Within_Variant (Comp)
11231 or else Has_Discriminant_Dependent_Constraint (Comp))
11232 and then (not P_Aliased or else Ada_Version >= Ada_2005)
11236 -- If the prefix is of an access type at this point, then we want
11237 -- to return False, rather than calling this function recursively
11238 -- on the access object (which itself might be a discriminant-
11239 -- dependent component of some other object, but that isn't
11240 -- relevant to checking the object passed to us). This avoids
11241 -- issuing wrong errors when compiling with -gnatc, where there
11242 -- can be implicit dereferences that have not been expanded.
11244 elsif Is_Access_Type (Etype (Prefix (Object))) then
11249 Is_Dependent_Component_Of_Mutable_Object (Prefix (Object));
11252 elsif Nkind (Object) = N_Indexed_Component
11253 or else Nkind (Object) = N_Slice
11255 return Is_Dependent_Component_Of_Mutable_Object (Prefix (Object));
11257 -- A type conversion that Is_Variable is a view conversion:
11258 -- go back to the denoted object.
11260 elsif Nkind (Object) = N_Type_Conversion then
11262 Is_Dependent_Component_Of_Mutable_Object (Expression (Object));
11267 end Is_Dependent_Component_Of_Mutable_Object;
11269 ---------------------
11270 -- Is_Dereferenced --
11271 ---------------------
11273 function Is_Dereferenced (N : Node_Id) return Boolean is
11274 P : constant Node_Id := Parent (N);
11276 return Nkind_In (P, N_Selected_Component,
11277 N_Explicit_Dereference,
11278 N_Indexed_Component,
11280 and then Prefix (P) = N;
11281 end Is_Dereferenced;
11283 ----------------------
11284 -- Is_Descendent_Of --
11285 ----------------------
11287 function Is_Descendent_Of (T1 : Entity_Id; T2 : Entity_Id) return Boolean is
11292 pragma Assert (Nkind (T1) in N_Entity);
11293 pragma Assert (Nkind (T2) in N_Entity);
11295 T := Base_Type (T1);
11297 -- Immediate return if the types match
11302 -- Comment needed here ???
11304 elsif Ekind (T) = E_Class_Wide_Type then
11305 return Etype (T) = T2;
11313 -- Done if we found the type we are looking for
11318 -- Done if no more derivations to check
11325 -- Following test catches error cases resulting from prev errors
11327 elsif No (Etyp) then
11330 elsif Is_Private_Type (T) and then Etyp = Full_View (T) then
11333 elsif Is_Private_Type (Etyp) and then Full_View (Etyp) = T then
11337 T := Base_Type (Etyp);
11340 end Is_Descendent_Of;
11342 ---------------------------------------------
11343 -- Is_Double_Precision_Floating_Point_Type --
11344 ---------------------------------------------
11346 function Is_Double_Precision_Floating_Point_Type
11347 (E : Entity_Id) return Boolean is
11349 return Is_Floating_Point_Type (E)
11350 and then Machine_Radix_Value (E) = Uint_2
11351 and then Machine_Mantissa_Value (E) = UI_From_Int (53)
11352 and then Machine_Emax_Value (E) = Uint_2 ** Uint_10
11353 and then Machine_Emin_Value (E) = Uint_3 - (Uint_2 ** Uint_10);
11354 end Is_Double_Precision_Floating_Point_Type;
11356 -----------------------------
11357 -- Is_Effectively_Volatile --
11358 -----------------------------
11360 function Is_Effectively_Volatile (Id : Entity_Id) return Boolean is
11362 if Is_Type (Id) then
11364 -- An arbitrary type is effectively volatile when it is subject to
11365 -- pragma Atomic or Volatile.
11367 if Is_Volatile (Id) then
11370 -- An array type is effectively volatile when it is subject to pragma
11371 -- Atomic_Components or Volatile_Components or its compolent type is
11372 -- effectively volatile.
11374 elsif Is_Array_Type (Id) then
11376 Has_Volatile_Components (Id)
11378 Is_Effectively_Volatile (Component_Type (Base_Type (Id)));
11384 -- Otherwise Id denotes an object
11389 or else Has_Volatile_Components (Id)
11390 or else Is_Effectively_Volatile (Etype (Id));
11392 end Is_Effectively_Volatile;
11394 ------------------------------------
11395 -- Is_Effectively_Volatile_Object --
11396 ------------------------------------
11398 function Is_Effectively_Volatile_Object (N : Node_Id) return Boolean is
11400 if Is_Entity_Name (N) then
11401 return Is_Effectively_Volatile (Entity (N));
11403 elsif Nkind (N) = N_Expanded_Name then
11404 return Is_Effectively_Volatile (Entity (N));
11406 elsif Nkind (N) = N_Indexed_Component then
11407 return Is_Effectively_Volatile_Object (Prefix (N));
11409 elsif Nkind (N) = N_Selected_Component then
11411 Is_Effectively_Volatile_Object (Prefix (N))
11413 Is_Effectively_Volatile_Object (Selector_Name (N));
11418 end Is_Effectively_Volatile_Object;
11420 ----------------------------
11421 -- Is_Expression_Function --
11422 ----------------------------
11424 function Is_Expression_Function (Subp : Entity_Id) return Boolean is
11428 if Ekind (Subp) /= E_Function then
11432 Decl := Unit_Declaration_Node (Subp);
11433 return Nkind (Decl) = N_Subprogram_Declaration
11435 (Nkind (Original_Node (Decl)) = N_Expression_Function
11437 (Present (Corresponding_Body (Decl))
11439 Nkind (Original_Node
11440 (Unit_Declaration_Node
11441 (Corresponding_Body (Decl)))) =
11442 N_Expression_Function));
11444 end Is_Expression_Function;
11446 -----------------------
11447 -- Is_EVF_Expression --
11448 -----------------------
11450 function Is_EVF_Expression (N : Node_Id) return Boolean is
11451 Orig_N : constant Node_Id := Original_Node (N);
11457 -- Detect a reference to a formal parameter of a specific tagged type
11458 -- whose related subprogram is subject to pragma Expresions_Visible with
11461 if Is_Entity_Name (N) and then Present (Entity (N)) then
11466 and then Is_Specific_Tagged_Type (Etype (Id))
11467 and then Extensions_Visible_Status (Id) =
11468 Extensions_Visible_False;
11470 -- A case expression is an EVF expression when it contains at least one
11471 -- EVF dependent_expression. Note that a case expression may have been
11472 -- expanded, hence the use of Original_Node.
11474 elsif Nkind (Orig_N) = N_Case_Expression then
11475 Alt := First (Alternatives (Orig_N));
11476 while Present (Alt) loop
11477 if Is_EVF_Expression (Expression (Alt)) then
11484 -- An if expression is an EVF expression when it contains at least one
11485 -- EVF dependent_expression. Note that an if expression may have been
11486 -- expanded, hence the use of Original_Node.
11488 elsif Nkind (Orig_N) = N_If_Expression then
11489 Expr := Next (First (Expressions (Orig_N)));
11490 while Present (Expr) loop
11491 if Is_EVF_Expression (Expr) then
11498 -- A qualified expression or a type conversion is an EVF expression when
11499 -- its operand is an EVF expression.
11501 elsif Nkind_In (N, N_Qualified_Expression,
11502 N_Unchecked_Type_Conversion,
11505 return Is_EVF_Expression (Expression (N));
11507 -- Attributes 'Loop_Entry, 'Old and 'Update are an EVF expression when
11508 -- their prefix denotes an EVF expression.
11510 elsif Nkind (N) = N_Attribute_Reference
11511 and then Nam_In (Attribute_Name (N), Name_Loop_Entry,
11515 return Is_EVF_Expression (Prefix (N));
11519 end Is_EVF_Expression;
11525 function Is_False (U : Uint) return Boolean is
11530 ---------------------------
11531 -- Is_Fixed_Model_Number --
11532 ---------------------------
11534 function Is_Fixed_Model_Number (U : Ureal; T : Entity_Id) return Boolean is
11535 S : constant Ureal := Small_Value (T);
11536 M : Urealp.Save_Mark;
11540 R := (U = UR_Trunc (U / S) * S);
11541 Urealp.Release (M);
11543 end Is_Fixed_Model_Number;
11545 -------------------------------
11546 -- Is_Fully_Initialized_Type --
11547 -------------------------------
11549 function Is_Fully_Initialized_Type (Typ : Entity_Id) return Boolean is
11553 if Is_Scalar_Type (Typ) then
11555 -- A scalar type with an aspect Default_Value is fully initialized
11557 -- Note: Iniitalize/Normalize_Scalars also ensure full initialization
11558 -- of a scalar type, but we don't take that into account here, since
11559 -- we don't want these to affect warnings.
11561 return Has_Default_Aspect (Typ);
11563 elsif Is_Access_Type (Typ) then
11566 elsif Is_Array_Type (Typ) then
11567 if Is_Fully_Initialized_Type (Component_Type (Typ))
11568 or else (Ada_Version >= Ada_2012 and then Has_Default_Aspect (Typ))
11573 -- An interesting case, if we have a constrained type one of whose
11574 -- bounds is known to be null, then there are no elements to be
11575 -- initialized, so all the elements are initialized.
11577 if Is_Constrained (Typ) then
11580 Indx_Typ : Entity_Id;
11581 Lbd, Hbd : Node_Id;
11584 Indx := First_Index (Typ);
11585 while Present (Indx) loop
11586 if Etype (Indx) = Any_Type then
11589 -- If index is a range, use directly
11591 elsif Nkind (Indx) = N_Range then
11592 Lbd := Low_Bound (Indx);
11593 Hbd := High_Bound (Indx);
11596 Indx_Typ := Etype (Indx);
11598 if Is_Private_Type (Indx_Typ) then
11599 Indx_Typ := Full_View (Indx_Typ);
11602 if No (Indx_Typ) or else Etype (Indx_Typ) = Any_Type then
11605 Lbd := Type_Low_Bound (Indx_Typ);
11606 Hbd := Type_High_Bound (Indx_Typ);
11610 if Compile_Time_Known_Value (Lbd)
11612 Compile_Time_Known_Value (Hbd)
11614 if Expr_Value (Hbd) < Expr_Value (Lbd) then
11624 -- If no null indexes, then type is not fully initialized
11630 elsif Is_Record_Type (Typ) then
11631 if Has_Discriminants (Typ)
11633 Present (Discriminant_Default_Value (First_Discriminant (Typ)))
11634 and then Is_Fully_Initialized_Variant (Typ)
11639 -- We consider bounded string types to be fully initialized, because
11640 -- otherwise we get false alarms when the Data component is not
11641 -- default-initialized.
11643 if Is_Bounded_String (Typ) then
11647 -- Controlled records are considered to be fully initialized if
11648 -- there is a user defined Initialize routine. This may not be
11649 -- entirely correct, but as the spec notes, we are guessing here
11650 -- what is best from the point of view of issuing warnings.
11652 if Is_Controlled (Typ) then
11654 Utyp : constant Entity_Id := Underlying_Type (Typ);
11657 if Present (Utyp) then
11659 Init : constant Entity_Id :=
11660 (Find_Optional_Prim_Op
11661 (Underlying_Type (Typ), Name_Initialize));
11665 and then Comes_From_Source (Init)
11667 Is_Predefined_File_Name
11668 (File_Name (Get_Source_File_Index (Sloc (Init))))
11672 elsif Has_Null_Extension (Typ)
11674 Is_Fully_Initialized_Type
11675 (Etype (Base_Type (Typ)))
11684 -- Otherwise see if all record components are initialized
11690 Ent := First_Entity (Typ);
11691 while Present (Ent) loop
11692 if Ekind (Ent) = E_Component
11693 and then (No (Parent (Ent))
11694 or else No (Expression (Parent (Ent))))
11695 and then not Is_Fully_Initialized_Type (Etype (Ent))
11697 -- Special VM case for tag components, which need to be
11698 -- defined in this case, but are never initialized as VMs
11699 -- are using other dispatching mechanisms. Ignore this
11700 -- uninitialized case. Note that this applies both to the
11701 -- uTag entry and the main vtable pointer (CPP_Class case).
11703 and then (Tagged_Type_Expansion or else not Is_Tag (Ent))
11712 -- No uninitialized components, so type is fully initialized.
11713 -- Note that this catches the case of no components as well.
11717 elsif Is_Concurrent_Type (Typ) then
11720 elsif Is_Private_Type (Typ) then
11722 U : constant Entity_Id := Underlying_Type (Typ);
11728 return Is_Fully_Initialized_Type (U);
11735 end Is_Fully_Initialized_Type;
11737 ----------------------------------
11738 -- Is_Fully_Initialized_Variant --
11739 ----------------------------------
11741 function Is_Fully_Initialized_Variant (Typ : Entity_Id) return Boolean is
11742 Loc : constant Source_Ptr := Sloc (Typ);
11743 Constraints : constant List_Id := New_List;
11744 Components : constant Elist_Id := New_Elmt_List;
11745 Comp_Elmt : Elmt_Id;
11747 Comp_List : Node_Id;
11749 Discr_Val : Node_Id;
11751 Report_Errors : Boolean;
11752 pragma Warnings (Off, Report_Errors);
11755 if Serious_Errors_Detected > 0 then
11759 if Is_Record_Type (Typ)
11760 and then Nkind (Parent (Typ)) = N_Full_Type_Declaration
11761 and then Nkind (Type_Definition (Parent (Typ))) = N_Record_Definition
11763 Comp_List := Component_List (Type_Definition (Parent (Typ)));
11765 Discr := First_Discriminant (Typ);
11766 while Present (Discr) loop
11767 if Nkind (Parent (Discr)) = N_Discriminant_Specification then
11768 Discr_Val := Expression (Parent (Discr));
11770 if Present (Discr_Val)
11771 and then Is_OK_Static_Expression (Discr_Val)
11773 Append_To (Constraints,
11774 Make_Component_Association (Loc,
11775 Choices => New_List (New_Occurrence_Of (Discr, Loc)),
11776 Expression => New_Copy (Discr_Val)));
11784 Next_Discriminant (Discr);
11789 Comp_List => Comp_List,
11790 Governed_By => Constraints,
11791 Into => Components,
11792 Report_Errors => Report_Errors);
11794 -- Check that each component present is fully initialized
11796 Comp_Elmt := First_Elmt (Components);
11797 while Present (Comp_Elmt) loop
11798 Comp_Id := Node (Comp_Elmt);
11800 if Ekind (Comp_Id) = E_Component
11801 and then (No (Parent (Comp_Id))
11802 or else No (Expression (Parent (Comp_Id))))
11803 and then not Is_Fully_Initialized_Type (Etype (Comp_Id))
11808 Next_Elmt (Comp_Elmt);
11813 elsif Is_Private_Type (Typ) then
11815 U : constant Entity_Id := Underlying_Type (Typ);
11821 return Is_Fully_Initialized_Variant (U);
11828 end Is_Fully_Initialized_Variant;
11830 ------------------------------------
11831 -- Is_Generic_Declaration_Or_Body --
11832 ------------------------------------
11834 function Is_Generic_Declaration_Or_Body (Decl : Node_Id) return Boolean is
11835 Spec_Decl : Node_Id;
11838 -- Package/subprogram body
11840 if Nkind_In (Decl, N_Package_Body, N_Subprogram_Body)
11841 and then Present (Corresponding_Spec (Decl))
11843 Spec_Decl := Unit_Declaration_Node (Corresponding_Spec (Decl));
11845 -- Package/subprogram body stub
11847 elsif Nkind_In (Decl, N_Package_Body_Stub, N_Subprogram_Body_Stub)
11848 and then Present (Corresponding_Spec_Of_Stub (Decl))
11851 Unit_Declaration_Node (Corresponding_Spec_Of_Stub (Decl));
11859 -- Rather than inspecting the defining entity of the spec declaration,
11860 -- look at its Nkind. This takes care of the case where the analysis of
11861 -- a generic body modifies the Ekind of its spec to allow for recursive
11865 Nkind_In (Spec_Decl, N_Generic_Package_Declaration,
11866 N_Generic_Subprogram_Declaration);
11867 end Is_Generic_Declaration_Or_Body;
11869 ----------------------------
11870 -- Is_Inherited_Operation --
11871 ----------------------------
11873 function Is_Inherited_Operation (E : Entity_Id) return Boolean is
11874 pragma Assert (Is_Overloadable (E));
11875 Kind : constant Node_Kind := Nkind (Parent (E));
11877 return Kind = N_Full_Type_Declaration
11878 or else Kind = N_Private_Extension_Declaration
11879 or else Kind = N_Subtype_Declaration
11880 or else (Ekind (E) = E_Enumeration_Literal
11881 and then Is_Derived_Type (Etype (E)));
11882 end Is_Inherited_Operation;
11884 -------------------------------------
11885 -- Is_Inherited_Operation_For_Type --
11886 -------------------------------------
11888 function Is_Inherited_Operation_For_Type
11890 Typ : Entity_Id) return Boolean
11893 -- Check that the operation has been created by the type declaration
11895 return Is_Inherited_Operation (E)
11896 and then Defining_Identifier (Parent (E)) = Typ;
11897 end Is_Inherited_Operation_For_Type;
11903 function Is_Iterator (Typ : Entity_Id) return Boolean is
11904 Ifaces_List : Elist_Id;
11905 Iface_Elmt : Elmt_Id;
11909 if Is_Class_Wide_Type (Typ)
11910 and then Nam_In (Chars (Etype (Typ)), Name_Forward_Iterator,
11911 Name_Reversible_Iterator)
11913 Is_Predefined_File_Name
11914 (Unit_File_Name (Get_Source_Unit (Etype (Typ))))
11918 elsif not Is_Tagged_Type (Typ) or else not Is_Derived_Type (Typ) then
11921 elsif Present (Find_Value_Of_Aspect (Typ, Aspect_Iterable)) then
11925 Collect_Interfaces (Typ, Ifaces_List);
11927 Iface_Elmt := First_Elmt (Ifaces_List);
11928 while Present (Iface_Elmt) loop
11929 Iface := Node (Iface_Elmt);
11930 if Chars (Iface) = Name_Forward_Iterator
11932 Is_Predefined_File_Name
11933 (Unit_File_Name (Get_Source_Unit (Iface)))
11938 Next_Elmt (Iface_Elmt);
11949 -- We seem to have a lot of overlapping functions that do similar things
11950 -- (testing for left hand sides or lvalues???).
11952 function Is_LHS (N : Node_Id) return Is_LHS_Result is
11953 P : constant Node_Id := Parent (N);
11956 -- Return True if we are the left hand side of an assignment statement
11958 if Nkind (P) = N_Assignment_Statement then
11959 if Name (P) = N then
11965 -- Case of prefix of indexed or selected component or slice
11967 elsif Nkind_In (P, N_Indexed_Component, N_Selected_Component, N_Slice)
11968 and then N = Prefix (P)
11970 -- Here we have the case where the parent P is N.Q or N(Q .. R).
11971 -- If P is an LHS, then N is also effectively an LHS, but there
11972 -- is an important exception. If N is of an access type, then
11973 -- what we really have is N.all.Q (or N.all(Q .. R)). In either
11974 -- case this makes N.all a left hand side but not N itself.
11976 -- If we don't know the type yet, this is the case where we return
11977 -- Unknown, since the answer depends on the type which is unknown.
11979 if No (Etype (N)) then
11982 -- We have an Etype set, so we can check it
11984 elsif Is_Access_Type (Etype (N)) then
11987 -- OK, not access type case, so just test whole expression
11993 -- All other cases are not left hand sides
12000 -----------------------------
12001 -- Is_Library_Level_Entity --
12002 -----------------------------
12004 function Is_Library_Level_Entity (E : Entity_Id) return Boolean is
12006 -- The following is a small optimization, and it also properly handles
12007 -- discriminals, which in task bodies might appear in expressions before
12008 -- the corresponding procedure has been created, and which therefore do
12009 -- not have an assigned scope.
12011 if Is_Formal (E) then
12015 -- Normal test is simply that the enclosing dynamic scope is Standard
12017 return Enclosing_Dynamic_Scope (E) = Standard_Standard;
12018 end Is_Library_Level_Entity;
12020 --------------------------------
12021 -- Is_Limited_Class_Wide_Type --
12022 --------------------------------
12024 function Is_Limited_Class_Wide_Type (Typ : Entity_Id) return Boolean is
12027 Is_Class_Wide_Type (Typ)
12028 and then (Is_Limited_Type (Typ) or else From_Limited_With (Typ));
12029 end Is_Limited_Class_Wide_Type;
12031 ---------------------------------
12032 -- Is_Local_Variable_Reference --
12033 ---------------------------------
12035 function Is_Local_Variable_Reference (Expr : Node_Id) return Boolean is
12037 if not Is_Entity_Name (Expr) then
12042 Ent : constant Entity_Id := Entity (Expr);
12043 Sub : constant Entity_Id := Enclosing_Subprogram (Ent);
12045 if not Ekind_In (Ent, E_Variable, E_In_Out_Parameter) then
12048 return Present (Sub) and then Sub = Current_Subprogram;
12052 end Is_Local_Variable_Reference;
12054 -------------------------
12055 -- Is_Object_Reference --
12056 -------------------------
12058 function Is_Object_Reference (N : Node_Id) return Boolean is
12060 function Is_Internally_Generated_Renaming (N : Node_Id) return Boolean;
12061 -- Determine whether N is the name of an internally-generated renaming
12063 --------------------------------------
12064 -- Is_Internally_Generated_Renaming --
12065 --------------------------------------
12067 function Is_Internally_Generated_Renaming (N : Node_Id) return Boolean is
12072 while Present (P) loop
12073 if Nkind (P) = N_Object_Renaming_Declaration then
12074 return not Comes_From_Source (P);
12075 elsif Is_List_Member (P) then
12083 end Is_Internally_Generated_Renaming;
12085 -- Start of processing for Is_Object_Reference
12088 if Is_Entity_Name (N) then
12089 return Present (Entity (N)) and then Is_Object (Entity (N));
12093 when N_Indexed_Component | N_Slice =>
12095 Is_Object_Reference (Prefix (N))
12096 or else Is_Access_Type (Etype (Prefix (N)));
12098 -- In Ada 95, a function call is a constant object; a procedure
12101 when N_Function_Call =>
12102 return Etype (N) /= Standard_Void_Type;
12104 -- Attributes 'Input, 'Loop_Entry, 'Old and 'Result produce
12107 when N_Attribute_Reference =>
12109 Nam_In (Attribute_Name (N), Name_Input,
12114 when N_Selected_Component =>
12116 Is_Object_Reference (Selector_Name (N))
12118 (Is_Object_Reference (Prefix (N))
12119 or else Is_Access_Type (Etype (Prefix (N))));
12121 when N_Explicit_Dereference =>
12124 -- A view conversion of a tagged object is an object reference
12126 when N_Type_Conversion =>
12127 return Is_Tagged_Type (Etype (Subtype_Mark (N)))
12128 and then Is_Tagged_Type (Etype (Expression (N)))
12129 and then Is_Object_Reference (Expression (N));
12131 -- An unchecked type conversion is considered to be an object if
12132 -- the operand is an object (this construction arises only as a
12133 -- result of expansion activities).
12135 when N_Unchecked_Type_Conversion =>
12138 -- Allow string literals to act as objects as long as they appear
12139 -- in internally-generated renamings. The expansion of iterators
12140 -- may generate such renamings when the range involves a string
12143 when N_String_Literal =>
12144 return Is_Internally_Generated_Renaming (Parent (N));
12146 -- AI05-0003: In Ada 2012 a qualified expression is a name.
12147 -- This allows disambiguation of function calls and the use
12148 -- of aggregates in more contexts.
12150 when N_Qualified_Expression =>
12151 if Ada_Version < Ada_2012 then
12154 return Is_Object_Reference (Expression (N))
12155 or else Nkind (Expression (N)) = N_Aggregate;
12162 end Is_Object_Reference;
12164 -----------------------------------
12165 -- Is_OK_Variable_For_Out_Formal --
12166 -----------------------------------
12168 function Is_OK_Variable_For_Out_Formal (AV : Node_Id) return Boolean is
12170 Note_Possible_Modification (AV, Sure => True);
12172 -- We must reject parenthesized variable names. Comes_From_Source is
12173 -- checked because there are currently cases where the compiler violates
12174 -- this rule (e.g. passing a task object to its controlled Initialize
12175 -- routine). This should be properly documented in sinfo???
12177 if Paren_Count (AV) > 0 and then Comes_From_Source (AV) then
12180 -- A variable is always allowed
12182 elsif Is_Variable (AV) then
12185 -- Generalized indexing operations are rewritten as explicit
12186 -- dereferences, and it is only during resolution that we can
12187 -- check whether the context requires an access_to_variable type.
12189 elsif Nkind (AV) = N_Explicit_Dereference
12190 and then Ada_Version >= Ada_2012
12191 and then Nkind (Original_Node (AV)) = N_Indexed_Component
12192 and then Present (Etype (Original_Node (AV)))
12193 and then Has_Implicit_Dereference (Etype (Original_Node (AV)))
12195 return not Is_Access_Constant (Etype (Prefix (AV)));
12197 -- Unchecked conversions are allowed only if they come from the
12198 -- generated code, which sometimes uses unchecked conversions for out
12199 -- parameters in cases where code generation is unaffected. We tell
12200 -- source unchecked conversions by seeing if they are rewrites of
12201 -- an original Unchecked_Conversion function call, or of an explicit
12202 -- conversion of a function call or an aggregate (as may happen in the
12203 -- expansion of a packed array aggregate).
12205 elsif Nkind (AV) = N_Unchecked_Type_Conversion then
12206 if Nkind_In (Original_Node (AV), N_Function_Call, N_Aggregate) then
12209 elsif Comes_From_Source (AV)
12210 and then Nkind (Original_Node (Expression (AV))) = N_Function_Call
12214 elsif Nkind (Original_Node (AV)) = N_Type_Conversion then
12215 return Is_OK_Variable_For_Out_Formal (Expression (AV));
12221 -- Normal type conversions are allowed if argument is a variable
12223 elsif Nkind (AV) = N_Type_Conversion then
12224 if Is_Variable (Expression (AV))
12225 and then Paren_Count (Expression (AV)) = 0
12227 Note_Possible_Modification (Expression (AV), Sure => True);
12230 -- We also allow a non-parenthesized expression that raises
12231 -- constraint error if it rewrites what used to be a variable
12233 elsif Raises_Constraint_Error (Expression (AV))
12234 and then Paren_Count (Expression (AV)) = 0
12235 and then Is_Variable (Original_Node (Expression (AV)))
12239 -- Type conversion of something other than a variable
12245 -- If this node is rewritten, then test the original form, if that is
12246 -- OK, then we consider the rewritten node OK (for example, if the
12247 -- original node is a conversion, then Is_Variable will not be true
12248 -- but we still want to allow the conversion if it converts a variable).
12250 elsif Original_Node (AV) /= AV then
12252 -- In Ada 2012, the explicit dereference may be a rewritten call to a
12253 -- Reference function.
12255 if Ada_Version >= Ada_2012
12256 and then Nkind (Original_Node (AV)) = N_Function_Call
12258 Has_Implicit_Dereference (Etype (Name (Original_Node (AV))))
12261 -- Check that this is not a constant reference.
12263 return not Is_Access_Constant (Etype (Prefix (AV)));
12265 elsif Has_Implicit_Dereference (Etype (Original_Node (AV))) then
12267 not Is_Access_Constant (Etype
12268 (Get_Reference_Discriminant (Etype (Original_Node (AV)))));
12271 return Is_OK_Variable_For_Out_Formal (Original_Node (AV));
12274 -- All other non-variables are rejected
12279 end Is_OK_Variable_For_Out_Formal;
12281 ------------------------------------
12282 -- Is_Package_Contract_Annotation --
12283 ------------------------------------
12285 function Is_Package_Contract_Annotation (Item : Node_Id) return Boolean is
12289 if Nkind (Item) = N_Aspect_Specification then
12290 Nam := Chars (Identifier (Item));
12292 else pragma Assert (Nkind (Item) = N_Pragma);
12293 Nam := Pragma_Name (Item);
12296 return Nam = Name_Abstract_State
12297 or else Nam = Name_Initial_Condition
12298 or else Nam = Name_Initializes
12299 or else Nam = Name_Refined_State;
12300 end Is_Package_Contract_Annotation;
12302 -----------------------------------
12303 -- Is_Partially_Initialized_Type --
12304 -----------------------------------
12306 function Is_Partially_Initialized_Type
12308 Include_Implicit : Boolean := True) return Boolean
12311 if Is_Scalar_Type (Typ) then
12314 elsif Is_Access_Type (Typ) then
12315 return Include_Implicit;
12317 elsif Is_Array_Type (Typ) then
12319 -- If component type is partially initialized, so is array type
12321 if Is_Partially_Initialized_Type
12322 (Component_Type (Typ), Include_Implicit)
12326 -- Otherwise we are only partially initialized if we are fully
12327 -- initialized (this is the empty array case, no point in us
12328 -- duplicating that code here).
12331 return Is_Fully_Initialized_Type (Typ);
12334 elsif Is_Record_Type (Typ) then
12336 -- A discriminated type is always partially initialized if in
12339 if Has_Discriminants (Typ) and then Include_Implicit then
12342 -- A tagged type is always partially initialized
12344 elsif Is_Tagged_Type (Typ) then
12347 -- Case of non-discriminated record
12353 Component_Present : Boolean := False;
12354 -- Set True if at least one component is present. If no
12355 -- components are present, then record type is fully
12356 -- initialized (another odd case, like the null array).
12359 -- Loop through components
12361 Ent := First_Entity (Typ);
12362 while Present (Ent) loop
12363 if Ekind (Ent) = E_Component then
12364 Component_Present := True;
12366 -- If a component has an initialization expression then
12367 -- the enclosing record type is partially initialized
12369 if Present (Parent (Ent))
12370 and then Present (Expression (Parent (Ent)))
12374 -- If a component is of a type which is itself partially
12375 -- initialized, then the enclosing record type is also.
12377 elsif Is_Partially_Initialized_Type
12378 (Etype (Ent), Include_Implicit)
12387 -- No initialized components found. If we found any components
12388 -- they were all uninitialized so the result is false.
12390 if Component_Present then
12393 -- But if we found no components, then all the components are
12394 -- initialized so we consider the type to be initialized.
12402 -- Concurrent types are always fully initialized
12404 elsif Is_Concurrent_Type (Typ) then
12407 -- For a private type, go to underlying type. If there is no underlying
12408 -- type then just assume this partially initialized. Not clear if this
12409 -- can happen in a non-error case, but no harm in testing for this.
12411 elsif Is_Private_Type (Typ) then
12413 U : constant Entity_Id := Underlying_Type (Typ);
12418 return Is_Partially_Initialized_Type (U, Include_Implicit);
12422 -- For any other type (are there any?) assume partially initialized
12427 end Is_Partially_Initialized_Type;
12429 ------------------------------------
12430 -- Is_Potentially_Persistent_Type --
12431 ------------------------------------
12433 function Is_Potentially_Persistent_Type (T : Entity_Id) return Boolean is
12438 -- For private type, test corresponding full type
12440 if Is_Private_Type (T) then
12441 return Is_Potentially_Persistent_Type (Full_View (T));
12443 -- Scalar types are potentially persistent
12445 elsif Is_Scalar_Type (T) then
12448 -- Record type is potentially persistent if not tagged and the types of
12449 -- all it components are potentially persistent, and no component has
12450 -- an initialization expression.
12452 elsif Is_Record_Type (T)
12453 and then not Is_Tagged_Type (T)
12454 and then not Is_Partially_Initialized_Type (T)
12456 Comp := First_Component (T);
12457 while Present (Comp) loop
12458 if not Is_Potentially_Persistent_Type (Etype (Comp)) then
12461 Next_Entity (Comp);
12467 -- Array type is potentially persistent if its component type is
12468 -- potentially persistent and if all its constraints are static.
12470 elsif Is_Array_Type (T) then
12471 if not Is_Potentially_Persistent_Type (Component_Type (T)) then
12475 Indx := First_Index (T);
12476 while Present (Indx) loop
12477 if not Is_OK_Static_Subtype (Etype (Indx)) then
12486 -- All other types are not potentially persistent
12491 end Is_Potentially_Persistent_Type;
12493 --------------------------------
12494 -- Is_Potentially_Unevaluated --
12495 --------------------------------
12497 function Is_Potentially_Unevaluated (N : Node_Id) return Boolean is
12505 -- A postcondition whose expression is a short-circuit is broken down
12506 -- into individual aspects for better exception reporting. The original
12507 -- short-circuit expression is rewritten as the second operand, and an
12508 -- occurrence of 'Old in that operand is potentially unevaluated.
12509 -- See Sem_ch13.adb for details of this transformation.
12511 if Nkind (Original_Node (Par)) = N_And_Then then
12515 while not Nkind_In (Par, N_If_Expression,
12523 Par := Parent (Par);
12525 -- If the context is not an expression, or if is the result of
12526 -- expansion of an enclosing construct (such as another attribute)
12527 -- the predicate does not apply.
12529 if Nkind (Par) not in N_Subexpr
12530 or else not Comes_From_Source (Par)
12536 if Nkind (Par) = N_If_Expression then
12537 return Is_Elsif (Par) or else Expr /= First (Expressions (Par));
12539 elsif Nkind (Par) = N_Case_Expression then
12540 return Expr /= Expression (Par);
12542 elsif Nkind_In (Par, N_And_Then, N_Or_Else) then
12543 return Expr = Right_Opnd (Par);
12545 elsif Nkind_In (Par, N_In, N_Not_In) then
12546 return Expr /= Left_Opnd (Par);
12551 end Is_Potentially_Unevaluated;
12553 ---------------------------------
12554 -- Is_Protected_Self_Reference --
12555 ---------------------------------
12557 function Is_Protected_Self_Reference (N : Node_Id) return Boolean is
12559 function In_Access_Definition (N : Node_Id) return Boolean;
12560 -- Returns true if N belongs to an access definition
12562 --------------------------
12563 -- In_Access_Definition --
12564 --------------------------
12566 function In_Access_Definition (N : Node_Id) return Boolean is
12571 while Present (P) loop
12572 if Nkind (P) = N_Access_Definition then
12580 end In_Access_Definition;
12582 -- Start of processing for Is_Protected_Self_Reference
12585 -- Verify that prefix is analyzed and has the proper form. Note that
12586 -- the attributes Elab_Spec, Elab_Body, Elab_Subp_Body and UET_Address,
12587 -- which also produce the address of an entity, do not analyze their
12588 -- prefix because they denote entities that are not necessarily visible.
12589 -- Neither of them can apply to a protected type.
12591 return Ada_Version >= Ada_2005
12592 and then Is_Entity_Name (N)
12593 and then Present (Entity (N))
12594 and then Is_Protected_Type (Entity (N))
12595 and then In_Open_Scopes (Entity (N))
12596 and then not In_Access_Definition (N);
12597 end Is_Protected_Self_Reference;
12599 -----------------------------
12600 -- Is_RCI_Pkg_Spec_Or_Body --
12601 -----------------------------
12603 function Is_RCI_Pkg_Spec_Or_Body (Cunit : Node_Id) return Boolean is
12605 function Is_RCI_Pkg_Decl_Cunit (Cunit : Node_Id) return Boolean;
12606 -- Return True if the unit of Cunit is an RCI package declaration
12608 ---------------------------
12609 -- Is_RCI_Pkg_Decl_Cunit --
12610 ---------------------------
12612 function Is_RCI_Pkg_Decl_Cunit (Cunit : Node_Id) return Boolean is
12613 The_Unit : constant Node_Id := Unit (Cunit);
12616 if Nkind (The_Unit) /= N_Package_Declaration then
12620 return Is_Remote_Call_Interface (Defining_Entity (The_Unit));
12621 end Is_RCI_Pkg_Decl_Cunit;
12623 -- Start of processing for Is_RCI_Pkg_Spec_Or_Body
12626 return Is_RCI_Pkg_Decl_Cunit (Cunit)
12628 (Nkind (Unit (Cunit)) = N_Package_Body
12629 and then Is_RCI_Pkg_Decl_Cunit (Library_Unit (Cunit)));
12630 end Is_RCI_Pkg_Spec_Or_Body;
12632 -----------------------------------------
12633 -- Is_Remote_Access_To_Class_Wide_Type --
12634 -----------------------------------------
12636 function Is_Remote_Access_To_Class_Wide_Type
12637 (E : Entity_Id) return Boolean
12640 -- A remote access to class-wide type is a general access to object type
12641 -- declared in the visible part of a Remote_Types or Remote_Call_
12644 return Ekind (E) = E_General_Access_Type
12645 and then (Is_Remote_Call_Interface (E) or else Is_Remote_Types (E));
12646 end Is_Remote_Access_To_Class_Wide_Type;
12648 -----------------------------------------
12649 -- Is_Remote_Access_To_Subprogram_Type --
12650 -----------------------------------------
12652 function Is_Remote_Access_To_Subprogram_Type
12653 (E : Entity_Id) return Boolean
12656 return (Ekind (E) = E_Access_Subprogram_Type
12657 or else (Ekind (E) = E_Record_Type
12658 and then Present (Corresponding_Remote_Type (E))))
12659 and then (Is_Remote_Call_Interface (E) or else Is_Remote_Types (E));
12660 end Is_Remote_Access_To_Subprogram_Type;
12662 --------------------
12663 -- Is_Remote_Call --
12664 --------------------
12666 function Is_Remote_Call (N : Node_Id) return Boolean is
12668 if Nkind (N) not in N_Subprogram_Call then
12670 -- An entry call cannot be remote
12674 elsif Nkind (Name (N)) in N_Has_Entity
12675 and then Is_Remote_Call_Interface (Entity (Name (N)))
12677 -- A subprogram declared in the spec of a RCI package is remote
12681 elsif Nkind (Name (N)) = N_Explicit_Dereference
12682 and then Is_Remote_Access_To_Subprogram_Type
12683 (Etype (Prefix (Name (N))))
12685 -- The dereference of a RAS is a remote call
12689 elsif Present (Controlling_Argument (N))
12690 and then Is_Remote_Access_To_Class_Wide_Type
12691 (Etype (Controlling_Argument (N)))
12693 -- Any primitive operation call with a controlling argument of
12694 -- a RACW type is a remote call.
12699 -- All other calls are local calls
12702 end Is_Remote_Call;
12704 ----------------------
12705 -- Is_Renamed_Entry --
12706 ----------------------
12708 function Is_Renamed_Entry (Proc_Nam : Entity_Id) return Boolean is
12709 Orig_Node : Node_Id := Empty;
12710 Subp_Decl : Node_Id := Parent (Parent (Proc_Nam));
12712 function Is_Entry (Nam : Node_Id) return Boolean;
12713 -- Determine whether Nam is an entry. Traverse selectors if there are
12714 -- nested selected components.
12720 function Is_Entry (Nam : Node_Id) return Boolean is
12722 if Nkind (Nam) = N_Selected_Component then
12723 return Is_Entry (Selector_Name (Nam));
12726 return Ekind (Entity (Nam)) = E_Entry;
12729 -- Start of processing for Is_Renamed_Entry
12732 if Present (Alias (Proc_Nam)) then
12733 Subp_Decl := Parent (Parent (Alias (Proc_Nam)));
12736 -- Look for a rewritten subprogram renaming declaration
12738 if Nkind (Subp_Decl) = N_Subprogram_Declaration
12739 and then Present (Original_Node (Subp_Decl))
12741 Orig_Node := Original_Node (Subp_Decl);
12744 -- The rewritten subprogram is actually an entry
12746 if Present (Orig_Node)
12747 and then Nkind (Orig_Node) = N_Subprogram_Renaming_Declaration
12748 and then Is_Entry (Name (Orig_Node))
12754 end Is_Renamed_Entry;
12756 -----------------------------
12757 -- Is_Renaming_Declaration --
12758 -----------------------------
12760 function Is_Renaming_Declaration (N : Node_Id) return Boolean is
12763 when N_Exception_Renaming_Declaration |
12764 N_Generic_Function_Renaming_Declaration |
12765 N_Generic_Package_Renaming_Declaration |
12766 N_Generic_Procedure_Renaming_Declaration |
12767 N_Object_Renaming_Declaration |
12768 N_Package_Renaming_Declaration |
12769 N_Subprogram_Renaming_Declaration =>
12775 end Is_Renaming_Declaration;
12777 ----------------------------
12778 -- Is_Reversible_Iterator --
12779 ----------------------------
12781 function Is_Reversible_Iterator (Typ : Entity_Id) return Boolean is
12782 Ifaces_List : Elist_Id;
12783 Iface_Elmt : Elmt_Id;
12787 if Is_Class_Wide_Type (Typ)
12788 and then Chars (Etype (Typ)) = Name_Reversible_Iterator
12789 and then Is_Predefined_File_Name
12790 (Unit_File_Name (Get_Source_Unit (Etype (Typ))))
12794 elsif not Is_Tagged_Type (Typ) or else not Is_Derived_Type (Typ) then
12798 Collect_Interfaces (Typ, Ifaces_List);
12800 Iface_Elmt := First_Elmt (Ifaces_List);
12801 while Present (Iface_Elmt) loop
12802 Iface := Node (Iface_Elmt);
12803 if Chars (Iface) = Name_Reversible_Iterator
12805 Is_Predefined_File_Name
12806 (Unit_File_Name (Get_Source_Unit (Iface)))
12811 Next_Elmt (Iface_Elmt);
12816 end Is_Reversible_Iterator;
12818 ----------------------
12819 -- Is_Selector_Name --
12820 ----------------------
12822 function Is_Selector_Name (N : Node_Id) return Boolean is
12824 if not Is_List_Member (N) then
12826 P : constant Node_Id := Parent (N);
12828 return Nkind_In (P, N_Expanded_Name,
12829 N_Generic_Association,
12830 N_Parameter_Association,
12831 N_Selected_Component)
12832 and then Selector_Name (P) = N;
12837 L : constant List_Id := List_Containing (N);
12838 P : constant Node_Id := Parent (L);
12840 return (Nkind (P) = N_Discriminant_Association
12841 and then Selector_Names (P) = L)
12843 (Nkind (P) = N_Component_Association
12844 and then Choices (P) = L);
12847 end Is_Selector_Name;
12849 ---------------------------------------------
12850 -- Is_Single_Precision_Floating_Point_Type --
12851 ---------------------------------------------
12853 function Is_Single_Precision_Floating_Point_Type
12854 (E : Entity_Id) return Boolean is
12856 return Is_Floating_Point_Type (E)
12857 and then Machine_Radix_Value (E) = Uint_2
12858 and then Machine_Mantissa_Value (E) = Uint_24
12859 and then Machine_Emax_Value (E) = Uint_2 ** Uint_7
12860 and then Machine_Emin_Value (E) = Uint_3 - (Uint_2 ** Uint_7);
12861 end Is_Single_Precision_Floating_Point_Type;
12863 -------------------------------------
12864 -- Is_SPARK_05_Initialization_Expr --
12865 -------------------------------------
12867 function Is_SPARK_05_Initialization_Expr (N : Node_Id) return Boolean is
12870 Comp_Assn : Node_Id;
12871 Orig_N : constant Node_Id := Original_Node (N);
12876 if not Comes_From_Source (Orig_N) then
12880 pragma Assert (Nkind (Orig_N) in N_Subexpr);
12882 case Nkind (Orig_N) is
12883 when N_Character_Literal |
12884 N_Integer_Literal |
12886 N_String_Literal =>
12889 when N_Identifier |
12891 if Is_Entity_Name (Orig_N)
12892 and then Present (Entity (Orig_N)) -- needed in some cases
12894 case Ekind (Entity (Orig_N)) is
12896 E_Enumeration_Literal |
12901 if Is_Type (Entity (Orig_N)) then
12909 when N_Qualified_Expression |
12910 N_Type_Conversion =>
12911 Is_Ok := Is_SPARK_05_Initialization_Expr (Expression (Orig_N));
12914 Is_Ok := Is_SPARK_05_Initialization_Expr (Right_Opnd (Orig_N));
12918 N_Membership_Test =>
12919 Is_Ok := Is_SPARK_05_Initialization_Expr (Left_Opnd (Orig_N))
12921 Is_SPARK_05_Initialization_Expr (Right_Opnd (Orig_N));
12924 N_Extension_Aggregate =>
12925 if Nkind (Orig_N) = N_Extension_Aggregate then
12927 Is_SPARK_05_Initialization_Expr (Ancestor_Part (Orig_N));
12930 Expr := First (Expressions (Orig_N));
12931 while Present (Expr) loop
12932 if not Is_SPARK_05_Initialization_Expr (Expr) then
12940 Comp_Assn := First (Component_Associations (Orig_N));
12941 while Present (Comp_Assn) loop
12942 Expr := Expression (Comp_Assn);
12944 -- Note: test for Present here needed for box assocation
12947 and then not Is_SPARK_05_Initialization_Expr (Expr)
12956 when N_Attribute_Reference =>
12957 if Nkind (Prefix (Orig_N)) in N_Subexpr then
12958 Is_Ok := Is_SPARK_05_Initialization_Expr (Prefix (Orig_N));
12961 Expr := First (Expressions (Orig_N));
12962 while Present (Expr) loop
12963 if not Is_SPARK_05_Initialization_Expr (Expr) then
12971 -- Selected components might be expanded named not yet resolved, so
12972 -- default on the safe side. (Eg on sparklex.ads)
12974 when N_Selected_Component =>
12983 end Is_SPARK_05_Initialization_Expr;
12985 ----------------------------------
12986 -- Is_SPARK_05_Object_Reference --
12987 ----------------------------------
12989 function Is_SPARK_05_Object_Reference (N : Node_Id) return Boolean is
12991 if Is_Entity_Name (N) then
12992 return Present (Entity (N))
12994 (Ekind_In (Entity (N), E_Constant, E_Variable)
12995 or else Ekind (Entity (N)) in Formal_Kind);
12999 when N_Selected_Component =>
13000 return Is_SPARK_05_Object_Reference (Prefix (N));
13006 end Is_SPARK_05_Object_Reference;
13008 -----------------------------
13009 -- Is_Specific_Tagged_Type --
13010 -----------------------------
13012 function Is_Specific_Tagged_Type (Typ : Entity_Id) return Boolean is
13013 Full_Typ : Entity_Id;
13016 -- Handle private types
13018 if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then
13019 Full_Typ := Full_View (Typ);
13024 -- A specific tagged type is a non-class-wide tagged type
13026 return Is_Tagged_Type (Full_Typ) and not Is_Class_Wide_Type (Full_Typ);
13027 end Is_Specific_Tagged_Type;
13033 function Is_Statement (N : Node_Id) return Boolean is
13036 Nkind (N) in N_Statement_Other_Than_Procedure_Call
13037 or else Nkind (N) = N_Procedure_Call_Statement;
13040 ---------------------------------------
13041 -- Is_Subprogram_Contract_Annotation --
13042 ---------------------------------------
13044 function Is_Subprogram_Contract_Annotation
13045 (Item : Node_Id) return Boolean
13050 if Nkind (Item) = N_Aspect_Specification then
13051 Nam := Chars (Identifier (Item));
13053 else pragma Assert (Nkind (Item) = N_Pragma);
13054 Nam := Pragma_Name (Item);
13057 return Nam = Name_Contract_Cases
13058 or else Nam = Name_Depends
13059 or else Nam = Name_Extensions_Visible
13060 or else Nam = Name_Global
13061 or else Nam = Name_Post
13062 or else Nam = Name_Post_Class
13063 or else Nam = Name_Postcondition
13064 or else Nam = Name_Pre
13065 or else Nam = Name_Pre_Class
13066 or else Nam = Name_Precondition
13067 or else Nam = Name_Refined_Depends
13068 or else Nam = Name_Refined_Global
13069 or else Nam = Name_Refined_Post
13070 or else Nam = Name_Test_Case;
13071 end Is_Subprogram_Contract_Annotation;
13073 --------------------------------------------------
13074 -- Is_Subprogram_Stub_Without_Prior_Declaration --
13075 --------------------------------------------------
13077 function Is_Subprogram_Stub_Without_Prior_Declaration
13078 (N : Node_Id) return Boolean
13081 -- A subprogram stub without prior declaration serves as declaration for
13082 -- the actual subprogram body. As such, it has an attached defining
13083 -- entity of E_[Generic_]Function or E_[Generic_]Procedure.
13085 return Nkind (N) = N_Subprogram_Body_Stub
13086 and then Ekind (Defining_Entity (N)) /= E_Subprogram_Body;
13087 end Is_Subprogram_Stub_Without_Prior_Declaration;
13089 ---------------------------------
13090 -- Is_Synchronized_Tagged_Type --
13091 ---------------------------------
13093 function Is_Synchronized_Tagged_Type (E : Entity_Id) return Boolean is
13094 Kind : constant Entity_Kind := Ekind (Base_Type (E));
13097 -- A task or protected type derived from an interface is a tagged type.
13098 -- Such a tagged type is called a synchronized tagged type, as are
13099 -- synchronized interfaces and private extensions whose declaration
13100 -- includes the reserved word synchronized.
13102 return (Is_Tagged_Type (E)
13103 and then (Kind = E_Task_Type
13105 Kind = E_Protected_Type))
13108 and then Is_Synchronized_Interface (E))
13110 (Ekind (E) = E_Record_Type_With_Private
13111 and then Nkind (Parent (E)) = N_Private_Extension_Declaration
13112 and then (Synchronized_Present (Parent (E))
13113 or else Is_Synchronized_Interface (Etype (E))));
13114 end Is_Synchronized_Tagged_Type;
13120 function Is_Transfer (N : Node_Id) return Boolean is
13121 Kind : constant Node_Kind := Nkind (N);
13124 if Kind = N_Simple_Return_Statement
13126 Kind = N_Extended_Return_Statement
13128 Kind = N_Goto_Statement
13130 Kind = N_Raise_Statement
13132 Kind = N_Requeue_Statement
13136 elsif (Kind = N_Exit_Statement or else Kind in N_Raise_xxx_Error)
13137 and then No (Condition (N))
13141 elsif Kind = N_Procedure_Call_Statement
13142 and then Is_Entity_Name (Name (N))
13143 and then Present (Entity (Name (N)))
13144 and then No_Return (Entity (Name (N)))
13148 elsif Nkind (Original_Node (N)) = N_Raise_Statement then
13160 function Is_True (U : Uint) return Boolean is
13165 --------------------------------------
13166 -- Is_Unchecked_Conversion_Instance --
13167 --------------------------------------
13169 function Is_Unchecked_Conversion_Instance (Id : Entity_Id) return Boolean is
13170 Gen_Par : Entity_Id;
13173 -- Look for a function whose generic parent is the predefined intrinsic
13174 -- function Unchecked_Conversion.
13176 if Ekind (Id) = E_Function then
13177 Gen_Par := Generic_Parent (Parent (Id));
13181 and then Chars (Gen_Par) = Name_Unchecked_Conversion
13182 and then Is_Intrinsic_Subprogram (Gen_Par)
13183 and then Is_Predefined_File_Name
13184 (Unit_File_Name (Get_Source_Unit (Gen_Par)));
13188 end Is_Unchecked_Conversion_Instance;
13190 -------------------------------
13191 -- Is_Universal_Numeric_Type --
13192 -------------------------------
13194 function Is_Universal_Numeric_Type (T : Entity_Id) return Boolean is
13196 return T = Universal_Integer or else T = Universal_Real;
13197 end Is_Universal_Numeric_Type;
13199 ----------------------------
13200 -- Is_Variable_Size_Array --
13201 ----------------------------
13203 function Is_Variable_Size_Array (E : Entity_Id) return Boolean is
13207 pragma Assert (Is_Array_Type (E));
13209 -- Check if some index is initialized with a non-constant value
13211 Idx := First_Index (E);
13212 while Present (Idx) loop
13213 if Nkind (Idx) = N_Range then
13214 if not Is_Constant_Bound (Low_Bound (Idx))
13215 or else not Is_Constant_Bound (High_Bound (Idx))
13221 Idx := Next_Index (Idx);
13225 end Is_Variable_Size_Array;
13227 -----------------------------
13228 -- Is_Variable_Size_Record --
13229 -----------------------------
13231 function Is_Variable_Size_Record (E : Entity_Id) return Boolean is
13233 Comp_Typ : Entity_Id;
13236 pragma Assert (Is_Record_Type (E));
13238 Comp := First_Entity (E);
13239 while Present (Comp) loop
13240 Comp_Typ := Etype (Comp);
13242 -- Recursive call if the record type has discriminants
13244 if Is_Record_Type (Comp_Typ)
13245 and then Has_Discriminants (Comp_Typ)
13246 and then Is_Variable_Size_Record (Comp_Typ)
13250 elsif Is_Array_Type (Comp_Typ)
13251 and then Is_Variable_Size_Array (Comp_Typ)
13256 Next_Entity (Comp);
13260 end Is_Variable_Size_Record;
13266 function Is_Variable
13268 Use_Original_Node : Boolean := True) return Boolean
13270 Orig_Node : Node_Id;
13272 function In_Protected_Function (E : Entity_Id) return Boolean;
13273 -- Within a protected function, the private components of the enclosing
13274 -- protected type are constants. A function nested within a (protected)
13275 -- procedure is not itself protected. Within the body of a protected
13276 -- function the current instance of the protected type is a constant.
13278 function Is_Variable_Prefix (P : Node_Id) return Boolean;
13279 -- Prefixes can involve implicit dereferences, in which case we must
13280 -- test for the case of a reference of a constant access type, which can
13281 -- can never be a variable.
13283 ---------------------------
13284 -- In_Protected_Function --
13285 ---------------------------
13287 function In_Protected_Function (E : Entity_Id) return Boolean is
13292 -- E is the current instance of a type
13294 if Is_Type (E) then
13303 if not Is_Protected_Type (Prot) then
13307 S := Current_Scope;
13308 while Present (S) and then S /= Prot loop
13309 if Ekind (S) = E_Function and then Scope (S) = Prot then
13318 end In_Protected_Function;
13320 ------------------------
13321 -- Is_Variable_Prefix --
13322 ------------------------
13324 function Is_Variable_Prefix (P : Node_Id) return Boolean is
13326 if Is_Access_Type (Etype (P)) then
13327 return not Is_Access_Constant (Root_Type (Etype (P)));
13329 -- For the case of an indexed component whose prefix has a packed
13330 -- array type, the prefix has been rewritten into a type conversion.
13331 -- Determine variable-ness from the converted expression.
13333 elsif Nkind (P) = N_Type_Conversion
13334 and then not Comes_From_Source (P)
13335 and then Is_Array_Type (Etype (P))
13336 and then Is_Packed (Etype (P))
13338 return Is_Variable (Expression (P));
13341 return Is_Variable (P);
13343 end Is_Variable_Prefix;
13345 -- Start of processing for Is_Variable
13348 -- Special check, allow x'Deref(expr) as a variable
13350 if Nkind (N) = N_Attribute_Reference
13351 and then Attribute_Name (N) = Name_Deref
13356 -- Check if we perform the test on the original node since this may be a
13357 -- test of syntactic categories which must not be disturbed by whatever
13358 -- rewriting might have occurred. For example, an aggregate, which is
13359 -- certainly NOT a variable, could be turned into a variable by
13362 if Use_Original_Node then
13363 Orig_Node := Original_Node (N);
13368 -- Definitely OK if Assignment_OK is set. Since this is something that
13369 -- only gets set for expanded nodes, the test is on N, not Orig_Node.
13371 if Nkind (N) in N_Subexpr and then Assignment_OK (N) then
13374 -- Normally we go to the original node, but there is one exception where
13375 -- we use the rewritten node, namely when it is an explicit dereference.
13376 -- The generated code may rewrite a prefix which is an access type with
13377 -- an explicit dereference. The dereference is a variable, even though
13378 -- the original node may not be (since it could be a constant of the
13381 -- In Ada 2005 we have a further case to consider: the prefix may be a
13382 -- function call given in prefix notation. The original node appears to
13383 -- be a selected component, but we need to examine the call.
13385 elsif Nkind (N) = N_Explicit_Dereference
13386 and then Nkind (Orig_Node) /= N_Explicit_Dereference
13387 and then Present (Etype (Orig_Node))
13388 and then Is_Access_Type (Etype (Orig_Node))
13390 -- Note that if the prefix is an explicit dereference that does not
13391 -- come from source, we must check for a rewritten function call in
13392 -- prefixed notation before other forms of rewriting, to prevent a
13396 (Nkind (Orig_Node) = N_Function_Call
13397 and then not Is_Access_Constant (Etype (Prefix (N))))
13399 Is_Variable_Prefix (Original_Node (Prefix (N)));
13401 -- in Ada 2012, the dereference may have been added for a type with
13402 -- a declared implicit dereference aspect. Check that it is not an
13403 -- access to constant.
13405 elsif Nkind (N) = N_Explicit_Dereference
13406 and then Present (Etype (Orig_Node))
13407 and then Ada_Version >= Ada_2012
13408 and then Has_Implicit_Dereference (Etype (Orig_Node))
13410 return not Is_Access_Constant (Etype (Prefix (N)));
13412 -- A function call is never a variable
13414 elsif Nkind (N) = N_Function_Call then
13417 -- All remaining checks use the original node
13419 elsif Is_Entity_Name (Orig_Node)
13420 and then Present (Entity (Orig_Node))
13423 E : constant Entity_Id := Entity (Orig_Node);
13424 K : constant Entity_Kind := Ekind (E);
13427 return (K = E_Variable
13428 and then Nkind (Parent (E)) /= N_Exception_Handler)
13429 or else (K = E_Component
13430 and then not In_Protected_Function (E))
13431 or else K = E_Out_Parameter
13432 or else K = E_In_Out_Parameter
13433 or else K = E_Generic_In_Out_Parameter
13435 -- Current instance of type. If this is a protected type, check
13436 -- we are not within the body of one of its protected functions.
13438 or else (Is_Type (E)
13439 and then In_Open_Scopes (E)
13440 and then not In_Protected_Function (E))
13442 or else (Is_Incomplete_Or_Private_Type (E)
13443 and then In_Open_Scopes (Full_View (E)));
13447 case Nkind (Orig_Node) is
13448 when N_Indexed_Component | N_Slice =>
13449 return Is_Variable_Prefix (Prefix (Orig_Node));
13451 when N_Selected_Component =>
13452 return (Is_Variable (Selector_Name (Orig_Node))
13453 and then Is_Variable_Prefix (Prefix (Orig_Node)))
13455 (Nkind (N) = N_Expanded_Name
13456 and then Scope (Entity (N)) = Entity (Prefix (N)));
13458 -- For an explicit dereference, the type of the prefix cannot
13459 -- be an access to constant or an access to subprogram.
13461 when N_Explicit_Dereference =>
13463 Typ : constant Entity_Id := Etype (Prefix (Orig_Node));
13465 return Is_Access_Type (Typ)
13466 and then not Is_Access_Constant (Root_Type (Typ))
13467 and then Ekind (Typ) /= E_Access_Subprogram_Type;
13470 -- The type conversion is the case where we do not deal with the
13471 -- context dependent special case of an actual parameter. Thus
13472 -- the type conversion is only considered a variable for the
13473 -- purposes of this routine if the target type is tagged. However,
13474 -- a type conversion is considered to be a variable if it does not
13475 -- come from source (this deals for example with the conversions
13476 -- of expressions to their actual subtypes).
13478 when N_Type_Conversion =>
13479 return Is_Variable (Expression (Orig_Node))
13481 (not Comes_From_Source (Orig_Node)
13483 (Is_Tagged_Type (Etype (Subtype_Mark (Orig_Node)))
13485 Is_Tagged_Type (Etype (Expression (Orig_Node)))));
13487 -- GNAT allows an unchecked type conversion as a variable. This
13488 -- only affects the generation of internal expanded code, since
13489 -- calls to instantiations of Unchecked_Conversion are never
13490 -- considered variables (since they are function calls).
13492 when N_Unchecked_Type_Conversion =>
13493 return Is_Variable (Expression (Orig_Node));
13501 ---------------------------
13502 -- Is_Visibly_Controlled --
13503 ---------------------------
13505 function Is_Visibly_Controlled (T : Entity_Id) return Boolean is
13506 Root : constant Entity_Id := Root_Type (T);
13508 return Chars (Scope (Root)) = Name_Finalization
13509 and then Chars (Scope (Scope (Root))) = Name_Ada
13510 and then Scope (Scope (Scope (Root))) = Standard_Standard;
13511 end Is_Visibly_Controlled;
13513 ------------------------
13514 -- Is_Volatile_Object --
13515 ------------------------
13517 function Is_Volatile_Object (N : Node_Id) return Boolean is
13519 function Is_Volatile_Prefix (N : Node_Id) return Boolean;
13520 -- If prefix is an implicit dereference, examine designated type
13522 function Object_Has_Volatile_Components (N : Node_Id) return Boolean;
13523 -- Determines if given object has volatile components
13525 ------------------------
13526 -- Is_Volatile_Prefix --
13527 ------------------------
13529 function Is_Volatile_Prefix (N : Node_Id) return Boolean is
13530 Typ : constant Entity_Id := Etype (N);
13533 if Is_Access_Type (Typ) then
13535 Dtyp : constant Entity_Id := Designated_Type (Typ);
13538 return Is_Volatile (Dtyp)
13539 or else Has_Volatile_Components (Dtyp);
13543 return Object_Has_Volatile_Components (N);
13545 end Is_Volatile_Prefix;
13547 ------------------------------------
13548 -- Object_Has_Volatile_Components --
13549 ------------------------------------
13551 function Object_Has_Volatile_Components (N : Node_Id) return Boolean is
13552 Typ : constant Entity_Id := Etype (N);
13555 if Is_Volatile (Typ)
13556 or else Has_Volatile_Components (Typ)
13560 elsif Is_Entity_Name (N)
13561 and then (Has_Volatile_Components (Entity (N))
13562 or else Is_Volatile (Entity (N)))
13566 elsif Nkind (N) = N_Indexed_Component
13567 or else Nkind (N) = N_Selected_Component
13569 return Is_Volatile_Prefix (Prefix (N));
13574 end Object_Has_Volatile_Components;
13576 -- Start of processing for Is_Volatile_Object
13579 if Nkind (N) = N_Defining_Identifier then
13580 return Is_Volatile (N) or else Is_Volatile (Etype (N));
13582 elsif Nkind (N) = N_Expanded_Name then
13583 return Is_Volatile_Object (Entity (N));
13585 elsif Is_Volatile (Etype (N))
13586 or else (Is_Entity_Name (N) and then Is_Volatile (Entity (N)))
13590 elsif Nkind_In (N, N_Indexed_Component, N_Selected_Component)
13591 and then Is_Volatile_Prefix (Prefix (N))
13595 elsif Nkind (N) = N_Selected_Component
13596 and then Is_Volatile (Entity (Selector_Name (N)))
13603 end Is_Volatile_Object;
13605 ---------------------------
13606 -- Itype_Has_Declaration --
13607 ---------------------------
13609 function Itype_Has_Declaration (Id : Entity_Id) return Boolean is
13611 pragma Assert (Is_Itype (Id));
13612 return Present (Parent (Id))
13613 and then Nkind_In (Parent (Id), N_Full_Type_Declaration,
13614 N_Subtype_Declaration)
13615 and then Defining_Entity (Parent (Id)) = Id;
13616 end Itype_Has_Declaration;
13618 -------------------------
13619 -- Kill_Current_Values --
13620 -------------------------
13622 procedure Kill_Current_Values
13624 Last_Assignment_Only : Boolean := False)
13627 if Is_Assignable (Ent) then
13628 Set_Last_Assignment (Ent, Empty);
13631 if Is_Object (Ent) then
13632 if not Last_Assignment_Only then
13634 Set_Current_Value (Ent, Empty);
13636 -- Do not reset the Is_Known_[Non_]Null and Is_Known_Valid flags
13637 -- for a constant. Once the constant is elaborated, its value is
13638 -- not changed, therefore the associated flags that describe the
13639 -- value should not be modified either.
13641 if Ekind (Ent) = E_Constant then
13644 -- Non-constant entities
13647 if not Can_Never_Be_Null (Ent) then
13648 Set_Is_Known_Non_Null (Ent, False);
13651 Set_Is_Known_Null (Ent, False);
13653 -- Reset the Is_Known_Valid flag unless the type is always
13654 -- valid. This does not apply to a loop parameter because its
13655 -- bounds are defined by the loop header and therefore always
13658 if not Is_Known_Valid (Etype (Ent))
13659 and then Ekind (Ent) /= E_Loop_Parameter
13661 Set_Is_Known_Valid (Ent, False);
13666 end Kill_Current_Values;
13668 procedure Kill_Current_Values (Last_Assignment_Only : Boolean := False) is
13671 procedure Kill_Current_Values_For_Entity_Chain (E : Entity_Id);
13672 -- Clear current value for entity E and all entities chained to E
13674 ------------------------------------------
13675 -- Kill_Current_Values_For_Entity_Chain --
13676 ------------------------------------------
13678 procedure Kill_Current_Values_For_Entity_Chain (E : Entity_Id) is
13682 while Present (Ent) loop
13683 Kill_Current_Values (Ent, Last_Assignment_Only);
13686 end Kill_Current_Values_For_Entity_Chain;
13688 -- Start of processing for Kill_Current_Values
13691 -- Kill all saved checks, a special case of killing saved values
13693 if not Last_Assignment_Only then
13697 -- Loop through relevant scopes, which includes the current scope and
13698 -- any parent scopes if the current scope is a block or a package.
13700 S := Current_Scope;
13703 -- Clear current values of all entities in current scope
13705 Kill_Current_Values_For_Entity_Chain (First_Entity (S));
13707 -- If scope is a package, also clear current values of all private
13708 -- entities in the scope.
13710 if Is_Package_Or_Generic_Package (S)
13711 or else Is_Concurrent_Type (S)
13713 Kill_Current_Values_For_Entity_Chain (First_Private_Entity (S));
13716 -- If this is a not a subprogram, deal with parents
13718 if not Is_Subprogram (S) then
13720 exit Scope_Loop when S = Standard_Standard;
13724 end loop Scope_Loop;
13725 end Kill_Current_Values;
13727 --------------------------
13728 -- Kill_Size_Check_Code --
13729 --------------------------
13731 procedure Kill_Size_Check_Code (E : Entity_Id) is
13733 if (Ekind (E) = E_Constant or else Ekind (E) = E_Variable)
13734 and then Present (Size_Check_Code (E))
13736 Remove (Size_Check_Code (E));
13737 Set_Size_Check_Code (E, Empty);
13739 end Kill_Size_Check_Code;
13741 --------------------------
13742 -- Known_To_Be_Assigned --
13743 --------------------------
13745 function Known_To_Be_Assigned (N : Node_Id) return Boolean is
13746 P : constant Node_Id := Parent (N);
13751 -- Test left side of assignment
13753 when N_Assignment_Statement =>
13754 return N = Name (P);
13756 -- Function call arguments are never lvalues
13758 when N_Function_Call =>
13761 -- Positional parameter for procedure or accept call
13763 when N_Procedure_Call_Statement |
13772 Proc := Get_Subprogram_Entity (P);
13778 -- If we are not a list member, something is strange, so
13779 -- be conservative and return False.
13781 if not Is_List_Member (N) then
13785 -- We are going to find the right formal by stepping forward
13786 -- through the formals, as we step backwards in the actuals.
13788 Form := First_Formal (Proc);
13791 -- If no formal, something is weird, so be conservative
13792 -- and return False.
13799 exit when No (Act);
13800 Next_Formal (Form);
13803 return Ekind (Form) /= E_In_Parameter;
13806 -- Named parameter for procedure or accept call
13808 when N_Parameter_Association =>
13814 Proc := Get_Subprogram_Entity (Parent (P));
13820 -- Loop through formals to find the one that matches
13822 Form := First_Formal (Proc);
13824 -- If no matching formal, that's peculiar, some kind of
13825 -- previous error, so return False to be conservative.
13826 -- Actually this also happens in legal code in the case
13827 -- where P is a parameter association for an Extra_Formal???
13833 -- Else test for match
13835 if Chars (Form) = Chars (Selector_Name (P)) then
13836 return Ekind (Form) /= E_In_Parameter;
13839 Next_Formal (Form);
13843 -- Test for appearing in a conversion that itself appears
13844 -- in an lvalue context, since this should be an lvalue.
13846 when N_Type_Conversion =>
13847 return Known_To_Be_Assigned (P);
13849 -- All other references are definitely not known to be modifications
13855 end Known_To_Be_Assigned;
13857 ---------------------------
13858 -- Last_Source_Statement --
13859 ---------------------------
13861 function Last_Source_Statement (HSS : Node_Id) return Node_Id is
13865 N := Last (Statements (HSS));
13866 while Present (N) loop
13867 exit when Comes_From_Source (N);
13872 end Last_Source_Statement;
13874 ----------------------------------
13875 -- Matching_Static_Array_Bounds --
13876 ----------------------------------
13878 function Matching_Static_Array_Bounds
13880 R_Typ : Node_Id) return Boolean
13882 L_Ndims : constant Nat := Number_Dimensions (L_Typ);
13883 R_Ndims : constant Nat := Number_Dimensions (R_Typ);
13895 if L_Ndims /= R_Ndims then
13899 -- Unconstrained types do not have static bounds
13901 if not Is_Constrained (L_Typ) or else not Is_Constrained (R_Typ) then
13905 -- First treat specially the first dimension, as the lower bound and
13906 -- length of string literals are not stored like those of arrays.
13908 if Ekind (L_Typ) = E_String_Literal_Subtype then
13909 L_Low := String_Literal_Low_Bound (L_Typ);
13910 L_Len := String_Literal_Length (L_Typ);
13912 L_Index := First_Index (L_Typ);
13913 Get_Index_Bounds (L_Index, L_Low, L_High);
13915 if Is_OK_Static_Expression (L_Low)
13917 Is_OK_Static_Expression (L_High)
13919 if Expr_Value (L_High) < Expr_Value (L_Low) then
13922 L_Len := (Expr_Value (L_High) - Expr_Value (L_Low)) + 1;
13929 if Ekind (R_Typ) = E_String_Literal_Subtype then
13930 R_Low := String_Literal_Low_Bound (R_Typ);
13931 R_Len := String_Literal_Length (R_Typ);
13933 R_Index := First_Index (R_Typ);
13934 Get_Index_Bounds (R_Index, R_Low, R_High);
13936 if Is_OK_Static_Expression (R_Low)
13938 Is_OK_Static_Expression (R_High)
13940 if Expr_Value (R_High) < Expr_Value (R_Low) then
13943 R_Len := (Expr_Value (R_High) - Expr_Value (R_Low)) + 1;
13950 if (Is_OK_Static_Expression (L_Low)
13952 Is_OK_Static_Expression (R_Low))
13953 and then Expr_Value (L_Low) = Expr_Value (R_Low)
13954 and then L_Len = R_Len
13961 -- Then treat all other dimensions
13963 for Indx in 2 .. L_Ndims loop
13967 Get_Index_Bounds (L_Index, L_Low, L_High);
13968 Get_Index_Bounds (R_Index, R_Low, R_High);
13970 if (Is_OK_Static_Expression (L_Low) and then
13971 Is_OK_Static_Expression (L_High) and then
13972 Is_OK_Static_Expression (R_Low) and then
13973 Is_OK_Static_Expression (R_High))
13974 and then (Expr_Value (L_Low) = Expr_Value (R_Low)
13976 Expr_Value (L_High) = Expr_Value (R_High))
13984 -- If we fall through the loop, all indexes matched
13987 end Matching_Static_Array_Bounds;
13989 -------------------
13990 -- May_Be_Lvalue --
13991 -------------------
13993 function May_Be_Lvalue (N : Node_Id) return Boolean is
13994 P : constant Node_Id := Parent (N);
13999 -- Test left side of assignment
14001 when N_Assignment_Statement =>
14002 return N = Name (P);
14004 -- Test prefix of component or attribute. Note that the prefix of an
14005 -- explicit or implicit dereference cannot be an l-value.
14007 when N_Attribute_Reference =>
14008 return N = Prefix (P)
14009 and then Name_Implies_Lvalue_Prefix (Attribute_Name (P));
14011 -- For an expanded name, the name is an lvalue if the expanded name
14012 -- is an lvalue, but the prefix is never an lvalue, since it is just
14013 -- the scope where the name is found.
14015 when N_Expanded_Name =>
14016 if N = Prefix (P) then
14017 return May_Be_Lvalue (P);
14022 -- For a selected component A.B, A is certainly an lvalue if A.B is.
14023 -- B is a little interesting, if we have A.B := 3, there is some
14024 -- discussion as to whether B is an lvalue or not, we choose to say
14025 -- it is. Note however that A is not an lvalue if it is of an access
14026 -- type since this is an implicit dereference.
14028 when N_Selected_Component =>
14030 and then Present (Etype (N))
14031 and then Is_Access_Type (Etype (N))
14035 return May_Be_Lvalue (P);
14038 -- For an indexed component or slice, the index or slice bounds is
14039 -- never an lvalue. The prefix is an lvalue if the indexed component
14040 -- or slice is an lvalue, except if it is an access type, where we
14041 -- have an implicit dereference.
14043 when N_Indexed_Component | N_Slice =>
14045 or else (Present (Etype (N)) and then Is_Access_Type (Etype (N)))
14049 return May_Be_Lvalue (P);
14052 -- Prefix of a reference is an lvalue if the reference is an lvalue
14054 when N_Reference =>
14055 return May_Be_Lvalue (P);
14057 -- Prefix of explicit dereference is never an lvalue
14059 when N_Explicit_Dereference =>
14062 -- Positional parameter for subprogram, entry, or accept call.
14063 -- In older versions of Ada function call arguments are never
14064 -- lvalues. In Ada 2012 functions can have in-out parameters.
14066 when N_Subprogram_Call |
14067 N_Entry_Call_Statement |
14070 if Nkind (P) = N_Function_Call and then Ada_Version < Ada_2012 then
14074 -- The following mechanism is clumsy and fragile. A single flag
14075 -- set in Resolve_Actuals would be preferable ???
14083 Proc := Get_Subprogram_Entity (P);
14089 -- If we are not a list member, something is strange, so be
14090 -- conservative and return True.
14092 if not Is_List_Member (N) then
14096 -- We are going to find the right formal by stepping forward
14097 -- through the formals, as we step backwards in the actuals.
14099 Form := First_Formal (Proc);
14102 -- If no formal, something is weird, so be conservative and
14110 exit when No (Act);
14111 Next_Formal (Form);
14114 return Ekind (Form) /= E_In_Parameter;
14117 -- Named parameter for procedure or accept call
14119 when N_Parameter_Association =>
14125 Proc := Get_Subprogram_Entity (Parent (P));
14131 -- Loop through formals to find the one that matches
14133 Form := First_Formal (Proc);
14135 -- If no matching formal, that's peculiar, some kind of
14136 -- previous error, so return True to be conservative.
14137 -- Actually happens with legal code for an unresolved call
14138 -- where we may get the wrong homonym???
14144 -- Else test for match
14146 if Chars (Form) = Chars (Selector_Name (P)) then
14147 return Ekind (Form) /= E_In_Parameter;
14150 Next_Formal (Form);
14154 -- Test for appearing in a conversion that itself appears in an
14155 -- lvalue context, since this should be an lvalue.
14157 when N_Type_Conversion =>
14158 return May_Be_Lvalue (P);
14160 -- Test for appearance in object renaming declaration
14162 when N_Object_Renaming_Declaration =>
14165 -- All other references are definitely not lvalues
14173 -----------------------
14174 -- Mark_Coextensions --
14175 -----------------------
14177 procedure Mark_Coextensions (Context_Nod : Node_Id; Root_Nod : Node_Id) is
14178 Is_Dynamic : Boolean;
14179 -- Indicates whether the context causes nested coextensions to be
14180 -- dynamic or static
14182 function Mark_Allocator (N : Node_Id) return Traverse_Result;
14183 -- Recognize an allocator node and label it as a dynamic coextension
14185 --------------------
14186 -- Mark_Allocator --
14187 --------------------
14189 function Mark_Allocator (N : Node_Id) return Traverse_Result is
14191 if Nkind (N) = N_Allocator then
14193 Set_Is_Dynamic_Coextension (N);
14195 -- If the allocator expression is potentially dynamic, it may
14196 -- be expanded out of order and require dynamic allocation
14197 -- anyway, so we treat the coextension itself as dynamic.
14198 -- Potential optimization ???
14200 elsif Nkind (Expression (N)) = N_Qualified_Expression
14201 and then Nkind (Expression (Expression (N))) = N_Op_Concat
14203 Set_Is_Dynamic_Coextension (N);
14205 Set_Is_Static_Coextension (N);
14210 end Mark_Allocator;
14212 procedure Mark_Allocators is new Traverse_Proc (Mark_Allocator);
14214 -- Start of processing Mark_Coextensions
14217 -- An allocator that appears on the right hand side of an assignment is
14218 -- treated as a potentially dynamic coextension when the right hand side
14219 -- is an allocator or a qualified expression.
14221 -- Obj := new ...'(new Coextension ...);
14223 if Nkind (Context_Nod) = N_Assignment_Statement then
14225 Nkind_In (Expression (Context_Nod), N_Allocator,
14226 N_Qualified_Expression);
14228 -- An allocator that appears within the expression of a simple return
14229 -- statement is treated as a potentially dynamic coextension when the
14230 -- expression is either aggregate, allocator or qualified expression.
14232 -- return (new Coextension ...);
14233 -- return new ...'(new Coextension ...);
14235 elsif Nkind (Context_Nod) = N_Simple_Return_Statement then
14237 Nkind_In (Expression (Context_Nod), N_Aggregate,
14239 N_Qualified_Expression);
14241 -- An alloctor that appears within the initialization expression of an
14242 -- object declaration is considered a potentially dynamic coextension
14243 -- when the initialization expression is an allocator or a qualified
14246 -- Obj : ... := new ...'(new Coextension ...);
14248 -- A similar case arises when the object declaration is part of an
14249 -- extended return statement.
14251 -- return Obj : ... := new ...'(new Coextension ...);
14252 -- return Obj : ... := (new Coextension ...);
14254 elsif Nkind (Context_Nod) = N_Object_Declaration then
14256 Nkind_In (Root_Nod, N_Allocator, N_Qualified_Expression)
14258 Nkind (Parent (Context_Nod)) = N_Extended_Return_Statement;
14260 -- This routine should not be called with constructs which may not
14261 -- contain coextensions.
14264 raise Program_Error;
14267 Mark_Allocators (Root_Nod);
14268 end Mark_Coextensions;
14270 ----------------------
14271 -- Needs_One_Actual --
14272 ----------------------
14274 function Needs_One_Actual (E : Entity_Id) return Boolean is
14275 Formal : Entity_Id;
14278 -- Ada 2005 or later, and formals present
14280 if Ada_Version >= Ada_2005 and then Present (First_Formal (E)) then
14281 Formal := Next_Formal (First_Formal (E));
14282 while Present (Formal) loop
14283 if No (Default_Value (Formal)) then
14287 Next_Formal (Formal);
14292 -- Ada 83/95 or no formals
14297 end Needs_One_Actual;
14299 ------------------------
14300 -- New_Copy_List_Tree --
14301 ------------------------
14303 function New_Copy_List_Tree (List : List_Id) return List_Id is
14308 if List = No_List then
14315 while Present (E) loop
14316 Append (New_Copy_Tree (E), NL);
14322 end New_Copy_List_Tree;
14324 --------------------------------------------------
14325 -- New_Copy_Tree Auxiliary Data and Subprograms --
14326 --------------------------------------------------
14328 use Atree.Unchecked_Access;
14329 use Atree_Private_Part;
14331 -- Our approach here requires a two pass traversal of the tree. The
14332 -- first pass visits all nodes that eventually will be copied looking
14333 -- for defining Itypes. If any defining Itypes are found, then they are
14334 -- copied, and an entry is added to the replacement map. In the second
14335 -- phase, the tree is copied, using the replacement map to replace any
14336 -- Itype references within the copied tree.
14338 -- The following hash tables are used if the Map supplied has more
14339 -- than hash threshold entries to speed up access to the map. If
14340 -- there are fewer entries, then the map is searched sequentially
14341 -- (because setting up a hash table for only a few entries takes
14342 -- more time than it saves.
14344 function New_Copy_Hash (E : Entity_Id) return NCT_Header_Num;
14345 -- Hash function used for hash operations
14347 -------------------
14348 -- New_Copy_Hash --
14349 -------------------
14351 function New_Copy_Hash (E : Entity_Id) return NCT_Header_Num is
14353 return Nat (E) mod (NCT_Header_Num'Last + 1);
14360 -- The hash table NCT_Assoc associates old entities in the table
14361 -- with their corresponding new entities (i.e. the pairs of entries
14362 -- presented in the original Map argument are Key-Element pairs).
14364 package NCT_Assoc is new Simple_HTable (
14365 Header_Num => NCT_Header_Num,
14366 Element => Entity_Id,
14367 No_Element => Empty,
14369 Hash => New_Copy_Hash,
14370 Equal => Types."=");
14372 ---------------------
14373 -- NCT_Itype_Assoc --
14374 ---------------------
14376 -- The hash table NCT_Itype_Assoc contains entries only for those
14377 -- old nodes which have a non-empty Associated_Node_For_Itype set.
14378 -- The key is the associated node, and the element is the new node
14379 -- itself (NOT the associated node for the new node).
14381 package NCT_Itype_Assoc is new Simple_HTable (
14382 Header_Num => NCT_Header_Num,
14383 Element => Entity_Id,
14384 No_Element => Empty,
14386 Hash => New_Copy_Hash,
14387 Equal => Types."=");
14389 -------------------
14390 -- New_Copy_Tree --
14391 -------------------
14393 function New_Copy_Tree
14395 Map : Elist_Id := No_Elist;
14396 New_Sloc : Source_Ptr := No_Location;
14397 New_Scope : Entity_Id := Empty) return Node_Id
14399 Actual_Map : Elist_Id := Map;
14400 -- This is the actual map for the copy. It is initialized with the
14401 -- given elements, and then enlarged as required for Itypes that are
14402 -- copied during the first phase of the copy operation. The visit
14403 -- procedures add elements to this map as Itypes are encountered.
14404 -- The reason we cannot use Map directly, is that it may well be
14405 -- (and normally is) initialized to No_Elist, and if we have mapped
14406 -- entities, we have to reset it to point to a real Elist.
14408 function Assoc (N : Node_Or_Entity_Id) return Node_Id;
14409 -- Called during second phase to map entities into their corresponding
14410 -- copies using Actual_Map. If the argument is not an entity, or is not
14411 -- in Actual_Map, then it is returned unchanged.
14413 procedure Build_NCT_Hash_Tables;
14414 -- Builds hash tables (number of elements >= threshold value)
14416 function Copy_Elist_With_Replacement
14417 (Old_Elist : Elist_Id) return Elist_Id;
14418 -- Called during second phase to copy element list doing replacements
14420 procedure Copy_Itype_With_Replacement (New_Itype : Entity_Id);
14421 -- Called during the second phase to process a copied Itype. The actual
14422 -- copy happened during the first phase (so that we could make the entry
14423 -- in the mapping), but we still have to deal with the descendents of
14424 -- the copied Itype and copy them where necessary.
14426 function Copy_List_With_Replacement (Old_List : List_Id) return List_Id;
14427 -- Called during second phase to copy list doing replacements
14429 function Copy_Node_With_Replacement (Old_Node : Node_Id) return Node_Id;
14430 -- Called during second phase to copy node doing replacements
14432 procedure Visit_Elist (E : Elist_Id);
14433 -- Called during first phase to visit all elements of an Elist
14435 procedure Visit_Field (F : Union_Id; N : Node_Id);
14436 -- Visit a single field, recursing to call Visit_Node or Visit_List
14437 -- if the field is a syntactic descendent of the current node (i.e.
14438 -- its parent is Node N).
14440 procedure Visit_Itype (Old_Itype : Entity_Id);
14441 -- Called during first phase to visit subsidiary fields of a defining
14442 -- Itype, and also create a copy and make an entry in the replacement
14443 -- map for the new copy.
14445 procedure Visit_List (L : List_Id);
14446 -- Called during first phase to visit all elements of a List
14448 procedure Visit_Node (N : Node_Or_Entity_Id);
14449 -- Called during first phase to visit a node and all its subtrees
14455 function Assoc (N : Node_Or_Entity_Id) return Node_Id is
14460 if not Has_Extension (N) or else No (Actual_Map) then
14463 elsif NCT_Hash_Tables_Used then
14464 Ent := NCT_Assoc.Get (Entity_Id (N));
14466 if Present (Ent) then
14472 -- No hash table used, do serial search
14475 E := First_Elmt (Actual_Map);
14476 while Present (E) loop
14477 if Node (E) = N then
14478 return Node (Next_Elmt (E));
14480 E := Next_Elmt (Next_Elmt (E));
14488 ---------------------------
14489 -- Build_NCT_Hash_Tables --
14490 ---------------------------
14492 procedure Build_NCT_Hash_Tables is
14496 if NCT_Hash_Table_Setup then
14498 NCT_Itype_Assoc.Reset;
14501 Elmt := First_Elmt (Actual_Map);
14502 while Present (Elmt) loop
14503 Ent := Node (Elmt);
14505 -- Get new entity, and associate old and new
14508 NCT_Assoc.Set (Ent, Node (Elmt));
14510 if Is_Type (Ent) then
14512 Anode : constant Entity_Id :=
14513 Associated_Node_For_Itype (Ent);
14516 if Present (Anode) then
14518 -- Enter a link between the associated node of the
14519 -- old Itype and the new Itype, for updating later
14520 -- when node is copied.
14522 NCT_Itype_Assoc.Set (Anode, Node (Elmt));
14530 NCT_Hash_Tables_Used := True;
14531 NCT_Hash_Table_Setup := True;
14532 end Build_NCT_Hash_Tables;
14534 ---------------------------------
14535 -- Copy_Elist_With_Replacement --
14536 ---------------------------------
14538 function Copy_Elist_With_Replacement
14539 (Old_Elist : Elist_Id) return Elist_Id
14542 New_Elist : Elist_Id;
14545 if No (Old_Elist) then
14549 New_Elist := New_Elmt_List;
14551 M := First_Elmt (Old_Elist);
14552 while Present (M) loop
14553 Append_Elmt (Copy_Node_With_Replacement (Node (M)), New_Elist);
14559 end Copy_Elist_With_Replacement;
14561 ---------------------------------
14562 -- Copy_Itype_With_Replacement --
14563 ---------------------------------
14565 -- This routine exactly parallels its phase one analog Visit_Itype,
14567 procedure Copy_Itype_With_Replacement (New_Itype : Entity_Id) is
14569 -- Translate Next_Entity, Scope and Etype fields, in case they
14570 -- reference entities that have been mapped into copies.
14572 Set_Next_Entity (New_Itype, Assoc (Next_Entity (New_Itype)));
14573 Set_Etype (New_Itype, Assoc (Etype (New_Itype)));
14575 if Present (New_Scope) then
14576 Set_Scope (New_Itype, New_Scope);
14578 Set_Scope (New_Itype, Assoc (Scope (New_Itype)));
14581 -- Copy referenced fields
14583 if Is_Discrete_Type (New_Itype) then
14584 Set_Scalar_Range (New_Itype,
14585 Copy_Node_With_Replacement (Scalar_Range (New_Itype)));
14587 elsif Has_Discriminants (Base_Type (New_Itype)) then
14588 Set_Discriminant_Constraint (New_Itype,
14589 Copy_Elist_With_Replacement
14590 (Discriminant_Constraint (New_Itype)));
14592 elsif Is_Array_Type (New_Itype) then
14593 if Present (First_Index (New_Itype)) then
14594 Set_First_Index (New_Itype,
14595 First (Copy_List_With_Replacement
14596 (List_Containing (First_Index (New_Itype)))));
14599 if Is_Packed (New_Itype) then
14600 Set_Packed_Array_Impl_Type (New_Itype,
14601 Copy_Node_With_Replacement
14602 (Packed_Array_Impl_Type (New_Itype)));
14605 end Copy_Itype_With_Replacement;
14607 --------------------------------
14608 -- Copy_List_With_Replacement --
14609 --------------------------------
14611 function Copy_List_With_Replacement
14612 (Old_List : List_Id) return List_Id
14614 New_List : List_Id;
14618 if Old_List = No_List then
14622 New_List := Empty_List;
14624 E := First (Old_List);
14625 while Present (E) loop
14626 Append (Copy_Node_With_Replacement (E), New_List);
14632 end Copy_List_With_Replacement;
14634 --------------------------------
14635 -- Copy_Node_With_Replacement --
14636 --------------------------------
14638 function Copy_Node_With_Replacement
14639 (Old_Node : Node_Id) return Node_Id
14641 New_Node : Node_Id;
14643 procedure Adjust_Named_Associations
14644 (Old_Node : Node_Id;
14645 New_Node : Node_Id);
14646 -- If a call node has named associations, these are chained through
14647 -- the First_Named_Actual, Next_Named_Actual links. These must be
14648 -- propagated separately to the new parameter list, because these
14649 -- are not syntactic fields.
14651 function Copy_Field_With_Replacement
14652 (Field : Union_Id) return Union_Id;
14653 -- Given Field, which is a field of Old_Node, return a copy of it
14654 -- if it is a syntactic field (i.e. its parent is Node), setting
14655 -- the parent of the copy to poit to New_Node. Otherwise returns
14656 -- the field (possibly mapped if it is an entity).
14658 -------------------------------
14659 -- Adjust_Named_Associations --
14660 -------------------------------
14662 procedure Adjust_Named_Associations
14663 (Old_Node : Node_Id;
14664 New_Node : Node_Id)
14669 Old_Next : Node_Id;
14670 New_Next : Node_Id;
14673 Old_E := First (Parameter_Associations (Old_Node));
14674 New_E := First (Parameter_Associations (New_Node));
14675 while Present (Old_E) loop
14676 if Nkind (Old_E) = N_Parameter_Association
14677 and then Present (Next_Named_Actual (Old_E))
14679 if First_Named_Actual (Old_Node)
14680 = Explicit_Actual_Parameter (Old_E)
14682 Set_First_Named_Actual
14683 (New_Node, Explicit_Actual_Parameter (New_E));
14686 -- Now scan parameter list from the beginning,to locate
14687 -- next named actual, which can be out of order.
14689 Old_Next := First (Parameter_Associations (Old_Node));
14690 New_Next := First (Parameter_Associations (New_Node));
14692 while Nkind (Old_Next) /= N_Parameter_Association
14693 or else Explicit_Actual_Parameter (Old_Next) /=
14694 Next_Named_Actual (Old_E)
14700 Set_Next_Named_Actual
14701 (New_E, Explicit_Actual_Parameter (New_Next));
14707 end Adjust_Named_Associations;
14709 ---------------------------------
14710 -- Copy_Field_With_Replacement --
14711 ---------------------------------
14713 function Copy_Field_With_Replacement
14714 (Field : Union_Id) return Union_Id
14717 if Field = Union_Id (Empty) then
14720 elsif Field in Node_Range then
14722 Old_N : constant Node_Id := Node_Id (Field);
14726 -- If syntactic field, as indicated by the parent pointer
14727 -- being set, then copy the referenced node recursively.
14729 if Parent (Old_N) = Old_Node then
14730 New_N := Copy_Node_With_Replacement (Old_N);
14732 if New_N /= Old_N then
14733 Set_Parent (New_N, New_Node);
14736 -- For semantic fields, update possible entity reference
14737 -- from the replacement map.
14740 New_N := Assoc (Old_N);
14743 return Union_Id (New_N);
14746 elsif Field in List_Range then
14748 Old_L : constant List_Id := List_Id (Field);
14752 -- If syntactic field, as indicated by the parent pointer,
14753 -- then recursively copy the entire referenced list.
14755 if Parent (Old_L) = Old_Node then
14756 New_L := Copy_List_With_Replacement (Old_L);
14757 Set_Parent (New_L, New_Node);
14759 -- For semantic list, just returned unchanged
14765 return Union_Id (New_L);
14768 -- Anything other than a list or a node is returned unchanged
14773 end Copy_Field_With_Replacement;
14775 -- Start of processing for Copy_Node_With_Replacement
14778 if Old_Node <= Empty_Or_Error then
14781 elsif Has_Extension (Old_Node) then
14782 return Assoc (Old_Node);
14785 New_Node := New_Copy (Old_Node);
14787 -- If the node we are copying is the associated node of a
14788 -- previously copied Itype, then adjust the associated node
14789 -- of the copy of that Itype accordingly.
14791 if Present (Actual_Map) then
14797 -- Case of hash table used
14799 if NCT_Hash_Tables_Used then
14800 Ent := NCT_Itype_Assoc.Get (Old_Node);
14802 if Present (Ent) then
14803 Set_Associated_Node_For_Itype (Ent, New_Node);
14806 -- Case of no hash table used
14809 E := First_Elmt (Actual_Map);
14810 while Present (E) loop
14811 if Is_Itype (Node (E))
14813 Old_Node = Associated_Node_For_Itype (Node (E))
14815 Set_Associated_Node_For_Itype
14816 (Node (Next_Elmt (E)), New_Node);
14819 E := Next_Elmt (Next_Elmt (E));
14825 -- Recursively copy descendents
14828 (New_Node, Copy_Field_With_Replacement (Field1 (New_Node)));
14830 (New_Node, Copy_Field_With_Replacement (Field2 (New_Node)));
14832 (New_Node, Copy_Field_With_Replacement (Field3 (New_Node)));
14834 (New_Node, Copy_Field_With_Replacement (Field4 (New_Node)));
14836 (New_Node, Copy_Field_With_Replacement (Field5 (New_Node)));
14838 -- Adjust Sloc of new node if necessary
14840 if New_Sloc /= No_Location then
14841 Set_Sloc (New_Node, New_Sloc);
14843 -- If we adjust the Sloc, then we are essentially making
14844 -- a completely new node, so the Comes_From_Source flag
14845 -- should be reset to the proper default value.
14847 Nodes.Table (New_Node).Comes_From_Source :=
14848 Default_Node.Comes_From_Source;
14851 -- If the node is call and has named associations,
14852 -- set the corresponding links in the copy.
14854 if (Nkind (Old_Node) = N_Function_Call
14855 or else Nkind (Old_Node) = N_Entry_Call_Statement
14857 Nkind (Old_Node) = N_Procedure_Call_Statement)
14858 and then Present (First_Named_Actual (Old_Node))
14860 Adjust_Named_Associations (Old_Node, New_Node);
14863 -- Reset First_Real_Statement for Handled_Sequence_Of_Statements.
14864 -- The replacement mechanism applies to entities, and is not used
14865 -- here. Eventually we may need a more general graph-copying
14866 -- routine. For now, do a sequential search to find desired node.
14868 if Nkind (Old_Node) = N_Handled_Sequence_Of_Statements
14869 and then Present (First_Real_Statement (Old_Node))
14872 Old_F : constant Node_Id := First_Real_Statement (Old_Node);
14876 N1 := First (Statements (Old_Node));
14877 N2 := First (Statements (New_Node));
14879 while N1 /= Old_F loop
14884 Set_First_Real_Statement (New_Node, N2);
14889 -- All done, return copied node
14892 end Copy_Node_With_Replacement;
14898 procedure Visit_Elist (E : Elist_Id) is
14901 if Present (E) then
14902 Elmt := First_Elmt (E);
14904 while Elmt /= No_Elmt loop
14905 Visit_Node (Node (Elmt));
14915 procedure Visit_Field (F : Union_Id; N : Node_Id) is
14917 if F = Union_Id (Empty) then
14920 elsif F in Node_Range then
14922 -- Copy node if it is syntactic, i.e. its parent pointer is
14923 -- set to point to the field that referenced it (certain
14924 -- Itypes will also meet this criterion, which is fine, since
14925 -- these are clearly Itypes that do need to be copied, since
14926 -- we are copying their parent.)
14928 if Parent (Node_Id (F)) = N then
14929 Visit_Node (Node_Id (F));
14932 -- Another case, if we are pointing to an Itype, then we want
14933 -- to copy it if its associated node is somewhere in the tree
14936 -- Note: the exclusion of self-referential copies is just an
14937 -- optimization, since the search of the already copied list
14938 -- would catch it, but it is a common case (Etype pointing
14939 -- to itself for an Itype that is a base type).
14941 elsif Has_Extension (Node_Id (F))
14942 and then Is_Itype (Entity_Id (F))
14943 and then Node_Id (F) /= N
14949 P := Associated_Node_For_Itype (Node_Id (F));
14950 while Present (P) loop
14952 Visit_Node (Node_Id (F));
14959 -- An Itype whose parent is not being copied definitely
14960 -- should NOT be copied, since it does not belong in any
14961 -- sense to the copied subtree.
14967 elsif F in List_Range and then Parent (List_Id (F)) = N then
14968 Visit_List (List_Id (F));
14977 procedure Visit_Itype (Old_Itype : Entity_Id) is
14978 New_Itype : Entity_Id;
14983 -- Itypes that describe the designated type of access to subprograms
14984 -- have the structure of subprogram declarations, with signatures,
14985 -- etc. Either we duplicate the signatures completely, or choose to
14986 -- share such itypes, which is fine because their elaboration will
14987 -- have no side effects.
14989 if Ekind (Old_Itype) = E_Subprogram_Type then
14993 New_Itype := New_Copy (Old_Itype);
14995 -- The new Itype has all the attributes of the old one, and
14996 -- we just copy the contents of the entity. However, the back-end
14997 -- needs different names for debugging purposes, so we create a
14998 -- new internal name for it in all cases.
15000 Set_Chars (New_Itype, New_Internal_Name ('T'));
15002 -- If our associated node is an entity that has already been copied,
15003 -- then set the associated node of the copy to point to the right
15004 -- copy. If we have copied an Itype that is itself the associated
15005 -- node of some previously copied Itype, then we set the right
15006 -- pointer in the other direction.
15008 if Present (Actual_Map) then
15010 -- Case of hash tables used
15012 if NCT_Hash_Tables_Used then
15014 Ent := NCT_Assoc.Get (Associated_Node_For_Itype (Old_Itype));
15016 if Present (Ent) then
15017 Set_Associated_Node_For_Itype (New_Itype, Ent);
15020 Ent := NCT_Itype_Assoc.Get (Old_Itype);
15021 if Present (Ent) then
15022 Set_Associated_Node_For_Itype (Ent, New_Itype);
15024 -- If the hash table has no association for this Itype and
15025 -- its associated node, enter one now.
15028 NCT_Itype_Assoc.Set
15029 (Associated_Node_For_Itype (Old_Itype), New_Itype);
15032 -- Case of hash tables not used
15035 E := First_Elmt (Actual_Map);
15036 while Present (E) loop
15037 if Associated_Node_For_Itype (Old_Itype) = Node (E) then
15038 Set_Associated_Node_For_Itype
15039 (New_Itype, Node (Next_Elmt (E)));
15042 if Is_Type (Node (E))
15043 and then Old_Itype = Associated_Node_For_Itype (Node (E))
15045 Set_Associated_Node_For_Itype
15046 (Node (Next_Elmt (E)), New_Itype);
15049 E := Next_Elmt (Next_Elmt (E));
15054 if Present (Freeze_Node (New_Itype)) then
15055 Set_Is_Frozen (New_Itype, False);
15056 Set_Freeze_Node (New_Itype, Empty);
15059 -- Add new association to map
15061 if No (Actual_Map) then
15062 Actual_Map := New_Elmt_List;
15065 Append_Elmt (Old_Itype, Actual_Map);
15066 Append_Elmt (New_Itype, Actual_Map);
15068 if NCT_Hash_Tables_Used then
15069 NCT_Assoc.Set (Old_Itype, New_Itype);
15072 NCT_Table_Entries := NCT_Table_Entries + 1;
15074 if NCT_Table_Entries > NCT_Hash_Threshold then
15075 Build_NCT_Hash_Tables;
15079 -- If a record subtype is simply copied, the entity list will be
15080 -- shared. Thus cloned_Subtype must be set to indicate the sharing.
15082 if Ekind_In (Old_Itype, E_Record_Subtype, E_Class_Wide_Subtype) then
15083 Set_Cloned_Subtype (New_Itype, Old_Itype);
15086 -- Visit descendents that eventually get copied
15088 Visit_Field (Union_Id (Etype (Old_Itype)), Old_Itype);
15090 if Is_Discrete_Type (Old_Itype) then
15091 Visit_Field (Union_Id (Scalar_Range (Old_Itype)), Old_Itype);
15093 elsif Has_Discriminants (Base_Type (Old_Itype)) then
15094 -- ??? This should involve call to Visit_Field
15095 Visit_Elist (Discriminant_Constraint (Old_Itype));
15097 elsif Is_Array_Type (Old_Itype) then
15098 if Present (First_Index (Old_Itype)) then
15099 Visit_Field (Union_Id (List_Containing
15100 (First_Index (Old_Itype))),
15104 if Is_Packed (Old_Itype) then
15105 Visit_Field (Union_Id (Packed_Array_Impl_Type (Old_Itype)),
15115 procedure Visit_List (L : List_Id) is
15118 if L /= No_List then
15121 while Present (N) loop
15132 procedure Visit_Node (N : Node_Or_Entity_Id) is
15134 -- Start of processing for Visit_Node
15137 -- Handle case of an Itype, which must be copied
15139 if Has_Extension (N) and then Is_Itype (N) then
15141 -- Nothing to do if already in the list. This can happen with an
15142 -- Itype entity that appears more than once in the tree.
15143 -- Note that we do not want to visit descendents in this case.
15145 -- Test for already in list when hash table is used
15147 if NCT_Hash_Tables_Used then
15148 if Present (NCT_Assoc.Get (Entity_Id (N))) then
15152 -- Test for already in list when hash table not used
15158 if Present (Actual_Map) then
15159 E := First_Elmt (Actual_Map);
15160 while Present (E) loop
15161 if Node (E) = N then
15164 E := Next_Elmt (Next_Elmt (E));
15174 -- Visit descendents
15176 Visit_Field (Field1 (N), N);
15177 Visit_Field (Field2 (N), N);
15178 Visit_Field (Field3 (N), N);
15179 Visit_Field (Field4 (N), N);
15180 Visit_Field (Field5 (N), N);
15183 -- Start of processing for New_Copy_Tree
15188 -- See if we should use hash table
15190 if No (Actual_Map) then
15191 NCT_Hash_Tables_Used := False;
15198 NCT_Table_Entries := 0;
15200 Elmt := First_Elmt (Actual_Map);
15201 while Present (Elmt) loop
15202 NCT_Table_Entries := NCT_Table_Entries + 1;
15207 if NCT_Table_Entries > NCT_Hash_Threshold then
15208 Build_NCT_Hash_Tables;
15210 NCT_Hash_Tables_Used := False;
15215 -- Hash table set up if required, now start phase one by visiting
15216 -- top node (we will recursively visit the descendents).
15218 Visit_Node (Source);
15220 -- Now the second phase of the copy can start. First we process
15221 -- all the mapped entities, copying their descendents.
15223 if Present (Actual_Map) then
15226 New_Itype : Entity_Id;
15228 Elmt := First_Elmt (Actual_Map);
15229 while Present (Elmt) loop
15231 New_Itype := Node (Elmt);
15232 Copy_Itype_With_Replacement (New_Itype);
15238 -- Now we can copy the actual tree
15240 return Copy_Node_With_Replacement (Source);
15243 -------------------------
15244 -- New_External_Entity --
15245 -------------------------
15247 function New_External_Entity
15248 (Kind : Entity_Kind;
15249 Scope_Id : Entity_Id;
15250 Sloc_Value : Source_Ptr;
15251 Related_Id : Entity_Id;
15252 Suffix : Character;
15253 Suffix_Index : Nat := 0;
15254 Prefix : Character := ' ') return Entity_Id
15256 N : constant Entity_Id :=
15257 Make_Defining_Identifier (Sloc_Value,
15259 (Chars (Related_Id), Suffix, Suffix_Index, Prefix));
15262 Set_Ekind (N, Kind);
15263 Set_Is_Internal (N, True);
15264 Append_Entity (N, Scope_Id);
15265 Set_Public_Status (N);
15267 if Kind in Type_Kind then
15268 Init_Size_Align (N);
15272 end New_External_Entity;
15274 -------------------------
15275 -- New_Internal_Entity --
15276 -------------------------
15278 function New_Internal_Entity
15279 (Kind : Entity_Kind;
15280 Scope_Id : Entity_Id;
15281 Sloc_Value : Source_Ptr;
15282 Id_Char : Character) return Entity_Id
15284 N : constant Entity_Id := Make_Temporary (Sloc_Value, Id_Char);
15287 Set_Ekind (N, Kind);
15288 Set_Is_Internal (N, True);
15289 Append_Entity (N, Scope_Id);
15291 if Kind in Type_Kind then
15292 Init_Size_Align (N);
15296 end New_Internal_Entity;
15302 function Next_Actual (Actual_Id : Node_Id) return Node_Id is
15306 -- If we are pointing at a positional parameter, it is a member of a
15307 -- node list (the list of parameters), and the next parameter is the
15308 -- next node on the list, unless we hit a parameter association, then
15309 -- we shift to using the chain whose head is the First_Named_Actual in
15310 -- the parent, and then is threaded using the Next_Named_Actual of the
15311 -- Parameter_Association. All this fiddling is because the original node
15312 -- list is in the textual call order, and what we need is the
15313 -- declaration order.
15315 if Is_List_Member (Actual_Id) then
15316 N := Next (Actual_Id);
15318 if Nkind (N) = N_Parameter_Association then
15319 return First_Named_Actual (Parent (Actual_Id));
15325 return Next_Named_Actual (Parent (Actual_Id));
15329 procedure Next_Actual (Actual_Id : in out Node_Id) is
15331 Actual_Id := Next_Actual (Actual_Id);
15334 -----------------------
15335 -- Normalize_Actuals --
15336 -----------------------
15338 -- Chain actuals according to formals of subprogram. If there are no named
15339 -- associations, the chain is simply the list of Parameter Associations,
15340 -- since the order is the same as the declaration order. If there are named
15341 -- associations, then the First_Named_Actual field in the N_Function_Call
15342 -- or N_Procedure_Call_Statement node points to the Parameter_Association
15343 -- node for the parameter that comes first in declaration order. The
15344 -- remaining named parameters are then chained in declaration order using
15345 -- Next_Named_Actual.
15347 -- This routine also verifies that the number of actuals is compatible with
15348 -- the number and default values of formals, but performs no type checking
15349 -- (type checking is done by the caller).
15351 -- If the matching succeeds, Success is set to True and the caller proceeds
15352 -- with type-checking. If the match is unsuccessful, then Success is set to
15353 -- False, and the caller attempts a different interpretation, if there is
15356 -- If the flag Report is on, the call is not overloaded, and a failure to
15357 -- match can be reported here, rather than in the caller.
15359 procedure Normalize_Actuals
15363 Success : out Boolean)
15365 Actuals : constant List_Id := Parameter_Associations (N);
15366 Actual : Node_Id := Empty;
15367 Formal : Entity_Id;
15368 Last : Node_Id := Empty;
15369 First_Named : Node_Id := Empty;
15372 Formals_To_Match : Integer := 0;
15373 Actuals_To_Match : Integer := 0;
15375 procedure Chain (A : Node_Id);
15376 -- Add named actual at the proper place in the list, using the
15377 -- Next_Named_Actual link.
15379 function Reporting return Boolean;
15380 -- Determines if an error is to be reported. To report an error, we
15381 -- need Report to be True, and also we do not report errors caused
15382 -- by calls to init procs that occur within other init procs. Such
15383 -- errors must always be cascaded errors, since if all the types are
15384 -- declared correctly, the compiler will certainly build decent calls.
15390 procedure Chain (A : Node_Id) is
15394 -- Call node points to first actual in list
15396 Set_First_Named_Actual (N, Explicit_Actual_Parameter (A));
15399 Set_Next_Named_Actual (Last, Explicit_Actual_Parameter (A));
15403 Set_Next_Named_Actual (Last, Empty);
15410 function Reporting return Boolean is
15415 elsif not Within_Init_Proc then
15418 elsif Is_Init_Proc (Entity (Name (N))) then
15426 -- Start of processing for Normalize_Actuals
15429 if Is_Access_Type (S) then
15431 -- The name in the call is a function call that returns an access
15432 -- to subprogram. The designated type has the list of formals.
15434 Formal := First_Formal (Designated_Type (S));
15436 Formal := First_Formal (S);
15439 while Present (Formal) loop
15440 Formals_To_Match := Formals_To_Match + 1;
15441 Next_Formal (Formal);
15444 -- Find if there is a named association, and verify that no positional
15445 -- associations appear after named ones.
15447 if Present (Actuals) then
15448 Actual := First (Actuals);
15451 while Present (Actual)
15452 and then Nkind (Actual) /= N_Parameter_Association
15454 Actuals_To_Match := Actuals_To_Match + 1;
15458 if No (Actual) and Actuals_To_Match = Formals_To_Match then
15460 -- Most common case: positional notation, no defaults
15465 elsif Actuals_To_Match > Formals_To_Match then
15467 -- Too many actuals: will not work
15470 if Is_Entity_Name (Name (N)) then
15471 Error_Msg_N ("too many arguments in call to&", Name (N));
15473 Error_Msg_N ("too many arguments in call", N);
15481 First_Named := Actual;
15483 while Present (Actual) loop
15484 if Nkind (Actual) /= N_Parameter_Association then
15486 ("positional parameters not allowed after named ones", Actual);
15491 Actuals_To_Match := Actuals_To_Match + 1;
15497 if Present (Actuals) then
15498 Actual := First (Actuals);
15501 Formal := First_Formal (S);
15502 while Present (Formal) loop
15504 -- Match the formals in order. If the corresponding actual is
15505 -- positional, nothing to do. Else scan the list of named actuals
15506 -- to find the one with the right name.
15508 if Present (Actual)
15509 and then Nkind (Actual) /= N_Parameter_Association
15512 Actuals_To_Match := Actuals_To_Match - 1;
15513 Formals_To_Match := Formals_To_Match - 1;
15516 -- For named parameters, search the list of actuals to find
15517 -- one that matches the next formal name.
15519 Actual := First_Named;
15521 while Present (Actual) loop
15522 if Chars (Selector_Name (Actual)) = Chars (Formal) then
15525 Actuals_To_Match := Actuals_To_Match - 1;
15526 Formals_To_Match := Formals_To_Match - 1;
15534 if Ekind (Formal) /= E_In_Parameter
15535 or else No (Default_Value (Formal))
15538 if (Comes_From_Source (S)
15539 or else Sloc (S) = Standard_Location)
15540 and then Is_Overloadable (S)
15544 Nkind_In (Parent (N), N_Procedure_Call_Statement,
15546 N_Parameter_Association)
15547 and then Ekind (S) /= E_Function
15549 Set_Etype (N, Etype (S));
15552 Error_Msg_Name_1 := Chars (S);
15553 Error_Msg_Sloc := Sloc (S);
15555 ("missing argument for parameter & "
15556 & "in call to % declared #", N, Formal);
15559 elsif Is_Overloadable (S) then
15560 Error_Msg_Name_1 := Chars (S);
15562 -- Point to type derivation that generated the
15565 Error_Msg_Sloc := Sloc (Parent (S));
15568 ("missing argument for parameter & "
15569 & "in call to % (inherited) #", N, Formal);
15573 ("missing argument for parameter &", N, Formal);
15581 Formals_To_Match := Formals_To_Match - 1;
15586 Next_Formal (Formal);
15589 if Formals_To_Match = 0 and then Actuals_To_Match = 0 then
15596 -- Find some superfluous named actual that did not get
15597 -- attached to the list of associations.
15599 Actual := First (Actuals);
15600 while Present (Actual) loop
15601 if Nkind (Actual) = N_Parameter_Association
15602 and then Actual /= Last
15603 and then No (Next_Named_Actual (Actual))
15605 Error_Msg_N ("unmatched actual & in call",
15606 Selector_Name (Actual));
15617 end Normalize_Actuals;
15619 --------------------------------
15620 -- Note_Possible_Modification --
15621 --------------------------------
15623 procedure Note_Possible_Modification (N : Node_Id; Sure : Boolean) is
15624 Modification_Comes_From_Source : constant Boolean :=
15625 Comes_From_Source (Parent (N));
15631 -- Loop to find referenced entity, if there is one
15637 if Is_Entity_Name (Exp) then
15638 Ent := Entity (Exp);
15640 -- If the entity is missing, it is an undeclared identifier,
15641 -- and there is nothing to annotate.
15647 elsif Nkind (Exp) = N_Explicit_Dereference then
15649 P : constant Node_Id := Prefix (Exp);
15652 -- In formal verification mode, keep track of all reads and
15653 -- writes through explicit dereferences.
15655 if GNATprove_Mode then
15656 SPARK_Specific.Generate_Dereference (N, 'm');
15659 if Nkind (P) = N_Selected_Component
15660 and then Present (Entry_Formal (Entity (Selector_Name (P))))
15662 -- Case of a reference to an entry formal
15664 Ent := Entry_Formal (Entity (Selector_Name (P)));
15666 elsif Nkind (P) = N_Identifier
15667 and then Nkind (Parent (Entity (P))) = N_Object_Declaration
15668 and then Present (Expression (Parent (Entity (P))))
15669 and then Nkind (Expression (Parent (Entity (P)))) =
15672 -- Case of a reference to a value on which side effects have
15675 Exp := Prefix (Expression (Parent (Entity (P))));
15683 elsif Nkind_In (Exp, N_Type_Conversion,
15684 N_Unchecked_Type_Conversion)
15686 Exp := Expression (Exp);
15689 elsif Nkind_In (Exp, N_Slice,
15690 N_Indexed_Component,
15691 N_Selected_Component)
15693 -- Special check, if the prefix is an access type, then return
15694 -- since we are modifying the thing pointed to, not the prefix.
15695 -- When we are expanding, most usually the prefix is replaced
15696 -- by an explicit dereference, and this test is not needed, but
15697 -- in some cases (notably -gnatc mode and generics) when we do
15698 -- not do full expansion, we need this special test.
15700 if Is_Access_Type (Etype (Prefix (Exp))) then
15703 -- Otherwise go to prefix and keep going
15706 Exp := Prefix (Exp);
15710 -- All other cases, not a modification
15716 -- Now look for entity being referenced
15718 if Present (Ent) then
15719 if Is_Object (Ent) then
15720 if Comes_From_Source (Exp)
15721 or else Modification_Comes_From_Source
15723 -- Give warning if pragma unmodified given and we are
15724 -- sure this is a modification.
15726 if Has_Pragma_Unmodified (Ent) and then Sure then
15727 Error_Msg_NE ("??pragma Unmodified given for &!", N, Ent);
15730 Set_Never_Set_In_Source (Ent, False);
15733 Set_Is_True_Constant (Ent, False);
15734 Set_Current_Value (Ent, Empty);
15735 Set_Is_Known_Null (Ent, False);
15737 if not Can_Never_Be_Null (Ent) then
15738 Set_Is_Known_Non_Null (Ent, False);
15741 -- Follow renaming chain
15743 if (Ekind (Ent) = E_Variable or else Ekind (Ent) = E_Constant)
15744 and then Present (Renamed_Object (Ent))
15746 Exp := Renamed_Object (Ent);
15748 -- If the entity is the loop variable in an iteration over
15749 -- a container, retrieve container expression to indicate
15750 -- possible modification.
15752 if Present (Related_Expression (Ent))
15753 and then Nkind (Parent (Related_Expression (Ent))) =
15754 N_Iterator_Specification
15756 Exp := Original_Node (Related_Expression (Ent));
15761 -- The expression may be the renaming of a subcomponent of an
15762 -- array or container. The assignment to the subcomponent is
15763 -- a modification of the container.
15765 elsif Comes_From_Source (Original_Node (Exp))
15766 and then Nkind_In (Original_Node (Exp), N_Selected_Component,
15767 N_Indexed_Component)
15769 Exp := Prefix (Original_Node (Exp));
15773 -- Generate a reference only if the assignment comes from
15774 -- source. This excludes, for example, calls to a dispatching
15775 -- assignment operation when the left-hand side is tagged. In
15776 -- GNATprove mode, we need those references also on generated
15777 -- code, as these are used to compute the local effects of
15780 if Modification_Comes_From_Source or GNATprove_Mode then
15781 Generate_Reference (Ent, Exp, 'm');
15783 -- If the target of the assignment is the bound variable
15784 -- in an iterator, indicate that the corresponding array
15785 -- or container is also modified.
15787 if Ada_Version >= Ada_2012
15788 and then Nkind (Parent (Ent)) = N_Iterator_Specification
15791 Domain : constant Node_Id := Name (Parent (Ent));
15794 -- TBD : in the full version of the construct, the
15795 -- domain of iteration can be given by an expression.
15797 if Is_Entity_Name (Domain) then
15798 Generate_Reference (Entity (Domain), Exp, 'm');
15799 Set_Is_True_Constant (Entity (Domain), False);
15800 Set_Never_Set_In_Source (Entity (Domain), False);
15809 -- If we are sure this is a modification from source, and we know
15810 -- this modifies a constant, then give an appropriate warning.
15812 if Overlays_Constant (Ent)
15813 and then (Modification_Comes_From_Source and Sure)
15816 A : constant Node_Id := Address_Clause (Ent);
15818 if Present (A) then
15820 Exp : constant Node_Id := Expression (A);
15822 if Nkind (Exp) = N_Attribute_Reference
15823 and then Attribute_Name (Exp) = Name_Address
15824 and then Is_Entity_Name (Prefix (Exp))
15826 Error_Msg_Sloc := Sloc (A);
15828 ("constant& may be modified via address "
15829 & "clause#??", N, Entity (Prefix (Exp)));
15842 end Note_Possible_Modification;
15844 -------------------------
15845 -- Object_Access_Level --
15846 -------------------------
15848 -- Returns the static accessibility level of the view denoted by Obj. Note
15849 -- that the value returned is the result of a call to Scope_Depth. Only
15850 -- scope depths associated with dynamic scopes can actually be returned.
15851 -- Since only relative levels matter for accessibility checking, the fact
15852 -- that the distance between successive levels of accessibility is not
15853 -- always one is immaterial (invariant: if level(E2) is deeper than
15854 -- level(E1), then Scope_Depth(E1) < Scope_Depth(E2)).
15856 function Object_Access_Level (Obj : Node_Id) return Uint is
15857 function Is_Interface_Conversion (N : Node_Id) return Boolean;
15858 -- Determine whether N is a construct of the form
15859 -- Some_Type (Operand._tag'Address)
15860 -- This construct appears in the context of dispatching calls.
15862 function Reference_To (Obj : Node_Id) return Node_Id;
15863 -- An explicit dereference is created when removing side-effects from
15864 -- expressions for constraint checking purposes. In this case a local
15865 -- access type is created for it. The correct access level is that of
15866 -- the original source node. We detect this case by noting that the
15867 -- prefix of the dereference is created by an object declaration whose
15868 -- initial expression is a reference.
15870 -----------------------------
15871 -- Is_Interface_Conversion --
15872 -----------------------------
15874 function Is_Interface_Conversion (N : Node_Id) return Boolean is
15876 return Nkind (N) = N_Unchecked_Type_Conversion
15877 and then Nkind (Expression (N)) = N_Attribute_Reference
15878 and then Attribute_Name (Expression (N)) = Name_Address;
15879 end Is_Interface_Conversion;
15885 function Reference_To (Obj : Node_Id) return Node_Id is
15886 Pref : constant Node_Id := Prefix (Obj);
15888 if Is_Entity_Name (Pref)
15889 and then Nkind (Parent (Entity (Pref))) = N_Object_Declaration
15890 and then Present (Expression (Parent (Entity (Pref))))
15891 and then Nkind (Expression (Parent (Entity (Pref)))) = N_Reference
15893 return (Prefix (Expression (Parent (Entity (Pref)))));
15903 -- Start of processing for Object_Access_Level
15906 if Nkind (Obj) = N_Defining_Identifier
15907 or else Is_Entity_Name (Obj)
15909 if Nkind (Obj) = N_Defining_Identifier then
15915 if Is_Prival (E) then
15916 E := Prival_Link (E);
15919 -- If E is a type then it denotes a current instance. For this case
15920 -- we add one to the normal accessibility level of the type to ensure
15921 -- that current instances are treated as always being deeper than
15922 -- than the level of any visible named access type (see 3.10.2(21)).
15924 if Is_Type (E) then
15925 return Type_Access_Level (E) + 1;
15927 elsif Present (Renamed_Object (E)) then
15928 return Object_Access_Level (Renamed_Object (E));
15930 -- Similarly, if E is a component of the current instance of a
15931 -- protected type, any instance of it is assumed to be at a deeper
15932 -- level than the type. For a protected object (whose type is an
15933 -- anonymous protected type) its components are at the same level
15934 -- as the type itself.
15936 elsif not Is_Overloadable (E)
15937 and then Ekind (Scope (E)) = E_Protected_Type
15938 and then Comes_From_Source (Scope (E))
15940 return Type_Access_Level (Scope (E)) + 1;
15943 -- Aliased formals take their access level from the point of call.
15944 -- This is smaller than the level of the subprogram itself.
15946 if Is_Formal (E) and then Is_Aliased (E) then
15947 return Type_Access_Level (Etype (E));
15950 return Scope_Depth (Enclosing_Dynamic_Scope (E));
15954 elsif Nkind (Obj) = N_Selected_Component then
15955 if Is_Access_Type (Etype (Prefix (Obj))) then
15956 return Type_Access_Level (Etype (Prefix (Obj)));
15958 return Object_Access_Level (Prefix (Obj));
15961 elsif Nkind (Obj) = N_Indexed_Component then
15962 if Is_Access_Type (Etype (Prefix (Obj))) then
15963 return Type_Access_Level (Etype (Prefix (Obj)));
15965 return Object_Access_Level (Prefix (Obj));
15968 elsif Nkind (Obj) = N_Explicit_Dereference then
15970 -- If the prefix is a selected access discriminant then we make a
15971 -- recursive call on the prefix, which will in turn check the level
15972 -- of the prefix object of the selected discriminant.
15974 -- In Ada 2012, if the discriminant has implicit dereference and
15975 -- the context is a selected component, treat this as an object of
15976 -- unknown scope (see below). This is necessary in compile-only mode;
15977 -- otherwise expansion will already have transformed the prefix into
15980 if Nkind (Prefix (Obj)) = N_Selected_Component
15981 and then Ekind (Etype (Prefix (Obj))) = E_Anonymous_Access_Type
15983 Ekind (Entity (Selector_Name (Prefix (Obj)))) = E_Discriminant
15985 (not Has_Implicit_Dereference
15986 (Entity (Selector_Name (Prefix (Obj))))
15987 or else Nkind (Parent (Obj)) /= N_Selected_Component)
15989 return Object_Access_Level (Prefix (Obj));
15991 -- Detect an interface conversion in the context of a dispatching
15992 -- call. Use the original form of the conversion to find the access
15993 -- level of the operand.
15995 elsif Is_Interface (Etype (Obj))
15996 and then Is_Interface_Conversion (Prefix (Obj))
15997 and then Nkind (Original_Node (Obj)) = N_Type_Conversion
15999 return Object_Access_Level (Original_Node (Obj));
16001 elsif not Comes_From_Source (Obj) then
16003 Ref : constant Node_Id := Reference_To (Obj);
16005 if Present (Ref) then
16006 return Object_Access_Level (Ref);
16008 return Type_Access_Level (Etype (Prefix (Obj)));
16013 return Type_Access_Level (Etype (Prefix (Obj)));
16016 elsif Nkind_In (Obj, N_Type_Conversion, N_Unchecked_Type_Conversion) then
16017 return Object_Access_Level (Expression (Obj));
16019 elsif Nkind (Obj) = N_Function_Call then
16021 -- Function results are objects, so we get either the access level of
16022 -- the function or, in the case of an indirect call, the level of the
16023 -- access-to-subprogram type. (This code is used for Ada 95, but it
16024 -- looks wrong, because it seems that we should be checking the level
16025 -- of the call itself, even for Ada 95. However, using the Ada 2005
16026 -- version of the code causes regressions in several tests that are
16027 -- compiled with -gnat95. ???)
16029 if Ada_Version < Ada_2005 then
16030 if Is_Entity_Name (Name (Obj)) then
16031 return Subprogram_Access_Level (Entity (Name (Obj)));
16033 return Type_Access_Level (Etype (Prefix (Name (Obj))));
16036 -- For Ada 2005, the level of the result object of a function call is
16037 -- defined to be the level of the call's innermost enclosing master.
16038 -- We determine that by querying the depth of the innermost enclosing
16042 Return_Master_Scope_Depth_Of_Call : declare
16044 function Innermost_Master_Scope_Depth
16045 (N : Node_Id) return Uint;
16046 -- Returns the scope depth of the given node's innermost
16047 -- enclosing dynamic scope (effectively the accessibility
16048 -- level of the innermost enclosing master).
16050 ----------------------------------
16051 -- Innermost_Master_Scope_Depth --
16052 ----------------------------------
16054 function Innermost_Master_Scope_Depth
16055 (N : Node_Id) return Uint
16057 Node_Par : Node_Id := Parent (N);
16060 -- Locate the nearest enclosing node (by traversing Parents)
16061 -- that Defining_Entity can be applied to, and return the
16062 -- depth of that entity's nearest enclosing dynamic scope.
16064 while Present (Node_Par) loop
16065 case Nkind (Node_Par) is
16066 when N_Component_Declaration |
16067 N_Entry_Declaration |
16068 N_Formal_Object_Declaration |
16069 N_Formal_Type_Declaration |
16070 N_Full_Type_Declaration |
16071 N_Incomplete_Type_Declaration |
16072 N_Loop_Parameter_Specification |
16073 N_Object_Declaration |
16074 N_Protected_Type_Declaration |
16075 N_Private_Extension_Declaration |
16076 N_Private_Type_Declaration |
16077 N_Subtype_Declaration |
16078 N_Function_Specification |
16079 N_Procedure_Specification |
16080 N_Task_Type_Declaration |
16082 N_Generic_Instantiation |
16084 N_Implicit_Label_Declaration |
16085 N_Package_Declaration |
16086 N_Single_Task_Declaration |
16087 N_Subprogram_Declaration |
16088 N_Generic_Declaration |
16089 N_Renaming_Declaration |
16090 N_Block_Statement |
16091 N_Formal_Subprogram_Declaration |
16092 N_Abstract_Subprogram_Declaration |
16094 N_Exception_Declaration |
16095 N_Formal_Package_Declaration |
16096 N_Number_Declaration |
16097 N_Package_Specification |
16098 N_Parameter_Specification |
16099 N_Single_Protected_Declaration |
16103 (Nearest_Dynamic_Scope
16104 (Defining_Entity (Node_Par)));
16110 Node_Par := Parent (Node_Par);
16113 pragma Assert (False);
16115 -- Should never reach the following return
16117 return Scope_Depth (Current_Scope) + 1;
16118 end Innermost_Master_Scope_Depth;
16120 -- Start of processing for Return_Master_Scope_Depth_Of_Call
16123 return Innermost_Master_Scope_Depth (Obj);
16124 end Return_Master_Scope_Depth_Of_Call;
16127 -- For convenience we handle qualified expressions, even though they
16128 -- aren't technically object names.
16130 elsif Nkind (Obj) = N_Qualified_Expression then
16131 return Object_Access_Level (Expression (Obj));
16133 -- Ditto for aggregates. They have the level of the temporary that
16134 -- will hold their value.
16136 elsif Nkind (Obj) = N_Aggregate then
16137 return Object_Access_Level (Current_Scope);
16139 -- Otherwise return the scope level of Standard. (If there are cases
16140 -- that fall through to this point they will be treated as having
16141 -- global accessibility for now. ???)
16144 return Scope_Depth (Standard_Standard);
16146 end Object_Access_Level;
16148 ---------------------------------
16149 -- Original_Aspect_Pragma_Name --
16150 ---------------------------------
16152 function Original_Aspect_Pragma_Name (N : Node_Id) return Name_Id is
16154 Item_Nam : Name_Id;
16157 pragma Assert (Nkind_In (N, N_Aspect_Specification, N_Pragma));
16161 -- The pragma was generated to emulate an aspect, use the original
16162 -- aspect specification.
16164 if Nkind (Item) = N_Pragma and then From_Aspect_Specification (Item) then
16165 Item := Corresponding_Aspect (Item);
16168 -- Retrieve the name of the aspect/pragma. Note that Pre, Pre_Class,
16169 -- Post and Post_Class rewrite their pragma identifier to preserve the
16171 -- ??? this is kludgey
16173 if Nkind (Item) = N_Pragma then
16174 Item_Nam := Chars (Original_Node (Pragma_Identifier (Item)));
16177 pragma Assert (Nkind (Item) = N_Aspect_Specification);
16178 Item_Nam := Chars (Identifier (Item));
16181 -- Deal with 'Class by converting the name to its _XXX form
16183 if Class_Present (Item) then
16184 if Item_Nam = Name_Invariant then
16185 Item_Nam := Name_uInvariant;
16187 elsif Item_Nam = Name_Post then
16188 Item_Nam := Name_uPost;
16190 elsif Item_Nam = Name_Pre then
16191 Item_Nam := Name_uPre;
16193 elsif Nam_In (Item_Nam, Name_Type_Invariant,
16194 Name_Type_Invariant_Class)
16196 Item_Nam := Name_uType_Invariant;
16198 -- Nothing to do for other cases (e.g. a Check that derived from
16199 -- Pre_Class and has the flag set). Also we do nothing if the name
16200 -- is already in special _xxx form.
16206 end Original_Aspect_Pragma_Name;
16208 --------------------------------------
16209 -- Original_Corresponding_Operation --
16210 --------------------------------------
16212 function Original_Corresponding_Operation (S : Entity_Id) return Entity_Id
16214 Typ : constant Entity_Id := Find_Dispatching_Type (S);
16217 -- If S is an inherited primitive S2 the original corresponding
16218 -- operation of S is the original corresponding operation of S2
16220 if Present (Alias (S))
16221 and then Find_Dispatching_Type (Alias (S)) /= Typ
16223 return Original_Corresponding_Operation (Alias (S));
16225 -- If S overrides an inherited subprogram S2 the original corresponding
16226 -- operation of S is the original corresponding operation of S2
16228 elsif Present (Overridden_Operation (S)) then
16229 return Original_Corresponding_Operation (Overridden_Operation (S));
16231 -- otherwise it is S itself
16236 end Original_Corresponding_Operation;
16238 ----------------------
16239 -- Policy_In_Effect --
16240 ----------------------
16242 function Policy_In_Effect (Policy : Name_Id) return Name_Id is
16243 function Policy_In_List (List : Node_Id) return Name_Id;
16244 -- Determine the mode of a policy in a N_Pragma list
16246 --------------------
16247 -- Policy_In_List --
16248 --------------------
16250 function Policy_In_List (List : Node_Id) return Name_Id is
16257 while Present (Prag) loop
16258 Arg1 := First (Pragma_Argument_Associations (Prag));
16259 Arg2 := Next (Arg1);
16261 Arg1 := Get_Pragma_Arg (Arg1);
16262 Arg2 := Get_Pragma_Arg (Arg2);
16264 -- The current Check_Policy pragma matches the requested policy or
16265 -- appears in the single argument form (Assertion, policy_id).
16267 if Nam_In (Chars (Arg1), Name_Assertion, Policy) then
16268 return Chars (Arg2);
16271 Prag := Next_Pragma (Prag);
16275 end Policy_In_List;
16281 -- Start of processing for Policy_In_Effect
16284 if not Is_Valid_Assertion_Kind (Policy) then
16285 raise Program_Error;
16288 -- Inspect all policy pragmas that appear within scopes (if any)
16290 Kind := Policy_In_List (Check_Policy_List);
16292 -- Inspect all configuration policy pragmas (if any)
16294 if Kind = No_Name then
16295 Kind := Policy_In_List (Check_Policy_List_Config);
16298 -- The context lacks policy pragmas, determine the mode based on whether
16299 -- assertions are enabled at the configuration level. This ensures that
16300 -- the policy is preserved when analyzing generics.
16302 if Kind = No_Name then
16303 if Assertions_Enabled_Config then
16304 Kind := Name_Check;
16306 Kind := Name_Ignore;
16311 end Policy_In_Effect;
16313 ----------------------------------
16314 -- Predicate_Tests_On_Arguments --
16315 ----------------------------------
16317 function Predicate_Tests_On_Arguments (Subp : Entity_Id) return Boolean is
16319 -- Always test predicates on indirect call
16321 if Ekind (Subp) = E_Subprogram_Type then
16324 -- Do not test predicates on call to generated default Finalize, since
16325 -- we are not interested in whether something we are finalizing (and
16326 -- typically destroying) satisfies its predicates.
16328 elsif Chars (Subp) = Name_Finalize
16329 and then not Comes_From_Source (Subp)
16333 -- Do not test predicates on any internally generated routines
16335 elsif Is_Internal_Name (Chars (Subp)) then
16338 -- Do not test predicates on call to Init_Proc, since if needed the
16339 -- predicate test will occur at some other point.
16341 elsif Is_Init_Proc (Subp) then
16344 -- Do not test predicates on call to predicate function, since this
16345 -- would cause infinite recursion.
16347 elsif Ekind (Subp) = E_Function
16348 and then (Is_Predicate_Function (Subp)
16350 Is_Predicate_Function_M (Subp))
16354 -- For now, no other exceptions
16359 end Predicate_Tests_On_Arguments;
16361 -----------------------
16362 -- Private_Component --
16363 -----------------------
16365 function Private_Component (Type_Id : Entity_Id) return Entity_Id is
16366 Ancestor : constant Entity_Id := Base_Type (Type_Id);
16368 function Trace_Components
16370 Check : Boolean) return Entity_Id;
16371 -- Recursive function that does the work, and checks against circular
16372 -- definition for each subcomponent type.
16374 ----------------------
16375 -- Trace_Components --
16376 ----------------------
16378 function Trace_Components
16380 Check : Boolean) return Entity_Id
16382 Btype : constant Entity_Id := Base_Type (T);
16383 Component : Entity_Id;
16385 Candidate : Entity_Id := Empty;
16388 if Check and then Btype = Ancestor then
16389 Error_Msg_N ("circular type definition", Type_Id);
16393 if Is_Private_Type (Btype) and then not Is_Generic_Type (Btype) then
16394 if Present (Full_View (Btype))
16395 and then Is_Record_Type (Full_View (Btype))
16396 and then not Is_Frozen (Btype)
16398 -- To indicate that the ancestor depends on a private type, the
16399 -- current Btype is sufficient. However, to check for circular
16400 -- definition we must recurse on the full view.
16402 Candidate := Trace_Components (Full_View (Btype), True);
16404 if Candidate = Any_Type then
16414 elsif Is_Array_Type (Btype) then
16415 return Trace_Components (Component_Type (Btype), True);
16417 elsif Is_Record_Type (Btype) then
16418 Component := First_Entity (Btype);
16419 while Present (Component)
16420 and then Comes_From_Source (Component)
16422 -- Skip anonymous types generated by constrained components
16424 if not Is_Type (Component) then
16425 P := Trace_Components (Etype (Component), True);
16427 if Present (P) then
16428 if P = Any_Type then
16436 Next_Entity (Component);
16444 end Trace_Components;
16446 -- Start of processing for Private_Component
16449 return Trace_Components (Type_Id, False);
16450 end Private_Component;
16452 ---------------------------
16453 -- Primitive_Names_Match --
16454 ---------------------------
16456 function Primitive_Names_Match (E1, E2 : Entity_Id) return Boolean is
16458 function Non_Internal_Name (E : Entity_Id) return Name_Id;
16459 -- Given an internal name, returns the corresponding non-internal name
16461 ------------------------
16462 -- Non_Internal_Name --
16463 ------------------------
16465 function Non_Internal_Name (E : Entity_Id) return Name_Id is
16467 Get_Name_String (Chars (E));
16468 Name_Len := Name_Len - 1;
16470 end Non_Internal_Name;
16472 -- Start of processing for Primitive_Names_Match
16475 pragma Assert (Present (E1) and then Present (E2));
16477 return Chars (E1) = Chars (E2)
16479 (not Is_Internal_Name (Chars (E1))
16480 and then Is_Internal_Name (Chars (E2))
16481 and then Non_Internal_Name (E2) = Chars (E1))
16483 (not Is_Internal_Name (Chars (E2))
16484 and then Is_Internal_Name (Chars (E1))
16485 and then Non_Internal_Name (E1) = Chars (E2))
16487 (Is_Predefined_Dispatching_Operation (E1)
16488 and then Is_Predefined_Dispatching_Operation (E2)
16489 and then Same_TSS (E1, E2))
16491 (Is_Init_Proc (E1) and then Is_Init_Proc (E2));
16492 end Primitive_Names_Match;
16494 -----------------------
16495 -- Process_End_Label --
16496 -----------------------
16498 procedure Process_End_Label
16507 Label_Ref : Boolean;
16508 -- Set True if reference to end label itself is required
16511 -- Gets set to the operator symbol or identifier that references the
16512 -- entity Ent. For the child unit case, this is the identifier from the
16513 -- designator. For other cases, this is simply Endl.
16515 procedure Generate_Parent_Ref (N : Node_Id; E : Entity_Id);
16516 -- N is an identifier node that appears as a parent unit reference in
16517 -- the case where Ent is a child unit. This procedure generates an
16518 -- appropriate cross-reference entry. E is the corresponding entity.
16520 -------------------------
16521 -- Generate_Parent_Ref --
16522 -------------------------
16524 procedure Generate_Parent_Ref (N : Node_Id; E : Entity_Id) is
16526 -- If names do not match, something weird, skip reference
16528 if Chars (E) = Chars (N) then
16530 -- Generate the reference. We do NOT consider this as a reference
16531 -- for unreferenced symbol purposes.
16533 Generate_Reference (E, N, 'r', Set_Ref => False, Force => True);
16535 if Style_Check then
16536 Style.Check_Identifier (N, E);
16539 end Generate_Parent_Ref;
16541 -- Start of processing for Process_End_Label
16544 -- If no node, ignore. This happens in some error situations, and
16545 -- also for some internally generated structures where no end label
16546 -- references are required in any case.
16552 -- Nothing to do if no End_Label, happens for internally generated
16553 -- constructs where we don't want an end label reference anyway. Also
16554 -- nothing to do if Endl is a string literal, which means there was
16555 -- some prior error (bad operator symbol)
16557 Endl := End_Label (N);
16559 if No (Endl) or else Nkind (Endl) = N_String_Literal then
16563 -- Reference node is not in extended main source unit
16565 if not In_Extended_Main_Source_Unit (N) then
16567 -- Generally we do not collect references except for the extended
16568 -- main source unit. The one exception is the 'e' entry for a
16569 -- package spec, where it is useful for a client to have the
16570 -- ending information to define scopes.
16576 Label_Ref := False;
16578 -- For this case, we can ignore any parent references, but we
16579 -- need the package name itself for the 'e' entry.
16581 if Nkind (Endl) = N_Designator then
16582 Endl := Identifier (Endl);
16586 -- Reference is in extended main source unit
16591 -- For designator, generate references for the parent entries
16593 if Nkind (Endl) = N_Designator then
16595 -- Generate references for the prefix if the END line comes from
16596 -- source (otherwise we do not need these references) We climb the
16597 -- scope stack to find the expected entities.
16599 if Comes_From_Source (Endl) then
16600 Nam := Name (Endl);
16601 Scop := Current_Scope;
16602 while Nkind (Nam) = N_Selected_Component loop
16603 Scop := Scope (Scop);
16604 exit when No (Scop);
16605 Generate_Parent_Ref (Selector_Name (Nam), Scop);
16606 Nam := Prefix (Nam);
16609 if Present (Scop) then
16610 Generate_Parent_Ref (Nam, Scope (Scop));
16614 Endl := Identifier (Endl);
16618 -- If the end label is not for the given entity, then either we have
16619 -- some previous error, or this is a generic instantiation for which
16620 -- we do not need to make a cross-reference in this case anyway. In
16621 -- either case we simply ignore the call.
16623 if Chars (Ent) /= Chars (Endl) then
16627 -- If label was really there, then generate a normal reference and then
16628 -- adjust the location in the end label to point past the name (which
16629 -- should almost always be the semicolon).
16631 Loc := Sloc (Endl);
16633 if Comes_From_Source (Endl) then
16635 -- If a label reference is required, then do the style check and
16636 -- generate an l-type cross-reference entry for the label
16639 if Style_Check then
16640 Style.Check_Identifier (Endl, Ent);
16643 Generate_Reference (Ent, Endl, 'l', Set_Ref => False);
16646 -- Set the location to point past the label (normally this will
16647 -- mean the semicolon immediately following the label). This is
16648 -- done for the sake of the 'e' or 't' entry generated below.
16650 Get_Decoded_Name_String (Chars (Endl));
16651 Set_Sloc (Endl, Sloc (Endl) + Source_Ptr (Name_Len));
16654 -- In SPARK mode, no missing label is allowed for packages and
16655 -- subprogram bodies. Detect those cases by testing whether
16656 -- Process_End_Label was called for a body (Typ = 't') or a package.
16658 if Restriction_Check_Required (SPARK_05)
16659 and then (Typ = 't' or else Ekind (Ent) = E_Package)
16661 Error_Msg_Node_1 := Endl;
16662 Check_SPARK_05_Restriction
16663 ("`END &` required", Endl, Force => True);
16667 -- Now generate the e/t reference
16669 Generate_Reference (Ent, Endl, Typ, Set_Ref => False, Force => True);
16671 -- Restore Sloc, in case modified above, since we have an identifier
16672 -- and the normal Sloc should be left set in the tree.
16674 Set_Sloc (Endl, Loc);
16675 end Process_End_Label;
16681 function Referenced (Id : Entity_Id; Expr : Node_Id) return Boolean is
16682 Seen : Boolean := False;
16684 function Is_Reference (N : Node_Id) return Traverse_Result;
16685 -- Determine whether node N denotes a reference to Id. If this is the
16686 -- case, set global flag Seen to True and stop the traversal.
16692 function Is_Reference (N : Node_Id) return Traverse_Result is
16694 if Is_Entity_Name (N)
16695 and then Present (Entity (N))
16696 and then Entity (N) = Id
16705 procedure Inspect_Expression is new Traverse_Proc (Is_Reference);
16707 -- Start of processing for Referenced
16710 Inspect_Expression (Expr);
16714 ------------------------------------
16715 -- References_Generic_Formal_Type --
16716 ------------------------------------
16718 function References_Generic_Formal_Type (N : Node_Id) return Boolean is
16720 function Process (N : Node_Id) return Traverse_Result;
16721 -- Process one node in search for generic formal type
16727 function Process (N : Node_Id) return Traverse_Result is
16729 if Nkind (N) in N_Has_Entity then
16731 E : constant Entity_Id := Entity (N);
16733 if Present (E) then
16734 if Is_Generic_Type (E) then
16736 elsif Present (Etype (E))
16737 and then Is_Generic_Type (Etype (E))
16748 function Traverse is new Traverse_Func (Process);
16749 -- Traverse tree to look for generic type
16752 if Inside_A_Generic then
16753 return Traverse (N) = Abandon;
16757 end References_Generic_Formal_Type;
16759 --------------------
16760 -- Remove_Homonym --
16761 --------------------
16763 procedure Remove_Homonym (E : Entity_Id) is
16764 Prev : Entity_Id := Empty;
16768 if E = Current_Entity (E) then
16769 if Present (Homonym (E)) then
16770 Set_Current_Entity (Homonym (E));
16772 Set_Name_Entity_Id (Chars (E), Empty);
16776 H := Current_Entity (E);
16777 while Present (H) and then H /= E loop
16782 -- If E is not on the homonym chain, nothing to do
16784 if Present (H) then
16785 Set_Homonym (Prev, Homonym (E));
16788 end Remove_Homonym;
16790 ---------------------
16791 -- Rep_To_Pos_Flag --
16792 ---------------------
16794 function Rep_To_Pos_Flag (E : Entity_Id; Loc : Source_Ptr) return Node_Id is
16796 return New_Occurrence_Of
16797 (Boolean_Literals (not Range_Checks_Suppressed (E)), Loc);
16798 end Rep_To_Pos_Flag;
16800 --------------------
16801 -- Require_Entity --
16802 --------------------
16804 procedure Require_Entity (N : Node_Id) is
16806 if Is_Entity_Name (N) and then No (Entity (N)) then
16807 if Total_Errors_Detected /= 0 then
16808 Set_Entity (N, Any_Id);
16810 raise Program_Error;
16813 end Require_Entity;
16815 -------------------------------
16816 -- Requires_State_Refinement --
16817 -------------------------------
16819 function Requires_State_Refinement
16820 (Spec_Id : Entity_Id;
16821 Body_Id : Entity_Id) return Boolean
16823 function Mode_Is_Off (Prag : Node_Id) return Boolean;
16824 -- Given pragma SPARK_Mode, determine whether the mode is Off
16830 function Mode_Is_Off (Prag : Node_Id) return Boolean is
16834 -- The default SPARK mode is On
16840 Mode := Get_Pragma_Arg (First (Pragma_Argument_Associations (Prag)));
16842 -- Then the pragma lacks an argument, the default mode is On
16847 return Chars (Mode) = Name_Off;
16851 -- Start of processing for Requires_State_Refinement
16854 -- A package that does not define at least one abstract state cannot
16855 -- possibly require refinement.
16857 if No (Abstract_States (Spec_Id)) then
16860 -- The package instroduces a single null state which does not merit
16863 elsif Has_Null_Abstract_State (Spec_Id) then
16866 -- Check whether the package body is subject to pragma SPARK_Mode. If
16867 -- it is and the mode is Off, the package body is considered to be in
16868 -- regular Ada and does not require refinement.
16870 elsif Mode_Is_Off (SPARK_Pragma (Body_Id)) then
16873 -- The body's SPARK_Mode may be inherited from a similar pragma that
16874 -- appears in the private declarations of the spec. The pragma we are
16875 -- interested appears as the second entry in SPARK_Pragma.
16877 elsif Present (SPARK_Pragma (Spec_Id))
16878 and then Mode_Is_Off (Next_Pragma (SPARK_Pragma (Spec_Id)))
16882 -- The spec defines at least one abstract state and the body has no way
16883 -- of circumventing the refinement.
16888 end Requires_State_Refinement;
16890 ------------------------------
16891 -- Requires_Transient_Scope --
16892 ------------------------------
16894 -- A transient scope is required when variable-sized temporaries are
16895 -- allocated on the secondary stack, or when finalization actions must be
16896 -- generated before the next instruction.
16898 function Old_Requires_Transient_Scope (Id : Entity_Id) return Boolean;
16899 function New_Requires_Transient_Scope (Id : Entity_Id) return Boolean;
16900 -- ???We retain the old and new algorithms for Requires_Transient_Scope for
16901 -- the time being. New_Requires_Transient_Scope is used by default; the
16902 -- debug switch -gnatdQ can be used to do Old_Requires_Transient_Scope
16903 -- instead. The intent is to use this temporarily to measure before/after
16904 -- efficiency. Note: when this temporary code is removed, the documentation
16905 -- of dQ in debug.adb should be removed.
16907 procedure Results_Differ (Id : Entity_Id);
16908 -- ???Debugging code. Called when the Old_ and New_ results differ. Will be
16909 -- removed when New_Requires_Transient_Scope becomes
16910 -- Requires_Transient_Scope and Old_Requires_Transient_Scope is eliminated.
16912 procedure Results_Differ (Id : Entity_Id) is
16914 if False then -- False to disable; True for debugging
16915 Treepr.Print_Tree_Node (Id);
16917 if Old_Requires_Transient_Scope (Id) =
16918 New_Requires_Transient_Scope (Id)
16920 raise Program_Error;
16923 end Results_Differ;
16925 function Requires_Transient_Scope (Id : Entity_Id) return Boolean is
16926 Old_Result : constant Boolean := Old_Requires_Transient_Scope (Id);
16929 if Debug_Flag_QQ then
16934 New_Result : constant Boolean := New_Requires_Transient_Scope (Id);
16937 -- Assert that we're not putting things on the secondary stack if we
16938 -- didn't before; we are trying to AVOID secondary stack when
16941 if not Old_Result then
16942 pragma Assert (not New_Result);
16946 if New_Result /= Old_Result then
16947 Results_Differ (Id);
16952 end Requires_Transient_Scope;
16954 ----------------------------------
16955 -- Old_Requires_Transient_Scope --
16956 ----------------------------------
16958 function Old_Requires_Transient_Scope (Id : Entity_Id) return Boolean is
16959 Typ : constant Entity_Id := Underlying_Type (Id);
16962 -- This is a private type which is not completed yet. This can only
16963 -- happen in a default expression (of a formal parameter or of a
16964 -- record component). Do not expand transient scope in this case.
16969 -- Do not expand transient scope for non-existent procedure return
16971 elsif Typ = Standard_Void_Type then
16974 -- Elementary types do not require a transient scope
16976 elsif Is_Elementary_Type (Typ) then
16979 -- Generally, indefinite subtypes require a transient scope, since the
16980 -- back end cannot generate temporaries, since this is not a valid type
16981 -- for declaring an object. It might be possible to relax this in the
16982 -- future, e.g. by declaring the maximum possible space for the type.
16984 elsif not Is_Definite_Subtype (Typ) then
16987 -- Functions returning tagged types may dispatch on result so their
16988 -- returned value is allocated on the secondary stack. Controlled
16989 -- type temporaries need finalization.
16991 elsif Is_Tagged_Type (Typ) or else Has_Controlled_Component (Typ) then
16996 elsif Is_Record_Type (Typ) then
17001 Comp := First_Entity (Typ);
17002 while Present (Comp) loop
17003 if Ekind (Comp) = E_Component then
17005 -- ???It's not clear we need a full recursive call to
17006 -- Old_Requires_Transient_Scope here. Note that the
17007 -- following can't happen.
17009 pragma Assert (Is_Definite_Subtype (Etype (Comp)));
17010 pragma Assert (not Has_Controlled_Component (Etype (Comp)));
17012 if Old_Requires_Transient_Scope (Etype (Comp)) then
17017 Next_Entity (Comp);
17023 -- String literal types never require transient scope
17025 elsif Ekind (Typ) = E_String_Literal_Subtype then
17028 -- Array type. Note that we already know that this is a constrained
17029 -- array, since unconstrained arrays will fail the indefinite test.
17031 elsif Is_Array_Type (Typ) then
17033 -- If component type requires a transient scope, the array does too
17035 if Old_Requires_Transient_Scope (Component_Type (Typ)) then
17038 -- Otherwise, we only need a transient scope if the size depends on
17039 -- the value of one or more discriminants.
17042 return Size_Depends_On_Discriminant (Typ);
17045 -- All other cases do not require a transient scope
17048 pragma Assert (Is_Protected_Type (Typ) or else Is_Task_Type (Typ));
17051 end Old_Requires_Transient_Scope;
17053 ----------------------------------
17054 -- New_Requires_Transient_Scope --
17055 ----------------------------------
17057 function New_Requires_Transient_Scope (Id : Entity_Id) return Boolean is
17059 function Caller_Known_Size_Record (Typ : Entity_Id) return Boolean;
17060 -- This is called for untagged records and protected types, with
17061 -- nondefaulted discriminants. Returns True if the size of function
17062 -- results is known at the call site, False otherwise. Returns False
17063 -- if there is a variant part that depends on the discriminants of
17064 -- this type, or if there is an array constrained by the discriminants
17065 -- of this type. ???Currently, this is overly conservative (the array
17066 -- could be nested inside some other record that is constrained by
17067 -- nondiscriminants). That is, the recursive calls are too conservative.
17069 ------------------------------
17070 -- Caller_Known_Size_Record --
17071 ------------------------------
17073 function Caller_Known_Size_Record (Typ : Entity_Id) return Boolean is
17074 pragma Assert (Typ = Underlying_Type (Typ));
17077 if Has_Variant_Part (Typ) and then not Is_Definite_Subtype (Typ) then
17085 Comp := First_Entity (Typ);
17086 while Present (Comp) loop
17088 -- Only look at E_Component entities. No need to look at
17089 -- E_Discriminant entities, and we must ignore internal
17090 -- subtypes generated for constrained components.
17092 if Ekind (Comp) = E_Component then
17094 Comp_Type : constant Entity_Id :=
17095 Underlying_Type (Etype (Comp));
17098 if Is_Record_Type (Comp_Type)
17100 Is_Protected_Type (Comp_Type)
17102 if not Caller_Known_Size_Record (Comp_Type) then
17106 elsif Is_Array_Type (Comp_Type) then
17107 if Size_Depends_On_Discriminant (Comp_Type) then
17114 Next_Entity (Comp);
17119 end Caller_Known_Size_Record;
17121 -- Local declarations
17123 Typ : constant Entity_Id := Underlying_Type (Id);
17125 -- Start of processing for New_Requires_Transient_Scope
17128 -- This is a private type which is not completed yet. This can only
17129 -- happen in a default expression (of a formal parameter or of a
17130 -- record component). Do not expand transient scope in this case.
17135 -- Do not expand transient scope for non-existent procedure return or
17136 -- string literal types.
17138 elsif Typ = Standard_Void_Type
17139 or else Ekind (Typ) = E_String_Literal_Subtype
17143 -- If Typ is a generic formal incomplete type, then we want to look at
17144 -- the actual type.
17146 elsif Ekind (Typ) = E_Record_Subtype
17147 and then Present (Cloned_Subtype (Typ))
17149 return New_Requires_Transient_Scope (Cloned_Subtype (Typ));
17151 -- Functions returning tagged types may dispatch on result so their
17152 -- returned value is allocated on the secondary stack, even in the
17153 -- definite case. Is_Tagged_Type includes controlled types and
17154 -- class-wide types. Controlled type temporaries need finalization.
17155 -- ???It's not clear why we need to return noncontrolled types with
17156 -- controlled components on the secondary stack. Also, it's not clear
17157 -- why nonprimitive tagged type functions need the secondary stack,
17158 -- since they can't be called via dispatching.
17160 elsif Is_Tagged_Type (Typ) or else Has_Controlled_Component (Typ) then
17163 -- Untagged definite subtypes are known size. This includes all
17164 -- elementary [sub]types. Tasks are known size even if they have
17167 elsif Is_Definite_Subtype (Typ) or else Is_Task_Type (Typ) then
17170 -- Indefinite (discriminated) untagged record or protected type
17172 elsif Is_Record_Type (Typ) or else Is_Protected_Type (Typ) then
17173 return not Caller_Known_Size_Record (Typ);
17175 -- Unconstrained array
17178 pragma Assert (Is_Array_Type (Typ) and not Is_Definite_Subtype (Typ));
17181 end New_Requires_Transient_Scope;
17183 --------------------------
17184 -- Reset_Analyzed_Flags --
17185 --------------------------
17187 procedure Reset_Analyzed_Flags (N : Node_Id) is
17189 function Clear_Analyzed (N : Node_Id) return Traverse_Result;
17190 -- Function used to reset Analyzed flags in tree. Note that we do
17191 -- not reset Analyzed flags in entities, since there is no need to
17192 -- reanalyze entities, and indeed, it is wrong to do so, since it
17193 -- can result in generating auxiliary stuff more than once.
17195 --------------------
17196 -- Clear_Analyzed --
17197 --------------------
17199 function Clear_Analyzed (N : Node_Id) return Traverse_Result is
17201 if not Has_Extension (N) then
17202 Set_Analyzed (N, False);
17206 end Clear_Analyzed;
17208 procedure Reset_Analyzed is new Traverse_Proc (Clear_Analyzed);
17210 -- Start of processing for Reset_Analyzed_Flags
17213 Reset_Analyzed (N);
17214 end Reset_Analyzed_Flags;
17216 ------------------------
17217 -- Restore_SPARK_Mode --
17218 ------------------------
17220 procedure Restore_SPARK_Mode (Mode : SPARK_Mode_Type) is
17222 SPARK_Mode := Mode;
17223 end Restore_SPARK_Mode;
17225 --------------------------------
17226 -- Returns_Unconstrained_Type --
17227 --------------------------------
17229 function Returns_Unconstrained_Type (Subp : Entity_Id) return Boolean is
17231 return Ekind (Subp) = E_Function
17232 and then not Is_Scalar_Type (Etype (Subp))
17233 and then not Is_Access_Type (Etype (Subp))
17234 and then not Is_Constrained (Etype (Subp));
17235 end Returns_Unconstrained_Type;
17237 ----------------------------
17238 -- Root_Type_Of_Full_View --
17239 ----------------------------
17241 function Root_Type_Of_Full_View (T : Entity_Id) return Entity_Id is
17242 Rtyp : constant Entity_Id := Root_Type (T);
17245 -- The root type of the full view may itself be a private type. Keep
17246 -- looking for the ultimate derivation parent.
17248 if Is_Private_Type (Rtyp) and then Present (Full_View (Rtyp)) then
17249 return Root_Type_Of_Full_View (Full_View (Rtyp));
17253 end Root_Type_Of_Full_View;
17255 ---------------------------
17256 -- Safe_To_Capture_Value --
17257 ---------------------------
17259 function Safe_To_Capture_Value
17262 Cond : Boolean := False) return Boolean
17265 -- The only entities for which we track constant values are variables
17266 -- which are not renamings, constants, out parameters, and in out
17267 -- parameters, so check if we have this case.
17269 -- Note: it may seem odd to track constant values for constants, but in
17270 -- fact this routine is used for other purposes than simply capturing
17271 -- the value. In particular, the setting of Known[_Non]_Null.
17273 if (Ekind (Ent) = E_Variable and then No (Renamed_Object (Ent)))
17275 Ekind_In (Ent, E_Constant, E_Out_Parameter, E_In_Out_Parameter)
17279 -- For conditionals, we also allow loop parameters and all formals,
17280 -- including in parameters.
17282 elsif Cond and then Ekind_In (Ent, E_Loop_Parameter, E_In_Parameter) then
17285 -- For all other cases, not just unsafe, but impossible to capture
17286 -- Current_Value, since the above are the only entities which have
17287 -- Current_Value fields.
17293 -- Skip if volatile or aliased, since funny things might be going on in
17294 -- these cases which we cannot necessarily track. Also skip any variable
17295 -- for which an address clause is given, or whose address is taken. Also
17296 -- never capture value of library level variables (an attempt to do so
17297 -- can occur in the case of package elaboration code).
17299 if Treat_As_Volatile (Ent)
17300 or else Is_Aliased (Ent)
17301 or else Present (Address_Clause (Ent))
17302 or else Address_Taken (Ent)
17303 or else (Is_Library_Level_Entity (Ent)
17304 and then Ekind (Ent) = E_Variable)
17309 -- OK, all above conditions are met. We also require that the scope of
17310 -- the reference be the same as the scope of the entity, not counting
17311 -- packages and blocks and loops.
17314 E_Scope : constant Entity_Id := Scope (Ent);
17315 R_Scope : Entity_Id;
17318 R_Scope := Current_Scope;
17319 while R_Scope /= Standard_Standard loop
17320 exit when R_Scope = E_Scope;
17322 if not Ekind_In (R_Scope, E_Package, E_Block, E_Loop) then
17325 R_Scope := Scope (R_Scope);
17330 -- We also require that the reference does not appear in a context
17331 -- where it is not sure to be executed (i.e. a conditional context
17332 -- or an exception handler). We skip this if Cond is True, since the
17333 -- capturing of values from conditional tests handles this ok.
17346 -- Seems dubious that case expressions are not handled here ???
17349 while Present (P) loop
17350 if Nkind (P) = N_If_Statement
17351 or else Nkind (P) = N_Case_Statement
17352 or else (Nkind (P) in N_Short_Circuit
17353 and then Desc = Right_Opnd (P))
17354 or else (Nkind (P) = N_If_Expression
17355 and then Desc /= First (Expressions (P)))
17356 or else Nkind (P) = N_Exception_Handler
17357 or else Nkind (P) = N_Selective_Accept
17358 or else Nkind (P) = N_Conditional_Entry_Call
17359 or else Nkind (P) = N_Timed_Entry_Call
17360 or else Nkind (P) = N_Asynchronous_Select
17368 -- A special Ada 2012 case: the original node may be part
17369 -- of the else_actions of a conditional expression, in which
17370 -- case it might not have been expanded yet, and appears in
17371 -- a non-syntactic list of actions. In that case it is clearly
17372 -- not safe to save a value.
17375 and then Is_List_Member (Desc)
17376 and then No (Parent (List_Containing (Desc)))
17384 -- OK, looks safe to set value
17387 end Safe_To_Capture_Value;
17393 function Same_Name (N1, N2 : Node_Id) return Boolean is
17394 K1 : constant Node_Kind := Nkind (N1);
17395 K2 : constant Node_Kind := Nkind (N2);
17398 if (K1 = N_Identifier or else K1 = N_Defining_Identifier)
17399 and then (K2 = N_Identifier or else K2 = N_Defining_Identifier)
17401 return Chars (N1) = Chars (N2);
17403 elsif (K1 = N_Selected_Component or else K1 = N_Expanded_Name)
17404 and then (K2 = N_Selected_Component or else K2 = N_Expanded_Name)
17406 return Same_Name (Selector_Name (N1), Selector_Name (N2))
17407 and then Same_Name (Prefix (N1), Prefix (N2));
17418 function Same_Object (Node1, Node2 : Node_Id) return Boolean is
17419 N1 : constant Node_Id := Original_Node (Node1);
17420 N2 : constant Node_Id := Original_Node (Node2);
17421 -- We do the tests on original nodes, since we are most interested
17422 -- in the original source, not any expansion that got in the way.
17424 K1 : constant Node_Kind := Nkind (N1);
17425 K2 : constant Node_Kind := Nkind (N2);
17428 -- First case, both are entities with same entity
17430 if K1 in N_Has_Entity and then K2 in N_Has_Entity then
17432 EN1 : constant Entity_Id := Entity (N1);
17433 EN2 : constant Entity_Id := Entity (N2);
17435 if Present (EN1) and then Present (EN2)
17436 and then (Ekind_In (EN1, E_Variable, E_Constant)
17437 or else Is_Formal (EN1))
17445 -- Second case, selected component with same selector, same record
17447 if K1 = N_Selected_Component
17448 and then K2 = N_Selected_Component
17449 and then Chars (Selector_Name (N1)) = Chars (Selector_Name (N2))
17451 return Same_Object (Prefix (N1), Prefix (N2));
17453 -- Third case, indexed component with same subscripts, same array
17455 elsif K1 = N_Indexed_Component
17456 and then K2 = N_Indexed_Component
17457 and then Same_Object (Prefix (N1), Prefix (N2))
17462 E1 := First (Expressions (N1));
17463 E2 := First (Expressions (N2));
17464 while Present (E1) loop
17465 if not Same_Value (E1, E2) then
17476 -- Fourth case, slice of same array with same bounds
17479 and then K2 = N_Slice
17480 and then Nkind (Discrete_Range (N1)) = N_Range
17481 and then Nkind (Discrete_Range (N2)) = N_Range
17482 and then Same_Value (Low_Bound (Discrete_Range (N1)),
17483 Low_Bound (Discrete_Range (N2)))
17484 and then Same_Value (High_Bound (Discrete_Range (N1)),
17485 High_Bound (Discrete_Range (N2)))
17487 return Same_Name (Prefix (N1), Prefix (N2));
17489 -- All other cases, not clearly the same object
17500 function Same_Type (T1, T2 : Entity_Id) return Boolean is
17505 elsif not Is_Constrained (T1)
17506 and then not Is_Constrained (T2)
17507 and then Base_Type (T1) = Base_Type (T2)
17511 -- For now don't bother with case of identical constraints, to be
17512 -- fiddled with later on perhaps (this is only used for optimization
17513 -- purposes, so it is not critical to do a best possible job)
17524 function Same_Value (Node1, Node2 : Node_Id) return Boolean is
17526 if Compile_Time_Known_Value (Node1)
17527 and then Compile_Time_Known_Value (Node2)
17528 and then Expr_Value (Node1) = Expr_Value (Node2)
17531 elsif Same_Object (Node1, Node2) then
17538 -----------------------------
17539 -- Save_SPARK_Mode_And_Set --
17540 -----------------------------
17542 procedure Save_SPARK_Mode_And_Set
17543 (Context : Entity_Id;
17544 Mode : out SPARK_Mode_Type)
17547 -- Save the current mode in effect
17549 Mode := SPARK_Mode;
17551 -- Do not consider illegal or partially decorated constructs
17553 if Ekind (Context) = E_Void or else Error_Posted (Context) then
17556 elsif Present (SPARK_Pragma (Context)) then
17557 SPARK_Mode := Get_SPARK_Mode_From_Pragma (SPARK_Pragma (Context));
17559 end Save_SPARK_Mode_And_Set;
17561 -------------------------
17562 -- Scalar_Part_Present --
17563 -------------------------
17565 function Scalar_Part_Present (T : Entity_Id) return Boolean is
17569 if Is_Scalar_Type (T) then
17572 elsif Is_Array_Type (T) then
17573 return Scalar_Part_Present (Component_Type (T));
17575 elsif Is_Record_Type (T) or else Has_Discriminants (T) then
17576 C := First_Component_Or_Discriminant (T);
17577 while Present (C) loop
17578 if Scalar_Part_Present (Etype (C)) then
17581 Next_Component_Or_Discriminant (C);
17587 end Scalar_Part_Present;
17589 ------------------------
17590 -- Scope_Is_Transient --
17591 ------------------------
17593 function Scope_Is_Transient return Boolean is
17595 return Scope_Stack.Table (Scope_Stack.Last).Is_Transient;
17596 end Scope_Is_Transient;
17602 function Scope_Within (Scope1, Scope2 : Entity_Id) return Boolean is
17607 while Scop /= Standard_Standard loop
17608 Scop := Scope (Scop);
17610 if Scop = Scope2 then
17618 --------------------------
17619 -- Scope_Within_Or_Same --
17620 --------------------------
17622 function Scope_Within_Or_Same (Scope1, Scope2 : Entity_Id) return Boolean is
17627 while Scop /= Standard_Standard loop
17628 if Scop = Scope2 then
17631 Scop := Scope (Scop);
17636 end Scope_Within_Or_Same;
17638 --------------------
17639 -- Set_Convention --
17640 --------------------
17642 procedure Set_Convention (E : Entity_Id; Val : Snames.Convention_Id) is
17644 Basic_Set_Convention (E, Val);
17647 and then Is_Access_Subprogram_Type (Base_Type (E))
17648 and then Has_Foreign_Convention (E)
17651 -- A pragma Convention in an instance may apply to the subtype
17652 -- created for a formal, in which case we have already verified
17653 -- that conventions of actual and formal match and there is nothing
17654 -- to flag on the subtype.
17656 if In_Instance then
17659 Set_Can_Use_Internal_Rep (E, False);
17663 -- If E is an object or component, and the type of E is an anonymous
17664 -- access type with no convention set, then also set the convention of
17665 -- the anonymous access type. We do not do this for anonymous protected
17666 -- types, since protected types always have the default convention.
17668 if Present (Etype (E))
17669 and then (Is_Object (E)
17670 or else Ekind (E) = E_Component
17672 -- Allow E_Void (happens for pragma Convention appearing
17673 -- in the middle of a record applying to a component)
17675 or else Ekind (E) = E_Void)
17678 Typ : constant Entity_Id := Etype (E);
17681 if Ekind_In (Typ, E_Anonymous_Access_Type,
17682 E_Anonymous_Access_Subprogram_Type)
17683 and then not Has_Convention_Pragma (Typ)
17685 Basic_Set_Convention (Typ, Val);
17686 Set_Has_Convention_Pragma (Typ);
17688 -- And for the access subprogram type, deal similarly with the
17689 -- designated E_Subprogram_Type if it is also internal (which
17692 if Ekind (Typ) = E_Anonymous_Access_Subprogram_Type then
17694 Dtype : constant Entity_Id := Designated_Type (Typ);
17696 if Ekind (Dtype) = E_Subprogram_Type
17697 and then Is_Itype (Dtype)
17698 and then not Has_Convention_Pragma (Dtype)
17700 Basic_Set_Convention (Dtype, Val);
17701 Set_Has_Convention_Pragma (Dtype);
17708 end Set_Convention;
17710 ------------------------
17711 -- Set_Current_Entity --
17712 ------------------------
17714 -- The given entity is to be set as the currently visible definition of its
17715 -- associated name (i.e. the Node_Id associated with its name). All we have
17716 -- to do is to get the name from the identifier, and then set the
17717 -- associated Node_Id to point to the given entity.
17719 procedure Set_Current_Entity (E : Entity_Id) is
17721 Set_Name_Entity_Id (Chars (E), E);
17722 end Set_Current_Entity;
17724 ---------------------------
17725 -- Set_Debug_Info_Needed --
17726 ---------------------------
17728 procedure Set_Debug_Info_Needed (T : Entity_Id) is
17730 procedure Set_Debug_Info_Needed_If_Not_Set (E : Entity_Id);
17731 pragma Inline (Set_Debug_Info_Needed_If_Not_Set);
17732 -- Used to set debug info in a related node if not set already
17734 --------------------------------------
17735 -- Set_Debug_Info_Needed_If_Not_Set --
17736 --------------------------------------
17738 procedure Set_Debug_Info_Needed_If_Not_Set (E : Entity_Id) is
17740 if Present (E) and then not Needs_Debug_Info (E) then
17741 Set_Debug_Info_Needed (E);
17743 -- For a private type, indicate that the full view also needs
17744 -- debug information.
17747 and then Is_Private_Type (E)
17748 and then Present (Full_View (E))
17750 Set_Debug_Info_Needed (Full_View (E));
17753 end Set_Debug_Info_Needed_If_Not_Set;
17755 -- Start of processing for Set_Debug_Info_Needed
17758 -- Nothing to do if argument is Empty or has Debug_Info_Off set, which
17759 -- indicates that Debug_Info_Needed is never required for the entity.
17760 -- Nothing to do if entity comes from a predefined file. Library files
17761 -- are compiled without debug information, but inlined bodies of these
17762 -- routines may appear in user code, and debug information on them ends
17763 -- up complicating debugging the user code.
17766 or else Debug_Info_Off (T)
17770 elsif In_Inlined_Body
17771 and then Is_Predefined_File_Name
17772 (Unit_File_Name (Get_Source_Unit (Sloc (T))))
17774 Set_Needs_Debug_Info (T, False);
17777 -- Set flag in entity itself. Note that we will go through the following
17778 -- circuitry even if the flag is already set on T. That's intentional,
17779 -- it makes sure that the flag will be set in subsidiary entities.
17781 Set_Needs_Debug_Info (T);
17783 -- Set flag on subsidiary entities if not set already
17785 if Is_Object (T) then
17786 Set_Debug_Info_Needed_If_Not_Set (Etype (T));
17788 elsif Is_Type (T) then
17789 Set_Debug_Info_Needed_If_Not_Set (Etype (T));
17791 if Is_Record_Type (T) then
17793 Ent : Entity_Id := First_Entity (T);
17795 while Present (Ent) loop
17796 Set_Debug_Info_Needed_If_Not_Set (Ent);
17801 -- For a class wide subtype, we also need debug information
17802 -- for the equivalent type.
17804 if Ekind (T) = E_Class_Wide_Subtype then
17805 Set_Debug_Info_Needed_If_Not_Set (Equivalent_Type (T));
17808 elsif Is_Array_Type (T) then
17809 Set_Debug_Info_Needed_If_Not_Set (Component_Type (T));
17812 Indx : Node_Id := First_Index (T);
17814 while Present (Indx) loop
17815 Set_Debug_Info_Needed_If_Not_Set (Etype (Indx));
17816 Indx := Next_Index (Indx);
17820 -- For a packed array type, we also need debug information for
17821 -- the type used to represent the packed array. Conversely, we
17822 -- also need it for the former if we need it for the latter.
17824 if Is_Packed (T) then
17825 Set_Debug_Info_Needed_If_Not_Set (Packed_Array_Impl_Type (T));
17828 if Is_Packed_Array_Impl_Type (T) then
17829 Set_Debug_Info_Needed_If_Not_Set (Original_Array_Type (T));
17832 elsif Is_Access_Type (T) then
17833 Set_Debug_Info_Needed_If_Not_Set (Directly_Designated_Type (T));
17835 elsif Is_Private_Type (T) then
17837 FV : constant Entity_Id := Full_View (T);
17840 Set_Debug_Info_Needed_If_Not_Set (FV);
17842 -- If the full view is itself a derived private type, we need
17843 -- debug information on its underlying type.
17846 and then Is_Private_Type (FV)
17847 and then Present (Underlying_Full_View (FV))
17849 Set_Needs_Debug_Info (Underlying_Full_View (FV));
17853 elsif Is_Protected_Type (T) then
17854 Set_Debug_Info_Needed_If_Not_Set (Corresponding_Record_Type (T));
17856 elsif Is_Scalar_Type (T) then
17858 -- If the subrange bounds are materialized by dedicated constant
17859 -- objects, also include them in the debug info to make sure the
17860 -- debugger can properly use them.
17862 if Present (Scalar_Range (T))
17863 and then Nkind (Scalar_Range (T)) = N_Range
17866 Low_Bnd : constant Node_Id := Type_Low_Bound (T);
17867 High_Bnd : constant Node_Id := Type_High_Bound (T);
17870 if Is_Entity_Name (Low_Bnd) then
17871 Set_Debug_Info_Needed_If_Not_Set (Entity (Low_Bnd));
17874 if Is_Entity_Name (High_Bnd) then
17875 Set_Debug_Info_Needed_If_Not_Set (Entity (High_Bnd));
17881 end Set_Debug_Info_Needed;
17883 ----------------------------
17884 -- Set_Entity_With_Checks --
17885 ----------------------------
17887 procedure Set_Entity_With_Checks (N : Node_Id; Val : Entity_Id) is
17888 Val_Actual : Entity_Id;
17890 Post_Node : Node_Id;
17893 -- Unconditionally set the entity
17895 Set_Entity (N, Val);
17897 -- The node to post on is the selector in the case of an expanded name,
17898 -- and otherwise the node itself.
17900 if Nkind (N) = N_Expanded_Name then
17901 Post_Node := Selector_Name (N);
17906 -- Check for violation of No_Fixed_IO
17908 if Restriction_Check_Required (No_Fixed_IO)
17910 ((RTU_Loaded (Ada_Text_IO)
17911 and then (Is_RTE (Val, RE_Decimal_IO)
17913 Is_RTE (Val, RE_Fixed_IO)))
17916 (RTU_Loaded (Ada_Wide_Text_IO)
17917 and then (Is_RTE (Val, RO_WT_Decimal_IO)
17919 Is_RTE (Val, RO_WT_Fixed_IO)))
17922 (RTU_Loaded (Ada_Wide_Wide_Text_IO)
17923 and then (Is_RTE (Val, RO_WW_Decimal_IO)
17925 Is_RTE (Val, RO_WW_Fixed_IO))))
17927 -- A special extra check, don't complain about a reference from within
17928 -- the Ada.Interrupts package itself!
17930 and then not In_Same_Extended_Unit (N, Val)
17932 Check_Restriction (No_Fixed_IO, Post_Node);
17935 -- Remaining checks are only done on source nodes. Note that we test
17936 -- for violation of No_Fixed_IO even on non-source nodes, because the
17937 -- cases for checking violations of this restriction are instantiations
17938 -- where the reference in the instance has Comes_From_Source False.
17940 if not Comes_From_Source (N) then
17944 -- Check for violation of No_Abort_Statements, which is triggered by
17945 -- call to Ada.Task_Identification.Abort_Task.
17947 if Restriction_Check_Required (No_Abort_Statements)
17948 and then (Is_RTE (Val, RE_Abort_Task))
17950 -- A special extra check, don't complain about a reference from within
17951 -- the Ada.Task_Identification package itself!
17953 and then not In_Same_Extended_Unit (N, Val)
17955 Check_Restriction (No_Abort_Statements, Post_Node);
17958 if Val = Standard_Long_Long_Integer then
17959 Check_Restriction (No_Long_Long_Integers, Post_Node);
17962 -- Check for violation of No_Dynamic_Attachment
17964 if Restriction_Check_Required (No_Dynamic_Attachment)
17965 and then RTU_Loaded (Ada_Interrupts)
17966 and then (Is_RTE (Val, RE_Is_Reserved) or else
17967 Is_RTE (Val, RE_Is_Attached) or else
17968 Is_RTE (Val, RE_Current_Handler) or else
17969 Is_RTE (Val, RE_Attach_Handler) or else
17970 Is_RTE (Val, RE_Exchange_Handler) or else
17971 Is_RTE (Val, RE_Detach_Handler) or else
17972 Is_RTE (Val, RE_Reference))
17974 -- A special extra check, don't complain about a reference from within
17975 -- the Ada.Interrupts package itself!
17977 and then not In_Same_Extended_Unit (N, Val)
17979 Check_Restriction (No_Dynamic_Attachment, Post_Node);
17982 -- Check for No_Implementation_Identifiers
17984 if Restriction_Check_Required (No_Implementation_Identifiers) then
17986 -- We have an implementation defined entity if it is marked as
17987 -- implementation defined, or is defined in a package marked as
17988 -- implementation defined. However, library packages themselves
17989 -- are excluded (we don't want to flag Interfaces itself, just
17990 -- the entities within it).
17992 if (Is_Implementation_Defined (Val)
17994 (Present (Scope (Val))
17995 and then Is_Implementation_Defined (Scope (Val))))
17996 and then not (Ekind_In (Val, E_Package, E_Generic_Package)
17997 and then Is_Library_Level_Entity (Val))
17999 Check_Restriction (No_Implementation_Identifiers, Post_Node);
18003 -- Do the style check
18006 and then not Suppress_Style_Checks (Val)
18007 and then not In_Instance
18009 if Nkind (N) = N_Identifier then
18011 elsif Nkind (N) = N_Expanded_Name then
18012 Nod := Selector_Name (N);
18017 -- A special situation arises for derived operations, where we want
18018 -- to do the check against the parent (since the Sloc of the derived
18019 -- operation points to the derived type declaration itself).
18022 while not Comes_From_Source (Val_Actual)
18023 and then Nkind (Val_Actual) in N_Entity
18024 and then (Ekind (Val_Actual) = E_Enumeration_Literal
18025 or else Is_Subprogram_Or_Generic_Subprogram (Val_Actual))
18026 and then Present (Alias (Val_Actual))
18028 Val_Actual := Alias (Val_Actual);
18031 -- Renaming declarations for generic actuals do not come from source,
18032 -- and have a different name from that of the entity they rename, so
18033 -- there is no style check to perform here.
18035 if Chars (Nod) = Chars (Val_Actual) then
18036 Style.Check_Identifier (Nod, Val_Actual);
18040 Set_Entity (N, Val);
18041 end Set_Entity_With_Checks;
18043 ------------------------
18044 -- Set_Name_Entity_Id --
18045 ------------------------
18047 procedure Set_Name_Entity_Id (Id : Name_Id; Val : Entity_Id) is
18049 Set_Name_Table_Int (Id, Int (Val));
18050 end Set_Name_Entity_Id;
18052 ---------------------
18053 -- Set_Next_Actual --
18054 ---------------------
18056 procedure Set_Next_Actual (Ass1_Id : Node_Id; Ass2_Id : Node_Id) is
18058 if Nkind (Parent (Ass1_Id)) = N_Parameter_Association then
18059 Set_First_Named_Actual (Parent (Ass1_Id), Ass2_Id);
18061 end Set_Next_Actual;
18063 ----------------------------------
18064 -- Set_Optimize_Alignment_Flags --
18065 ----------------------------------
18067 procedure Set_Optimize_Alignment_Flags (E : Entity_Id) is
18069 if Optimize_Alignment = 'S' then
18070 Set_Optimize_Alignment_Space (E);
18071 elsif Optimize_Alignment = 'T' then
18072 Set_Optimize_Alignment_Time (E);
18074 end Set_Optimize_Alignment_Flags;
18076 -----------------------
18077 -- Set_Public_Status --
18078 -----------------------
18080 procedure Set_Public_Status (Id : Entity_Id) is
18081 S : constant Entity_Id := Current_Scope;
18083 function Within_HSS_Or_If (E : Entity_Id) return Boolean;
18084 -- Determines if E is defined within handled statement sequence or
18085 -- an if statement, returns True if so, False otherwise.
18087 ----------------------
18088 -- Within_HSS_Or_If --
18089 ----------------------
18091 function Within_HSS_Or_If (E : Entity_Id) return Boolean is
18094 N := Declaration_Node (E);
18101 elsif Nkind_In (N, N_Handled_Sequence_Of_Statements,
18107 end Within_HSS_Or_If;
18109 -- Start of processing for Set_Public_Status
18112 -- Everything in the scope of Standard is public
18114 if S = Standard_Standard then
18115 Set_Is_Public (Id);
18117 -- Entity is definitely not public if enclosing scope is not public
18119 elsif not Is_Public (S) then
18122 -- An object or function declaration that occurs in a handled sequence
18123 -- of statements or within an if statement is the declaration for a
18124 -- temporary object or local subprogram generated by the expander. It
18125 -- never needs to be made public and furthermore, making it public can
18126 -- cause back end problems.
18128 elsif Nkind_In (Parent (Id), N_Object_Declaration,
18129 N_Function_Specification)
18130 and then Within_HSS_Or_If (Id)
18134 -- Entities in public packages or records are public
18136 elsif Ekind (S) = E_Package or Is_Record_Type (S) then
18137 Set_Is_Public (Id);
18139 -- The bounds of an entry family declaration can generate object
18140 -- declarations that are visible to the back-end, e.g. in the
18141 -- the declaration of a composite type that contains tasks.
18143 elsif Is_Concurrent_Type (S)
18144 and then not Has_Completion (S)
18145 and then Nkind (Parent (Id)) = N_Object_Declaration
18147 Set_Is_Public (Id);
18149 end Set_Public_Status;
18151 -----------------------------
18152 -- Set_Referenced_Modified --
18153 -----------------------------
18155 procedure Set_Referenced_Modified (N : Node_Id; Out_Param : Boolean) is
18159 -- Deal with indexed or selected component where prefix is modified
18161 if Nkind_In (N, N_Indexed_Component, N_Selected_Component) then
18162 Pref := Prefix (N);
18164 -- If prefix is access type, then it is the designated object that is
18165 -- being modified, which means we have no entity to set the flag on.
18167 if No (Etype (Pref)) or else Is_Access_Type (Etype (Pref)) then
18170 -- Otherwise chase the prefix
18173 Set_Referenced_Modified (Pref, Out_Param);
18176 -- Otherwise see if we have an entity name (only other case to process)
18178 elsif Is_Entity_Name (N) and then Present (Entity (N)) then
18179 Set_Referenced_As_LHS (Entity (N), not Out_Param);
18180 Set_Referenced_As_Out_Parameter (Entity (N), Out_Param);
18182 end Set_Referenced_Modified;
18184 ----------------------------
18185 -- Set_Scope_Is_Transient --
18186 ----------------------------
18188 procedure Set_Scope_Is_Transient (V : Boolean := True) is
18190 Scope_Stack.Table (Scope_Stack.Last).Is_Transient := V;
18191 end Set_Scope_Is_Transient;
18193 -------------------
18194 -- Set_Size_Info --
18195 -------------------
18197 procedure Set_Size_Info (T1, T2 : Entity_Id) is
18199 -- We copy Esize, but not RM_Size, since in general RM_Size is
18200 -- subtype specific and does not get inherited by all subtypes.
18202 Set_Esize (T1, Esize (T2));
18203 Set_Has_Biased_Representation (T1, Has_Biased_Representation (T2));
18205 if Is_Discrete_Or_Fixed_Point_Type (T1)
18207 Is_Discrete_Or_Fixed_Point_Type (T2)
18209 Set_Is_Unsigned_Type (T1, Is_Unsigned_Type (T2));
18212 Set_Alignment (T1, Alignment (T2));
18215 --------------------
18216 -- Static_Boolean --
18217 --------------------
18219 function Static_Boolean (N : Node_Id) return Uint is
18221 Analyze_And_Resolve (N, Standard_Boolean);
18224 or else Error_Posted (N)
18225 or else Etype (N) = Any_Type
18230 if Is_OK_Static_Expression (N) then
18231 if not Raises_Constraint_Error (N) then
18232 return Expr_Value (N);
18237 elsif Etype (N) = Any_Type then
18241 Flag_Non_Static_Expr
18242 ("static boolean expression required here", N);
18245 end Static_Boolean;
18247 --------------------
18248 -- Static_Integer --
18249 --------------------
18251 function Static_Integer (N : Node_Id) return Uint is
18253 Analyze_And_Resolve (N, Any_Integer);
18256 or else Error_Posted (N)
18257 or else Etype (N) = Any_Type
18262 if Is_OK_Static_Expression (N) then
18263 if not Raises_Constraint_Error (N) then
18264 return Expr_Value (N);
18269 elsif Etype (N) = Any_Type then
18273 Flag_Non_Static_Expr
18274 ("static integer expression required here", N);
18277 end Static_Integer;
18279 --------------------------
18280 -- Statically_Different --
18281 --------------------------
18283 function Statically_Different (E1, E2 : Node_Id) return Boolean is
18284 R1 : constant Node_Id := Get_Referenced_Object (E1);
18285 R2 : constant Node_Id := Get_Referenced_Object (E2);
18287 return Is_Entity_Name (R1)
18288 and then Is_Entity_Name (R2)
18289 and then Entity (R1) /= Entity (R2)
18290 and then not Is_Formal (Entity (R1))
18291 and then not Is_Formal (Entity (R2));
18292 end Statically_Different;
18294 --------------------------------------
18295 -- Subject_To_Loop_Entry_Attributes --
18296 --------------------------------------
18298 function Subject_To_Loop_Entry_Attributes (N : Node_Id) return Boolean is
18304 -- The expansion mechanism transform a loop subject to at least one
18305 -- 'Loop_Entry attribute into a conditional block. Infinite loops lack
18306 -- the conditional part.
18308 if Nkind_In (Stmt, N_Block_Statement, N_If_Statement)
18309 and then Nkind (Original_Node (N)) = N_Loop_Statement
18311 Stmt := Original_Node (N);
18315 Nkind (Stmt) = N_Loop_Statement
18316 and then Present (Identifier (Stmt))
18317 and then Present (Entity (Identifier (Stmt)))
18318 and then Has_Loop_Entry_Attributes (Entity (Identifier (Stmt)));
18319 end Subject_To_Loop_Entry_Attributes;
18321 -----------------------------
18322 -- Subprogram_Access_Level --
18323 -----------------------------
18325 function Subprogram_Access_Level (Subp : Entity_Id) return Uint is
18327 if Present (Alias (Subp)) then
18328 return Subprogram_Access_Level (Alias (Subp));
18330 return Scope_Depth (Enclosing_Dynamic_Scope (Subp));
18332 end Subprogram_Access_Level;
18334 -------------------------------
18335 -- Support_Atomic_Primitives --
18336 -------------------------------
18338 function Support_Atomic_Primitives (Typ : Entity_Id) return Boolean is
18342 -- Verify the alignment of Typ is known
18344 if not Known_Alignment (Typ) then
18348 if Known_Static_Esize (Typ) then
18349 Size := UI_To_Int (Esize (Typ));
18351 -- If the Esize (Object_Size) is unknown at compile time, look at the
18352 -- RM_Size (Value_Size) which may have been set by an explicit rep item.
18354 elsif Known_Static_RM_Size (Typ) then
18355 Size := UI_To_Int (RM_Size (Typ));
18357 -- Otherwise, the size is considered to be unknown.
18363 -- Check that the size of the component is 8, 16, 32 or 64 bits and that
18364 -- Typ is properly aligned.
18367 when 8 | 16 | 32 | 64 =>
18368 return Size = UI_To_Int (Alignment (Typ)) * 8;
18372 end Support_Atomic_Primitives;
18378 procedure Trace_Scope (N : Node_Id; E : Entity_Id; Msg : String) is
18380 if Debug_Flag_W then
18381 for J in 0 .. Scope_Stack.Last loop
18386 Write_Name (Chars (E));
18387 Write_Str (" from ");
18388 Write_Location (Sloc (N));
18393 -----------------------
18394 -- Transfer_Entities --
18395 -----------------------
18397 procedure Transfer_Entities (From : Entity_Id; To : Entity_Id) is
18398 procedure Set_Public_Status_Of (Id : Entity_Id);
18399 -- Set the Is_Public attribute of arbitrary entity Id by calling routine
18400 -- Set_Public_Status. If successfull and Id denotes a record type, set
18401 -- the Is_Public attribute of its fields.
18403 --------------------------
18404 -- Set_Public_Status_Of --
18405 --------------------------
18407 procedure Set_Public_Status_Of (Id : Entity_Id) is
18411 if not Is_Public (Id) then
18412 Set_Public_Status (Id);
18414 -- When the input entity is a public record type, ensure that all
18415 -- its internal fields are also exposed to the linker. The fields
18416 -- of a class-wide type are never made public.
18419 and then Is_Record_Type (Id)
18420 and then not Is_Class_Wide_Type (Id)
18422 Field := First_Entity (Id);
18423 while Present (Field) loop
18424 Set_Is_Public (Field);
18425 Next_Entity (Field);
18429 end Set_Public_Status_Of;
18433 Full_Id : Entity_Id;
18436 -- Start of processing for Transfer_Entities
18439 Id := First_Entity (From);
18441 if Present (Id) then
18443 -- Merge the entity chain of the source scope with that of the
18444 -- destination scope.
18446 if Present (Last_Entity (To)) then
18447 Set_Next_Entity (Last_Entity (To), Id);
18449 Set_First_Entity (To, Id);
18452 Set_Last_Entity (To, Last_Entity (From));
18454 -- Inspect the entities of the source scope and update their Scope
18457 while Present (Id) loop
18458 Set_Scope (Id, To);
18459 Set_Public_Status_Of (Id);
18461 -- Handle an internally generated full view for a private type
18463 if Is_Private_Type (Id)
18464 and then Present (Full_View (Id))
18465 and then Is_Itype (Full_View (Id))
18467 Full_Id := Full_View (Id);
18469 Set_Scope (Full_Id, To);
18470 Set_Public_Status_Of (Full_Id);
18476 Set_First_Entity (From, Empty);
18477 Set_Last_Entity (From, Empty);
18479 end Transfer_Entities;
18481 -----------------------
18482 -- Type_Access_Level --
18483 -----------------------
18485 function Type_Access_Level (Typ : Entity_Id) return Uint is
18489 Btyp := Base_Type (Typ);
18491 -- Ada 2005 (AI-230): For most cases of anonymous access types, we
18492 -- simply use the level where the type is declared. This is true for
18493 -- stand-alone object declarations, and for anonymous access types
18494 -- associated with components the level is the same as that of the
18495 -- enclosing composite type. However, special treatment is needed for
18496 -- the cases of access parameters, return objects of an anonymous access
18497 -- type, and, in Ada 95, access discriminants of limited types.
18499 if Is_Access_Type (Btyp) then
18500 if Ekind (Btyp) = E_Anonymous_Access_Type then
18502 -- If the type is a nonlocal anonymous access type (such as for
18503 -- an access parameter) we treat it as being declared at the
18504 -- library level to ensure that names such as X.all'access don't
18505 -- fail static accessibility checks.
18507 if not Is_Local_Anonymous_Access (Typ) then
18508 return Scope_Depth (Standard_Standard);
18510 -- If this is a return object, the accessibility level is that of
18511 -- the result subtype of the enclosing function. The test here is
18512 -- little complicated, because we have to account for extended
18513 -- return statements that have been rewritten as blocks, in which
18514 -- case we have to find and the Is_Return_Object attribute of the
18515 -- itype's associated object. It would be nice to find a way to
18516 -- simplify this test, but it doesn't seem worthwhile to add a new
18517 -- flag just for purposes of this test. ???
18519 elsif Ekind (Scope (Btyp)) = E_Return_Statement
18522 and then Nkind (Associated_Node_For_Itype (Btyp)) =
18523 N_Object_Declaration
18524 and then Is_Return_Object
18525 (Defining_Identifier
18526 (Associated_Node_For_Itype (Btyp))))
18532 Scop := Scope (Scope (Btyp));
18533 while Present (Scop) loop
18534 exit when Ekind (Scop) = E_Function;
18535 Scop := Scope (Scop);
18538 -- Treat the return object's type as having the level of the
18539 -- function's result subtype (as per RM05-6.5(5.3/2)).
18541 return Type_Access_Level (Etype (Scop));
18546 Btyp := Root_Type (Btyp);
18548 -- The accessibility level of anonymous access types associated with
18549 -- discriminants is that of the current instance of the type, and
18550 -- that's deeper than the type itself (AARM 3.10.2 (12.3.21)).
18552 -- AI-402: access discriminants have accessibility based on the
18553 -- object rather than the type in Ada 2005, so the above paragraph
18556 -- ??? Needs completion with rules from AI-416
18558 if Ada_Version <= Ada_95
18559 and then Ekind (Typ) = E_Anonymous_Access_Type
18560 and then Present (Associated_Node_For_Itype (Typ))
18561 and then Nkind (Associated_Node_For_Itype (Typ)) =
18562 N_Discriminant_Specification
18564 return Scope_Depth (Enclosing_Dynamic_Scope (Btyp)) + 1;
18568 -- Return library level for a generic formal type. This is done because
18569 -- RM(10.3.2) says that "The statically deeper relationship does not
18570 -- apply to ... a descendant of a generic formal type". Rather than
18571 -- checking at each point where a static accessibility check is
18572 -- performed to see if we are dealing with a formal type, this rule is
18573 -- implemented by having Type_Access_Level and Deepest_Type_Access_Level
18574 -- return extreme values for a formal type; Deepest_Type_Access_Level
18575 -- returns Int'Last. By calling the appropriate function from among the
18576 -- two, we ensure that the static accessibility check will pass if we
18577 -- happen to run into a formal type. More specifically, we should call
18578 -- Deepest_Type_Access_Level instead of Type_Access_Level whenever the
18579 -- call occurs as part of a static accessibility check and the error
18580 -- case is the case where the type's level is too shallow (as opposed
18583 if Is_Generic_Type (Root_Type (Btyp)) then
18584 return Scope_Depth (Standard_Standard);
18587 return Scope_Depth (Enclosing_Dynamic_Scope (Btyp));
18588 end Type_Access_Level;
18590 ------------------------------------
18591 -- Type_Without_Stream_Operation --
18592 ------------------------------------
18594 function Type_Without_Stream_Operation
18596 Op : TSS_Name_Type := TSS_Null) return Entity_Id
18598 BT : constant Entity_Id := Base_Type (T);
18599 Op_Missing : Boolean;
18602 if not Restriction_Active (No_Default_Stream_Attributes) then
18606 if Is_Elementary_Type (T) then
18607 if Op = TSS_Null then
18609 No (TSS (BT, TSS_Stream_Read))
18610 or else No (TSS (BT, TSS_Stream_Write));
18613 Op_Missing := No (TSS (BT, Op));
18622 elsif Is_Array_Type (T) then
18623 return Type_Without_Stream_Operation (Component_Type (T), Op);
18625 elsif Is_Record_Type (T) then
18631 Comp := First_Component (T);
18632 while Present (Comp) loop
18633 C_Typ := Type_Without_Stream_Operation (Etype (Comp), Op);
18635 if Present (C_Typ) then
18639 Next_Component (Comp);
18645 elsif Is_Private_Type (T) and then Present (Full_View (T)) then
18646 return Type_Without_Stream_Operation (Full_View (T), Op);
18650 end Type_Without_Stream_Operation;
18652 ----------------------------
18653 -- Unique_Defining_Entity --
18654 ----------------------------
18656 function Unique_Defining_Entity (N : Node_Id) return Entity_Id is
18658 return Unique_Entity (Defining_Entity (N));
18659 end Unique_Defining_Entity;
18661 -------------------
18662 -- Unique_Entity --
18663 -------------------
18665 function Unique_Entity (E : Entity_Id) return Entity_Id is
18666 U : Entity_Id := E;
18672 if Present (Full_View (E)) then
18673 U := Full_View (E);
18677 if Present (Full_View (E)) then
18678 U := Full_View (E);
18681 when E_Package_Body =>
18684 if Nkind (P) = N_Defining_Program_Unit_Name then
18688 U := Corresponding_Spec (P);
18690 when E_Subprogram_Body =>
18693 if Nkind (P) = N_Defining_Program_Unit_Name then
18699 if Nkind (P) = N_Subprogram_Body_Stub then
18700 if Present (Library_Unit (P)) then
18702 -- Get to the function or procedure (generic) entity through
18703 -- the body entity.
18706 Unique_Entity (Defining_Entity (Get_Body_From_Stub (P)));
18709 U := Corresponding_Spec (P);
18712 when Formal_Kind =>
18713 if Present (Spec_Entity (E)) then
18714 U := Spec_Entity (E);
18728 function Unique_Name (E : Entity_Id) return String is
18730 -- Names of E_Subprogram_Body or E_Package_Body entities are not
18731 -- reliable, as they may not include the overloading suffix. Instead,
18732 -- when looking for the name of E or one of its enclosing scope, we get
18733 -- the name of the corresponding Unique_Entity.
18735 function Get_Scoped_Name (E : Entity_Id) return String;
18736 -- Return the name of E prefixed by all the names of the scopes to which
18737 -- E belongs, except for Standard.
18739 ---------------------
18740 -- Get_Scoped_Name --
18741 ---------------------
18743 function Get_Scoped_Name (E : Entity_Id) return String is
18744 Name : constant String := Get_Name_String (Chars (E));
18746 if Has_Fully_Qualified_Name (E)
18747 or else Scope (E) = Standard_Standard
18751 return Get_Scoped_Name (Unique_Entity (Scope (E))) & "__" & Name;
18753 end Get_Scoped_Name;
18755 -- Start of processing for Unique_Name
18758 if E = Standard_Standard then
18759 return Get_Name_String (Name_Standard);
18761 elsif Scope (E) = Standard_Standard
18762 and then not (Ekind (E) = E_Package or else Is_Subprogram (E))
18764 return Get_Name_String (Name_Standard) & "__" &
18765 Get_Name_String (Chars (E));
18767 elsif Ekind (E) = E_Enumeration_Literal then
18768 return Unique_Name (Etype (E)) & "__" & Get_Name_String (Chars (E));
18771 return Get_Scoped_Name (Unique_Entity (E));
18775 ---------------------
18776 -- Unit_Is_Visible --
18777 ---------------------
18779 function Unit_Is_Visible (U : Entity_Id) return Boolean is
18780 Curr : constant Node_Id := Cunit (Current_Sem_Unit);
18781 Curr_Entity : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
18783 function Unit_In_Parent_Context (Par_Unit : Node_Id) return Boolean;
18784 -- For a child unit, check whether unit appears in a with_clause
18787 function Unit_In_Context (Comp_Unit : Node_Id) return Boolean;
18788 -- Scan the context clause of one compilation unit looking for a
18789 -- with_clause for the unit in question.
18791 ----------------------------
18792 -- Unit_In_Parent_Context --
18793 ----------------------------
18795 function Unit_In_Parent_Context (Par_Unit : Node_Id) return Boolean is
18797 if Unit_In_Context (Par_Unit) then
18800 elsif Is_Child_Unit (Defining_Entity (Unit (Par_Unit))) then
18801 return Unit_In_Parent_Context (Parent_Spec (Unit (Par_Unit)));
18806 end Unit_In_Parent_Context;
18808 ---------------------
18809 -- Unit_In_Context --
18810 ---------------------
18812 function Unit_In_Context (Comp_Unit : Node_Id) return Boolean is
18816 Clause := First (Context_Items (Comp_Unit));
18817 while Present (Clause) loop
18818 if Nkind (Clause) = N_With_Clause then
18819 if Library_Unit (Clause) = U then
18822 -- The with_clause may denote a renaming of the unit we are
18823 -- looking for, eg. Text_IO which renames Ada.Text_IO.
18826 Renamed_Entity (Entity (Name (Clause))) =
18827 Defining_Entity (Unit (U))
18837 end Unit_In_Context;
18839 -- Start of processing for Unit_Is_Visible
18842 -- The currrent unit is directly visible
18847 elsif Unit_In_Context (Curr) then
18850 -- If the current unit is a body, check the context of the spec
18852 elsif Nkind (Unit (Curr)) = N_Package_Body
18854 (Nkind (Unit (Curr)) = N_Subprogram_Body
18855 and then not Acts_As_Spec (Unit (Curr)))
18857 if Unit_In_Context (Library_Unit (Curr)) then
18862 -- If the spec is a child unit, examine the parents
18864 if Is_Child_Unit (Curr_Entity) then
18865 if Nkind (Unit (Curr)) in N_Unit_Body then
18867 Unit_In_Parent_Context
18868 (Parent_Spec (Unit (Library_Unit (Curr))));
18870 return Unit_In_Parent_Context (Parent_Spec (Unit (Curr)));
18876 end Unit_Is_Visible;
18878 ------------------------------
18879 -- Universal_Interpretation --
18880 ------------------------------
18882 function Universal_Interpretation (Opnd : Node_Id) return Entity_Id is
18883 Index : Interp_Index;
18887 -- The argument may be a formal parameter of an operator or subprogram
18888 -- with multiple interpretations, or else an expression for an actual.
18890 if Nkind (Opnd) = N_Defining_Identifier
18891 or else not Is_Overloaded (Opnd)
18893 if Etype (Opnd) = Universal_Integer
18894 or else Etype (Opnd) = Universal_Real
18896 return Etype (Opnd);
18902 Get_First_Interp (Opnd, Index, It);
18903 while Present (It.Typ) loop
18904 if It.Typ = Universal_Integer
18905 or else It.Typ = Universal_Real
18910 Get_Next_Interp (Index, It);
18915 end Universal_Interpretation;
18921 function Unqualify (Expr : Node_Id) return Node_Id is
18923 -- Recurse to handle unlikely case of multiple levels of qualification
18925 if Nkind (Expr) = N_Qualified_Expression then
18926 return Unqualify (Expression (Expr));
18928 -- Normal case, not a qualified expression
18935 -----------------------
18936 -- Visible_Ancestors --
18937 -----------------------
18939 function Visible_Ancestors (Typ : Entity_Id) return Elist_Id is
18945 pragma Assert (Is_Record_Type (Typ) and then Is_Tagged_Type (Typ));
18947 -- Collect all the parents and progenitors of Typ. If the full-view of
18948 -- private parents and progenitors is available then it is used to
18949 -- generate the list of visible ancestors; otherwise their partial
18950 -- view is added to the resulting list.
18955 Use_Full_View => True);
18959 Ifaces_List => List_2,
18960 Exclude_Parents => True,
18961 Use_Full_View => True);
18963 -- Join the two lists. Avoid duplications because an interface may
18964 -- simultaneously be parent and progenitor of a type.
18966 Elmt := First_Elmt (List_2);
18967 while Present (Elmt) loop
18968 Append_Unique_Elmt (Node (Elmt), List_1);
18973 end Visible_Ancestors;
18975 ----------------------
18976 -- Within_Init_Proc --
18977 ----------------------
18979 function Within_Init_Proc return Boolean is
18983 S := Current_Scope;
18984 while not Is_Overloadable (S) loop
18985 if S = Standard_Standard then
18992 return Is_Init_Proc (S);
18993 end Within_Init_Proc;
18999 function Within_Scope (E : Entity_Id; S : Entity_Id) return Boolean is
19006 elsif SE = Standard_Standard then
19018 procedure Wrong_Type (Expr : Node_Id; Expected_Type : Entity_Id) is
19019 Found_Type : constant Entity_Id := First_Subtype (Etype (Expr));
19020 Expec_Type : constant Entity_Id := First_Subtype (Expected_Type);
19022 Matching_Field : Entity_Id;
19023 -- Entity to give a more precise suggestion on how to write a one-
19024 -- element positional aggregate.
19026 function Has_One_Matching_Field return Boolean;
19027 -- Determines if Expec_Type is a record type with a single component or
19028 -- discriminant whose type matches the found type or is one dimensional
19029 -- array whose component type matches the found type. In the case of
19030 -- one discriminant, we ignore the variant parts. That's not accurate,
19031 -- but good enough for the warning.
19033 ----------------------------
19034 -- Has_One_Matching_Field --
19035 ----------------------------
19037 function Has_One_Matching_Field return Boolean is
19041 Matching_Field := Empty;
19043 if Is_Array_Type (Expec_Type)
19044 and then Number_Dimensions (Expec_Type) = 1
19045 and then Covers (Etype (Component_Type (Expec_Type)), Found_Type)
19047 -- Use type name if available. This excludes multidimensional
19048 -- arrays and anonymous arrays.
19050 if Comes_From_Source (Expec_Type) then
19051 Matching_Field := Expec_Type;
19053 -- For an assignment, use name of target
19055 elsif Nkind (Parent (Expr)) = N_Assignment_Statement
19056 and then Is_Entity_Name (Name (Parent (Expr)))
19058 Matching_Field := Entity (Name (Parent (Expr)));
19063 elsif not Is_Record_Type (Expec_Type) then
19067 E := First_Entity (Expec_Type);
19072 elsif not Ekind_In (E, E_Discriminant, E_Component)
19073 or else Nam_In (Chars (E), Name_uTag, Name_uParent)
19082 if not Covers (Etype (E), Found_Type) then
19085 elsif Present (Next_Entity (E))
19086 and then (Ekind (E) = E_Component
19087 or else Ekind (Next_Entity (E)) = E_Discriminant)
19092 Matching_Field := E;
19096 end Has_One_Matching_Field;
19098 -- Start of processing for Wrong_Type
19101 -- Don't output message if either type is Any_Type, or if a message
19102 -- has already been posted for this node. We need to do the latter
19103 -- check explicitly (it is ordinarily done in Errout), because we
19104 -- are using ! to force the output of the error messages.
19106 if Expec_Type = Any_Type
19107 or else Found_Type = Any_Type
19108 or else Error_Posted (Expr)
19112 -- If one of the types is a Taft-Amendment type and the other it its
19113 -- completion, it must be an illegal use of a TAT in the spec, for
19114 -- which an error was already emitted. Avoid cascaded errors.
19116 elsif Is_Incomplete_Type (Expec_Type)
19117 and then Has_Completion_In_Body (Expec_Type)
19118 and then Full_View (Expec_Type) = Etype (Expr)
19122 elsif Is_Incomplete_Type (Etype (Expr))
19123 and then Has_Completion_In_Body (Etype (Expr))
19124 and then Full_View (Etype (Expr)) = Expec_Type
19128 -- In an instance, there is an ongoing problem with completion of
19129 -- type derived from private types. Their structure is what Gigi
19130 -- expects, but the Etype is the parent type rather than the
19131 -- derived private type itself. Do not flag error in this case. The
19132 -- private completion is an entity without a parent, like an Itype.
19133 -- Similarly, full and partial views may be incorrect in the instance.
19134 -- There is no simple way to insure that it is consistent ???
19136 -- A similar view discrepancy can happen in an inlined body, for the
19137 -- same reason: inserted body may be outside of the original package
19138 -- and only partial views are visible at the point of insertion.
19140 elsif In_Instance or else In_Inlined_Body then
19141 if Etype (Etype (Expr)) = Etype (Expected_Type)
19143 (Has_Private_Declaration (Expected_Type)
19144 or else Has_Private_Declaration (Etype (Expr)))
19145 and then No (Parent (Expected_Type))
19149 elsif Nkind (Parent (Expr)) = N_Qualified_Expression
19150 and then Entity (Subtype_Mark (Parent (Expr))) = Expected_Type
19154 elsif Is_Private_Type (Expected_Type)
19155 and then Present (Full_View (Expected_Type))
19156 and then Covers (Full_View (Expected_Type), Etype (Expr))
19160 -- Conversely, type of expression may be the private one
19162 elsif Is_Private_Type (Base_Type (Etype (Expr)))
19163 and then Full_View (Base_Type (Etype (Expr))) = Expected_Type
19169 -- An interesting special check. If the expression is parenthesized
19170 -- and its type corresponds to the type of the sole component of the
19171 -- expected record type, or to the component type of the expected one
19172 -- dimensional array type, then assume we have a bad aggregate attempt.
19174 if Nkind (Expr) in N_Subexpr
19175 and then Paren_Count (Expr) /= 0
19176 and then Has_One_Matching_Field
19178 Error_Msg_N ("positional aggregate cannot have one component", Expr);
19180 if Present (Matching_Field) then
19181 if Is_Array_Type (Expec_Type) then
19183 ("\write instead `&''First ='> ...`", Expr, Matching_Field);
19186 ("\write instead `& ='> ...`", Expr, Matching_Field);
19190 -- Another special check, if we are looking for a pool-specific access
19191 -- type and we found an E_Access_Attribute_Type, then we have the case
19192 -- of an Access attribute being used in a context which needs a pool-
19193 -- specific type, which is never allowed. The one extra check we make
19194 -- is that the expected designated type covers the Found_Type.
19196 elsif Is_Access_Type (Expec_Type)
19197 and then Ekind (Found_Type) = E_Access_Attribute_Type
19198 and then Ekind (Base_Type (Expec_Type)) /= E_General_Access_Type
19199 and then Ekind (Base_Type (Expec_Type)) /= E_Anonymous_Access_Type
19201 (Designated_Type (Expec_Type), Designated_Type (Found_Type))
19203 Error_Msg_N -- CODEFIX
19204 ("result must be general access type!", Expr);
19205 Error_Msg_NE -- CODEFIX
19206 ("add ALL to }!", Expr, Expec_Type);
19208 -- Another special check, if the expected type is an integer type,
19209 -- but the expression is of type System.Address, and the parent is
19210 -- an addition or subtraction operation whose left operand is the
19211 -- expression in question and whose right operand is of an integral
19212 -- type, then this is an attempt at address arithmetic, so give
19213 -- appropriate message.
19215 elsif Is_Integer_Type (Expec_Type)
19216 and then Is_RTE (Found_Type, RE_Address)
19217 and then Nkind_In (Parent (Expr), N_Op_Add, N_Op_Subtract)
19218 and then Expr = Left_Opnd (Parent (Expr))
19219 and then Is_Integer_Type (Etype (Right_Opnd (Parent (Expr))))
19222 ("address arithmetic not predefined in package System",
19225 ("\possible missing with/use of System.Storage_Elements",
19229 -- If the expected type is an anonymous access type, as for access
19230 -- parameters and discriminants, the error is on the designated types.
19232 elsif Ekind (Expec_Type) = E_Anonymous_Access_Type then
19233 if Comes_From_Source (Expec_Type) then
19234 Error_Msg_NE ("expected}!", Expr, Expec_Type);
19237 ("expected an access type with designated}",
19238 Expr, Designated_Type (Expec_Type));
19241 if Is_Access_Type (Found_Type)
19242 and then not Comes_From_Source (Found_Type)
19245 ("\\found an access type with designated}!",
19246 Expr, Designated_Type (Found_Type));
19248 if From_Limited_With (Found_Type) then
19249 Error_Msg_NE ("\\found incomplete}!", Expr, Found_Type);
19250 Error_Msg_Qual_Level := 99;
19251 Error_Msg_NE -- CODEFIX
19252 ("\\missing `WITH &;", Expr, Scope (Found_Type));
19253 Error_Msg_Qual_Level := 0;
19255 Error_Msg_NE ("found}!", Expr, Found_Type);
19259 -- Normal case of one type found, some other type expected
19262 -- If the names of the two types are the same, see if some number
19263 -- of levels of qualification will help. Don't try more than three
19264 -- levels, and if we get to standard, it's no use (and probably
19265 -- represents an error in the compiler) Also do not bother with
19266 -- internal scope names.
19269 Expec_Scope : Entity_Id;
19270 Found_Scope : Entity_Id;
19273 Expec_Scope := Expec_Type;
19274 Found_Scope := Found_Type;
19276 for Levels in Int range 0 .. 3 loop
19277 if Chars (Expec_Scope) /= Chars (Found_Scope) then
19278 Error_Msg_Qual_Level := Levels;
19282 Expec_Scope := Scope (Expec_Scope);
19283 Found_Scope := Scope (Found_Scope);
19285 exit when Expec_Scope = Standard_Standard
19286 or else Found_Scope = Standard_Standard
19287 or else not Comes_From_Source (Expec_Scope)
19288 or else not Comes_From_Source (Found_Scope);
19292 if Is_Record_Type (Expec_Type)
19293 and then Present (Corresponding_Remote_Type (Expec_Type))
19295 Error_Msg_NE ("expected}!", Expr,
19296 Corresponding_Remote_Type (Expec_Type));
19298 Error_Msg_NE ("expected}!", Expr, Expec_Type);
19301 if Is_Entity_Name (Expr)
19302 and then Is_Package_Or_Generic_Package (Entity (Expr))
19304 Error_Msg_N ("\\found package name!", Expr);
19306 elsif Is_Entity_Name (Expr)
19307 and then Ekind_In (Entity (Expr), E_Procedure, E_Generic_Procedure)
19309 if Ekind (Expec_Type) = E_Access_Subprogram_Type then
19311 ("found procedure name, possibly missing Access attribute!",
19315 ("\\found procedure name instead of function!", Expr);
19318 elsif Nkind (Expr) = N_Function_Call
19319 and then Ekind (Expec_Type) = E_Access_Subprogram_Type
19320 and then Etype (Designated_Type (Expec_Type)) = Etype (Expr)
19321 and then No (Parameter_Associations (Expr))
19324 ("found function name, possibly missing Access attribute!",
19327 -- Catch common error: a prefix or infix operator which is not
19328 -- directly visible because the type isn't.
19330 elsif Nkind (Expr) in N_Op
19331 and then Is_Overloaded (Expr)
19332 and then not Is_Immediately_Visible (Expec_Type)
19333 and then not Is_Potentially_Use_Visible (Expec_Type)
19334 and then not In_Use (Expec_Type)
19335 and then Has_Compatible_Type (Right_Opnd (Expr), Expec_Type)
19338 ("operator of the type is not directly visible!", Expr);
19340 elsif Ekind (Found_Type) = E_Void
19341 and then Present (Parent (Found_Type))
19342 and then Nkind (Parent (Found_Type)) = N_Full_Type_Declaration
19344 Error_Msg_NE ("\\found premature usage of}!", Expr, Found_Type);
19347 Error_Msg_NE ("\\found}!", Expr, Found_Type);
19350 -- A special check for cases like M1 and M2 = 0 where M1 and M2 are
19351 -- of the same modular type, and (M1 and M2) = 0 was intended.
19353 if Expec_Type = Standard_Boolean
19354 and then Is_Modular_Integer_Type (Found_Type)
19355 and then Nkind_In (Parent (Expr), N_Op_And, N_Op_Or, N_Op_Xor)
19356 and then Nkind (Right_Opnd (Parent (Expr))) in N_Op_Compare
19359 Op : constant Node_Id := Right_Opnd (Parent (Expr));
19360 L : constant Node_Id := Left_Opnd (Op);
19361 R : constant Node_Id := Right_Opnd (Op);
19364 -- The case for the message is when the left operand of the
19365 -- comparison is the same modular type, or when it is an
19366 -- integer literal (or other universal integer expression),
19367 -- which would have been typed as the modular type if the
19368 -- parens had been there.
19370 if (Etype (L) = Found_Type
19372 Etype (L) = Universal_Integer)
19373 and then Is_Integer_Type (Etype (R))
19376 ("\\possible missing parens for modular operation", Expr);
19381 -- Reset error message qualification indication
19383 Error_Msg_Qual_Level := 0;