1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Aspects; use Aspects;
27 with Atree; use Atree;
28 with Casing; use Casing;
29 with Checks; use Checks;
30 with Debug; use Debug;
31 with Elists; use Elists;
32 with Errout; use Errout;
33 with Exp_Ch11; use Exp_Ch11;
34 with Exp_Disp; use Exp_Disp;
35 with Exp_Util; use Exp_Util;
36 with Fname; use Fname;
37 with Freeze; use Freeze;
39 with Lib.Xref; use Lib.Xref;
40 with Namet.Sp; use Namet.Sp;
41 with Nlists; use Nlists;
42 with Nmake; use Nmake;
43 with Output; use Output;
44 with Restrict; use Restrict;
45 with Rident; use Rident;
46 with Rtsfind; use Rtsfind;
48 with Sem_Aux; use Sem_Aux;
49 with Sem_Attr; use Sem_Attr;
50 with Sem_Ch8; use Sem_Ch8;
51 with Sem_Disp; use Sem_Disp;
52 with Sem_Eval; use Sem_Eval;
53 with Sem_Prag; use Sem_Prag;
54 with Sem_Res; use Sem_Res;
55 with Sem_Warn; use Sem_Warn;
56 with Sem_Type; use Sem_Type;
57 with Sinfo; use Sinfo;
58 with Sinput; use Sinput;
59 with Stand; use Stand;
61 with Stringt; use Stringt;
62 with Targparm; use Targparm;
63 with Tbuild; use Tbuild;
64 with Ttypes; use Ttypes;
65 with Uname; use Uname;
67 with GNAT.HTable; use GNAT.HTable;
69 package body Sem_Util is
71 ----------------------------------------
72 -- Global_Variables for New_Copy_Tree --
73 ----------------------------------------
75 -- These global variables are used by New_Copy_Tree. See description
76 -- of the body of this subprogram for details. Global variables can be
77 -- safely used by New_Copy_Tree, since there is no case of a recursive
78 -- call from the processing inside New_Copy_Tree.
80 NCT_Hash_Threshold : constant := 20;
81 -- If there are more than this number of pairs of entries in the
82 -- map, then Hash_Tables_Used will be set, and the hash tables will
83 -- be initialized and used for the searches.
85 NCT_Hash_Tables_Used : Boolean := False;
86 -- Set to True if hash tables are in use
88 NCT_Table_Entries : Nat := 0;
89 -- Count entries in table to see if threshold is reached
91 NCT_Hash_Table_Setup : Boolean := False;
92 -- Set to True if hash table contains data. We set this True if we
93 -- setup the hash table with data, and leave it set permanently
94 -- from then on, this is a signal that second and subsequent users
95 -- of the hash table must clear the old entries before reuse.
97 subtype NCT_Header_Num is Int range 0 .. 511;
98 -- Defines range of headers in hash tables (512 headers)
100 -----------------------
101 -- Local Subprograms --
102 -----------------------
104 function Build_Component_Subtype
107 T : Entity_Id) return Node_Id;
108 -- This function builds the subtype for Build_Actual_Subtype_Of_Component
109 -- and Build_Discriminal_Subtype_Of_Component. C is a list of constraints,
110 -- Loc is the source location, T is the original subtype.
112 function Is_Fully_Initialized_Variant (Typ : Entity_Id) return Boolean;
113 -- Subsidiary to Is_Fully_Initialized_Type. For an unconstrained type
114 -- with discriminants whose default values are static, examine only the
115 -- components in the selected variant to determine whether all of them
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 ------------------------------
130 -- Abstract_Interface_List --
131 ------------------------------
133 function Abstract_Interface_List (Typ : Entity_Id) return List_Id is
137 if Is_Concurrent_Type (Typ) then
139 -- If we are dealing with a synchronized subtype, go to the base
140 -- type, whose declaration has the interface list.
142 -- Shouldn't this be Declaration_Node???
144 Nod := Parent (Base_Type (Typ));
146 if Nkind (Nod) = N_Full_Type_Declaration then
150 elsif Ekind (Typ) = E_Record_Type_With_Private then
151 if Nkind (Parent (Typ)) = N_Full_Type_Declaration then
152 Nod := Type_Definition (Parent (Typ));
154 elsif Nkind (Parent (Typ)) = N_Private_Type_Declaration then
155 if Present (Full_View (Typ))
156 and then Nkind (Parent (Full_View (Typ)))
157 = N_Full_Type_Declaration
159 Nod := Type_Definition (Parent (Full_View (Typ)));
161 -- If the full-view is not available we cannot do anything else
162 -- here (the source has errors).
168 -- Support for generic formals with interfaces is still missing ???
170 elsif Nkind (Parent (Typ)) = N_Formal_Type_Declaration then
175 (Nkind (Parent (Typ)) = N_Private_Extension_Declaration);
179 elsif Ekind (Typ) = E_Record_Subtype then
180 Nod := Type_Definition (Parent (Etype (Typ)));
182 elsif Ekind (Typ) = E_Record_Subtype_With_Private then
184 -- Recurse, because parent may still be a private extension. Also
185 -- note that the full view of the subtype or the full view of its
186 -- base type may (both) be unavailable.
188 return Abstract_Interface_List (Etype (Typ));
190 else pragma Assert ((Ekind (Typ)) = E_Record_Type);
191 if Nkind (Parent (Typ)) = N_Formal_Type_Declaration then
192 Nod := Formal_Type_Definition (Parent (Typ));
194 Nod := Type_Definition (Parent (Typ));
198 return Interface_List (Nod);
199 end Abstract_Interface_List;
201 --------------------------------
202 -- Add_Access_Type_To_Process --
203 --------------------------------
205 procedure Add_Access_Type_To_Process (E : Entity_Id; A : Entity_Id) is
209 Ensure_Freeze_Node (E);
210 L := Access_Types_To_Process (Freeze_Node (E));
214 Set_Access_Types_To_Process (Freeze_Node (E), L);
218 end Add_Access_Type_To_Process;
220 --------------------------
221 -- Add_Block_Identifier --
222 --------------------------
224 procedure Add_Block_Identifier (N : Node_Id; Id : out Entity_Id) is
225 Loc : constant Source_Ptr := Sloc (N);
228 pragma Assert (Nkind (N) = N_Block_Statement);
230 -- The block already has a label, return its entity
232 if Present (Identifier (N)) then
233 Id := Entity (Identifier (N));
235 -- Create a new block label and set its attributes
238 Id := New_Internal_Entity (E_Block, Current_Scope, Loc, 'B');
239 Set_Etype (Id, Standard_Void_Type);
242 Set_Identifier (N, New_Occurrence_Of (Id, Loc));
243 Set_Block_Node (Id, Identifier (N));
245 end Add_Block_Identifier;
247 -----------------------
248 -- Add_Contract_Item --
249 -----------------------
251 procedure Add_Contract_Item (Prag : Node_Id; Id : Entity_Id) is
252 Items : constant Node_Id := Contract (Id);
257 -- The related context must have a contract and the item to be added
260 pragma Assert (Present (Items));
261 pragma Assert (Nkind (Prag) = N_Pragma);
263 Nam := Original_Aspect_Name (Prag);
265 -- Contract items related to [generic] packages or instantiations. The
266 -- applicable pragmas are:
270 -- Part_Of (instantiation only)
272 if Ekind_In (Id, E_Generic_Package, E_Package) then
273 if Nam_In (Nam, Name_Abstract_State,
274 Name_Initial_Condition,
277 Set_Next_Pragma (Prag, Classifications (Items));
278 Set_Classifications (Items, Prag);
280 -- Indicator Part_Of must be associated with a package instantiation
282 elsif Nam = Name_Part_Of and then Is_Generic_Instance (Id) then
283 Set_Next_Pragma (Prag, Classifications (Items));
284 Set_Classifications (Items, Prag);
286 -- The pragma is not a proper contract item
292 -- Contract items related to package bodies. The applicable pragmas are:
295 elsif Ekind (Id) = E_Package_Body then
296 if Nam = Name_Refined_State then
297 Set_Next_Pragma (Prag, Classifications (Items));
298 Set_Classifications (Items, Prag);
300 -- The pragma is not a proper contract item
306 -- Contract items related to subprogram or entry declarations. The
307 -- applicable pragmas are:
317 elsif Ekind_In (Id, E_Entry, E_Entry_Family)
318 or else Is_Generic_Subprogram (Id)
319 or else Is_Subprogram (Id)
321 if Nam_In (Nam, Name_Precondition,
328 -- Before we add a precondition or postcondition to the list,
329 -- make sure we do not have a disallowed duplicate, which can
330 -- happen if we use a pragma for Pre[_Class] or Post[_Class]
331 -- instead of the corresponding aspect.
333 if not From_Aspect_Specification (Prag)
334 and then Nam_In (Nam, Name_Pre_Class,
341 N := Pre_Post_Conditions (Items);
342 while Present (N) loop
344 and then Original_Aspect_Name (N) = Nam
346 Error_Msg_Sloc := Sloc (N);
348 ("duplication of aspect for & given#", Prag, Id);
351 N := Next_Pragma (N);
356 Set_Next_Pragma (Prag, Pre_Post_Conditions (Items));
357 Set_Pre_Post_Conditions (Items, Prag);
359 elsif Nam_In (Nam, Name_Contract_Cases, Name_Test_Case) then
360 Set_Next_Pragma (Prag, Contract_Test_Cases (Items));
361 Set_Contract_Test_Cases (Items, Prag);
363 elsif Nam_In (Nam, Name_Depends, Name_Global) then
364 Set_Next_Pragma (Prag, Classifications (Items));
365 Set_Classifications (Items, Prag);
367 -- The pragma is not a proper contract item
373 -- Contract items related to subprogram bodies. The applicable pragmas
379 elsif Ekind (Id) = E_Subprogram_Body then
380 if Nam = Name_Refined_Post then
381 Set_Next_Pragma (Prag, Pre_Post_Conditions (Items));
382 Set_Pre_Post_Conditions (Items, Prag);
384 elsif Nam_In (Nam, Name_Refined_Depends, Name_Refined_Global) then
385 Set_Next_Pragma (Prag, Classifications (Items));
386 Set_Classifications (Items, Prag);
388 -- The pragma is not a proper contract item
394 -- Contract items related to variables. The applicable pragmas are:
401 elsif Ekind (Id) = E_Variable then
402 if Nam_In (Nam, Name_Async_Readers,
404 Name_Effective_Reads,
405 Name_Effective_Writes,
408 Set_Next_Pragma (Prag, Classifications (Items));
409 Set_Classifications (Items, Prag);
411 -- The pragma is not a proper contract item
417 end Add_Contract_Item;
419 ----------------------------
420 -- Add_Global_Declaration --
421 ----------------------------
423 procedure Add_Global_Declaration (N : Node_Id) is
424 Aux_Node : constant Node_Id := Aux_Decls_Node (Cunit (Current_Sem_Unit));
427 if No (Declarations (Aux_Node)) then
428 Set_Declarations (Aux_Node, New_List);
431 Append_To (Declarations (Aux_Node), N);
433 end Add_Global_Declaration;
435 --------------------------------
436 -- Address_Integer_Convert_OK --
437 --------------------------------
439 function Address_Integer_Convert_OK (T1, T2 : Entity_Id) return Boolean is
441 if Allow_Integer_Address
442 and then ((Is_Descendent_Of_Address (T1)
443 and then Is_Private_Type (T1)
444 and then Is_Integer_Type (T2))
446 (Is_Descendent_Of_Address (T2)
447 and then Is_Private_Type (T2)
448 and then Is_Integer_Type (T1)))
454 end Address_Integer_Convert_OK;
460 -- For now, just 8/16/32/64. but analyze later if AAMP is special???
462 function Addressable (V : Uint) return Boolean is
464 return V = Uint_8 or else
470 function Addressable (V : Int) return Boolean is
478 ---------------------------------
479 -- Aggregate_Constraint_Checks --
480 ---------------------------------
482 procedure Aggregate_Constraint_Checks
484 Check_Typ : Entity_Id)
486 Exp_Typ : constant Entity_Id := Etype (Exp);
489 if Raises_Constraint_Error (Exp) then
493 -- Ada 2005 (AI-230): Generate a conversion to an anonymous access
494 -- component's type to force the appropriate accessibility checks.
496 -- Ada 2005 (AI-231): Generate conversion to the null-excluding
497 -- type to force the corresponding run-time check
499 if Is_Access_Type (Check_Typ)
500 and then ((Is_Local_Anonymous_Access (Check_Typ))
501 or else (Can_Never_Be_Null (Check_Typ)
502 and then not Can_Never_Be_Null (Exp_Typ)))
504 Rewrite (Exp, Convert_To (Check_Typ, Relocate_Node (Exp)));
505 Analyze_And_Resolve (Exp, Check_Typ);
506 Check_Unset_Reference (Exp);
509 -- This is really expansion activity, so make sure that expansion is
510 -- on and is allowed. In GNATprove mode, we also want check flags to
511 -- be added in the tree, so that the formal verification can rely on
512 -- those to be present. In GNATprove mode for formal verification, some
513 -- treatment typically only done during expansion needs to be performed
514 -- on the tree, but it should not be applied inside generics. Otherwise,
515 -- this breaks the name resolution mechanism for generic instances.
517 if not Expander_Active
518 and (Inside_A_Generic or not Full_Analysis or not GNATprove_Mode)
523 -- First check if we have to insert discriminant checks
525 if Has_Discriminants (Exp_Typ) then
526 Apply_Discriminant_Check (Exp, Check_Typ);
528 -- Next emit length checks for array aggregates
530 elsif Is_Array_Type (Exp_Typ) then
531 Apply_Length_Check (Exp, Check_Typ);
533 -- Finally emit scalar and string checks. If we are dealing with a
534 -- scalar literal we need to check by hand because the Etype of
535 -- literals is not necessarily correct.
537 elsif Is_Scalar_Type (Exp_Typ)
538 and then Compile_Time_Known_Value (Exp)
540 if Is_Out_Of_Range (Exp, Base_Type (Check_Typ)) then
541 Apply_Compile_Time_Constraint_Error
542 (Exp, "value not in range of}??", CE_Range_Check_Failed,
543 Ent => Base_Type (Check_Typ),
544 Typ => Base_Type (Check_Typ));
546 elsif Is_Out_Of_Range (Exp, Check_Typ) then
547 Apply_Compile_Time_Constraint_Error
548 (Exp, "value not in range of}??", CE_Range_Check_Failed,
552 elsif not Range_Checks_Suppressed (Check_Typ) then
553 Apply_Scalar_Range_Check (Exp, Check_Typ);
556 -- Verify that target type is also scalar, to prevent view anomalies
557 -- in instantiations.
559 elsif (Is_Scalar_Type (Exp_Typ)
560 or else Nkind (Exp) = N_String_Literal)
561 and then Is_Scalar_Type (Check_Typ)
562 and then Exp_Typ /= Check_Typ
564 if Is_Entity_Name (Exp)
565 and then Ekind (Entity (Exp)) = E_Constant
567 -- If expression is a constant, it is worthwhile checking whether
568 -- it is a bound of the type.
570 if (Is_Entity_Name (Type_Low_Bound (Check_Typ))
571 and then Entity (Exp) = Entity (Type_Low_Bound (Check_Typ)))
573 (Is_Entity_Name (Type_High_Bound (Check_Typ))
574 and then Entity (Exp) = Entity (Type_High_Bound (Check_Typ)))
579 Rewrite (Exp, Convert_To (Check_Typ, Relocate_Node (Exp)));
580 Analyze_And_Resolve (Exp, Check_Typ);
581 Check_Unset_Reference (Exp);
584 -- Could use a comment on this case ???
587 Rewrite (Exp, Convert_To (Check_Typ, Relocate_Node (Exp)));
588 Analyze_And_Resolve (Exp, Check_Typ);
589 Check_Unset_Reference (Exp);
593 end Aggregate_Constraint_Checks;
595 -----------------------
596 -- Alignment_In_Bits --
597 -----------------------
599 function Alignment_In_Bits (E : Entity_Id) return Uint is
601 return Alignment (E) * System_Storage_Unit;
602 end Alignment_In_Bits;
604 ---------------------------------
605 -- Append_Inherited_Subprogram --
606 ---------------------------------
608 procedure Append_Inherited_Subprogram (S : Entity_Id) is
609 Par : constant Entity_Id := Alias (S);
610 -- The parent subprogram
612 Scop : constant Entity_Id := Scope (Par);
613 -- The scope of definition of the parent subprogram
615 Typ : constant Entity_Id := Defining_Entity (Parent (S));
616 -- The derived type of which S is a primitive operation
622 if Ekind (Current_Scope) = E_Package
623 and then In_Private_Part (Current_Scope)
624 and then Has_Private_Declaration (Typ)
625 and then Is_Tagged_Type (Typ)
626 and then Scop = Current_Scope
628 -- The inherited operation is available at the earliest place after
629 -- the derived type declaration ( RM 7.3.1 (6/1)). This is only
630 -- relevant for type extensions. If the parent operation appears
631 -- after the type extension, the operation is not visible.
634 (Visible_Declarations
635 (Package_Specification (Current_Scope)));
636 while Present (Decl) loop
637 if Nkind (Decl) = N_Private_Extension_Declaration
638 and then Defining_Entity (Decl) = Typ
640 if Sloc (Decl) > Sloc (Par) then
641 Next_E := Next_Entity (Par);
642 Set_Next_Entity (Par, S);
643 Set_Next_Entity (S, Next_E);
655 -- If partial view is not a type extension, or it appears before the
656 -- subprogram declaration, insert normally at end of entity list.
658 Append_Entity (S, Current_Scope);
659 end Append_Inherited_Subprogram;
661 -----------------------------------------
662 -- Apply_Compile_Time_Constraint_Error --
663 -----------------------------------------
665 procedure Apply_Compile_Time_Constraint_Error
668 Reason : RT_Exception_Code;
669 Ent : Entity_Id := Empty;
670 Typ : Entity_Id := Empty;
671 Loc : Source_Ptr := No_Location;
672 Rep : Boolean := True;
673 Warn : Boolean := False)
675 Stat : constant Boolean := Is_Static_Expression (N);
676 R_Stat : constant Node_Id :=
677 Make_Raise_Constraint_Error (Sloc (N), Reason => Reason);
688 (Compile_Time_Constraint_Error (N, Msg, Ent, Loc, Warn => Warn));
694 -- Now we replace the node by an N_Raise_Constraint_Error node
695 -- This does not need reanalyzing, so set it as analyzed now.
698 Set_Analyzed (N, True);
701 Set_Raises_Constraint_Error (N);
703 -- Now deal with possible local raise handling
705 Possible_Local_Raise (N, Standard_Constraint_Error);
707 -- If the original expression was marked as static, the result is
708 -- still marked as static, but the Raises_Constraint_Error flag is
709 -- always set so that further static evaluation is not attempted.
712 Set_Is_Static_Expression (N);
714 end Apply_Compile_Time_Constraint_Error;
716 ---------------------------
717 -- Async_Readers_Enabled --
718 ---------------------------
720 function Async_Readers_Enabled (Id : Entity_Id) return Boolean is
722 return Has_Enabled_Property (Id, Name_Async_Readers);
723 end Async_Readers_Enabled;
725 ---------------------------
726 -- Async_Writers_Enabled --
727 ---------------------------
729 function Async_Writers_Enabled (Id : Entity_Id) return Boolean is
731 return Has_Enabled_Property (Id, Name_Async_Writers);
732 end Async_Writers_Enabled;
734 --------------------------------------
735 -- Available_Full_View_Of_Component --
736 --------------------------------------
738 function Available_Full_View_Of_Component (T : Entity_Id) return Boolean is
739 ST : constant Entity_Id := Scope (T);
740 SCT : constant Entity_Id := Scope (Component_Type (T));
742 return In_Open_Scopes (ST)
743 and then In_Open_Scopes (SCT)
744 and then Scope_Depth (ST) >= Scope_Depth (SCT);
745 end Available_Full_View_Of_Component;
751 procedure Bad_Attribute
754 Warn : Boolean := False)
757 Error_Msg_Warn := Warn;
758 Error_Msg_N ("unrecognized attribute&<<", N);
760 -- Check for possible misspelling
762 Error_Msg_Name_1 := First_Attribute_Name;
763 while Error_Msg_Name_1 <= Last_Attribute_Name loop
764 if Is_Bad_Spelling_Of (Nam, Error_Msg_Name_1) then
765 Error_Msg_N -- CODEFIX
766 ("\possible misspelling of %<<", N);
770 Error_Msg_Name_1 := Error_Msg_Name_1 + 1;
774 --------------------------------
775 -- Bad_Predicated_Subtype_Use --
776 --------------------------------
778 procedure Bad_Predicated_Subtype_Use
782 Suggest_Static : Boolean := False)
785 if Has_Predicates (Typ) then
786 if Is_Generic_Actual_Type (Typ) then
787 Error_Msg_Warn := SPARK_Mode /= On;
788 Error_Msg_FE (Msg & "<<", N, Typ);
789 Error_Msg_F ("\Program_Error [<<", N);
791 Make_Raise_Program_Error (Sloc (N),
792 Reason => PE_Bad_Predicated_Generic_Type));
795 Error_Msg_FE (Msg, N, Typ);
798 -- Emit an optional suggestion on how to remedy the error if the
799 -- context warrants it.
801 if Suggest_Static and then Present (Static_Predicate (Typ)) then
802 Error_Msg_FE ("\predicate of & should be marked static", N, Typ);
805 end Bad_Predicated_Subtype_Use;
807 -----------------------------------------
808 -- Bad_Unordered_Enumeration_Reference --
809 -----------------------------------------
811 function Bad_Unordered_Enumeration_Reference
813 T : Entity_Id) return Boolean
816 return Is_Enumeration_Type (T)
817 and then Comes_From_Source (N)
818 and then Warn_On_Unordered_Enumeration_Type
819 and then not Has_Pragma_Ordered (T)
820 and then not In_Same_Extended_Unit (N, T);
821 end Bad_Unordered_Enumeration_Reference;
823 --------------------------
824 -- Build_Actual_Subtype --
825 --------------------------
827 function Build_Actual_Subtype
829 N : Node_Or_Entity_Id) return Node_Id
832 -- Normally Sloc (N), but may point to corresponding body in some cases
834 Constraints : List_Id;
840 Disc_Type : Entity_Id;
846 if Nkind (N) = N_Defining_Identifier then
847 Obj := New_Occurrence_Of (N, Loc);
849 -- If this is a formal parameter of a subprogram declaration, and
850 -- we are compiling the body, we want the declaration for the
851 -- actual subtype to carry the source position of the body, to
852 -- prevent anomalies in gdb when stepping through the code.
854 if Is_Formal (N) then
856 Decl : constant Node_Id := Unit_Declaration_Node (Scope (N));
858 if Nkind (Decl) = N_Subprogram_Declaration
859 and then Present (Corresponding_Body (Decl))
861 Loc := Sloc (Corresponding_Body (Decl));
870 if Is_Array_Type (T) then
871 Constraints := New_List;
872 for J in 1 .. Number_Dimensions (T) loop
874 -- Build an array subtype declaration with the nominal subtype and
875 -- the bounds of the actual. Add the declaration in front of the
876 -- local declarations for the subprogram, for analysis before any
877 -- reference to the formal in the body.
880 Make_Attribute_Reference (Loc,
882 Duplicate_Subexpr_No_Checks (Obj, Name_Req => True),
883 Attribute_Name => Name_First,
884 Expressions => New_List (
885 Make_Integer_Literal (Loc, J)));
888 Make_Attribute_Reference (Loc,
890 Duplicate_Subexpr_No_Checks (Obj, Name_Req => True),
891 Attribute_Name => Name_Last,
892 Expressions => New_List (
893 Make_Integer_Literal (Loc, J)));
895 Append (Make_Range (Loc, Lo, Hi), Constraints);
898 -- If the type has unknown discriminants there is no constrained
899 -- subtype to build. This is never called for a formal or for a
900 -- lhs, so returning the type is ok ???
902 elsif Has_Unknown_Discriminants (T) then
906 Constraints := New_List;
908 -- Type T is a generic derived type, inherit the discriminants from
911 if Is_Private_Type (T)
912 and then No (Full_View (T))
914 -- T was flagged as an error if it was declared as a formal
915 -- derived type with known discriminants. In this case there
916 -- is no need to look at the parent type since T already carries
917 -- its own discriminants.
919 and then not Error_Posted (T)
921 Disc_Type := Etype (Base_Type (T));
926 Discr := First_Discriminant (Disc_Type);
927 while Present (Discr) loop
928 Append_To (Constraints,
929 Make_Selected_Component (Loc,
931 Duplicate_Subexpr_No_Checks (Obj),
932 Selector_Name => New_Occurrence_Of (Discr, Loc)));
933 Next_Discriminant (Discr);
937 Subt := Make_Temporary (Loc, 'S', Related_Node => N);
938 Set_Is_Internal (Subt);
941 Make_Subtype_Declaration (Loc,
942 Defining_Identifier => Subt,
943 Subtype_Indication =>
944 Make_Subtype_Indication (Loc,
945 Subtype_Mark => New_Occurrence_Of (T, Loc),
947 Make_Index_Or_Discriminant_Constraint (Loc,
948 Constraints => Constraints)));
950 Mark_Rewrite_Insertion (Decl);
952 end Build_Actual_Subtype;
954 ---------------------------------------
955 -- Build_Actual_Subtype_Of_Component --
956 ---------------------------------------
958 function Build_Actual_Subtype_Of_Component
960 N : Node_Id) return Node_Id
962 Loc : constant Source_Ptr := Sloc (N);
963 P : constant Node_Id := Prefix (N);
966 Index_Typ : Entity_Id;
968 Desig_Typ : Entity_Id;
969 -- This is either a copy of T, or if T is an access type, then it is
970 -- the directly designated type of this access type.
972 function Build_Actual_Array_Constraint return List_Id;
973 -- If one or more of the bounds of the component depends on
974 -- discriminants, build actual constraint using the discriminants
977 function Build_Actual_Record_Constraint return List_Id;
978 -- Similar to previous one, for discriminated components constrained
979 -- by the discriminant of the enclosing object.
981 -----------------------------------
982 -- Build_Actual_Array_Constraint --
983 -----------------------------------
985 function Build_Actual_Array_Constraint return List_Id is
986 Constraints : constant List_Id := New_List;
994 Indx := First_Index (Desig_Typ);
995 while Present (Indx) loop
996 Old_Lo := Type_Low_Bound (Etype (Indx));
997 Old_Hi := Type_High_Bound (Etype (Indx));
999 if Denotes_Discriminant (Old_Lo) then
1001 Make_Selected_Component (Loc,
1002 Prefix => New_Copy_Tree (P),
1003 Selector_Name => New_Occurrence_Of (Entity (Old_Lo), Loc));
1006 Lo := New_Copy_Tree (Old_Lo);
1008 -- The new bound will be reanalyzed in the enclosing
1009 -- declaration. For literal bounds that come from a type
1010 -- declaration, the type of the context must be imposed, so
1011 -- insure that analysis will take place. For non-universal
1012 -- types this is not strictly necessary.
1014 Set_Analyzed (Lo, False);
1017 if Denotes_Discriminant (Old_Hi) then
1019 Make_Selected_Component (Loc,
1020 Prefix => New_Copy_Tree (P),
1021 Selector_Name => New_Occurrence_Of (Entity (Old_Hi), Loc));
1024 Hi := New_Copy_Tree (Old_Hi);
1025 Set_Analyzed (Hi, False);
1028 Append (Make_Range (Loc, Lo, Hi), Constraints);
1033 end Build_Actual_Array_Constraint;
1035 ------------------------------------
1036 -- Build_Actual_Record_Constraint --
1037 ------------------------------------
1039 function Build_Actual_Record_Constraint return List_Id is
1040 Constraints : constant List_Id := New_List;
1045 D := First_Elmt (Discriminant_Constraint (Desig_Typ));
1046 while Present (D) loop
1047 if Denotes_Discriminant (Node (D)) then
1048 D_Val := Make_Selected_Component (Loc,
1049 Prefix => New_Copy_Tree (P),
1050 Selector_Name => New_Occurrence_Of (Entity (Node (D)), Loc));
1053 D_Val := New_Copy_Tree (Node (D));
1056 Append (D_Val, Constraints);
1061 end Build_Actual_Record_Constraint;
1063 -- Start of processing for Build_Actual_Subtype_Of_Component
1066 -- Why the test for Spec_Expression mode here???
1068 if In_Spec_Expression then
1071 -- More comments for the rest of this body would be good ???
1073 elsif Nkind (N) = N_Explicit_Dereference then
1074 if Is_Composite_Type (T)
1075 and then not Is_Constrained (T)
1076 and then not (Is_Class_Wide_Type (T)
1077 and then Is_Constrained (Root_Type (T)))
1078 and then not Has_Unknown_Discriminants (T)
1080 -- If the type of the dereference is already constrained, it is an
1083 if Is_Array_Type (Etype (N))
1084 and then Is_Constrained (Etype (N))
1088 Remove_Side_Effects (P);
1089 return Build_Actual_Subtype (T, N);
1096 if Ekind (T) = E_Access_Subtype then
1097 Desig_Typ := Designated_Type (T);
1102 if Ekind (Desig_Typ) = E_Array_Subtype then
1103 Id := First_Index (Desig_Typ);
1104 while Present (Id) loop
1105 Index_Typ := Underlying_Type (Etype (Id));
1107 if Denotes_Discriminant (Type_Low_Bound (Index_Typ))
1109 Denotes_Discriminant (Type_High_Bound (Index_Typ))
1111 Remove_Side_Effects (P);
1113 Build_Component_Subtype
1114 (Build_Actual_Array_Constraint, Loc, Base_Type (T));
1120 elsif Is_Composite_Type (Desig_Typ)
1121 and then Has_Discriminants (Desig_Typ)
1122 and then not Has_Unknown_Discriminants (Desig_Typ)
1124 if Is_Private_Type (Desig_Typ)
1125 and then No (Discriminant_Constraint (Desig_Typ))
1127 Desig_Typ := Full_View (Desig_Typ);
1130 D := First_Elmt (Discriminant_Constraint (Desig_Typ));
1131 while Present (D) loop
1132 if Denotes_Discriminant (Node (D)) then
1133 Remove_Side_Effects (P);
1135 Build_Component_Subtype (
1136 Build_Actual_Record_Constraint, Loc, Base_Type (T));
1143 -- If none of the above, the actual and nominal subtypes are the same
1146 end Build_Actual_Subtype_Of_Component;
1148 -----------------------------
1149 -- Build_Component_Subtype --
1150 -----------------------------
1152 function Build_Component_Subtype
1155 T : Entity_Id) return Node_Id
1161 -- Unchecked_Union components do not require component subtypes
1163 if Is_Unchecked_Union (T) then
1167 Subt := Make_Temporary (Loc, 'S');
1168 Set_Is_Internal (Subt);
1171 Make_Subtype_Declaration (Loc,
1172 Defining_Identifier => Subt,
1173 Subtype_Indication =>
1174 Make_Subtype_Indication (Loc,
1175 Subtype_Mark => New_Occurrence_Of (Base_Type (T), Loc),
1177 Make_Index_Or_Discriminant_Constraint (Loc,
1178 Constraints => C)));
1180 Mark_Rewrite_Insertion (Decl);
1182 end Build_Component_Subtype;
1184 ---------------------------
1185 -- Build_Default_Subtype --
1186 ---------------------------
1188 function Build_Default_Subtype
1190 N : Node_Id) return Entity_Id
1192 Loc : constant Source_Ptr := Sloc (N);
1196 -- The base type that is to be constrained by the defaults
1199 if not Has_Discriminants (T) or else Is_Constrained (T) then
1203 Bas := Base_Type (T);
1205 -- If T is non-private but its base type is private, this is the
1206 -- completion of a subtype declaration whose parent type is private
1207 -- (see Complete_Private_Subtype in Sem_Ch3). The proper discriminants
1208 -- are to be found in the full view of the base. Check that the private
1209 -- status of T and its base differ.
1211 if Is_Private_Type (Bas)
1212 and then not Is_Private_Type (T)
1213 and then Present (Full_View (Bas))
1215 Bas := Full_View (Bas);
1218 Disc := First_Discriminant (T);
1220 if No (Discriminant_Default_Value (Disc)) then
1225 Act : constant Entity_Id := Make_Temporary (Loc, 'S');
1226 Constraints : constant List_Id := New_List;
1230 while Present (Disc) loop
1231 Append_To (Constraints,
1232 New_Copy_Tree (Discriminant_Default_Value (Disc)));
1233 Next_Discriminant (Disc);
1237 Make_Subtype_Declaration (Loc,
1238 Defining_Identifier => Act,
1239 Subtype_Indication =>
1240 Make_Subtype_Indication (Loc,
1241 Subtype_Mark => New_Occurrence_Of (Bas, Loc),
1243 Make_Index_Or_Discriminant_Constraint (Loc,
1244 Constraints => Constraints)));
1246 Insert_Action (N, Decl);
1250 end Build_Default_Subtype;
1252 --------------------------------------------
1253 -- Build_Discriminal_Subtype_Of_Component --
1254 --------------------------------------------
1256 function Build_Discriminal_Subtype_Of_Component
1257 (T : Entity_Id) return Node_Id
1259 Loc : constant Source_Ptr := Sloc (T);
1263 function Build_Discriminal_Array_Constraint return List_Id;
1264 -- If one or more of the bounds of the component depends on
1265 -- discriminants, build actual constraint using the discriminants
1268 function Build_Discriminal_Record_Constraint return List_Id;
1269 -- Similar to previous one, for discriminated components constrained by
1270 -- the discriminant of the enclosing object.
1272 ----------------------------------------
1273 -- Build_Discriminal_Array_Constraint --
1274 ----------------------------------------
1276 function Build_Discriminal_Array_Constraint return List_Id is
1277 Constraints : constant List_Id := New_List;
1285 Indx := First_Index (T);
1286 while Present (Indx) loop
1287 Old_Lo := Type_Low_Bound (Etype (Indx));
1288 Old_Hi := Type_High_Bound (Etype (Indx));
1290 if Denotes_Discriminant (Old_Lo) then
1291 Lo := New_Occurrence_Of (Discriminal (Entity (Old_Lo)), Loc);
1294 Lo := New_Copy_Tree (Old_Lo);
1297 if Denotes_Discriminant (Old_Hi) then
1298 Hi := New_Occurrence_Of (Discriminal (Entity (Old_Hi)), Loc);
1301 Hi := New_Copy_Tree (Old_Hi);
1304 Append (Make_Range (Loc, Lo, Hi), Constraints);
1309 end Build_Discriminal_Array_Constraint;
1311 -----------------------------------------
1312 -- Build_Discriminal_Record_Constraint --
1313 -----------------------------------------
1315 function Build_Discriminal_Record_Constraint return List_Id is
1316 Constraints : constant List_Id := New_List;
1321 D := First_Elmt (Discriminant_Constraint (T));
1322 while Present (D) loop
1323 if Denotes_Discriminant (Node (D)) then
1325 New_Occurrence_Of (Discriminal (Entity (Node (D))), Loc);
1327 D_Val := New_Copy_Tree (Node (D));
1330 Append (D_Val, Constraints);
1335 end Build_Discriminal_Record_Constraint;
1337 -- Start of processing for Build_Discriminal_Subtype_Of_Component
1340 if Ekind (T) = E_Array_Subtype then
1341 Id := First_Index (T);
1342 while Present (Id) loop
1343 if Denotes_Discriminant (Type_Low_Bound (Etype (Id)))
1345 Denotes_Discriminant (Type_High_Bound (Etype (Id)))
1347 return Build_Component_Subtype
1348 (Build_Discriminal_Array_Constraint, Loc, T);
1354 elsif Ekind (T) = E_Record_Subtype
1355 and then Has_Discriminants (T)
1356 and then not Has_Unknown_Discriminants (T)
1358 D := First_Elmt (Discriminant_Constraint (T));
1359 while Present (D) loop
1360 if Denotes_Discriminant (Node (D)) then
1361 return Build_Component_Subtype
1362 (Build_Discriminal_Record_Constraint, Loc, T);
1369 -- If none of the above, the actual and nominal subtypes are the same
1372 end Build_Discriminal_Subtype_Of_Component;
1374 ------------------------------
1375 -- Build_Elaboration_Entity --
1376 ------------------------------
1378 procedure Build_Elaboration_Entity (N : Node_Id; Spec_Id : Entity_Id) is
1379 Loc : constant Source_Ptr := Sloc (N);
1381 Elab_Ent : Entity_Id;
1383 procedure Set_Package_Name (Ent : Entity_Id);
1384 -- Given an entity, sets the fully qualified name of the entity in
1385 -- Name_Buffer, with components separated by double underscores. This
1386 -- is a recursive routine that climbs the scope chain to Standard.
1388 ----------------------
1389 -- Set_Package_Name --
1390 ----------------------
1392 procedure Set_Package_Name (Ent : Entity_Id) is
1394 if Scope (Ent) /= Standard_Standard then
1395 Set_Package_Name (Scope (Ent));
1398 Nam : constant String := Get_Name_String (Chars (Ent));
1400 Name_Buffer (Name_Len + 1) := '_';
1401 Name_Buffer (Name_Len + 2) := '_';
1402 Name_Buffer (Name_Len + 3 .. Name_Len + Nam'Length + 2) := Nam;
1403 Name_Len := Name_Len + Nam'Length + 2;
1407 Get_Name_String (Chars (Ent));
1409 end Set_Package_Name;
1411 -- Start of processing for Build_Elaboration_Entity
1414 -- Ignore call if already constructed
1416 if Present (Elaboration_Entity (Spec_Id)) then
1419 -- Ignore in ASIS mode, elaboration entity is not in source and plays
1420 -- no role in analysis.
1422 elsif ASIS_Mode then
1425 -- See if we need elaboration entity. We always need it for the dynamic
1426 -- elaboration model, since it is needed to properly generate the PE
1427 -- exception for access before elaboration.
1429 elsif Dynamic_Elaboration_Checks then
1432 -- For the static model, we don't need the elaboration counter if this
1433 -- unit is sure to have no elaboration code, since that means there
1434 -- is no elaboration unit to be called. Note that we can't just decide
1435 -- after the fact by looking to see whether there was elaboration code,
1436 -- because that's too late to make this decision.
1438 elsif Restriction_Active (No_Elaboration_Code) then
1441 -- Similarly, for the static model, we can skip the elaboration counter
1442 -- if we have the No_Multiple_Elaboration restriction, since for the
1443 -- static model, that's the only purpose of the counter (to avoid
1444 -- multiple elaboration).
1446 elsif Restriction_Active (No_Multiple_Elaboration) then
1450 -- Here we need the elaboration entity
1452 -- Construct name of elaboration entity as xxx_E, where xxx is the unit
1453 -- name with dots replaced by double underscore. We have to manually
1454 -- construct this name, since it will be elaborated in the outer scope,
1455 -- and thus will not have the unit name automatically prepended.
1457 Set_Package_Name (Spec_Id);
1458 Add_Str_To_Name_Buffer ("_E");
1460 -- Create elaboration counter
1462 Elab_Ent := Make_Defining_Identifier (Loc, Chars => Name_Find);
1463 Set_Elaboration_Entity (Spec_Id, Elab_Ent);
1466 Make_Object_Declaration (Loc,
1467 Defining_Identifier => Elab_Ent,
1468 Object_Definition =>
1469 New_Occurrence_Of (Standard_Short_Integer, Loc),
1470 Expression => Make_Integer_Literal (Loc, Uint_0));
1472 Push_Scope (Standard_Standard);
1473 Add_Global_Declaration (Decl);
1476 -- Reset True_Constant indication, since we will indeed assign a value
1477 -- to the variable in the binder main. We also kill the Current_Value
1478 -- and Last_Assignment fields for the same reason.
1480 Set_Is_True_Constant (Elab_Ent, False);
1481 Set_Current_Value (Elab_Ent, Empty);
1482 Set_Last_Assignment (Elab_Ent, Empty);
1484 -- We do not want any further qualification of the name (if we did not
1485 -- do this, we would pick up the name of the generic package in the case
1486 -- of a library level generic instantiation).
1488 Set_Has_Qualified_Name (Elab_Ent);
1489 Set_Has_Fully_Qualified_Name (Elab_Ent);
1490 end Build_Elaboration_Entity;
1492 --------------------------------
1493 -- Build_Explicit_Dereference --
1494 --------------------------------
1496 procedure Build_Explicit_Dereference
1500 Loc : constant Source_Ptr := Sloc (Expr);
1503 -- An entity of a type with a reference aspect is overloaded with
1504 -- both interpretations: with and without the dereference. Now that
1505 -- the dereference is made explicit, set the type of the node properly,
1506 -- to prevent anomalies in the backend. Same if the expression is an
1507 -- overloaded function call whose return type has a reference aspect.
1509 if Is_Entity_Name (Expr) then
1510 Set_Etype (Expr, Etype (Entity (Expr)));
1512 elsif Nkind (Expr) = N_Function_Call then
1513 Set_Etype (Expr, Etype (Name (Expr)));
1516 Set_Is_Overloaded (Expr, False);
1518 -- The expression will often be a generalized indexing that yields a
1519 -- container element that is then dereferenced, in which case the
1520 -- generalized indexing call is also non-overloaded.
1522 if Nkind (Expr) = N_Indexed_Component
1523 and then Present (Generalized_Indexing (Expr))
1525 Set_Is_Overloaded (Generalized_Indexing (Expr), False);
1529 Make_Explicit_Dereference (Loc,
1531 Make_Selected_Component (Loc,
1532 Prefix => Relocate_Node (Expr),
1533 Selector_Name => New_Occurrence_Of (Disc, Loc))));
1534 Set_Etype (Prefix (Expr), Etype (Disc));
1535 Set_Etype (Expr, Designated_Type (Etype (Disc)));
1536 end Build_Explicit_Dereference;
1538 -----------------------------------
1539 -- Cannot_Raise_Constraint_Error --
1540 -----------------------------------
1542 function Cannot_Raise_Constraint_Error (Expr : Node_Id) return Boolean is
1544 if Compile_Time_Known_Value (Expr) then
1547 elsif Do_Range_Check (Expr) then
1550 elsif Raises_Constraint_Error (Expr) then
1554 case Nkind (Expr) is
1555 when N_Identifier =>
1558 when N_Expanded_Name =>
1561 when N_Selected_Component =>
1562 return not Do_Discriminant_Check (Expr);
1564 when N_Attribute_Reference =>
1565 if Do_Overflow_Check (Expr) then
1568 elsif No (Expressions (Expr)) then
1576 N := First (Expressions (Expr));
1577 while Present (N) loop
1578 if Cannot_Raise_Constraint_Error (N) then
1589 when N_Type_Conversion =>
1590 if Do_Overflow_Check (Expr)
1591 or else Do_Length_Check (Expr)
1592 or else Do_Tag_Check (Expr)
1596 return Cannot_Raise_Constraint_Error (Expression (Expr));
1599 when N_Unchecked_Type_Conversion =>
1600 return Cannot_Raise_Constraint_Error (Expression (Expr));
1603 if Do_Overflow_Check (Expr) then
1606 return Cannot_Raise_Constraint_Error (Right_Opnd (Expr));
1613 if Do_Division_Check (Expr)
1615 Do_Overflow_Check (Expr)
1620 Cannot_Raise_Constraint_Error (Left_Opnd (Expr))
1622 Cannot_Raise_Constraint_Error (Right_Opnd (Expr));
1641 N_Op_Shift_Right_Arithmetic |
1645 if Do_Overflow_Check (Expr) then
1649 Cannot_Raise_Constraint_Error (Left_Opnd (Expr))
1651 Cannot_Raise_Constraint_Error (Right_Opnd (Expr));
1658 end Cannot_Raise_Constraint_Error;
1660 -----------------------------------------
1661 -- Check_Dynamically_Tagged_Expression --
1662 -----------------------------------------
1664 procedure Check_Dynamically_Tagged_Expression
1667 Related_Nod : Node_Id)
1670 pragma Assert (Is_Tagged_Type (Typ));
1672 -- In order to avoid spurious errors when analyzing the expanded code,
1673 -- this check is done only for nodes that come from source and for
1674 -- actuals of generic instantiations.
1676 if (Comes_From_Source (Related_Nod)
1677 or else In_Generic_Actual (Expr))
1678 and then (Is_Class_Wide_Type (Etype (Expr))
1679 or else Is_Dynamically_Tagged (Expr))
1680 and then Is_Tagged_Type (Typ)
1681 and then not Is_Class_Wide_Type (Typ)
1683 Error_Msg_N ("dynamically tagged expression not allowed!", Expr);
1685 end Check_Dynamically_Tagged_Expression;
1687 -----------------------------------------------
1688 -- Check_Expression_Against_Static_Predicate --
1689 -----------------------------------------------
1691 procedure Check_Expression_Against_Static_Predicate
1696 -- When the predicate is static and the value of the expression is known
1697 -- at compile time, evaluate the predicate check. A type is non-static
1698 -- when it has aspect Dynamic_Predicate, but if the dynamic predicate
1699 -- was predicate-static, we still check it statically. After all this
1700 -- is only a warning, not an error.
1702 if Compile_Time_Known_Value (Expr)
1703 and then Has_Predicates (Typ)
1704 and then Has_Static_Predicate (Typ)
1706 -- Either -gnatc is enabled or the expression is ok
1708 if Operating_Mode < Generate_Code
1709 or else Eval_Static_Predicate_Check (Expr, Typ)
1713 -- The expression is prohibited by the static predicate. There has
1714 -- been some debate if this is an illegality (in the case where
1715 -- the static predicate was explicitly given as such), but that
1716 -- discussion decided this was not illegal, just a warning situation.
1720 ("??static expression fails predicate check on &", Expr, Typ);
1722 -- We now reset the static expression indication on the expression
1723 -- since it is no longer static if it fails a predicate test. We
1724 -- do not do this if the predicate was officially dynamic, since
1725 -- dynamic predicates don't affect legality in this manner.
1727 if not Has_Dynamic_Predicate_Aspect (Typ) then
1729 ("\??expression is no longer considered static", Expr);
1730 Set_Is_Static_Expression (Expr, False);
1734 end Check_Expression_Against_Static_Predicate;
1736 --------------------------
1737 -- Check_Fully_Declared --
1738 --------------------------
1740 procedure Check_Fully_Declared (T : Entity_Id; N : Node_Id) is
1742 if Ekind (T) = E_Incomplete_Type then
1744 -- Ada 2005 (AI-50217): If the type is available through a limited
1745 -- with_clause, verify that its full view has been analyzed.
1747 if From_Limited_With (T)
1748 and then Present (Non_Limited_View (T))
1749 and then Ekind (Non_Limited_View (T)) /= E_Incomplete_Type
1751 -- The non-limited view is fully declared
1756 ("premature usage of incomplete}", N, First_Subtype (T));
1759 -- Need comments for these tests ???
1761 elsif Has_Private_Component (T)
1762 and then not Is_Generic_Type (Root_Type (T))
1763 and then not In_Spec_Expression
1765 -- Special case: if T is the anonymous type created for a single
1766 -- task or protected object, use the name of the source object.
1768 if Is_Concurrent_Type (T)
1769 and then not Comes_From_Source (T)
1770 and then Nkind (N) = N_Object_Declaration
1773 ("type of& has incomplete component",
1774 N, Defining_Identifier (N));
1777 ("premature usage of incomplete}",
1778 N, First_Subtype (T));
1781 end Check_Fully_Declared;
1783 -------------------------------------
1784 -- Check_Function_Writable_Actuals --
1785 -------------------------------------
1787 procedure Check_Function_Writable_Actuals (N : Node_Id) is
1788 Writable_Actuals_List : Elist_Id := No_Elist;
1789 Identifiers_List : Elist_Id := No_Elist;
1790 Error_Node : Node_Id := Empty;
1792 procedure Collect_Identifiers (N : Node_Id);
1793 -- In a single traversal of subtree N collect in Writable_Actuals_List
1794 -- all the actuals of functions with writable actuals, and in the list
1795 -- Identifiers_List collect all the identifiers that are not actuals of
1796 -- functions with writable actuals. If a writable actual is referenced
1797 -- twice as writable actual then Error_Node is set to reference its
1798 -- second occurrence, the error is reported, and the tree traversal
1801 function Get_Function_Id (Call : Node_Id) return Entity_Id;
1802 -- Return the entity associated with the function call
1804 procedure Preanalyze_Without_Errors (N : Node_Id);
1805 -- Preanalyze N without reporting errors. Very dubious, you can't just
1806 -- go analyzing things more than once???
1808 -------------------------
1809 -- Collect_Identifiers --
1810 -------------------------
1812 procedure Collect_Identifiers (N : Node_Id) is
1814 function Check_Node (N : Node_Id) return Traverse_Result;
1815 -- Process a single node during the tree traversal to collect the
1816 -- writable actuals of functions and all the identifiers which are
1817 -- not writable actuals of functions.
1819 function Contains (List : Elist_Id; N : Node_Id) return Boolean;
1820 -- Returns True if List has a node whose Entity is Entity (N)
1822 -------------------------
1823 -- Check_Function_Call --
1824 -------------------------
1826 function Check_Node (N : Node_Id) return Traverse_Result is
1827 Is_Writable_Actual : Boolean := False;
1831 if Nkind (N) = N_Identifier then
1833 -- No analysis possible if the entity is not decorated
1835 if No (Entity (N)) then
1838 -- Don't collect identifiers of packages, called functions, etc
1840 elsif Ekind_In (Entity (N), E_Package,
1847 -- Analyze if N is a writable actual of a function
1849 elsif Nkind (Parent (N)) = N_Function_Call then
1851 Call : constant Node_Id := Parent (N);
1856 Id := Get_Function_Id (Call);
1858 Formal := First_Formal (Id);
1859 Actual := First_Actual (Call);
1860 while Present (Actual) and then Present (Formal) loop
1862 if Ekind_In (Formal, E_Out_Parameter,
1865 Is_Writable_Actual := True;
1871 Next_Formal (Formal);
1872 Next_Actual (Actual);
1877 if Is_Writable_Actual then
1878 if Contains (Writable_Actuals_List, N) then
1880 ("value may be affected by call to& "
1881 & "because order of evaluation is arbitrary", N, Id);
1886 if Writable_Actuals_List = No_Elist then
1887 Writable_Actuals_List := New_Elmt_List;
1890 Append_Elmt (N, Writable_Actuals_List);
1893 if Identifiers_List = No_Elist then
1894 Identifiers_List := New_Elmt_List;
1897 Append_Unique_Elmt (N, Identifiers_List);
1910 N : Node_Id) return Boolean
1912 pragma Assert (Nkind (N) in N_Has_Entity);
1917 if List = No_Elist then
1921 Elmt := First_Elmt (List);
1922 while Present (Elmt) loop
1923 if Entity (Node (Elmt)) = Entity (N) then
1937 procedure Do_Traversal is new Traverse_Proc (Check_Node);
1938 -- The traversal procedure
1940 -- Start of processing for Collect_Identifiers
1943 if Present (Error_Node) then
1947 if Nkind (N) in N_Subexpr and then Is_Static_Expression (N) then
1952 end Collect_Identifiers;
1954 ---------------------
1955 -- Get_Function_Id --
1956 ---------------------
1958 function Get_Function_Id (Call : Node_Id) return Entity_Id is
1959 Nam : constant Node_Id := Name (Call);
1963 if Nkind (Nam) = N_Explicit_Dereference then
1965 pragma Assert (Ekind (Id) = E_Subprogram_Type);
1967 elsif Nkind (Nam) = N_Selected_Component then
1968 Id := Entity (Selector_Name (Nam));
1970 elsif Nkind (Nam) = N_Indexed_Component then
1971 Id := Entity (Selector_Name (Prefix (Nam)));
1978 end Get_Function_Id;
1980 ---------------------------
1981 -- Preanalyze_Expression --
1982 ---------------------------
1984 procedure Preanalyze_Without_Errors (N : Node_Id) is
1985 Status : constant Boolean := Get_Ignore_Errors;
1987 Set_Ignore_Errors (True);
1989 Set_Ignore_Errors (Status);
1990 end Preanalyze_Without_Errors;
1992 -- Start of processing for Check_Function_Writable_Actuals
1995 -- The check only applies to Ada 2012 code, and only to constructs that
1996 -- have multiple constituents whose order of evaluation is not specified
1999 if Ada_Version < Ada_2012
2000 or else (not (Nkind (N) in N_Op)
2001 and then not (Nkind (N) in N_Membership_Test)
2002 and then not Nkind_In (N, N_Range,
2004 N_Extension_Aggregate,
2005 N_Full_Type_Declaration,
2007 N_Procedure_Call_Statement,
2008 N_Entry_Call_Statement))
2009 or else (Nkind (N) = N_Full_Type_Declaration
2010 and then not Is_Record_Type (Defining_Identifier (N)))
2012 -- In addition, this check only applies to source code, not to code
2013 -- generated by constraint checks.
2015 or else not Comes_From_Source (N)
2020 -- If a construct C has two or more direct constituents that are names
2021 -- or expressions whose evaluation may occur in an arbitrary order, at
2022 -- least one of which contains a function call with an in out or out
2023 -- parameter, then the construct is legal only if: for each name N that
2024 -- is passed as a parameter of mode in out or out to some inner function
2025 -- call C2 (not including the construct C itself), there is no other
2026 -- name anywhere within a direct constituent of the construct C other
2027 -- than the one containing C2, that is known to refer to the same
2028 -- object (RM 6.4.1(6.17/3)).
2032 Collect_Identifiers (Low_Bound (N));
2033 Collect_Identifiers (High_Bound (N));
2035 when N_Op | N_Membership_Test =>
2040 Collect_Identifiers (Left_Opnd (N));
2042 if Present (Right_Opnd (N)) then
2043 Collect_Identifiers (Right_Opnd (N));
2046 if Nkind_In (N, N_In, N_Not_In)
2047 and then Present (Alternatives (N))
2049 Expr := First (Alternatives (N));
2050 while Present (Expr) loop
2051 Collect_Identifiers (Expr);
2058 when N_Full_Type_Declaration =>
2060 function Get_Record_Part (N : Node_Id) return Node_Id;
2061 -- Return the record part of this record type definition
2063 function Get_Record_Part (N : Node_Id) return Node_Id is
2064 Type_Def : constant Node_Id := Type_Definition (N);
2066 if Nkind (Type_Def) = N_Derived_Type_Definition then
2067 return Record_Extension_Part (Type_Def);
2071 end Get_Record_Part;
2074 Def_Id : Entity_Id := Defining_Identifier (N);
2075 Rec : Node_Id := Get_Record_Part (N);
2078 -- No need to perform any analysis if the record has no
2081 if No (Rec) or else No (Component_List (Rec)) then
2085 -- Collect the identifiers starting from the deepest
2086 -- derivation. Done to report the error in the deepest
2090 if Present (Component_List (Rec)) then
2091 Comp := First (Component_Items (Component_List (Rec)));
2092 while Present (Comp) loop
2093 if Nkind (Comp) = N_Component_Declaration
2094 and then Present (Expression (Comp))
2096 Collect_Identifiers (Expression (Comp));
2103 exit when No (Underlying_Type (Etype (Def_Id)))
2104 or else Base_Type (Underlying_Type (Etype (Def_Id)))
2107 Def_Id := Base_Type (Underlying_Type (Etype (Def_Id)));
2108 Rec := Get_Record_Part (Parent (Def_Id));
2112 when N_Subprogram_Call |
2113 N_Entry_Call_Statement =>
2115 Id : constant Entity_Id := Get_Function_Id (N);
2120 Formal := First_Formal (Id);
2121 Actual := First_Actual (N);
2122 while Present (Actual) and then Present (Formal) loop
2123 if Ekind_In (Formal, E_Out_Parameter,
2126 Collect_Identifiers (Actual);
2129 Next_Formal (Formal);
2130 Next_Actual (Actual);
2135 N_Extension_Aggregate =>
2139 Comp_Expr : Node_Id;
2142 -- Handle the N_Others_Choice of array aggregates with static
2143 -- bounds. There is no need to perform this analysis in
2144 -- aggregates without static bounds since we cannot evaluate
2145 -- if the N_Others_Choice covers several elements. There is
2146 -- no need to handle the N_Others choice of record aggregates
2147 -- since at this stage it has been already expanded by
2148 -- Resolve_Record_Aggregate.
2150 if Is_Array_Type (Etype (N))
2151 and then Nkind (N) = N_Aggregate
2152 and then Present (Aggregate_Bounds (N))
2153 and then Compile_Time_Known_Bounds (Etype (N))
2154 and then Expr_Value (High_Bound (Aggregate_Bounds (N)))
2156 Expr_Value (Low_Bound (Aggregate_Bounds (N)))
2159 Count_Components : Uint := Uint_0;
2160 Num_Components : Uint;
2161 Others_Assoc : Node_Id;
2162 Others_Choice : Node_Id := Empty;
2163 Others_Box_Present : Boolean := False;
2166 -- Count positional associations
2168 if Present (Expressions (N)) then
2169 Comp_Expr := First (Expressions (N));
2170 while Present (Comp_Expr) loop
2171 Count_Components := Count_Components + 1;
2176 -- Count the rest of elements and locate the N_Others
2179 Assoc := First (Component_Associations (N));
2180 while Present (Assoc) loop
2181 Choice := First (Choices (Assoc));
2182 while Present (Choice) loop
2183 if Nkind (Choice) = N_Others_Choice then
2184 Others_Assoc := Assoc;
2185 Others_Choice := Choice;
2186 Others_Box_Present := Box_Present (Assoc);
2188 -- Count several components
2190 elsif Nkind_In (Choice, N_Range,
2191 N_Subtype_Indication)
2192 or else (Is_Entity_Name (Choice)
2193 and then Is_Type (Entity (Choice)))
2198 Get_Index_Bounds (Choice, L, H);
2200 (Compile_Time_Known_Value (L)
2201 and then Compile_Time_Known_Value (H));
2204 + Expr_Value (H) - Expr_Value (L) + 1;
2207 -- Count single component. No other case available
2208 -- since we are handling an aggregate with static
2212 pragma Assert (Is_Static_Expression (Choice)
2213 or else Nkind (Choice) = N_Identifier
2214 or else Nkind (Choice) = N_Integer_Literal);
2216 Count_Components := Count_Components + 1;
2226 Expr_Value (High_Bound (Aggregate_Bounds (N))) -
2227 Expr_Value (Low_Bound (Aggregate_Bounds (N))) + 1;
2229 pragma Assert (Count_Components <= Num_Components);
2231 -- Handle the N_Others choice if it covers several
2234 if Present (Others_Choice)
2235 and then (Num_Components - Count_Components) > 1
2237 if not Others_Box_Present then
2239 -- At this stage, if expansion is active, the
2240 -- expression of the others choice has not been
2241 -- analyzed. Hence we generate a duplicate and
2242 -- we analyze it silently to have available the
2243 -- minimum decoration required to collect the
2246 if not Expander_Active then
2247 Comp_Expr := Expression (Others_Assoc);
2250 New_Copy_Tree (Expression (Others_Assoc));
2251 Preanalyze_Without_Errors (Comp_Expr);
2254 Collect_Identifiers (Comp_Expr);
2256 if Writable_Actuals_List /= No_Elist then
2258 -- As suggested by Robert, at current stage we
2259 -- report occurrences of this case as warnings.
2262 ("writable function parameter may affect "
2263 & "value in other component because order "
2264 & "of evaluation is unspecified??",
2265 Node (First_Elmt (Writable_Actuals_List)));
2272 -- Handle ancestor part of extension aggregates
2274 if Nkind (N) = N_Extension_Aggregate then
2275 Collect_Identifiers (Ancestor_Part (N));
2278 -- Handle positional associations
2280 if Present (Expressions (N)) then
2281 Comp_Expr := First (Expressions (N));
2282 while Present (Comp_Expr) loop
2283 if not Is_Static_Expression (Comp_Expr) then
2284 Collect_Identifiers (Comp_Expr);
2291 -- Handle discrete associations
2293 if Present (Component_Associations (N)) then
2294 Assoc := First (Component_Associations (N));
2295 while Present (Assoc) loop
2297 if not Box_Present (Assoc) then
2298 Choice := First (Choices (Assoc));
2299 while Present (Choice) loop
2301 -- For now we skip discriminants since it requires
2302 -- performing the analysis in two phases: first one
2303 -- analyzing discriminants and second one analyzing
2304 -- the rest of components since discriminants are
2305 -- evaluated prior to components: too much extra
2306 -- work to detect a corner case???
2308 if Nkind (Choice) in N_Has_Entity
2309 and then Present (Entity (Choice))
2310 and then Ekind (Entity (Choice)) = E_Discriminant
2314 elsif Box_Present (Assoc) then
2318 if not Analyzed (Expression (Assoc)) then
2320 New_Copy_Tree (Expression (Assoc));
2321 Set_Parent (Comp_Expr, Parent (N));
2322 Preanalyze_Without_Errors (Comp_Expr);
2324 Comp_Expr := Expression (Assoc);
2327 Collect_Identifiers (Comp_Expr);
2343 -- No further action needed if we already reported an error
2345 if Present (Error_Node) then
2349 -- Check if some writable argument of a function is referenced
2351 if Writable_Actuals_List /= No_Elist
2352 and then Identifiers_List /= No_Elist
2359 Elmt_1 := First_Elmt (Writable_Actuals_List);
2360 while Present (Elmt_1) loop
2361 Elmt_2 := First_Elmt (Identifiers_List);
2362 while Present (Elmt_2) loop
2363 if Entity (Node (Elmt_1)) = Entity (Node (Elmt_2)) then
2364 case Nkind (Parent (Node (Elmt_2))) is
2366 N_Component_Association |
2367 N_Component_Declaration =>
2369 ("value may be affected by call in other "
2370 & "component because they are evaluated "
2371 & "in unspecified order",
2374 when N_In | N_Not_In =>
2376 ("value may be affected by call in other "
2377 & "alternative because they are evaluated "
2378 & "in unspecified order",
2383 ("value of actual may be affected by call in "
2384 & "other actual because they are evaluated "
2385 & "in unspecified order",
2397 end Check_Function_Writable_Actuals;
2399 --------------------------------
2400 -- Check_Implicit_Dereference --
2401 --------------------------------
2403 procedure Check_Implicit_Dereference (Nam : Node_Id; Typ : Entity_Id) is
2408 if Ada_Version < Ada_2012
2409 or else not Has_Implicit_Dereference (Base_Type (Typ))
2413 elsif not Comes_From_Source (Nam) then
2416 elsif Is_Entity_Name (Nam)
2417 and then Is_Type (Entity (Nam))
2422 Disc := First_Discriminant (Typ);
2423 while Present (Disc) loop
2424 if Has_Implicit_Dereference (Disc) then
2425 Desig := Designated_Type (Etype (Disc));
2426 Add_One_Interp (Nam, Disc, Desig);
2430 Next_Discriminant (Disc);
2433 end Check_Implicit_Dereference;
2435 ----------------------------------
2436 -- Check_Internal_Protected_Use --
2437 ----------------------------------
2439 procedure Check_Internal_Protected_Use (N : Node_Id; Nam : Entity_Id) is
2445 while Present (S) loop
2446 if S = Standard_Standard then
2449 elsif Ekind (S) = E_Function
2450 and then Ekind (Scope (S)) = E_Protected_Type
2459 if Scope (Nam) = Prot and then Ekind (Nam) /= E_Function then
2461 -- An indirect function call (e.g. a callback within a protected
2462 -- function body) is not statically illegal. If the access type is
2463 -- anonymous and is the type of an access parameter, the scope of Nam
2464 -- will be the protected type, but it is not a protected operation.
2466 if Ekind (Nam) = E_Subprogram_Type
2468 Nkind (Associated_Node_For_Itype (Nam)) = N_Function_Specification
2472 elsif Nkind (N) = N_Subprogram_Renaming_Declaration then
2474 ("within protected function cannot use protected "
2475 & "procedure in renaming or as generic actual", N);
2477 elsif Nkind (N) = N_Attribute_Reference then
2479 ("within protected function cannot take access of "
2480 & " protected procedure", N);
2484 ("within protected function, protected object is constant", N);
2486 ("\cannot call operation that may modify it", N);
2489 end Check_Internal_Protected_Use;
2491 ---------------------------------------
2492 -- Check_Later_Vs_Basic_Declarations --
2493 ---------------------------------------
2495 procedure Check_Later_Vs_Basic_Declarations
2497 During_Parsing : Boolean)
2499 Body_Sloc : Source_Ptr;
2502 function Is_Later_Declarative_Item (Decl : Node_Id) return Boolean;
2503 -- Return whether Decl is considered as a declarative item.
2504 -- When During_Parsing is True, the semantics of Ada 83 is followed.
2505 -- When During_Parsing is False, the semantics of SPARK is followed.
2507 -------------------------------
2508 -- Is_Later_Declarative_Item --
2509 -------------------------------
2511 function Is_Later_Declarative_Item (Decl : Node_Id) return Boolean is
2513 if Nkind (Decl) in N_Later_Decl_Item then
2516 elsif Nkind (Decl) = N_Pragma then
2519 elsif During_Parsing then
2522 -- In SPARK, a package declaration is not considered as a later
2523 -- declarative item.
2525 elsif Nkind (Decl) = N_Package_Declaration then
2528 -- In SPARK, a renaming is considered as a later declarative item
2530 elsif Nkind (Decl) in N_Renaming_Declaration then
2536 end Is_Later_Declarative_Item;
2538 -- Start of Check_Later_Vs_Basic_Declarations
2541 Decl := First (Decls);
2543 -- Loop through sequence of basic declarative items
2545 Outer : while Present (Decl) loop
2546 if not Nkind_In (Decl, N_Subprogram_Body, N_Package_Body, N_Task_Body)
2547 and then Nkind (Decl) not in N_Body_Stub
2551 -- Once a body is encountered, we only allow later declarative
2552 -- items. The inner loop checks the rest of the list.
2555 Body_Sloc := Sloc (Decl);
2557 Inner : while Present (Decl) loop
2558 if not Is_Later_Declarative_Item (Decl) then
2559 if During_Parsing then
2560 if Ada_Version = Ada_83 then
2561 Error_Msg_Sloc := Body_Sloc;
2563 ("(Ada 83) decl cannot appear after body#", Decl);
2566 Error_Msg_Sloc := Body_Sloc;
2567 Check_SPARK_Restriction
2568 ("decl cannot appear after body#", Decl);
2576 end Check_Later_Vs_Basic_Declarations;
2578 -------------------------
2579 -- Check_Nested_Access --
2580 -------------------------
2582 procedure Check_Nested_Access (Ent : Entity_Id) is
2583 Scop : constant Entity_Id := Current_Scope;
2584 Current_Subp : Entity_Id;
2585 Enclosing : Entity_Id;
2588 -- Currently only enabled for VM back-ends for efficiency, should we
2589 -- enable it more systematically ???
2591 -- Check for Is_Imported needs commenting below ???
2593 if VM_Target /= No_VM
2594 and then (Ekind (Ent) = E_Variable
2596 Ekind (Ent) = E_Constant
2598 Ekind (Ent) = E_Loop_Parameter)
2599 and then Scope (Ent) /= Empty
2600 and then not Is_Library_Level_Entity (Ent)
2601 and then not Is_Imported (Ent)
2603 if Is_Subprogram (Scop)
2604 or else Is_Generic_Subprogram (Scop)
2605 or else Is_Entry (Scop)
2607 Current_Subp := Scop;
2609 Current_Subp := Current_Subprogram;
2612 Enclosing := Enclosing_Subprogram (Ent);
2614 if Enclosing /= Empty
2615 and then Enclosing /= Current_Subp
2617 Set_Has_Up_Level_Access (Ent, True);
2620 end Check_Nested_Access;
2622 ---------------------------
2623 -- Check_No_Hidden_State --
2624 ---------------------------
2626 procedure Check_No_Hidden_State (Id : Entity_Id) is
2627 function Has_Null_Abstract_State (Pkg : Entity_Id) return Boolean;
2628 -- Determine whether the entity of a package denoted by Pkg has a null
2631 -----------------------------
2632 -- Has_Null_Abstract_State --
2633 -----------------------------
2635 function Has_Null_Abstract_State (Pkg : Entity_Id) return Boolean is
2636 States : constant Elist_Id := Abstract_States (Pkg);
2639 -- Check first available state of related package. A null abstract
2640 -- state always appears as the sole element of the state list.
2644 and then Is_Null_State (Node (First_Elmt (States)));
2645 end Has_Null_Abstract_State;
2649 Context : Entity_Id := Empty;
2650 Not_Visible : Boolean := False;
2653 -- Start of processing for Check_No_Hidden_State
2656 pragma Assert (Ekind_In (Id, E_Abstract_State, E_Variable));
2658 -- Find the proper context where the object or state appears
2661 while Present (Scop) loop
2664 -- Keep track of the context's visibility
2666 Not_Visible := Not_Visible or else In_Private_Part (Context);
2668 -- Prevent the search from going too far
2670 if Context = Standard_Standard then
2673 -- Objects and states that appear immediately within a subprogram or
2674 -- inside a construct nested within a subprogram do not introduce a
2675 -- hidden state. They behave as local variable declarations.
2677 elsif Is_Subprogram (Context) then
2680 -- When examining a package body, use the entity of the spec as it
2681 -- carries the abstract state declarations.
2683 elsif Ekind (Context) = E_Package_Body then
2684 Context := Spec_Entity (Context);
2687 -- Stop the traversal when a package subject to a null abstract state
2690 if Ekind_In (Context, E_Generic_Package, E_Package)
2691 and then Has_Null_Abstract_State (Context)
2696 Scop := Scope (Scop);
2699 -- At this point we know that there is at least one package with a null
2700 -- abstract state in visibility. Emit an error message unconditionally
2701 -- if the entity being processed is a state because the placement of the
2702 -- related package is irrelevant. This is not the case for objects as
2703 -- the intermediate context matters.
2705 if Present (Context)
2706 and then (Ekind (Id) = E_Abstract_State or else Not_Visible)
2708 Error_Msg_N ("cannot introduce hidden state &", Id);
2709 Error_Msg_NE ("\package & has null abstract state", Id, Context);
2711 end Check_No_Hidden_State;
2713 ------------------------------------------
2714 -- Check_Potentially_Blocking_Operation --
2715 ------------------------------------------
2717 procedure Check_Potentially_Blocking_Operation (N : Node_Id) is
2721 -- N is one of the potentially blocking operations listed in 9.5.1(8).
2722 -- When pragma Detect_Blocking is active, the run time will raise
2723 -- Program_Error. Here we only issue a warning, since we generally
2724 -- support the use of potentially blocking operations in the absence
2727 -- Indirect blocking through a subprogram call cannot be diagnosed
2728 -- statically without interprocedural analysis, so we do not attempt
2731 S := Scope (Current_Scope);
2732 while Present (S) and then S /= Standard_Standard loop
2733 if Is_Protected_Type (S) then
2735 ("potentially blocking operation in protected operation??", N);
2741 end Check_Potentially_Blocking_Operation;
2743 ---------------------------------
2744 -- Check_Result_And_Post_State --
2745 ---------------------------------
2747 procedure Check_Result_And_Post_State
2749 Result_Seen : in out Boolean)
2751 procedure Check_Expression (Expr : Node_Id);
2752 -- Perform the 'Result and post-state checks on a given expression
2754 function Is_Function_Result (N : Node_Id) return Traverse_Result;
2755 -- Attempt to find attribute 'Result in a subtree denoted by N
2757 function Is_Trivial_Boolean (N : Node_Id) return Boolean;
2758 -- Determine whether source node N denotes "True" or "False"
2760 function Mentions_Post_State (N : Node_Id) return Boolean;
2761 -- Determine whether a subtree denoted by N mentions any construct that
2762 -- denotes a post-state.
2764 procedure Check_Function_Result is
2765 new Traverse_Proc (Is_Function_Result);
2767 ----------------------
2768 -- Check_Expression --
2769 ----------------------
2771 procedure Check_Expression (Expr : Node_Id) is
2773 if not Is_Trivial_Boolean (Expr) then
2774 Check_Function_Result (Expr);
2776 if not Mentions_Post_State (Expr) then
2777 if Pragma_Name (Prag) = Name_Contract_Cases then
2779 ("contract case refers only to pre-state?T?", Expr);
2781 elsif Pragma_Name (Prag) = Name_Refined_Post then
2783 ("refined postcondition refers only to pre-state?T?",
2788 ("postcondition refers only to pre-state?T?", Prag);
2792 end Check_Expression;
2794 ------------------------
2795 -- Is_Function_Result --
2796 ------------------------
2798 function Is_Function_Result (N : Node_Id) return Traverse_Result is
2800 if Is_Attribute_Result (N) then
2801 Result_Seen := True;
2804 -- Continue the traversal
2809 end Is_Function_Result;
2811 ------------------------
2812 -- Is_Trivial_Boolean --
2813 ------------------------
2815 function Is_Trivial_Boolean (N : Node_Id) return Boolean is
2818 Comes_From_Source (N)
2819 and then Is_Entity_Name (N)
2820 and then (Entity (N) = Standard_True
2821 or else Entity (N) = Standard_False);
2822 end Is_Trivial_Boolean;
2824 -------------------------
2825 -- Mentions_Post_State --
2826 -------------------------
2828 function Mentions_Post_State (N : Node_Id) return Boolean is
2829 Post_State_Seen : Boolean := False;
2831 function Is_Post_State (N : Node_Id) return Traverse_Result;
2832 -- Attempt to find a construct that denotes a post-state. If this is
2833 -- the case, set flag Post_State_Seen.
2839 function Is_Post_State (N : Node_Id) return Traverse_Result is
2843 if Nkind_In (N, N_Explicit_Dereference, N_Function_Call) then
2844 Post_State_Seen := True;
2847 elsif Nkind_In (N, N_Expanded_Name, N_Identifier) then
2850 -- The entity may be modifiable through an implicit dereference
2853 or else Ekind (Ent) in Assignable_Kind
2854 or else (Is_Access_Type (Etype (Ent))
2855 and then Nkind (Parent (N)) = N_Selected_Component)
2857 Post_State_Seen := True;
2861 elsif Nkind (N) = N_Attribute_Reference then
2862 if Attribute_Name (N) = Name_Old then
2865 elsif Attribute_Name (N) = Name_Result then
2866 Post_State_Seen := True;
2874 procedure Find_Post_State is new Traverse_Proc (Is_Post_State);
2876 -- Start of processing for Mentions_Post_State
2879 Find_Post_State (N);
2881 return Post_State_Seen;
2882 end Mentions_Post_State;
2886 Expr : constant Node_Id :=
2887 Get_Pragma_Arg (First (Pragma_Argument_Associations (Prag)));
2888 Nam : constant Name_Id := Pragma_Name (Prag);
2891 -- Start of processing for Check_Result_And_Post_State
2894 -- Examine all consequences
2896 if Nam = Name_Contract_Cases then
2897 CCase := First (Component_Associations (Expr));
2898 while Present (CCase) loop
2899 Check_Expression (Expression (CCase));
2904 -- Examine the expression of a postcondition
2906 else pragma Assert (Nam_In (Nam, Name_Postcondition, Name_Refined_Post));
2907 Check_Expression (Expr);
2909 end Check_Result_And_Post_State;
2911 ---------------------------------
2912 -- Check_SPARK_Mode_In_Generic --
2913 ---------------------------------
2915 procedure Check_SPARK_Mode_In_Generic (N : Node_Id) is
2919 -- Try to find aspect SPARK_Mode and flag it as illegal
2921 if Has_Aspects (N) then
2922 Aspect := First (Aspect_Specifications (N));
2923 while Present (Aspect) loop
2924 if Get_Aspect_Id (Aspect) = Aspect_SPARK_Mode then
2925 Error_Msg_Name_1 := Name_SPARK_Mode;
2927 ("incorrect placement of aspect % on a generic", Aspect);
2934 end Check_SPARK_Mode_In_Generic;
2936 ------------------------------
2937 -- Check_Unprotected_Access --
2938 ------------------------------
2940 procedure Check_Unprotected_Access
2944 Cont_Encl_Typ : Entity_Id;
2945 Pref_Encl_Typ : Entity_Id;
2947 function Enclosing_Protected_Type (Obj : Node_Id) return Entity_Id;
2948 -- Check whether Obj is a private component of a protected object.
2949 -- Return the protected type where the component resides, Empty
2952 function Is_Public_Operation return Boolean;
2953 -- Verify that the enclosing operation is callable from outside the
2954 -- protected object, to minimize false positives.
2956 ------------------------------
2957 -- Enclosing_Protected_Type --
2958 ------------------------------
2960 function Enclosing_Protected_Type (Obj : Node_Id) return Entity_Id is
2962 if Is_Entity_Name (Obj) then
2964 Ent : Entity_Id := Entity (Obj);
2967 -- The object can be a renaming of a private component, use
2968 -- the original record component.
2970 if Is_Prival (Ent) then
2971 Ent := Prival_Link (Ent);
2974 if Is_Protected_Type (Scope (Ent)) then
2980 -- For indexed and selected components, recursively check the prefix
2982 if Nkind_In (Obj, N_Indexed_Component, N_Selected_Component) then
2983 return Enclosing_Protected_Type (Prefix (Obj));
2985 -- The object does not denote a protected component
2990 end Enclosing_Protected_Type;
2992 -------------------------
2993 -- Is_Public_Operation --
2994 -------------------------
2996 function Is_Public_Operation return Boolean is
3003 and then S /= Pref_Encl_Typ
3005 if Scope (S) = Pref_Encl_Typ then
3006 E := First_Entity (Pref_Encl_Typ);
3008 and then E /= First_Private_Entity (Pref_Encl_Typ)
3021 end Is_Public_Operation;
3023 -- Start of processing for Check_Unprotected_Access
3026 if Nkind (Expr) = N_Attribute_Reference
3027 and then Attribute_Name (Expr) = Name_Unchecked_Access
3029 Cont_Encl_Typ := Enclosing_Protected_Type (Context);
3030 Pref_Encl_Typ := Enclosing_Protected_Type (Prefix (Expr));
3032 -- Check whether we are trying to export a protected component to a
3033 -- context with an equal or lower access level.
3035 if Present (Pref_Encl_Typ)
3036 and then No (Cont_Encl_Typ)
3037 and then Is_Public_Operation
3038 and then Scope_Depth (Pref_Encl_Typ) >=
3039 Object_Access_Level (Context)
3042 ("??possible unprotected access to protected data", Expr);
3045 end Check_Unprotected_Access;
3051 procedure Check_VMS (Construct : Node_Id) is
3053 if not OpenVMS_On_Target then
3055 ("this construct is allowed only in Open'V'M'S", Construct);
3059 ------------------------
3060 -- Collect_Interfaces --
3061 ------------------------
3063 procedure Collect_Interfaces
3065 Ifaces_List : out Elist_Id;
3066 Exclude_Parents : Boolean := False;
3067 Use_Full_View : Boolean := True)
3069 procedure Collect (Typ : Entity_Id);
3070 -- Subsidiary subprogram used to traverse the whole list
3071 -- of directly and indirectly implemented interfaces
3077 procedure Collect (Typ : Entity_Id) is
3078 Ancestor : Entity_Id;
3086 -- Handle private types
3089 and then Is_Private_Type (Typ)
3090 and then Present (Full_View (Typ))
3092 Full_T := Full_View (Typ);
3095 -- Include the ancestor if we are generating the whole list of
3096 -- abstract interfaces.
3098 if Etype (Full_T) /= Typ
3100 -- Protect the frontend against wrong sources. For example:
3103 -- type A is tagged null record;
3104 -- type B is new A with private;
3105 -- type C is new A with private;
3107 -- type B is new C with null record;
3108 -- type C is new B with null record;
3111 and then Etype (Full_T) /= T
3113 Ancestor := Etype (Full_T);
3116 if Is_Interface (Ancestor)
3117 and then not Exclude_Parents
3119 Append_Unique_Elmt (Ancestor, Ifaces_List);
3123 -- Traverse the graph of ancestor interfaces
3125 if Is_Non_Empty_List (Abstract_Interface_List (Full_T)) then
3126 Id := First (Abstract_Interface_List (Full_T));
3127 while Present (Id) loop
3128 Iface := Etype (Id);
3130 -- Protect against wrong uses. For example:
3131 -- type I is interface;
3132 -- type O is tagged null record;
3133 -- type Wrong is new I and O with null record; -- ERROR
3135 if Is_Interface (Iface) then
3137 and then Etype (T) /= T
3138 and then Interface_Present_In_Ancestor (Etype (T), Iface)
3143 Append_Unique_Elmt (Iface, Ifaces_List);
3152 -- Start of processing for Collect_Interfaces
3155 pragma Assert (Is_Tagged_Type (T) or else Is_Concurrent_Type (T));
3156 Ifaces_List := New_Elmt_List;
3158 end Collect_Interfaces;
3160 ----------------------------------
3161 -- Collect_Interface_Components --
3162 ----------------------------------
3164 procedure Collect_Interface_Components
3165 (Tagged_Type : Entity_Id;
3166 Components_List : out Elist_Id)
3168 procedure Collect (Typ : Entity_Id);
3169 -- Subsidiary subprogram used to climb to the parents
3175 procedure Collect (Typ : Entity_Id) is
3176 Tag_Comp : Entity_Id;
3177 Parent_Typ : Entity_Id;
3180 -- Handle private types
3182 if Present (Full_View (Etype (Typ))) then
3183 Parent_Typ := Full_View (Etype (Typ));
3185 Parent_Typ := Etype (Typ);
3188 if Parent_Typ /= Typ
3190 -- Protect the frontend against wrong sources. For example:
3193 -- type A is tagged null record;
3194 -- type B is new A with private;
3195 -- type C is new A with private;
3197 -- type B is new C with null record;
3198 -- type C is new B with null record;
3201 and then Parent_Typ /= Tagged_Type
3203 Collect (Parent_Typ);
3206 -- Collect the components containing tags of secondary dispatch
3209 Tag_Comp := Next_Tag_Component (First_Tag_Component (Typ));
3210 while Present (Tag_Comp) loop
3211 pragma Assert (Present (Related_Type (Tag_Comp)));
3212 Append_Elmt (Tag_Comp, Components_List);
3214 Tag_Comp := Next_Tag_Component (Tag_Comp);
3218 -- Start of processing for Collect_Interface_Components
3221 pragma Assert (Ekind (Tagged_Type) = E_Record_Type
3222 and then Is_Tagged_Type (Tagged_Type));
3224 Components_List := New_Elmt_List;
3225 Collect (Tagged_Type);
3226 end Collect_Interface_Components;
3228 -----------------------------
3229 -- Collect_Interfaces_Info --
3230 -----------------------------
3232 procedure Collect_Interfaces_Info
3234 Ifaces_List : out Elist_Id;
3235 Components_List : out Elist_Id;
3236 Tags_List : out Elist_Id)
3238 Comps_List : Elist_Id;
3239 Comp_Elmt : Elmt_Id;
3240 Comp_Iface : Entity_Id;
3241 Iface_Elmt : Elmt_Id;
3244 function Search_Tag (Iface : Entity_Id) return Entity_Id;
3245 -- Search for the secondary tag associated with the interface type
3246 -- Iface that is implemented by T.
3252 function Search_Tag (Iface : Entity_Id) return Entity_Id is
3255 if not Is_CPP_Class (T) then
3256 ADT := Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (T))));
3258 ADT := Next_Elmt (First_Elmt (Access_Disp_Table (T)));
3262 and then Is_Tag (Node (ADT))
3263 and then Related_Type (Node (ADT)) /= Iface
3265 -- Skip secondary dispatch table referencing thunks to user
3266 -- defined primitives covered by this interface.
3268 pragma Assert (Has_Suffix (Node (ADT), 'P'));
3271 -- Skip secondary dispatch tables of Ada types
3273 if not Is_CPP_Class (T) then
3275 -- Skip secondary dispatch table referencing thunks to
3276 -- predefined primitives.
3278 pragma Assert (Has_Suffix (Node (ADT), 'Y'));
3281 -- Skip secondary dispatch table referencing user-defined
3282 -- primitives covered by this interface.
3284 pragma Assert (Has_Suffix (Node (ADT), 'D'));
3287 -- Skip secondary dispatch table referencing predefined
3290 pragma Assert (Has_Suffix (Node (ADT), 'Z'));
3295 pragma Assert (Is_Tag (Node (ADT)));
3299 -- Start of processing for Collect_Interfaces_Info
3302 Collect_Interfaces (T, Ifaces_List);
3303 Collect_Interface_Components (T, Comps_List);
3305 -- Search for the record component and tag associated with each
3306 -- interface type of T.
3308 Components_List := New_Elmt_List;
3309 Tags_List := New_Elmt_List;
3311 Iface_Elmt := First_Elmt (Ifaces_List);
3312 while Present (Iface_Elmt) loop
3313 Iface := Node (Iface_Elmt);
3315 -- Associate the primary tag component and the primary dispatch table
3316 -- with all the interfaces that are parents of T
3318 if Is_Ancestor (Iface, T, Use_Full_View => True) then
3319 Append_Elmt (First_Tag_Component (T), Components_List);
3320 Append_Elmt (Node (First_Elmt (Access_Disp_Table (T))), Tags_List);
3322 -- Otherwise search for the tag component and secondary dispatch
3326 Comp_Elmt := First_Elmt (Comps_List);
3327 while Present (Comp_Elmt) loop
3328 Comp_Iface := Related_Type (Node (Comp_Elmt));
3330 if Comp_Iface = Iface
3331 or else Is_Ancestor (Iface, Comp_Iface, Use_Full_View => True)
3333 Append_Elmt (Node (Comp_Elmt), Components_List);
3334 Append_Elmt (Search_Tag (Comp_Iface), Tags_List);
3338 Next_Elmt (Comp_Elmt);
3340 pragma Assert (Present (Comp_Elmt));
3343 Next_Elmt (Iface_Elmt);
3345 end Collect_Interfaces_Info;
3347 ---------------------
3348 -- Collect_Parents --
3349 ---------------------
3351 procedure Collect_Parents
3353 List : out Elist_Id;
3354 Use_Full_View : Boolean := True)
3356 Current_Typ : Entity_Id := T;
3357 Parent_Typ : Entity_Id;
3360 List := New_Elmt_List;
3362 -- No action if the if the type has no parents
3364 if T = Etype (T) then
3369 Parent_Typ := Etype (Current_Typ);
3371 if Is_Private_Type (Parent_Typ)
3372 and then Present (Full_View (Parent_Typ))
3373 and then Use_Full_View
3375 Parent_Typ := Full_View (Base_Type (Parent_Typ));
3378 Append_Elmt (Parent_Typ, List);
3380 exit when Parent_Typ = Current_Typ;
3381 Current_Typ := Parent_Typ;
3383 end Collect_Parents;
3385 ----------------------------------
3386 -- Collect_Primitive_Operations --
3387 ----------------------------------
3389 function Collect_Primitive_Operations (T : Entity_Id) return Elist_Id is
3390 B_Type : constant Entity_Id := Base_Type (T);
3391 B_Decl : constant Node_Id := Original_Node (Parent (B_Type));
3392 B_Scope : Entity_Id := Scope (B_Type);
3396 Is_Type_In_Pkg : Boolean;
3397 Formal_Derived : Boolean := False;
3400 function Match (E : Entity_Id) return Boolean;
3401 -- True if E's base type is B_Type, or E is of an anonymous access type
3402 -- and the base type of its designated type is B_Type.
3408 function Match (E : Entity_Id) return Boolean is
3409 Etyp : Entity_Id := Etype (E);
3412 if Ekind (Etyp) = E_Anonymous_Access_Type then
3413 Etyp := Designated_Type (Etyp);
3416 -- In Ada 2012 a primitive operation may have a formal of an
3417 -- incomplete view of the parent type.
3419 return Base_Type (Etyp) = B_Type
3421 (Ada_Version >= Ada_2012
3422 and then Ekind (Etyp) = E_Incomplete_Type
3423 and then Full_View (Etyp) = B_Type);
3426 -- Start of processing for Collect_Primitive_Operations
3429 -- For tagged types, the primitive operations are collected as they
3430 -- are declared, and held in an explicit list which is simply returned.
3432 if Is_Tagged_Type (B_Type) then
3433 return Primitive_Operations (B_Type);
3435 -- An untagged generic type that is a derived type inherits the
3436 -- primitive operations of its parent type. Other formal types only
3437 -- have predefined operators, which are not explicitly represented.
3439 elsif Is_Generic_Type (B_Type) then
3440 if Nkind (B_Decl) = N_Formal_Type_Declaration
3441 and then Nkind (Formal_Type_Definition (B_Decl))
3442 = N_Formal_Derived_Type_Definition
3444 Formal_Derived := True;
3446 return New_Elmt_List;
3450 Op_List := New_Elmt_List;
3452 if B_Scope = Standard_Standard then
3453 if B_Type = Standard_String then
3454 Append_Elmt (Standard_Op_Concat, Op_List);
3456 elsif B_Type = Standard_Wide_String then
3457 Append_Elmt (Standard_Op_Concatw, Op_List);
3463 -- Locate the primitive subprograms of the type
3466 -- The primitive operations appear after the base type, except
3467 -- if the derivation happens within the private part of B_Scope
3468 -- and the type is a private type, in which case both the type
3469 -- and some primitive operations may appear before the base
3470 -- type, and the list of candidates starts after the type.
3472 if In_Open_Scopes (B_Scope)
3473 and then Scope (T) = B_Scope
3474 and then In_Private_Part (B_Scope)
3476 Id := Next_Entity (T);
3478 -- In Ada 2012, If the type has an incomplete partial view, there
3479 -- may be primitive operations declared before the full view, so
3480 -- we need to start scanning from the incomplete view.
3482 elsif Nkind (Parent (B_Type)) = N_Full_Type_Declaration
3483 and then Present (Incomplete_View (Parent (B_Type)))
3485 Id := Defining_Entity (Next (Incomplete_View (Parent (B_Type))));
3488 Id := Next_Entity (B_Type);
3491 -- Set flag if this is a type in a package spec
3494 Is_Package_Or_Generic_Package (B_Scope)
3496 Nkind (Parent (Declaration_Node (First_Subtype (T)))) /=
3499 while Present (Id) loop
3501 -- Test whether the result type or any of the parameter types of
3502 -- each subprogram following the type match that type when the
3503 -- type is declared in a package spec, is a derived type, or the
3504 -- subprogram is marked as primitive. (The Is_Primitive test is
3505 -- needed to find primitives of nonderived types in declarative
3506 -- parts that happen to override the predefined "=" operator.)
3508 -- Note that generic formal subprograms are not considered to be
3509 -- primitive operations and thus are never inherited.
3511 if Is_Overloadable (Id)
3512 and then (Is_Type_In_Pkg
3513 or else Is_Derived_Type (B_Type)
3514 or else Is_Primitive (Id))
3515 and then Nkind (Parent (Parent (Id)))
3516 not in N_Formal_Subprogram_Declaration
3524 Formal := First_Formal (Id);
3525 while Present (Formal) loop
3526 if Match (Formal) then
3531 Next_Formal (Formal);
3535 -- For a formal derived type, the only primitives are the ones
3536 -- inherited from the parent type. Operations appearing in the
3537 -- package declaration are not primitive for it.
3540 and then (not Formal_Derived
3541 or else Present (Alias (Id)))
3543 -- In the special case of an equality operator aliased to
3544 -- an overriding dispatching equality belonging to the same
3545 -- type, we don't include it in the list of primitives.
3546 -- This avoids inheriting multiple equality operators when
3547 -- deriving from untagged private types whose full type is
3548 -- tagged, which can otherwise cause ambiguities. Note that
3549 -- this should only happen for this kind of untagged parent
3550 -- type, since normally dispatching operations are inherited
3551 -- using the type's Primitive_Operations list.
3553 if Chars (Id) = Name_Op_Eq
3554 and then Is_Dispatching_Operation (Id)
3555 and then Present (Alias (Id))
3556 and then Present (Overridden_Operation (Alias (Id)))
3557 and then Base_Type (Etype (First_Entity (Id))) =
3558 Base_Type (Etype (First_Entity (Alias (Id))))
3562 -- Include the subprogram in the list of primitives
3565 Append_Elmt (Id, Op_List);
3572 -- For a type declared in System, some of its operations may
3573 -- appear in the target-specific extension to System.
3576 and then B_Scope = RTU_Entity (System)
3577 and then Present_System_Aux
3579 B_Scope := System_Aux_Id;
3580 Id := First_Entity (System_Aux_Id);
3586 end Collect_Primitive_Operations;
3588 -----------------------------------
3589 -- Compile_Time_Constraint_Error --
3590 -----------------------------------
3592 function Compile_Time_Constraint_Error
3595 Ent : Entity_Id := Empty;
3596 Loc : Source_Ptr := No_Location;
3597 Warn : Boolean := False) return Node_Id
3599 Msgc : String (1 .. Msg'Length + 3);
3600 -- Copy of message, with room for possible ?? or << and ! at end
3610 -- If this is a warning, convert it into an error if we are in code
3611 -- subject to SPARK_Mode being set ON.
3613 Error_Msg_Warn := SPARK_Mode /= On;
3615 -- A static constraint error in an instance body is not a fatal error.
3616 -- we choose to inhibit the message altogether, because there is no
3617 -- obvious node (for now) on which to post it. On the other hand the
3618 -- offending node must be replaced with a constraint_error in any case.
3620 -- No messages are generated if we already posted an error on this node
3622 if not Error_Posted (N) then
3623 if Loc /= No_Location then
3629 -- Copy message to Msgc, converting any ? in the message into
3630 -- < instead, so that we have an error in GNATprove mode.
3634 for J in 1 .. Msgl loop
3635 if Msg (J) = '?' and then (J = 1 or else Msg (J) /= ''') then
3638 Msgc (J) := Msg (J);
3642 -- Message is a warning, even in Ada 95 case
3644 if Msg (Msg'Last) = '?' or else Msg (Msg'Last) = '<' then
3647 -- In Ada 83, all messages are warnings. In the private part and
3648 -- the body of an instance, constraint_checks are only warnings.
3649 -- We also make this a warning if the Warn parameter is set.
3652 or else (Ada_Version = Ada_83 and then Comes_From_Source (N))
3660 elsif In_Instance_Not_Visible then
3667 -- Otherwise we have a real error message (Ada 95 static case)
3668 -- and we make this an unconditional message. Note that in the
3669 -- warning case we do not make the message unconditional, it seems
3670 -- quite reasonable to delete messages like this (about exceptions
3671 -- that will be raised) in dead code.
3679 -- Should we generate a warning? The answer is not quite yes. The
3680 -- very annoying exception occurs in the case of a short circuit
3681 -- operator where the left operand is static and decisive. Climb
3682 -- parents to see if that is the case we have here. Conditional
3683 -- expressions with decisive conditions are a similar situation.
3691 -- And then with False as left operand
3693 if Nkind (P) = N_And_Then
3694 and then Compile_Time_Known_Value (Left_Opnd (P))
3695 and then Is_False (Expr_Value (Left_Opnd (P)))
3700 -- OR ELSE with True as left operand
3702 elsif Nkind (P) = N_Or_Else
3703 and then Compile_Time_Known_Value (Left_Opnd (P))
3704 and then Is_True (Expr_Value (Left_Opnd (P)))
3711 elsif Nkind (P) = N_If_Expression then
3713 Cond : constant Node_Id := First (Expressions (P));
3714 Texp : constant Node_Id := Next (Cond);
3715 Fexp : constant Node_Id := Next (Texp);
3718 if Compile_Time_Known_Value (Cond) then
3720 -- Condition is True and we are in the right operand
3722 if Is_True (Expr_Value (Cond))
3723 and then OldP = Fexp
3728 -- Condition is False and we are in the left operand
3730 elsif Is_False (Expr_Value (Cond))
3731 and then OldP = Texp
3739 -- Special case for component association in aggregates, where
3740 -- we want to keep climbing up to the parent aggregate.
3742 elsif Nkind (P) = N_Component_Association
3743 and then Nkind (Parent (P)) = N_Aggregate
3747 -- Keep going if within subexpression
3750 exit when Nkind (P) not in N_Subexpr;
3755 Error_Msg_Warn := SPARK_Mode /= On;
3757 if Present (Ent) then
3758 Error_Msg_NEL (Msgc (1 .. Msgl), N, Ent, Eloc);
3760 Error_Msg_NEL (Msgc (1 .. Msgl), N, Etype (N), Eloc);
3765 -- Check whether the context is an Init_Proc
3767 if Inside_Init_Proc then
3769 Conc_Typ : constant Entity_Id :=
3770 Corresponding_Concurrent_Type
3771 (Entity (Parameter_Type (First
3772 (Parameter_Specifications
3773 (Parent (Current_Scope))))));
3776 -- Don't complain if the corresponding concurrent type
3777 -- doesn't come from source (i.e. a single task/protected
3780 if Present (Conc_Typ)
3781 and then not Comes_From_Source (Conc_Typ)
3784 ("\& [<<", N, Standard_Constraint_Error, Eloc);
3787 if GNATprove_Mode then
3789 ("\& would have been raised for objects of this "
3790 & "type", N, Standard_Constraint_Error, Eloc);
3793 ("\& will be raised for objects of this type??",
3794 N, Standard_Constraint_Error, Eloc);
3800 Error_Msg_NEL ("\& [<<", N, Standard_Constraint_Error, Eloc);
3804 Error_Msg ("\static expression fails Constraint_Check", Eloc);
3805 Set_Error_Posted (N);
3811 end Compile_Time_Constraint_Error;
3813 -----------------------
3814 -- Conditional_Delay --
3815 -----------------------
3817 procedure Conditional_Delay (New_Ent, Old_Ent : Entity_Id) is
3819 if Has_Delayed_Freeze (Old_Ent) and then not Is_Frozen (Old_Ent) then
3820 Set_Has_Delayed_Freeze (New_Ent);
3822 end Conditional_Delay;
3824 ----------------------------
3825 -- Contains_Refined_State --
3826 ----------------------------
3828 function Contains_Refined_State (Prag : Node_Id) return Boolean is
3829 function Has_State_In_Dependency (List : Node_Id) return Boolean;
3830 -- Determine whether a dependency list mentions a state with a visible
3833 function Has_State_In_Global (List : Node_Id) return Boolean;
3834 -- Determine whether a global list mentions a state with a visible
3837 function Is_Refined_State (Item : Node_Id) return Boolean;
3838 -- Determine whether Item is a reference to an abstract state with a
3839 -- visible refinement.
3841 -----------------------------
3842 -- Has_State_In_Dependency --
3843 -----------------------------
3845 function Has_State_In_Dependency (List : Node_Id) return Boolean is
3850 -- A null dependency list does not mention any states
3852 if Nkind (List) = N_Null then
3855 -- Dependency clauses appear as component associations of an
3858 elsif Nkind (List) = N_Aggregate
3859 and then Present (Component_Associations (List))
3861 Clause := First (Component_Associations (List));
3862 while Present (Clause) loop
3864 -- Inspect the outputs of a dependency clause
3866 Output := First (Choices (Clause));
3867 while Present (Output) loop
3868 if Is_Refined_State (Output) then
3875 -- Inspect the outputs of a dependency clause
3877 if Is_Refined_State (Expression (Clause)) then
3884 -- If we get here, then none of the dependency clauses mention a
3885 -- state with visible refinement.
3889 -- An illegal pragma managed to sneak in
3892 raise Program_Error;
3894 end Has_State_In_Dependency;
3896 -------------------------
3897 -- Has_State_In_Global --
3898 -------------------------
3900 function Has_State_In_Global (List : Node_Id) return Boolean is
3904 -- A null global list does not mention any states
3906 if Nkind (List) = N_Null then
3909 -- Simple global list or moded global list declaration
3911 elsif Nkind (List) = N_Aggregate then
3913 -- The declaration of a simple global list appear as a collection
3916 if Present (Expressions (List)) then
3917 Item := First (Expressions (List));
3918 while Present (Item) loop
3919 if Is_Refined_State (Item) then
3926 -- The declaration of a moded global list appears as a collection
3927 -- of component associations where individual choices denote
3931 Item := First (Component_Associations (List));
3932 while Present (Item) loop
3933 if Has_State_In_Global (Expression (Item)) then
3941 -- If we get here, then the simple/moded global list did not
3942 -- mention any states with a visible refinement.
3946 -- Single global item declaration
3948 elsif Is_Entity_Name (List) then
3949 return Is_Refined_State (List);
3951 -- An illegal pragma managed to sneak in
3954 raise Program_Error;
3956 end Has_State_In_Global;
3958 ----------------------
3959 -- Is_Refined_State --
3960 ----------------------
3962 function Is_Refined_State (Item : Node_Id) return Boolean is
3964 Item_Id : Entity_Id;
3967 if Nkind (Item) = N_Null then
3970 -- States cannot be subject to attribute 'Result. This case arises
3971 -- in dependency relations.
3973 elsif Nkind (Item) = N_Attribute_Reference
3974 and then Attribute_Name (Item) = Name_Result
3978 -- Multiple items appear as an aggregate. This case arises in
3979 -- dependency relations.
3981 elsif Nkind (Item) = N_Aggregate
3982 and then Present (Expressions (Item))
3984 Elmt := First (Expressions (Item));
3985 while Present (Elmt) loop
3986 if Is_Refined_State (Elmt) then
3993 -- If we get here, then none of the inputs or outputs reference a
3994 -- state with visible refinement.
4001 Item_Id := Entity_Of (Item);
4005 and then Ekind (Item_Id) = E_Abstract_State
4006 and then Has_Visible_Refinement (Item_Id);
4008 end Is_Refined_State;
4012 Arg : constant Node_Id :=
4013 Get_Pragma_Arg (First (Pragma_Argument_Associations (Prag)));
4014 Nam : constant Name_Id := Pragma_Name (Prag);
4016 -- Start of processing for Contains_Refined_State
4019 if Nam = Name_Depends then
4020 return Has_State_In_Dependency (Arg);
4022 else pragma Assert (Nam = Name_Global);
4023 return Has_State_In_Global (Arg);
4025 end Contains_Refined_State;
4027 -------------------------
4028 -- Copy_Component_List --
4029 -------------------------
4031 function Copy_Component_List
4033 Loc : Source_Ptr) return List_Id
4036 Comps : constant List_Id := New_List;
4039 Comp := First_Component (Underlying_Type (R_Typ));
4040 while Present (Comp) loop
4041 if Comes_From_Source (Comp) then
4043 Comp_Decl : constant Node_Id := Declaration_Node (Comp);
4046 Make_Component_Declaration (Loc,
4047 Defining_Identifier =>
4048 Make_Defining_Identifier (Loc, Chars (Comp)),
4049 Component_Definition =>
4051 (Component_Definition (Comp_Decl), New_Sloc => Loc)));
4055 Next_Component (Comp);
4059 end Copy_Component_List;
4061 -------------------------
4062 -- Copy_Parameter_List --
4063 -------------------------
4065 function Copy_Parameter_List (Subp_Id : Entity_Id) return List_Id is
4066 Loc : constant Source_Ptr := Sloc (Subp_Id);
4071 if No (First_Formal (Subp_Id)) then
4075 Formal := First_Formal (Subp_Id);
4076 while Present (Formal) loop
4078 (Make_Parameter_Specification (Loc,
4079 Defining_Identifier =>
4080 Make_Defining_Identifier (Sloc (Formal),
4081 Chars => Chars (Formal)),
4082 In_Present => In_Present (Parent (Formal)),
4083 Out_Present => Out_Present (Parent (Formal)),
4085 New_Occurrence_Of (Etype (Formal), Loc),
4087 New_Copy_Tree (Expression (Parent (Formal)))),
4090 Next_Formal (Formal);
4095 end Copy_Parameter_List;
4097 --------------------------------
4098 -- Corresponding_Generic_Type --
4099 --------------------------------
4101 function Corresponding_Generic_Type (T : Entity_Id) return Entity_Id is
4107 if not Is_Generic_Actual_Type (T) then
4110 -- If the actual is the actual of an enclosing instance, resolution
4111 -- was correct in the generic.
4113 elsif Nkind (Parent (T)) = N_Subtype_Declaration
4114 and then Is_Entity_Name (Subtype_Indication (Parent (T)))
4116 Is_Generic_Actual_Type (Entity (Subtype_Indication (Parent (T))))
4123 if Is_Wrapper_Package (Inst) then
4124 Inst := Related_Instance (Inst);
4129 (Specification (Unit_Declaration_Node (Inst)));
4131 -- Generic actual has the same name as the corresponding formal
4133 Typ := First_Entity (Gen);
4134 while Present (Typ) loop
4135 if Chars (Typ) = Chars (T) then
4144 end Corresponding_Generic_Type;
4146 --------------------
4147 -- Current_Entity --
4148 --------------------
4150 -- The currently visible definition for a given identifier is the
4151 -- one most chained at the start of the visibility chain, i.e. the
4152 -- one that is referenced by the Node_Id value of the name of the
4153 -- given identifier.
4155 function Current_Entity (N : Node_Id) return Entity_Id is
4157 return Get_Name_Entity_Id (Chars (N));
4160 -----------------------------
4161 -- Current_Entity_In_Scope --
4162 -----------------------------
4164 function Current_Entity_In_Scope (N : Node_Id) return Entity_Id is
4166 CS : constant Entity_Id := Current_Scope;
4168 Transient_Case : constant Boolean := Scope_Is_Transient;
4171 E := Get_Name_Entity_Id (Chars (N));
4173 and then Scope (E) /= CS
4174 and then (not Transient_Case or else Scope (E) /= Scope (CS))
4180 end Current_Entity_In_Scope;
4186 function Current_Scope return Entity_Id is
4188 if Scope_Stack.Last = -1 then
4189 return Standard_Standard;
4192 C : constant Entity_Id :=
4193 Scope_Stack.Table (Scope_Stack.Last).Entity;
4198 return Standard_Standard;
4204 ------------------------
4205 -- Current_Subprogram --
4206 ------------------------
4208 function Current_Subprogram return Entity_Id is
4209 Scop : constant Entity_Id := Current_Scope;
4211 if Is_Subprogram (Scop) or else Is_Generic_Subprogram (Scop) then
4214 return Enclosing_Subprogram (Scop);
4216 end Current_Subprogram;
4218 ----------------------------------
4219 -- Deepest_Type_Access_Level --
4220 ----------------------------------
4222 function Deepest_Type_Access_Level (Typ : Entity_Id) return Uint is
4224 if Ekind (Typ) = E_Anonymous_Access_Type
4225 and then not Is_Local_Anonymous_Access (Typ)
4226 and then Nkind (Associated_Node_For_Itype (Typ)) = N_Object_Declaration
4228 -- Typ is the type of an Ada 2012 stand-alone object of an anonymous
4232 Scope_Depth (Enclosing_Dynamic_Scope
4233 (Defining_Identifier
4234 (Associated_Node_For_Itype (Typ))));
4236 -- For generic formal type, return Int'Last (infinite).
4237 -- See comment preceding Is_Generic_Type call in Type_Access_Level.
4239 elsif Is_Generic_Type (Root_Type (Typ)) then
4240 return UI_From_Int (Int'Last);
4243 return Type_Access_Level (Typ);
4245 end Deepest_Type_Access_Level;
4247 ---------------------
4248 -- Defining_Entity --
4249 ---------------------
4251 function Defining_Entity (N : Node_Id) return Entity_Id is
4252 K : constant Node_Kind := Nkind (N);
4253 Err : Entity_Id := Empty;
4258 N_Subprogram_Declaration |
4259 N_Abstract_Subprogram_Declaration |
4261 N_Package_Declaration |
4262 N_Subprogram_Renaming_Declaration |
4263 N_Subprogram_Body_Stub |
4264 N_Generic_Subprogram_Declaration |
4265 N_Generic_Package_Declaration |
4266 N_Formal_Subprogram_Declaration |
4267 N_Expression_Function
4269 return Defining_Entity (Specification (N));
4272 N_Component_Declaration |
4273 N_Defining_Program_Unit_Name |
4274 N_Discriminant_Specification |
4276 N_Entry_Declaration |
4277 N_Entry_Index_Specification |
4278 N_Exception_Declaration |
4279 N_Exception_Renaming_Declaration |
4280 N_Formal_Object_Declaration |
4281 N_Formal_Package_Declaration |
4282 N_Formal_Type_Declaration |
4283 N_Full_Type_Declaration |
4284 N_Implicit_Label_Declaration |
4285 N_Incomplete_Type_Declaration |
4286 N_Loop_Parameter_Specification |
4287 N_Number_Declaration |
4288 N_Object_Declaration |
4289 N_Object_Renaming_Declaration |
4290 N_Package_Body_Stub |
4291 N_Parameter_Specification |
4292 N_Private_Extension_Declaration |
4293 N_Private_Type_Declaration |
4295 N_Protected_Body_Stub |
4296 N_Protected_Type_Declaration |
4297 N_Single_Protected_Declaration |
4298 N_Single_Task_Declaration |
4299 N_Subtype_Declaration |
4302 N_Task_Type_Declaration
4304 return Defining_Identifier (N);
4307 return Defining_Entity (Proper_Body (N));
4310 N_Function_Instantiation |
4311 N_Function_Specification |
4312 N_Generic_Function_Renaming_Declaration |
4313 N_Generic_Package_Renaming_Declaration |
4314 N_Generic_Procedure_Renaming_Declaration |
4316 N_Package_Instantiation |
4317 N_Package_Renaming_Declaration |
4318 N_Package_Specification |
4319 N_Procedure_Instantiation |
4320 N_Procedure_Specification
4323 Nam : constant Node_Id := Defining_Unit_Name (N);
4326 if Nkind (Nam) in N_Entity then
4329 -- For Error, make up a name and attach to declaration
4330 -- so we can continue semantic analysis
4332 elsif Nam = Error then
4333 Err := Make_Temporary (Sloc (N), 'T');
4334 Set_Defining_Unit_Name (N, Err);
4338 -- If not an entity, get defining identifier
4341 return Defining_Identifier (Nam);
4345 when N_Block_Statement =>
4346 return Entity (Identifier (N));
4349 raise Program_Error;
4352 end Defining_Entity;
4354 --------------------------
4355 -- Denotes_Discriminant --
4356 --------------------------
4358 function Denotes_Discriminant
4360 Check_Concurrent : Boolean := False) return Boolean
4364 if not Is_Entity_Name (N)
4365 or else No (Entity (N))
4372 -- If we are checking for a protected type, the discriminant may have
4373 -- been rewritten as the corresponding discriminal of the original type
4374 -- or of the corresponding concurrent record, depending on whether we
4375 -- are in the spec or body of the protected type.
4377 return Ekind (E) = E_Discriminant
4380 and then Ekind (E) = E_In_Parameter
4381 and then Present (Discriminal_Link (E))
4383 (Is_Concurrent_Type (Scope (Discriminal_Link (E)))
4385 Is_Concurrent_Record_Type (Scope (Discriminal_Link (E)))));
4387 end Denotes_Discriminant;
4389 -------------------------
4390 -- Denotes_Same_Object --
4391 -------------------------
4393 function Denotes_Same_Object (A1, A2 : Node_Id) return Boolean is
4394 Obj1 : Node_Id := A1;
4395 Obj2 : Node_Id := A2;
4397 function Has_Prefix (N : Node_Id) return Boolean;
4398 -- Return True if N has attribute Prefix
4400 function Is_Renaming (N : Node_Id) return Boolean;
4401 -- Return true if N names a renaming entity
4403 function Is_Valid_Renaming (N : Node_Id) return Boolean;
4404 -- For renamings, return False if the prefix of any dereference within
4405 -- the renamed object_name is a variable, or any expression within the
4406 -- renamed object_name contains references to variables or calls on
4407 -- nonstatic functions; otherwise return True (RM 6.4.1(6.10/3))
4413 function Has_Prefix (N : Node_Id) return Boolean is
4417 N_Attribute_Reference,
4419 N_Explicit_Dereference,
4420 N_Indexed_Component,
4422 N_Selected_Component,
4430 function Is_Renaming (N : Node_Id) return Boolean is
4432 return Is_Entity_Name (N)
4433 and then Present (Renamed_Entity (Entity (N)));
4436 -----------------------
4437 -- Is_Valid_Renaming --
4438 -----------------------
4440 function Is_Valid_Renaming (N : Node_Id) return Boolean is
4442 function Check_Renaming (N : Node_Id) return Boolean;
4443 -- Recursive function used to traverse all the prefixes of N
4445 function Check_Renaming (N : Node_Id) return Boolean is
4448 and then not Check_Renaming (Renamed_Entity (Entity (N)))
4453 if Nkind (N) = N_Indexed_Component then
4458 Indx := First (Expressions (N));
4459 while Present (Indx) loop
4460 if not Is_OK_Static_Expression (Indx) then
4469 if Has_Prefix (N) then
4471 P : constant Node_Id := Prefix (N);
4474 if Nkind (N) = N_Explicit_Dereference
4475 and then Is_Variable (P)
4479 elsif Is_Entity_Name (P)
4480 and then Ekind (Entity (P)) = E_Function
4484 elsif Nkind (P) = N_Function_Call then
4488 -- Recursion to continue traversing the prefix of the
4489 -- renaming expression
4491 return Check_Renaming (P);
4498 -- Start of processing for Is_Valid_Renaming
4501 return Check_Renaming (N);
4502 end Is_Valid_Renaming;
4504 -- Start of processing for Denotes_Same_Object
4507 -- Both names statically denote the same stand-alone object or parameter
4508 -- (RM 6.4.1(6.5/3))
4510 if Is_Entity_Name (Obj1)
4511 and then Is_Entity_Name (Obj2)
4512 and then Entity (Obj1) = Entity (Obj2)
4517 -- For renamings, the prefix of any dereference within the renamed
4518 -- object_name is not a variable, and any expression within the
4519 -- renamed object_name contains no references to variables nor
4520 -- calls on nonstatic functions (RM 6.4.1(6.10/3)).
4522 if Is_Renaming (Obj1) then
4523 if Is_Valid_Renaming (Obj1) then
4524 Obj1 := Renamed_Entity (Entity (Obj1));
4530 if Is_Renaming (Obj2) then
4531 if Is_Valid_Renaming (Obj2) then
4532 Obj2 := Renamed_Entity (Entity (Obj2));
4538 -- No match if not same node kind (such cases are handled by
4539 -- Denotes_Same_Prefix)
4541 if Nkind (Obj1) /= Nkind (Obj2) then
4544 -- After handling valid renamings, one of the two names statically
4545 -- denoted a renaming declaration whose renamed object_name is known
4546 -- to denote the same object as the other (RM 6.4.1(6.10/3))
4548 elsif Is_Entity_Name (Obj1) then
4549 if Is_Entity_Name (Obj2) then
4550 return Entity (Obj1) = Entity (Obj2);
4555 -- Both names are selected_components, their prefixes are known to
4556 -- denote the same object, and their selector_names denote the same
4557 -- component (RM 6.4.1(6.6/3)
4559 elsif Nkind (Obj1) = N_Selected_Component then
4560 return Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2))
4562 Entity (Selector_Name (Obj1)) = Entity (Selector_Name (Obj2));
4564 -- Both names are dereferences and the dereferenced names are known to
4565 -- denote the same object (RM 6.4.1(6.7/3))
4567 elsif Nkind (Obj1) = N_Explicit_Dereference then
4568 return Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2));
4570 -- Both names are indexed_components, their prefixes are known to denote
4571 -- the same object, and each of the pairs of corresponding index values
4572 -- are either both static expressions with the same static value or both
4573 -- names that are known to denote the same object (RM 6.4.1(6.8/3))
4575 elsif Nkind (Obj1) = N_Indexed_Component then
4576 if not Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2)) then
4584 Indx1 := First (Expressions (Obj1));
4585 Indx2 := First (Expressions (Obj2));
4586 while Present (Indx1) loop
4588 -- Indexes must denote the same static value or same object
4590 if Is_OK_Static_Expression (Indx1) then
4591 if not Is_OK_Static_Expression (Indx2) then
4594 elsif Expr_Value (Indx1) /= Expr_Value (Indx2) then
4598 elsif not Denotes_Same_Object (Indx1, Indx2) then
4610 -- Both names are slices, their prefixes are known to denote the same
4611 -- object, and the two slices have statically matching index constraints
4612 -- (RM 6.4.1(6.9/3))
4614 elsif Nkind (Obj1) = N_Slice
4615 and then Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2))
4618 Lo1, Lo2, Hi1, Hi2 : Node_Id;
4621 Get_Index_Bounds (Etype (Obj1), Lo1, Hi1);
4622 Get_Index_Bounds (Etype (Obj2), Lo2, Hi2);
4624 -- Check whether bounds are statically identical. There is no
4625 -- attempt to detect partial overlap of slices.
4627 return Denotes_Same_Object (Lo1, Lo2)
4628 and then Denotes_Same_Object (Hi1, Hi2);
4631 -- In the recursion, literals appear as indexes.
4633 elsif Nkind (Obj1) = N_Integer_Literal
4634 and then Nkind (Obj2) = N_Integer_Literal
4636 return Intval (Obj1) = Intval (Obj2);
4641 end Denotes_Same_Object;
4643 -------------------------
4644 -- Denotes_Same_Prefix --
4645 -------------------------
4647 function Denotes_Same_Prefix (A1, A2 : Node_Id) return Boolean is
4650 if Is_Entity_Name (A1) then
4651 if Nkind_In (A2, N_Selected_Component, N_Indexed_Component)
4652 and then not Is_Access_Type (Etype (A1))
4654 return Denotes_Same_Object (A1, Prefix (A2))
4655 or else Denotes_Same_Prefix (A1, Prefix (A2));
4660 elsif Is_Entity_Name (A2) then
4661 return Denotes_Same_Prefix (A1 => A2, A2 => A1);
4663 elsif Nkind_In (A1, N_Selected_Component, N_Indexed_Component, N_Slice)
4665 Nkind_In (A2, N_Selected_Component, N_Indexed_Component, N_Slice)
4668 Root1, Root2 : Node_Id;
4669 Depth1, Depth2 : Int := 0;
4672 Root1 := Prefix (A1);
4673 while not Is_Entity_Name (Root1) loop
4675 (Root1, N_Selected_Component, N_Indexed_Component)
4679 Root1 := Prefix (Root1);
4682 Depth1 := Depth1 + 1;
4685 Root2 := Prefix (A2);
4686 while not Is_Entity_Name (Root2) loop
4688 (Root2, N_Selected_Component, N_Indexed_Component)
4692 Root2 := Prefix (Root2);
4695 Depth2 := Depth2 + 1;
4698 -- If both have the same depth and they do not denote the same
4699 -- object, they are disjoint and no warning is needed.
4701 if Depth1 = Depth2 then
4704 elsif Depth1 > Depth2 then
4705 Root1 := Prefix (A1);
4706 for I in 1 .. Depth1 - Depth2 - 1 loop
4707 Root1 := Prefix (Root1);
4710 return Denotes_Same_Object (Root1, A2);
4713 Root2 := Prefix (A2);
4714 for I in 1 .. Depth2 - Depth1 - 1 loop
4715 Root2 := Prefix (Root2);
4718 return Denotes_Same_Object (A1, Root2);
4725 end Denotes_Same_Prefix;
4727 ----------------------
4728 -- Denotes_Variable --
4729 ----------------------
4731 function Denotes_Variable (N : Node_Id) return Boolean is
4733 return Is_Variable (N) and then Paren_Count (N) = 0;
4734 end Denotes_Variable;
4736 -----------------------------
4737 -- Depends_On_Discriminant --
4738 -----------------------------
4740 function Depends_On_Discriminant (N : Node_Id) return Boolean is
4745 Get_Index_Bounds (N, L, H);
4746 return Denotes_Discriminant (L) or else Denotes_Discriminant (H);
4747 end Depends_On_Discriminant;
4749 -------------------------
4750 -- Designate_Same_Unit --
4751 -------------------------
4753 function Designate_Same_Unit
4755 Name2 : Node_Id) return Boolean
4757 K1 : constant Node_Kind := Nkind (Name1);
4758 K2 : constant Node_Kind := Nkind (Name2);
4760 function Prefix_Node (N : Node_Id) return Node_Id;
4761 -- Returns the parent unit name node of a defining program unit name
4762 -- or the prefix if N is a selected component or an expanded name.
4764 function Select_Node (N : Node_Id) return Node_Id;
4765 -- Returns the defining identifier node of a defining program unit
4766 -- name or the selector node if N is a selected component or an
4773 function Prefix_Node (N : Node_Id) return Node_Id is
4775 if Nkind (N) = N_Defining_Program_Unit_Name then
4787 function Select_Node (N : Node_Id) return Node_Id is
4789 if Nkind (N) = N_Defining_Program_Unit_Name then
4790 return Defining_Identifier (N);
4793 return Selector_Name (N);
4797 -- Start of processing for Designate_Next_Unit
4800 if (K1 = N_Identifier or else
4801 K1 = N_Defining_Identifier)
4803 (K2 = N_Identifier or else
4804 K2 = N_Defining_Identifier)
4806 return Chars (Name1) = Chars (Name2);
4809 (K1 = N_Expanded_Name or else
4810 K1 = N_Selected_Component or else
4811 K1 = N_Defining_Program_Unit_Name)
4813 (K2 = N_Expanded_Name or else
4814 K2 = N_Selected_Component or else
4815 K2 = N_Defining_Program_Unit_Name)
4818 (Chars (Select_Node (Name1)) = Chars (Select_Node (Name2)))
4820 Designate_Same_Unit (Prefix_Node (Name1), Prefix_Node (Name2));
4825 end Designate_Same_Unit;
4827 ------------------------------------------
4828 -- function Dynamic_Accessibility_Level --
4829 ------------------------------------------
4831 function Dynamic_Accessibility_Level (Expr : Node_Id) return Node_Id is
4833 Loc : constant Source_Ptr := Sloc (Expr);
4835 function Make_Level_Literal (Level : Uint) return Node_Id;
4836 -- Construct an integer literal representing an accessibility level
4837 -- with its type set to Natural.
4839 ------------------------
4840 -- Make_Level_Literal --
4841 ------------------------
4843 function Make_Level_Literal (Level : Uint) return Node_Id is
4844 Result : constant Node_Id := Make_Integer_Literal (Loc, Level);
4846 Set_Etype (Result, Standard_Natural);
4848 end Make_Level_Literal;
4850 -- Start of processing for Dynamic_Accessibility_Level
4853 if Is_Entity_Name (Expr) then
4856 if Present (Renamed_Object (E)) then
4857 return Dynamic_Accessibility_Level (Renamed_Object (E));
4860 if Is_Formal (E) or else Ekind_In (E, E_Variable, E_Constant) then
4861 if Present (Extra_Accessibility (E)) then
4862 return New_Occurrence_Of (Extra_Accessibility (E), Loc);
4867 -- Unimplemented: Ptr.all'Access, where Ptr has Extra_Accessibility ???
4869 case Nkind (Expr) is
4871 -- For access discriminant, the level of the enclosing object
4873 when N_Selected_Component =>
4874 if Ekind (Entity (Selector_Name (Expr))) = E_Discriminant
4875 and then Ekind (Etype (Entity (Selector_Name (Expr)))) =
4876 E_Anonymous_Access_Type
4878 return Make_Level_Literal (Object_Access_Level (Expr));
4881 when N_Attribute_Reference =>
4882 case Get_Attribute_Id (Attribute_Name (Expr)) is
4884 -- For X'Access, the level of the prefix X
4886 when Attribute_Access =>
4887 return Make_Level_Literal
4888 (Object_Access_Level (Prefix (Expr)));
4890 -- Treat the unchecked attributes as library-level
4892 when Attribute_Unchecked_Access |
4893 Attribute_Unrestricted_Access =>
4894 return Make_Level_Literal (Scope_Depth (Standard_Standard));
4896 -- No other access-valued attributes
4899 raise Program_Error;
4904 -- Unimplemented: depends on context. As an actual parameter where
4905 -- formal type is anonymous, use
4906 -- Scope_Depth (Current_Scope) + 1.
4907 -- For other cases, see 3.10.2(14/3) and following. ???
4911 when N_Type_Conversion =>
4912 if not Is_Local_Anonymous_Access (Etype (Expr)) then
4914 -- Handle type conversions introduced for a rename of an
4915 -- Ada 2012 stand-alone object of an anonymous access type.
4917 return Dynamic_Accessibility_Level (Expression (Expr));
4924 return Make_Level_Literal (Type_Access_Level (Etype (Expr)));
4925 end Dynamic_Accessibility_Level;
4927 -----------------------------------
4928 -- Effective_Extra_Accessibility --
4929 -----------------------------------
4931 function Effective_Extra_Accessibility (Id : Entity_Id) return Entity_Id is
4933 if Present (Renamed_Object (Id))
4934 and then Is_Entity_Name (Renamed_Object (Id))
4936 return Effective_Extra_Accessibility (Entity (Renamed_Object (Id)));
4938 return Extra_Accessibility (Id);
4940 end Effective_Extra_Accessibility;
4942 -----------------------------
4943 -- Effective_Reads_Enabled --
4944 -----------------------------
4946 function Effective_Reads_Enabled (Id : Entity_Id) return Boolean is
4948 return Has_Enabled_Property (Id, Name_Effective_Reads);
4949 end Effective_Reads_Enabled;
4951 ------------------------------
4952 -- Effective_Writes_Enabled --
4953 ------------------------------
4955 function Effective_Writes_Enabled (Id : Entity_Id) return Boolean is
4957 return Has_Enabled_Property (Id, Name_Effective_Writes);
4958 end Effective_Writes_Enabled;
4960 ------------------------------
4961 -- Enclosing_Comp_Unit_Node --
4962 ------------------------------
4964 function Enclosing_Comp_Unit_Node (N : Node_Id) return Node_Id is
4965 Current_Node : Node_Id;
4969 while Present (Current_Node)
4970 and then Nkind (Current_Node) /= N_Compilation_Unit
4972 Current_Node := Parent (Current_Node);
4975 if Nkind (Current_Node) /= N_Compilation_Unit then
4978 return Current_Node;
4980 end Enclosing_Comp_Unit_Node;
4982 --------------------------
4983 -- Enclosing_CPP_Parent --
4984 --------------------------
4986 function Enclosing_CPP_Parent (Typ : Entity_Id) return Entity_Id is
4987 Parent_Typ : Entity_Id := Typ;
4990 while not Is_CPP_Class (Parent_Typ)
4991 and then Etype (Parent_Typ) /= Parent_Typ
4993 Parent_Typ := Etype (Parent_Typ);
4995 if Is_Private_Type (Parent_Typ) then
4996 Parent_Typ := Full_View (Base_Type (Parent_Typ));
5000 pragma Assert (Is_CPP_Class (Parent_Typ));
5002 end Enclosing_CPP_Parent;
5004 ----------------------------
5005 -- Enclosing_Generic_Body --
5006 ----------------------------
5008 function Enclosing_Generic_Body
5009 (N : Node_Id) return Node_Id
5017 while Present (P) loop
5018 if Nkind (P) = N_Package_Body
5019 or else Nkind (P) = N_Subprogram_Body
5021 Spec := Corresponding_Spec (P);
5023 if Present (Spec) then
5024 Decl := Unit_Declaration_Node (Spec);
5026 if Nkind (Decl) = N_Generic_Package_Declaration
5027 or else Nkind (Decl) = N_Generic_Subprogram_Declaration
5038 end Enclosing_Generic_Body;
5040 ----------------------------
5041 -- Enclosing_Generic_Unit --
5042 ----------------------------
5044 function Enclosing_Generic_Unit
5045 (N : Node_Id) return Node_Id
5053 while Present (P) loop
5054 if Nkind (P) = N_Generic_Package_Declaration
5055 or else Nkind (P) = N_Generic_Subprogram_Declaration
5059 elsif Nkind (P) = N_Package_Body
5060 or else Nkind (P) = N_Subprogram_Body
5062 Spec := Corresponding_Spec (P);
5064 if Present (Spec) then
5065 Decl := Unit_Declaration_Node (Spec);
5067 if Nkind (Decl) = N_Generic_Package_Declaration
5068 or else Nkind (Decl) = N_Generic_Subprogram_Declaration
5079 end Enclosing_Generic_Unit;
5081 -------------------------------
5082 -- Enclosing_Lib_Unit_Entity --
5083 -------------------------------
5085 function Enclosing_Lib_Unit_Entity
5086 (E : Entity_Id := Current_Scope) return Entity_Id
5088 Unit_Entity : Entity_Id;
5091 -- Look for enclosing library unit entity by following scope links.
5092 -- Equivalent to, but faster than indexing through the scope stack.
5095 while (Present (Scope (Unit_Entity))
5096 and then Scope (Unit_Entity) /= Standard_Standard)
5097 and not Is_Child_Unit (Unit_Entity)
5099 Unit_Entity := Scope (Unit_Entity);
5103 end Enclosing_Lib_Unit_Entity;
5105 -----------------------
5106 -- Enclosing_Package --
5107 -----------------------
5109 function Enclosing_Package (E : Entity_Id) return Entity_Id is
5110 Dynamic_Scope : constant Entity_Id := Enclosing_Dynamic_Scope (E);
5113 if Dynamic_Scope = Standard_Standard then
5114 return Standard_Standard;
5116 elsif Dynamic_Scope = Empty then
5119 elsif Ekind_In (Dynamic_Scope, E_Package, E_Package_Body,
5122 return Dynamic_Scope;
5125 return Enclosing_Package (Dynamic_Scope);
5127 end Enclosing_Package;
5129 --------------------------
5130 -- Enclosing_Subprogram --
5131 --------------------------
5133 function Enclosing_Subprogram (E : Entity_Id) return Entity_Id is
5134 Dynamic_Scope : constant Entity_Id := Enclosing_Dynamic_Scope (E);
5137 if Dynamic_Scope = Standard_Standard then
5140 elsif Dynamic_Scope = Empty then
5143 elsif Ekind (Dynamic_Scope) = E_Subprogram_Body then
5144 return Corresponding_Spec (Parent (Parent (Dynamic_Scope)));
5146 elsif Ekind (Dynamic_Scope) = E_Block
5147 or else Ekind (Dynamic_Scope) = E_Return_Statement
5149 return Enclosing_Subprogram (Dynamic_Scope);
5151 elsif Ekind (Dynamic_Scope) = E_Task_Type then
5152 return Get_Task_Body_Procedure (Dynamic_Scope);
5154 elsif Ekind (Dynamic_Scope) = E_Limited_Private_Type
5155 and then Present (Full_View (Dynamic_Scope))
5156 and then Ekind (Full_View (Dynamic_Scope)) = E_Task_Type
5158 return Get_Task_Body_Procedure (Full_View (Dynamic_Scope));
5160 -- No body is generated if the protected operation is eliminated
5162 elsif Convention (Dynamic_Scope) = Convention_Protected
5163 and then not Is_Eliminated (Dynamic_Scope)
5164 and then Present (Protected_Body_Subprogram (Dynamic_Scope))
5166 return Protected_Body_Subprogram (Dynamic_Scope);
5169 return Dynamic_Scope;
5171 end Enclosing_Subprogram;
5173 ------------------------
5174 -- Ensure_Freeze_Node --
5175 ------------------------
5177 procedure Ensure_Freeze_Node (E : Entity_Id) is
5180 if No (Freeze_Node (E)) then
5181 FN := Make_Freeze_Entity (Sloc (E));
5182 Set_Has_Delayed_Freeze (E);
5183 Set_Freeze_Node (E, FN);
5184 Set_Access_Types_To_Process (FN, No_Elist);
5185 Set_TSS_Elist (FN, No_Elist);
5188 end Ensure_Freeze_Node;
5194 procedure Enter_Name (Def_Id : Entity_Id) is
5195 C : constant Entity_Id := Current_Entity (Def_Id);
5196 E : constant Entity_Id := Current_Entity_In_Scope (Def_Id);
5197 S : constant Entity_Id := Current_Scope;
5200 Generate_Definition (Def_Id);
5202 -- Add new name to current scope declarations. Check for duplicate
5203 -- declaration, which may or may not be a genuine error.
5207 -- Case of previous entity entered because of a missing declaration
5208 -- or else a bad subtype indication. Best is to use the new entity,
5209 -- and make the previous one invisible.
5211 if Etype (E) = Any_Type then
5212 Set_Is_Immediately_Visible (E, False);
5214 -- Case of renaming declaration constructed for package instances.
5215 -- if there is an explicit declaration with the same identifier,
5216 -- the renaming is not immediately visible any longer, but remains
5217 -- visible through selected component notation.
5219 elsif Nkind (Parent (E)) = N_Package_Renaming_Declaration
5220 and then not Comes_From_Source (E)
5222 Set_Is_Immediately_Visible (E, False);
5224 -- The new entity may be the package renaming, which has the same
5225 -- same name as a generic formal which has been seen already.
5227 elsif Nkind (Parent (Def_Id)) = N_Package_Renaming_Declaration
5228 and then not Comes_From_Source (Def_Id)
5230 Set_Is_Immediately_Visible (E, False);
5232 -- For a fat pointer corresponding to a remote access to subprogram,
5233 -- we use the same identifier as the RAS type, so that the proper
5234 -- name appears in the stub. This type is only retrieved through
5235 -- the RAS type and never by visibility, and is not added to the
5236 -- visibility list (see below).
5238 elsif Nkind (Parent (Def_Id)) = N_Full_Type_Declaration
5239 and then Ekind (Def_Id) = E_Record_Type
5240 and then Present (Corresponding_Remote_Type (Def_Id))
5244 -- Case of an implicit operation or derived literal. The new entity
5245 -- hides the implicit one, which is removed from all visibility,
5246 -- i.e. the entity list of its scope, and homonym chain of its name.
5248 elsif (Is_Overloadable (E) and then Is_Inherited_Operation (E))
5249 or else Is_Internal (E)
5253 Prev_Vis : Entity_Id;
5254 Decl : constant Node_Id := Parent (E);
5257 -- If E is an implicit declaration, it cannot be the first
5258 -- entity in the scope.
5260 Prev := First_Entity (Current_Scope);
5261 while Present (Prev)
5262 and then Next_Entity (Prev) /= E
5269 -- If E is not on the entity chain of the current scope,
5270 -- it is an implicit declaration in the generic formal
5271 -- part of a generic subprogram. When analyzing the body,
5272 -- the generic formals are visible but not on the entity
5273 -- chain of the subprogram. The new entity will become
5274 -- the visible one in the body.
5277 (Nkind (Parent (Decl)) = N_Generic_Subprogram_Declaration);
5281 Set_Next_Entity (Prev, Next_Entity (E));
5283 if No (Next_Entity (Prev)) then
5284 Set_Last_Entity (Current_Scope, Prev);
5287 if E = Current_Entity (E) then
5291 Prev_Vis := Current_Entity (E);
5292 while Homonym (Prev_Vis) /= E loop
5293 Prev_Vis := Homonym (Prev_Vis);
5297 if Present (Prev_Vis) then
5299 -- Skip E in the visibility chain
5301 Set_Homonym (Prev_Vis, Homonym (E));
5304 Set_Name_Entity_Id (Chars (E), Homonym (E));
5309 -- This section of code could use a comment ???
5311 elsif Present (Etype (E))
5312 and then Is_Concurrent_Type (Etype (E))
5317 -- If the homograph is a protected component renaming, it should not
5318 -- be hiding the current entity. Such renamings are treated as weak
5321 elsif Is_Prival (E) then
5322 Set_Is_Immediately_Visible (E, False);
5324 -- In this case the current entity is a protected component renaming.
5325 -- Perform minimal decoration by setting the scope and return since
5326 -- the prival should not be hiding other visible entities.
5328 elsif Is_Prival (Def_Id) then
5329 Set_Scope (Def_Id, Current_Scope);
5332 -- Analogous to privals, the discriminal generated for an entry index
5333 -- parameter acts as a weak declaration. Perform minimal decoration
5334 -- to avoid bogus errors.
5336 elsif Is_Discriminal (Def_Id)
5337 and then Ekind (Discriminal_Link (Def_Id)) = E_Entry_Index_Parameter
5339 Set_Scope (Def_Id, Current_Scope);
5342 -- In the body or private part of an instance, a type extension may
5343 -- introduce a component with the same name as that of an actual. The
5344 -- legality rule is not enforced, but the semantics of the full type
5345 -- with two components of same name are not clear at this point???
5347 elsif In_Instance_Not_Visible then
5350 -- When compiling a package body, some child units may have become
5351 -- visible. They cannot conflict with local entities that hide them.
5353 elsif Is_Child_Unit (E)
5354 and then In_Open_Scopes (Scope (E))
5355 and then not Is_Immediately_Visible (E)
5359 -- Conversely, with front-end inlining we may compile the parent body
5360 -- first, and a child unit subsequently. The context is now the
5361 -- parent spec, and body entities are not visible.
5363 elsif Is_Child_Unit (Def_Id)
5364 and then Is_Package_Body_Entity (E)
5365 and then not In_Package_Body (Current_Scope)
5369 -- Case of genuine duplicate declaration
5372 Error_Msg_Sloc := Sloc (E);
5374 -- If the previous declaration is an incomplete type declaration
5375 -- this may be an attempt to complete it with a private type. The
5376 -- following avoids confusing cascaded errors.
5378 if Nkind (Parent (E)) = N_Incomplete_Type_Declaration
5379 and then Nkind (Parent (Def_Id)) = N_Private_Type_Declaration
5382 ("incomplete type cannot be completed with a private " &
5383 "declaration", Parent (Def_Id));
5384 Set_Is_Immediately_Visible (E, False);
5385 Set_Full_View (E, Def_Id);
5387 -- An inherited component of a record conflicts with a new
5388 -- discriminant. The discriminant is inserted first in the scope,
5389 -- but the error should be posted on it, not on the component.
5391 elsif Ekind (E) = E_Discriminant
5392 and then Present (Scope (Def_Id))
5393 and then Scope (Def_Id) /= Current_Scope
5395 Error_Msg_Sloc := Sloc (Def_Id);
5396 Error_Msg_N ("& conflicts with declaration#", E);
5399 -- If the name of the unit appears in its own context clause, a
5400 -- dummy package with the name has already been created, and the
5401 -- error emitted. Try to continue quietly.
5403 elsif Error_Posted (E)
5404 and then Sloc (E) = No_Location
5405 and then Nkind (Parent (E)) = N_Package_Specification
5406 and then Current_Scope = Standard_Standard
5408 Set_Scope (Def_Id, Current_Scope);
5412 Error_Msg_N ("& conflicts with declaration#", Def_Id);
5414 -- Avoid cascaded messages with duplicate components in
5417 if Ekind_In (E, E_Component, E_Discriminant) then
5422 if Nkind (Parent (Parent (Def_Id))) =
5423 N_Generic_Subprogram_Declaration
5425 Defining_Entity (Specification (Parent (Parent (Def_Id))))
5427 Error_Msg_N ("\generic units cannot be overloaded", Def_Id);
5430 -- If entity is in standard, then we are in trouble, because it
5431 -- means that we have a library package with a duplicated name.
5432 -- That's hard to recover from, so abort.
5434 if S = Standard_Standard then
5435 raise Unrecoverable_Error;
5437 -- Otherwise we continue with the declaration. Having two
5438 -- identical declarations should not cause us too much trouble.
5446 -- If we fall through, declaration is OK, at least OK enough to continue
5448 -- If Def_Id is a discriminant or a record component we are in the midst
5449 -- of inheriting components in a derived record definition. Preserve
5450 -- their Ekind and Etype.
5452 if Ekind_In (Def_Id, E_Discriminant, E_Component) then
5455 -- If a type is already set, leave it alone (happens when a type
5456 -- declaration is reanalyzed following a call to the optimizer).
5458 elsif Present (Etype (Def_Id)) then
5461 -- Otherwise, the kind E_Void insures that premature uses of the entity
5462 -- will be detected. Any_Type insures that no cascaded errors will occur
5465 Set_Ekind (Def_Id, E_Void);
5466 Set_Etype (Def_Id, Any_Type);
5469 -- Inherited discriminants and components in derived record types are
5470 -- immediately visible. Itypes are not.
5472 -- Unless the Itype is for a record type with a corresponding remote
5473 -- type (what is that about, it was not commented ???)
5475 if Ekind_In (Def_Id, E_Discriminant, E_Component)
5477 ((not Is_Record_Type (Def_Id)
5478 or else No (Corresponding_Remote_Type (Def_Id)))
5479 and then not Is_Itype (Def_Id))
5481 Set_Is_Immediately_Visible (Def_Id);
5482 Set_Current_Entity (Def_Id);
5485 Set_Homonym (Def_Id, C);
5486 Append_Entity (Def_Id, S);
5487 Set_Public_Status (Def_Id);
5489 -- Declaring a homonym is not allowed in SPARK ...
5492 and then Restriction_Check_Required (SPARK_05)
5495 Enclosing_Subp : constant Node_Id := Enclosing_Subprogram (Def_Id);
5496 Enclosing_Pack : constant Node_Id := Enclosing_Package (Def_Id);
5497 Other_Scope : constant Node_Id := Enclosing_Dynamic_Scope (C);
5500 -- ... unless the new declaration is in a subprogram, and the
5501 -- visible declaration is a variable declaration or a parameter
5502 -- specification outside that subprogram.
5504 if Present (Enclosing_Subp)
5505 and then Nkind_In (Parent (C), N_Object_Declaration,
5506 N_Parameter_Specification)
5507 and then not Scope_Within_Or_Same (Other_Scope, Enclosing_Subp)
5511 -- ... or the new declaration is in a package, and the visible
5512 -- declaration occurs outside that package.
5514 elsif Present (Enclosing_Pack)
5515 and then not Scope_Within_Or_Same (Other_Scope, Enclosing_Pack)
5519 -- ... or the new declaration is a component declaration in a
5520 -- record type definition.
5522 elsif Nkind (Parent (Def_Id)) = N_Component_Declaration then
5525 -- Don't issue error for non-source entities
5527 elsif Comes_From_Source (Def_Id)
5528 and then Comes_From_Source (C)
5530 Error_Msg_Sloc := Sloc (C);
5531 Check_SPARK_Restriction
5532 ("redeclaration of identifier &#", Def_Id);
5537 -- Warn if new entity hides an old one
5539 if Warn_On_Hiding and then Present (C)
5541 -- Don't warn for record components since they always have a well
5542 -- defined scope which does not confuse other uses. Note that in
5543 -- some cases, Ekind has not been set yet.
5545 and then Ekind (C) /= E_Component
5546 and then Ekind (C) /= E_Discriminant
5547 and then Nkind (Parent (C)) /= N_Component_Declaration
5548 and then Ekind (Def_Id) /= E_Component
5549 and then Ekind (Def_Id) /= E_Discriminant
5550 and then Nkind (Parent (Def_Id)) /= N_Component_Declaration
5552 -- Don't warn for one character variables. It is too common to use
5553 -- such variables as locals and will just cause too many false hits.
5555 and then Length_Of_Name (Chars (C)) /= 1
5557 -- Don't warn for non-source entities
5559 and then Comes_From_Source (C)
5560 and then Comes_From_Source (Def_Id)
5562 -- Don't warn unless entity in question is in extended main source
5564 and then In_Extended_Main_Source_Unit (Def_Id)
5566 -- Finally, the hidden entity must be either immediately visible or
5567 -- use visible (i.e. from a used package).
5570 (Is_Immediately_Visible (C)
5572 Is_Potentially_Use_Visible (C))
5574 Error_Msg_Sloc := Sloc (C);
5575 Error_Msg_N ("declaration hides &#?h?", Def_Id);
5583 function Entity_Of (N : Node_Id) return Entity_Id is
5589 if Is_Entity_Name (N) then
5592 -- Follow a possible chain of renamings to reach the root renamed
5595 while Present (Id) and then Present (Renamed_Object (Id)) loop
5596 if Is_Entity_Name (Renamed_Object (Id)) then
5597 Id := Entity (Renamed_Object (Id));
5608 --------------------------
5609 -- Explain_Limited_Type --
5610 --------------------------
5612 procedure Explain_Limited_Type (T : Entity_Id; N : Node_Id) is
5616 -- For array, component type must be limited
5618 if Is_Array_Type (T) then
5619 Error_Msg_Node_2 := T;
5621 ("\component type& of type& is limited", N, Component_Type (T));
5622 Explain_Limited_Type (Component_Type (T), N);
5624 elsif Is_Record_Type (T) then
5626 -- No need for extra messages if explicit limited record
5628 if Is_Limited_Record (Base_Type (T)) then
5632 -- Otherwise find a limited component. Check only components that
5633 -- come from source, or inherited components that appear in the
5634 -- source of the ancestor.
5636 C := First_Component (T);
5637 while Present (C) loop
5638 if Is_Limited_Type (Etype (C))
5640 (Comes_From_Source (C)
5642 (Present (Original_Record_Component (C))
5644 Comes_From_Source (Original_Record_Component (C))))
5646 Error_Msg_Node_2 := T;
5647 Error_Msg_NE ("\component& of type& has limited type", N, C);
5648 Explain_Limited_Type (Etype (C), N);
5655 -- The type may be declared explicitly limited, even if no component
5656 -- of it is limited, in which case we fall out of the loop.
5659 end Explain_Limited_Type;
5665 procedure Find_Actual
5667 Formal : out Entity_Id;
5670 Parnt : constant Node_Id := Parent (N);
5674 if (Nkind (Parnt) = N_Indexed_Component
5676 Nkind (Parnt) = N_Selected_Component)
5677 and then N = Prefix (Parnt)
5679 Find_Actual (Parnt, Formal, Call);
5682 elsif Nkind (Parnt) = N_Parameter_Association
5683 and then N = Explicit_Actual_Parameter (Parnt)
5685 Call := Parent (Parnt);
5687 elsif Nkind (Parnt) in N_Subprogram_Call then
5696 -- If we have a call to a subprogram look for the parameter. Note that
5697 -- we exclude overloaded calls, since we don't know enough to be sure
5698 -- of giving the right answer in this case.
5700 if Nkind_In (Call, N_Function_Call, N_Procedure_Call_Statement)
5701 and then Is_Entity_Name (Name (Call))
5702 and then Present (Entity (Name (Call)))
5703 and then Is_Overloadable (Entity (Name (Call)))
5704 and then not Is_Overloaded (Name (Call))
5706 -- Fall here if we are definitely a parameter
5708 Actual := First_Actual (Call);
5709 Formal := First_Formal (Entity (Name (Call)));
5710 while Present (Formal) and then Present (Actual) loop
5714 -- An actual that is the prefix in a prefixed call may have
5715 -- been rewritten in the call, after the deferred reference
5716 -- was collected. Check if sloc and kinds and names match.
5718 elsif Sloc (Actual) = Sloc (N)
5719 and then Nkind (Actual) = N_Identifier
5720 and then Nkind (Actual) = Nkind (N)
5721 and then Chars (Actual) = Chars (N)
5726 Actual := Next_Actual (Actual);
5727 Formal := Next_Formal (Formal);
5732 -- Fall through here if we did not find matching actual
5738 ---------------------------
5739 -- Find_Body_Discriminal --
5740 ---------------------------
5742 function Find_Body_Discriminal
5743 (Spec_Discriminant : Entity_Id) return Entity_Id
5749 -- If expansion is suppressed, then the scope can be the concurrent type
5750 -- itself rather than a corresponding concurrent record type.
5752 if Is_Concurrent_Type (Scope (Spec_Discriminant)) then
5753 Tsk := Scope (Spec_Discriminant);
5756 pragma Assert (Is_Concurrent_Record_Type (Scope (Spec_Discriminant)));
5758 Tsk := Corresponding_Concurrent_Type (Scope (Spec_Discriminant));
5761 -- Find discriminant of original concurrent type, and use its current
5762 -- discriminal, which is the renaming within the task/protected body.
5764 Disc := First_Discriminant (Tsk);
5765 while Present (Disc) loop
5766 if Chars (Disc) = Chars (Spec_Discriminant) then
5767 return Discriminal (Disc);
5770 Next_Discriminant (Disc);
5773 -- That loop should always succeed in finding a matching entry and
5774 -- returning. Fatal error if not.
5776 raise Program_Error;
5777 end Find_Body_Discriminal;
5779 -------------------------------------
5780 -- Find_Corresponding_Discriminant --
5781 -------------------------------------
5783 function Find_Corresponding_Discriminant
5785 Typ : Entity_Id) return Entity_Id
5787 Par_Disc : Entity_Id;
5788 Old_Disc : Entity_Id;
5789 New_Disc : Entity_Id;
5792 Par_Disc := Original_Record_Component (Original_Discriminant (Id));
5794 -- The original type may currently be private, and the discriminant
5795 -- only appear on its full view.
5797 if Is_Private_Type (Scope (Par_Disc))
5798 and then not Has_Discriminants (Scope (Par_Disc))
5799 and then Present (Full_View (Scope (Par_Disc)))
5801 Old_Disc := First_Discriminant (Full_View (Scope (Par_Disc)));
5803 Old_Disc := First_Discriminant (Scope (Par_Disc));
5806 if Is_Class_Wide_Type (Typ) then
5807 New_Disc := First_Discriminant (Root_Type (Typ));
5809 New_Disc := First_Discriminant (Typ);
5812 while Present (Old_Disc) and then Present (New_Disc) loop
5813 if Old_Disc = Par_Disc then
5816 Next_Discriminant (Old_Disc);
5817 Next_Discriminant (New_Disc);
5821 -- Should always find it
5823 raise Program_Error;
5824 end Find_Corresponding_Discriminant;
5826 ----------------------------------
5827 -- Find_Enclosing_Iterator_Loop --
5828 ----------------------------------
5830 function Find_Enclosing_Iterator_Loop (Id : Entity_Id) return Entity_Id is
5835 -- Traverse the scope chain looking for an iterator loop. Such loops are
5836 -- usually transformed into blocks, hence the use of Original_Node.
5839 while Present (S) and then S /= Standard_Standard loop
5840 if Ekind (S) = E_Loop
5841 and then Nkind (Parent (S)) = N_Implicit_Label_Declaration
5843 Constr := Original_Node (Label_Construct (Parent (S)));
5845 if Nkind (Constr) = N_Loop_Statement
5846 and then Present (Iteration_Scheme (Constr))
5847 and then Nkind (Iterator_Specification
5848 (Iteration_Scheme (Constr))) =
5849 N_Iterator_Specification
5859 end Find_Enclosing_Iterator_Loop;
5861 ------------------------------------
5862 -- Find_Loop_In_Conditional_Block --
5863 ------------------------------------
5865 function Find_Loop_In_Conditional_Block (N : Node_Id) return Node_Id is
5871 if Nkind (Stmt) = N_If_Statement then
5872 Stmt := First (Then_Statements (Stmt));
5875 pragma Assert (Nkind (Stmt) = N_Block_Statement);
5877 -- Inspect the statements of the conditional block. In general the loop
5878 -- should be the first statement in the statement sequence of the block,
5879 -- but the finalization machinery may have introduced extra object
5882 Stmt := First (Statements (Handled_Statement_Sequence (Stmt)));
5883 while Present (Stmt) loop
5884 if Nkind (Stmt) = N_Loop_Statement then
5891 -- The expansion of attribute 'Loop_Entry produced a malformed block
5893 raise Program_Error;
5894 end Find_Loop_In_Conditional_Block;
5896 --------------------------
5897 -- Find_Overlaid_Entity --
5898 --------------------------
5900 procedure Find_Overlaid_Entity
5902 Ent : out Entity_Id;
5908 -- We are looking for one of the two following forms:
5910 -- for X'Address use Y'Address
5914 -- Const : constant Address := expr;
5916 -- for X'Address use Const;
5918 -- In the second case, the expr is either Y'Address, or recursively a
5919 -- constant that eventually references Y'Address.
5924 if Nkind (N) = N_Attribute_Definition_Clause
5925 and then Chars (N) = Name_Address
5927 Expr := Expression (N);
5929 -- This loop checks the form of the expression for Y'Address,
5930 -- using recursion to deal with intermediate constants.
5933 -- Check for Y'Address
5935 if Nkind (Expr) = N_Attribute_Reference
5936 and then Attribute_Name (Expr) = Name_Address
5938 Expr := Prefix (Expr);
5941 -- Check for Const where Const is a constant entity
5943 elsif Is_Entity_Name (Expr)
5944 and then Ekind (Entity (Expr)) = E_Constant
5946 Expr := Constant_Value (Entity (Expr));
5948 -- Anything else does not need checking
5955 -- This loop checks the form of the prefix for an entity, using
5956 -- recursion to deal with intermediate components.
5959 -- Check for Y where Y is an entity
5961 if Is_Entity_Name (Expr) then
5962 Ent := Entity (Expr);
5965 -- Check for components
5968 Nkind_In (Expr, N_Selected_Component, N_Indexed_Component)
5970 Expr := Prefix (Expr);
5973 -- Anything else does not need checking
5980 end Find_Overlaid_Entity;
5982 -------------------------
5983 -- Find_Parameter_Type --
5984 -------------------------
5986 function Find_Parameter_Type (Param : Node_Id) return Entity_Id is
5988 if Nkind (Param) /= N_Parameter_Specification then
5991 -- For an access parameter, obtain the type from the formal entity
5992 -- itself, because access to subprogram nodes do not carry a type.
5993 -- Shouldn't we always use the formal entity ???
5995 elsif Nkind (Parameter_Type (Param)) = N_Access_Definition then
5996 return Etype (Defining_Identifier (Param));
5999 return Etype (Parameter_Type (Param));
6001 end Find_Parameter_Type;
6003 -----------------------------------
6004 -- Find_Placement_In_State_Space --
6005 -----------------------------------
6007 procedure Find_Placement_In_State_Space
6008 (Item_Id : Entity_Id;
6009 Placement : out State_Space_Kind;
6010 Pack_Id : out Entity_Id)
6012 Context : Entity_Id;
6015 -- Assume that the item does not appear in the state space of a package
6017 Placement := Not_In_Package;
6020 -- Climb the scope stack and examine the enclosing context
6022 Context := Scope (Item_Id);
6023 while Present (Context) and then Context /= Standard_Standard loop
6024 if Ekind (Context) = E_Package then
6027 -- A package body is a cut off point for the traversal as the item
6028 -- cannot be visible to the outside from this point on. Note that
6029 -- this test must be done first as a body is also classified as a
6032 if In_Package_Body (Context) then
6033 Placement := Body_State_Space;
6036 -- The private part of a package is a cut off point for the
6037 -- traversal as the item cannot be visible to the outside from
6040 elsif In_Private_Part (Context) then
6041 Placement := Private_State_Space;
6044 -- When the item appears in the visible state space of a package,
6045 -- continue to climb the scope stack as this may not be the final
6049 Placement := Visible_State_Space;
6051 -- The visible state space of a child unit acts as the proper
6052 -- placement of an item.
6054 if Is_Child_Unit (Context) then
6059 -- The item or its enclosing package appear in a construct that has
6063 Placement := Not_In_Package;
6067 Context := Scope (Context);
6069 end Find_Placement_In_State_Space;
6071 -----------------------------
6072 -- Find_Static_Alternative --
6073 -----------------------------
6075 function Find_Static_Alternative (N : Node_Id) return Node_Id is
6076 Expr : constant Node_Id := Expression (N);
6077 Val : constant Uint := Expr_Value (Expr);
6082 Alt := First (Alternatives (N));
6085 if Nkind (Alt) /= N_Pragma then
6086 Choice := First (Discrete_Choices (Alt));
6087 while Present (Choice) loop
6089 -- Others choice, always matches
6091 if Nkind (Choice) = N_Others_Choice then
6094 -- Range, check if value is in the range
6096 elsif Nkind (Choice) = N_Range then
6098 Val >= Expr_Value (Low_Bound (Choice))
6100 Val <= Expr_Value (High_Bound (Choice));
6102 -- Choice is a subtype name. Note that we know it must
6103 -- be a static subtype, since otherwise it would have
6104 -- been diagnosed as illegal.
6106 elsif Is_Entity_Name (Choice)
6107 and then Is_Type (Entity (Choice))
6109 exit Search when Is_In_Range (Expr, Etype (Choice),
6110 Assume_Valid => False);
6112 -- Choice is a subtype indication
6114 elsif Nkind (Choice) = N_Subtype_Indication then
6116 C : constant Node_Id := Constraint (Choice);
6117 R : constant Node_Id := Range_Expression (C);
6121 Val >= Expr_Value (Low_Bound (R))
6123 Val <= Expr_Value (High_Bound (R));
6126 -- Choice is a simple expression
6129 exit Search when Val = Expr_Value (Choice);
6137 pragma Assert (Present (Alt));
6140 -- The above loop *must* terminate by finding a match, since
6141 -- we know the case statement is valid, and the value of the
6142 -- expression is known at compile time. When we fall out of
6143 -- the loop, Alt points to the alternative that we know will
6144 -- be selected at run time.
6147 end Find_Static_Alternative;
6153 function First_Actual (Node : Node_Id) return Node_Id is
6157 if No (Parameter_Associations (Node)) then
6161 N := First (Parameter_Associations (Node));
6163 if Nkind (N) = N_Parameter_Association then
6164 return First_Named_Actual (Node);
6170 -----------------------
6171 -- Gather_Components --
6172 -----------------------
6174 procedure Gather_Components
6176 Comp_List : Node_Id;
6177 Governed_By : List_Id;
6179 Report_Errors : out Boolean)
6183 Discrete_Choice : Node_Id;
6184 Comp_Item : Node_Id;
6186 Discrim : Entity_Id;
6187 Discrim_Name : Node_Id;
6188 Discrim_Value : Node_Id;
6191 Report_Errors := False;
6193 if No (Comp_List) or else Null_Present (Comp_List) then
6196 elsif Present (Component_Items (Comp_List)) then
6197 Comp_Item := First (Component_Items (Comp_List));
6203 while Present (Comp_Item) loop
6205 -- Skip the tag of a tagged record, the interface tags, as well
6206 -- as all items that are not user components (anonymous types,
6207 -- rep clauses, Parent field, controller field).
6209 if Nkind (Comp_Item) = N_Component_Declaration then
6211 Comp : constant Entity_Id := Defining_Identifier (Comp_Item);
6213 if not Is_Tag (Comp)
6214 and then Chars (Comp) /= Name_uParent
6216 Append_Elmt (Comp, Into);
6224 if No (Variant_Part (Comp_List)) then
6227 Discrim_Name := Name (Variant_Part (Comp_List));
6228 Variant := First_Non_Pragma (Variants (Variant_Part (Comp_List)));
6231 -- Look for the discriminant that governs this variant part.
6232 -- The discriminant *must* be in the Governed_By List
6234 Assoc := First (Governed_By);
6235 Find_Constraint : loop
6236 Discrim := First (Choices (Assoc));
6237 exit Find_Constraint when Chars (Discrim_Name) = Chars (Discrim)
6238 or else (Present (Corresponding_Discriminant (Entity (Discrim)))
6240 Chars (Corresponding_Discriminant (Entity (Discrim))) =
6241 Chars (Discrim_Name))
6242 or else Chars (Original_Record_Component (Entity (Discrim)))
6243 = Chars (Discrim_Name);
6245 if No (Next (Assoc)) then
6246 if not Is_Constrained (Typ)
6247 and then Is_Derived_Type (Typ)
6248 and then Present (Stored_Constraint (Typ))
6250 -- If the type is a tagged type with inherited discriminants,
6251 -- use the stored constraint on the parent in order to find
6252 -- the values of discriminants that are otherwise hidden by an
6253 -- explicit constraint. Renamed discriminants are handled in
6256 -- If several parent discriminants are renamed by a single
6257 -- discriminant of the derived type, the call to obtain the
6258 -- Corresponding_Discriminant field only retrieves the last
6259 -- of them. We recover the constraint on the others from the
6260 -- Stored_Constraint as well.
6267 D := First_Discriminant (Etype (Typ));
6268 C := First_Elmt (Stored_Constraint (Typ));
6269 while Present (D) and then Present (C) loop
6270 if Chars (Discrim_Name) = Chars (D) then
6271 if Is_Entity_Name (Node (C))
6272 and then Entity (Node (C)) = Entity (Discrim)
6274 -- D is renamed by Discrim, whose value is given in
6281 Make_Component_Association (Sloc (Typ),
6283 (New_Occurrence_Of (D, Sloc (Typ))),
6284 Duplicate_Subexpr_No_Checks (Node (C)));
6286 exit Find_Constraint;
6289 Next_Discriminant (D);
6296 if No (Next (Assoc)) then
6297 Error_Msg_NE (" missing value for discriminant&",
6298 First (Governed_By), Discrim_Name);
6299 Report_Errors := True;
6304 end loop Find_Constraint;
6306 Discrim_Value := Expression (Assoc);
6308 if not Is_OK_Static_Expression (Discrim_Value) then
6310 ("value for discriminant & must be static!",
6311 Discrim_Value, Discrim);
6312 Why_Not_Static (Discrim_Value);
6313 Report_Errors := True;
6317 Search_For_Discriminant_Value : declare
6323 UI_Discrim_Value : constant Uint := Expr_Value (Discrim_Value);
6326 Find_Discrete_Value : while Present (Variant) loop
6327 Discrete_Choice := First (Discrete_Choices (Variant));
6328 while Present (Discrete_Choice) loop
6329 exit Find_Discrete_Value when
6330 Nkind (Discrete_Choice) = N_Others_Choice;
6332 Get_Index_Bounds (Discrete_Choice, Low, High);
6334 UI_Low := Expr_Value (Low);
6335 UI_High := Expr_Value (High);
6337 exit Find_Discrete_Value when
6338 UI_Low <= UI_Discrim_Value
6340 UI_High >= UI_Discrim_Value;
6342 Next (Discrete_Choice);
6345 Next_Non_Pragma (Variant);
6346 end loop Find_Discrete_Value;
6347 end Search_For_Discriminant_Value;
6349 if No (Variant) then
6351 ("value of discriminant & is out of range", Discrim_Value, Discrim);
6352 Report_Errors := True;
6356 -- If we have found the corresponding choice, recursively add its
6357 -- components to the Into list.
6360 (Empty, Component_List (Variant), Governed_By, Into, Report_Errors);
6361 end Gather_Components;
6363 ------------------------
6364 -- Get_Actual_Subtype --
6365 ------------------------
6367 function Get_Actual_Subtype (N : Node_Id) return Entity_Id is
6368 Typ : constant Entity_Id := Etype (N);
6369 Utyp : Entity_Id := Underlying_Type (Typ);
6378 -- If what we have is an identifier that references a subprogram
6379 -- formal, or a variable or constant object, then we get the actual
6380 -- subtype from the referenced entity if one has been built.
6382 if Nkind (N) = N_Identifier
6384 (Is_Formal (Entity (N))
6385 or else Ekind (Entity (N)) = E_Constant
6386 or else Ekind (Entity (N)) = E_Variable)
6387 and then Present (Actual_Subtype (Entity (N)))
6389 return Actual_Subtype (Entity (N));
6391 -- Actual subtype of unchecked union is always itself. We never need
6392 -- the "real" actual subtype. If we did, we couldn't get it anyway
6393 -- because the discriminant is not available. The restrictions on
6394 -- Unchecked_Union are designed to make sure that this is OK.
6396 elsif Is_Unchecked_Union (Base_Type (Utyp)) then
6399 -- Here for the unconstrained case, we must find actual subtype
6400 -- No actual subtype is available, so we must build it on the fly.
6402 -- Checking the type, not the underlying type, for constrainedness
6403 -- seems to be necessary. Maybe all the tests should be on the type???
6405 elsif (not Is_Constrained (Typ))
6406 and then (Is_Array_Type (Utyp)
6407 or else (Is_Record_Type (Utyp)
6408 and then Has_Discriminants (Utyp)))
6409 and then not Has_Unknown_Discriminants (Utyp)
6410 and then not (Ekind (Utyp) = E_String_Literal_Subtype)
6412 -- Nothing to do if in spec expression (why not???)
6414 if In_Spec_Expression then
6417 elsif Is_Private_Type (Typ)
6418 and then not Has_Discriminants (Typ)
6420 -- If the type has no discriminants, there is no subtype to
6421 -- build, even if the underlying type is discriminated.
6425 -- Else build the actual subtype
6428 Decl := Build_Actual_Subtype (Typ, N);
6429 Atyp := Defining_Identifier (Decl);
6431 -- If Build_Actual_Subtype generated a new declaration then use it
6435 -- The actual subtype is an Itype, so analyze the declaration,
6436 -- but do not attach it to the tree, to get the type defined.
6438 Set_Parent (Decl, N);
6439 Set_Is_Itype (Atyp);
6440 Analyze (Decl, Suppress => All_Checks);
6441 Set_Associated_Node_For_Itype (Atyp, N);
6442 Set_Has_Delayed_Freeze (Atyp, False);
6444 -- We need to freeze the actual subtype immediately. This is
6445 -- needed, because otherwise this Itype will not get frozen
6446 -- at all, and it is always safe to freeze on creation because
6447 -- any associated types must be frozen at this point.
6449 Freeze_Itype (Atyp, N);
6452 -- Otherwise we did not build a declaration, so return original
6459 -- For all remaining cases, the actual subtype is the same as
6460 -- the nominal type.
6465 end Get_Actual_Subtype;
6467 -------------------------------------
6468 -- Get_Actual_Subtype_If_Available --
6469 -------------------------------------
6471 function Get_Actual_Subtype_If_Available (N : Node_Id) return Entity_Id is
6472 Typ : constant Entity_Id := Etype (N);
6475 -- If what we have is an identifier that references a subprogram
6476 -- formal, or a variable or constant object, then we get the actual
6477 -- subtype from the referenced entity if one has been built.
6479 if Nkind (N) = N_Identifier
6481 (Is_Formal (Entity (N))
6482 or else Ekind (Entity (N)) = E_Constant
6483 or else Ekind (Entity (N)) = E_Variable)
6484 and then Present (Actual_Subtype (Entity (N)))
6486 return Actual_Subtype (Entity (N));
6488 -- Otherwise the Etype of N is returned unchanged
6493 end Get_Actual_Subtype_If_Available;
6495 ------------------------
6496 -- Get_Body_From_Stub --
6497 ------------------------
6499 function Get_Body_From_Stub (N : Node_Id) return Node_Id is
6501 return Proper_Body (Unit (Library_Unit (N)));
6502 end Get_Body_From_Stub;
6504 ---------------------
6505 -- Get_Cursor_Type --
6506 ---------------------
6508 function Get_Cursor_Type
6510 Typ : Entity_Id) return Entity_Id
6514 First_Op : Entity_Id;
6518 -- If error already detected, return
6520 if Error_Posted (Aspect) then
6524 -- The cursor type for an Iterable aspect is the return type of a
6525 -- non-overloaded First primitive operation. Locate association for
6528 Assoc := First (Component_Associations (Expression (Aspect)));
6530 while Present (Assoc) loop
6531 if Chars (First (Choices (Assoc))) = Name_First then
6532 First_Op := Expression (Assoc);
6539 if First_Op = Any_Id then
6540 Error_Msg_N ("aspect Iterable must specify First operation", Aspect);
6546 -- Locate function with desired name and profile in scope of type
6548 Func := First_Entity (Scope (Typ));
6549 while Present (Func) loop
6550 if Chars (Func) = Chars (First_Op)
6551 and then Ekind (Func) = E_Function
6552 and then Present (First_Formal (Func))
6553 and then Etype (First_Formal (Func)) = Typ
6554 and then No (Next_Formal (First_Formal (Func)))
6556 if Cursor /= Any_Type then
6558 ("Operation First for iterable type must be unique", Aspect);
6561 Cursor := Etype (Func);
6568 -- If not found, no way to resolve remaining primitives.
6570 if Cursor = Any_Type then
6572 ("No legal primitive operation First for Iterable type", Aspect);
6576 end Get_Cursor_Type;
6578 -------------------------------
6579 -- Get_Default_External_Name --
6580 -------------------------------
6582 function Get_Default_External_Name (E : Node_Or_Entity_Id) return Node_Id is
6584 Get_Decoded_Name_String (Chars (E));
6586 if Opt.External_Name_Imp_Casing = Uppercase then
6587 Set_Casing (All_Upper_Case);
6589 Set_Casing (All_Lower_Case);
6593 Make_String_Literal (Sloc (E),
6594 Strval => String_From_Name_Buffer);
6595 end Get_Default_External_Name;
6597 --------------------------
6598 -- Get_Enclosing_Object --
6599 --------------------------
6601 function Get_Enclosing_Object (N : Node_Id) return Entity_Id is
6603 if Is_Entity_Name (N) then
6607 when N_Indexed_Component |
6609 N_Selected_Component =>
6611 -- If not generating code, a dereference may be left implicit.
6612 -- In thoses cases, return Empty.
6614 if Is_Access_Type (Etype (Prefix (N))) then
6617 return Get_Enclosing_Object (Prefix (N));
6620 when N_Type_Conversion =>
6621 return Get_Enclosing_Object (Expression (N));
6627 end Get_Enclosing_Object;
6629 ---------------------------
6630 -- Get_Enum_Lit_From_Pos --
6631 ---------------------------
6633 function Get_Enum_Lit_From_Pos
6636 Loc : Source_Ptr) return Node_Id
6638 Btyp : Entity_Id := Base_Type (T);
6642 -- In the case where the literal is of type Character, Wide_Character
6643 -- or Wide_Wide_Character or of a type derived from them, there needs
6644 -- to be some special handling since there is no explicit chain of
6645 -- literals to search. Instead, an N_Character_Literal node is created
6646 -- with the appropriate Char_Code and Chars fields.
6648 if Is_Standard_Character_Type (T) then
6649 Set_Character_Literal_Name (UI_To_CC (Pos));
6651 Make_Character_Literal (Loc,
6653 Char_Literal_Value => Pos);
6655 -- For all other cases, we have a complete table of literals, and
6656 -- we simply iterate through the chain of literal until the one
6657 -- with the desired position value is found.
6661 if Is_Private_Type (Btyp) and then Present (Full_View (Btyp)) then
6662 Btyp := Full_View (Btyp);
6665 Lit := First_Literal (Btyp);
6666 for J in 1 .. UI_To_Int (Pos) loop
6670 return New_Occurrence_Of (Lit, Loc);
6672 end Get_Enum_Lit_From_Pos;
6674 ---------------------------------
6675 -- Get_Ensures_From_CTC_Pragma --
6676 ---------------------------------
6678 function Get_Ensures_From_CTC_Pragma (N : Node_Id) return Node_Id is
6679 Args : constant List_Id := Pragma_Argument_Associations (N);
6683 if List_Length (Args) = 4 then
6684 Res := Pick (Args, 4);
6686 elsif List_Length (Args) = 3 then
6687 Res := Pick (Args, 3);
6689 if Chars (Res) /= Name_Ensures then
6698 end Get_Ensures_From_CTC_Pragma;
6700 ------------------------
6701 -- Get_Generic_Entity --
6702 ------------------------
6704 function Get_Generic_Entity (N : Node_Id) return Entity_Id is
6705 Ent : constant Entity_Id := Entity (Name (N));
6707 if Present (Renamed_Object (Ent)) then
6708 return Renamed_Object (Ent);
6712 end Get_Generic_Entity;
6714 -------------------------------------
6715 -- Get_Incomplete_View_Of_Ancestor --
6716 -------------------------------------
6718 function Get_Incomplete_View_Of_Ancestor (E : Entity_Id) return Entity_Id is
6719 Cur_Unit : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
6720 Par_Scope : Entity_Id;
6721 Par_Type : Entity_Id;
6724 -- The incomplete view of an ancestor is only relevant for private
6725 -- derived types in child units.
6727 if not Is_Derived_Type (E)
6728 or else not Is_Child_Unit (Cur_Unit)
6733 Par_Scope := Scope (Cur_Unit);
6734 if No (Par_Scope) then
6738 Par_Type := Etype (Base_Type (E));
6740 -- Traverse list of ancestor types until we find one declared in
6741 -- a parent or grandparent unit (two levels seem sufficient).
6743 while Present (Par_Type) loop
6744 if Scope (Par_Type) = Par_Scope
6745 or else Scope (Par_Type) = Scope (Par_Scope)
6749 elsif not Is_Derived_Type (Par_Type) then
6753 Par_Type := Etype (Base_Type (Par_Type));
6757 -- If none found, there is no relevant ancestor type.
6761 end Get_Incomplete_View_Of_Ancestor;
6763 ----------------------
6764 -- Get_Index_Bounds --
6765 ----------------------
6767 procedure Get_Index_Bounds (N : Node_Id; L, H : out Node_Id) is
6768 Kind : constant Node_Kind := Nkind (N);
6772 if Kind = N_Range then
6774 H := High_Bound (N);
6776 elsif Kind = N_Subtype_Indication then
6777 R := Range_Expression (Constraint (N));
6785 L := Low_Bound (Range_Expression (Constraint (N)));
6786 H := High_Bound (Range_Expression (Constraint (N)));
6789 elsif Is_Entity_Name (N) and then Is_Type (Entity (N)) then
6790 if Error_Posted (Scalar_Range (Entity (N))) then
6794 elsif Nkind (Scalar_Range (Entity (N))) = N_Subtype_Indication then
6795 Get_Index_Bounds (Scalar_Range (Entity (N)), L, H);
6798 L := Low_Bound (Scalar_Range (Entity (N)));
6799 H := High_Bound (Scalar_Range (Entity (N)));
6803 -- N is an expression, indicating a range with one value
6808 end Get_Index_Bounds;
6810 ---------------------------------
6811 -- Get_Iterable_Type_Primitive --
6812 ---------------------------------
6814 function Get_Iterable_Type_Primitive
6816 Nam : Name_Id) return Entity_Id
6818 Funcs : constant Node_Id := Find_Value_Of_Aspect (Typ, Aspect_Iterable);
6826 Assoc := First (Component_Associations (Funcs));
6827 while Present (Assoc) loop
6828 if Chars (First (Choices (Assoc))) = Nam then
6829 return Entity (Expression (Assoc));
6832 Assoc := Next (Assoc);
6837 end Get_Iterable_Type_Primitive;
6839 ----------------------------------
6840 -- Get_Library_Unit_Name_string --
6841 ----------------------------------
6843 procedure Get_Library_Unit_Name_String (Decl_Node : Node_Id) is
6844 Unit_Name_Id : constant Unit_Name_Type := Get_Unit_Name (Decl_Node);
6847 Get_Unit_Name_String (Unit_Name_Id);
6849 -- Remove seven last character (" (spec)" or " (body)")
6851 Name_Len := Name_Len - 7;
6852 pragma Assert (Name_Buffer (Name_Len + 1) = ' ');
6853 end Get_Library_Unit_Name_String;
6855 ------------------------
6856 -- Get_Name_Entity_Id --
6857 ------------------------
6859 function Get_Name_Entity_Id (Id : Name_Id) return Entity_Id is
6861 return Entity_Id (Get_Name_Table_Info (Id));
6862 end Get_Name_Entity_Id;
6864 ------------------------------
6865 -- Get_Name_From_CTC_Pragma --
6866 ------------------------------
6868 function Get_Name_From_CTC_Pragma (N : Node_Id) return String_Id is
6869 Arg : constant Node_Id :=
6870 Get_Pragma_Arg (First (Pragma_Argument_Associations (N)));
6872 return Strval (Expr_Value_S (Arg));
6873 end Get_Name_From_CTC_Pragma;
6879 function Get_Pragma_Id (N : Node_Id) return Pragma_Id is
6881 return Get_Pragma_Id (Pragma_Name (N));
6884 -----------------------
6885 -- Get_Reason_String --
6886 -----------------------
6888 procedure Get_Reason_String (N : Node_Id) is
6890 if Nkind (N) = N_String_Literal then
6891 Store_String_Chars (Strval (N));
6893 elsif Nkind (N) = N_Op_Concat then
6894 Get_Reason_String (Left_Opnd (N));
6895 Get_Reason_String (Right_Opnd (N));
6897 -- If not of required form, error
6901 ("Reason for pragma Warnings has wrong form", N);
6903 ("\must be string literal or concatenation of string literals", N);
6906 end Get_Reason_String;
6908 ---------------------------
6909 -- Get_Referenced_Object --
6910 ---------------------------
6912 function Get_Referenced_Object (N : Node_Id) return Node_Id is
6917 while Is_Entity_Name (R)
6918 and then Present (Renamed_Object (Entity (R)))
6920 R := Renamed_Object (Entity (R));
6924 end Get_Referenced_Object;
6926 ------------------------
6927 -- Get_Renamed_Entity --
6928 ------------------------
6930 function Get_Renamed_Entity (E : Entity_Id) return Entity_Id is
6935 while Present (Renamed_Entity (R)) loop
6936 R := Renamed_Entity (R);
6940 end Get_Renamed_Entity;
6942 ----------------------------------
6943 -- Get_Requires_From_CTC_Pragma --
6944 ----------------------------------
6946 function Get_Requires_From_CTC_Pragma (N : Node_Id) return Node_Id is
6947 Args : constant List_Id := Pragma_Argument_Associations (N);
6951 if List_Length (Args) >= 3 then
6952 Res := Pick (Args, 3);
6954 if Chars (Res) /= Name_Requires then
6963 end Get_Requires_From_CTC_Pragma;
6965 -------------------------
6966 -- Get_Subprogram_Body --
6967 -------------------------
6969 function Get_Subprogram_Body (E : Entity_Id) return Node_Id is
6973 Decl := Unit_Declaration_Node (E);
6975 if Nkind (Decl) = N_Subprogram_Body then
6978 -- The below comment is bad, because it is possible for
6979 -- Nkind (Decl) to be an N_Subprogram_Body_Stub ???
6981 else -- Nkind (Decl) = N_Subprogram_Declaration
6983 if Present (Corresponding_Body (Decl)) then
6984 return Unit_Declaration_Node (Corresponding_Body (Decl));
6986 -- Imported subprogram case
6992 end Get_Subprogram_Body;
6994 ---------------------------
6995 -- Get_Subprogram_Entity --
6996 ---------------------------
6998 function Get_Subprogram_Entity (Nod : Node_Id) return Entity_Id is
7000 Subp_Id : Entity_Id;
7003 if Nkind (Nod) = N_Accept_Statement then
7004 Subp := Entry_Direct_Name (Nod);
7006 elsif Nkind (Nod) = N_Slice then
7007 Subp := Prefix (Nod);
7013 -- Strip the subprogram call
7016 if Nkind_In (Subp, N_Explicit_Dereference,
7017 N_Indexed_Component,
7018 N_Selected_Component)
7020 Subp := Prefix (Subp);
7022 elsif Nkind_In (Subp, N_Type_Conversion,
7023 N_Unchecked_Type_Conversion)
7025 Subp := Expression (Subp);
7032 -- Extract the entity of the subprogram call
7034 if Is_Entity_Name (Subp) then
7035 Subp_Id := Entity (Subp);
7037 if Ekind (Subp_Id) = E_Access_Subprogram_Type then
7038 Subp_Id := Directly_Designated_Type (Subp_Id);
7041 if Is_Subprogram (Subp_Id) then
7047 -- The search did not find a construct that denotes a subprogram
7052 end Get_Subprogram_Entity;
7054 -----------------------------
7055 -- Get_Task_Body_Procedure --
7056 -----------------------------
7058 function Get_Task_Body_Procedure (E : Entity_Id) return Node_Id is
7060 -- Note: A task type may be the completion of a private type with
7061 -- discriminants. When performing elaboration checks on a task
7062 -- declaration, the current view of the type may be the private one,
7063 -- and the procedure that holds the body of the task is held in its
7066 -- This is an odd function, why not have Task_Body_Procedure do
7067 -- the following digging???
7069 return Task_Body_Procedure (Underlying_Type (Root_Type (E)));
7070 end Get_Task_Body_Procedure;
7072 -----------------------
7073 -- Has_Access_Values --
7074 -----------------------
7076 function Has_Access_Values (T : Entity_Id) return Boolean is
7077 Typ : constant Entity_Id := Underlying_Type (T);
7080 -- Case of a private type which is not completed yet. This can only
7081 -- happen in the case of a generic format type appearing directly, or
7082 -- as a component of the type to which this function is being applied
7083 -- at the top level. Return False in this case, since we certainly do
7084 -- not know that the type contains access types.
7089 elsif Is_Access_Type (Typ) then
7092 elsif Is_Array_Type (Typ) then
7093 return Has_Access_Values (Component_Type (Typ));
7095 elsif Is_Record_Type (Typ) then
7100 -- Loop to Check components
7102 Comp := First_Component_Or_Discriminant (Typ);
7103 while Present (Comp) loop
7105 -- Check for access component, tag field does not count, even
7106 -- though it is implemented internally using an access type.
7108 if Has_Access_Values (Etype (Comp))
7109 and then Chars (Comp) /= Name_uTag
7114 Next_Component_Or_Discriminant (Comp);
7123 end Has_Access_Values;
7125 ------------------------------
7126 -- Has_Compatible_Alignment --
7127 ------------------------------
7129 function Has_Compatible_Alignment
7131 Expr : Node_Id) return Alignment_Result
7133 function Has_Compatible_Alignment_Internal
7136 Default : Alignment_Result) return Alignment_Result;
7137 -- This is the internal recursive function that actually does the work.
7138 -- There is one additional parameter, which says what the result should
7139 -- be if no alignment information is found, and there is no definite
7140 -- indication of compatible alignments. At the outer level, this is set
7141 -- to Unknown, but for internal recursive calls in the case where types
7142 -- are known to be correct, it is set to Known_Compatible.
7144 ---------------------------------------
7145 -- Has_Compatible_Alignment_Internal --
7146 ---------------------------------------
7148 function Has_Compatible_Alignment_Internal
7151 Default : Alignment_Result) return Alignment_Result
7153 Result : Alignment_Result := Known_Compatible;
7154 -- Holds the current status of the result. Note that once a value of
7155 -- Known_Incompatible is set, it is sticky and does not get changed
7156 -- to Unknown (the value in Result only gets worse as we go along,
7159 Offs : Uint := No_Uint;
7160 -- Set to a factor of the offset from the base object when Expr is a
7161 -- selected or indexed component, based on Component_Bit_Offset and
7162 -- Component_Size respectively. A negative value is used to represent
7163 -- a value which is not known at compile time.
7165 procedure Check_Prefix;
7166 -- Checks the prefix recursively in the case where the expression
7167 -- is an indexed or selected component.
7169 procedure Set_Result (R : Alignment_Result);
7170 -- If R represents a worse outcome (unknown instead of known
7171 -- compatible, or known incompatible), then set Result to R.
7177 procedure Check_Prefix is
7179 -- The subtlety here is that in doing a recursive call to check
7180 -- the prefix, we have to decide what to do in the case where we
7181 -- don't find any specific indication of an alignment problem.
7183 -- At the outer level, we normally set Unknown as the result in
7184 -- this case, since we can only set Known_Compatible if we really
7185 -- know that the alignment value is OK, but for the recursive
7186 -- call, in the case where the types match, and we have not
7187 -- specified a peculiar alignment for the object, we are only
7188 -- concerned about suspicious rep clauses, the default case does
7189 -- not affect us, since the compiler will, in the absence of such
7190 -- rep clauses, ensure that the alignment is correct.
7192 if Default = Known_Compatible
7194 (Etype (Obj) = Etype (Expr)
7195 and then (Unknown_Alignment (Obj)
7197 Alignment (Obj) = Alignment (Etype (Obj))))
7200 (Has_Compatible_Alignment_Internal
7201 (Obj, Prefix (Expr), Known_Compatible));
7203 -- In all other cases, we need a full check on the prefix
7207 (Has_Compatible_Alignment_Internal
7208 (Obj, Prefix (Expr), Unknown));
7216 procedure Set_Result (R : Alignment_Result) is
7223 -- Start of processing for Has_Compatible_Alignment_Internal
7226 -- If Expr is a selected component, we must make sure there is no
7227 -- potentially troublesome component clause, and that the record is
7230 if Nkind (Expr) = N_Selected_Component then
7232 -- Packed record always generate unknown alignment
7234 if Is_Packed (Etype (Prefix (Expr))) then
7235 Set_Result (Unknown);
7238 -- Check prefix and component offset
7241 Offs := Component_Bit_Offset (Entity (Selector_Name (Expr)));
7243 -- If Expr is an indexed component, we must make sure there is no
7244 -- potentially troublesome Component_Size clause and that the array
7245 -- is not bit-packed.
7247 elsif Nkind (Expr) = N_Indexed_Component then
7249 Typ : constant Entity_Id := Etype (Prefix (Expr));
7250 Ind : constant Node_Id := First_Index (Typ);
7253 -- Bit packed array always generates unknown alignment
7255 if Is_Bit_Packed_Array (Typ) then
7256 Set_Result (Unknown);
7259 -- Check prefix and component offset
7262 Offs := Component_Size (Typ);
7264 -- Small optimization: compute the full offset when possible
7267 and then Offs > Uint_0
7268 and then Present (Ind)
7269 and then Nkind (Ind) = N_Range
7270 and then Compile_Time_Known_Value (Low_Bound (Ind))
7271 and then Compile_Time_Known_Value (First (Expressions (Expr)))
7273 Offs := Offs * (Expr_Value (First (Expressions (Expr)))
7274 - Expr_Value (Low_Bound ((Ind))));
7279 -- If we have a null offset, the result is entirely determined by
7280 -- the base object and has already been computed recursively.
7282 if Offs = Uint_0 then
7285 -- Case where we know the alignment of the object
7287 elsif Known_Alignment (Obj) then
7289 ObjA : constant Uint := Alignment (Obj);
7290 ExpA : Uint := No_Uint;
7291 SizA : Uint := No_Uint;
7294 -- If alignment of Obj is 1, then we are always OK
7297 Set_Result (Known_Compatible);
7299 -- Alignment of Obj is greater than 1, so we need to check
7302 -- If we have an offset, see if it is compatible
7304 if Offs /= No_Uint and Offs > Uint_0 then
7305 if Offs mod (System_Storage_Unit * ObjA) /= 0 then
7306 Set_Result (Known_Incompatible);
7309 -- See if Expr is an object with known alignment
7311 elsif Is_Entity_Name (Expr)
7312 and then Known_Alignment (Entity (Expr))
7314 ExpA := Alignment (Entity (Expr));
7316 -- Otherwise, we can use the alignment of the type of
7317 -- Expr given that we already checked for
7318 -- discombobulating rep clauses for the cases of indexed
7319 -- and selected components above.
7321 elsif Known_Alignment (Etype (Expr)) then
7322 ExpA := Alignment (Etype (Expr));
7324 -- Otherwise the alignment is unknown
7327 Set_Result (Default);
7330 -- If we got an alignment, see if it is acceptable
7332 if ExpA /= No_Uint and then ExpA < ObjA then
7333 Set_Result (Known_Incompatible);
7336 -- If Expr is not a piece of a larger object, see if size
7337 -- is given. If so, check that it is not too small for the
7338 -- required alignment.
7340 if Offs /= No_Uint then
7343 -- See if Expr is an object with known size
7345 elsif Is_Entity_Name (Expr)
7346 and then Known_Static_Esize (Entity (Expr))
7348 SizA := Esize (Entity (Expr));
7350 -- Otherwise, we check the object size of the Expr type
7352 elsif Known_Static_Esize (Etype (Expr)) then
7353 SizA := Esize (Etype (Expr));
7356 -- If we got a size, see if it is a multiple of the Obj
7357 -- alignment, if not, then the alignment cannot be
7358 -- acceptable, since the size is always a multiple of the
7361 if SizA /= No_Uint then
7362 if SizA mod (ObjA * Ttypes.System_Storage_Unit) /= 0 then
7363 Set_Result (Known_Incompatible);
7369 -- If we do not know required alignment, any non-zero offset is a
7370 -- potential problem (but certainly may be OK, so result is unknown).
7372 elsif Offs /= No_Uint then
7373 Set_Result (Unknown);
7375 -- If we can't find the result by direct comparison of alignment
7376 -- values, then there is still one case that we can determine known
7377 -- result, and that is when we can determine that the types are the
7378 -- same, and no alignments are specified. Then we known that the
7379 -- alignments are compatible, even if we don't know the alignment
7380 -- value in the front end.
7382 elsif Etype (Obj) = Etype (Expr) then
7384 -- Types are the same, but we have to check for possible size
7385 -- and alignments on the Expr object that may make the alignment
7386 -- different, even though the types are the same.
7388 if Is_Entity_Name (Expr) then
7390 -- First check alignment of the Expr object. Any alignment less
7391 -- than Maximum_Alignment is worrisome since this is the case
7392 -- where we do not know the alignment of Obj.
7394 if Known_Alignment (Entity (Expr))
7396 UI_To_Int (Alignment (Entity (Expr))) <
7397 Ttypes.Maximum_Alignment
7399 Set_Result (Unknown);
7401 -- Now check size of Expr object. Any size that is not an
7402 -- even multiple of Maximum_Alignment is also worrisome
7403 -- since it may cause the alignment of the object to be less
7404 -- than the alignment of the type.
7406 elsif Known_Static_Esize (Entity (Expr))
7408 (UI_To_Int (Esize (Entity (Expr))) mod
7409 (Ttypes.Maximum_Alignment * Ttypes.System_Storage_Unit))
7412 Set_Result (Unknown);
7414 -- Otherwise same type is decisive
7417 Set_Result (Known_Compatible);
7421 -- Another case to deal with is when there is an explicit size or
7422 -- alignment clause when the types are not the same. If so, then the
7423 -- result is Unknown. We don't need to do this test if the Default is
7424 -- Unknown, since that result will be set in any case.
7426 elsif Default /= Unknown
7427 and then (Has_Size_Clause (Etype (Expr))
7429 Has_Alignment_Clause (Etype (Expr)))
7431 Set_Result (Unknown);
7433 -- If no indication found, set default
7436 Set_Result (Default);
7439 -- Return worst result found
7442 end Has_Compatible_Alignment_Internal;
7444 -- Start of processing for Has_Compatible_Alignment
7447 -- If Obj has no specified alignment, then set alignment from the type
7448 -- alignment. Perhaps we should always do this, but for sure we should
7449 -- do it when there is an address clause since we can do more if the
7450 -- alignment is known.
7452 if Unknown_Alignment (Obj) then
7453 Set_Alignment (Obj, Alignment (Etype (Obj)));
7456 -- Now do the internal call that does all the work
7458 return Has_Compatible_Alignment_Internal (Obj, Expr, Unknown);
7459 end Has_Compatible_Alignment;
7461 ----------------------
7462 -- Has_Declarations --
7463 ----------------------
7465 function Has_Declarations (N : Node_Id) return Boolean is
7467 return Nkind_In (Nkind (N), N_Accept_Statement,
7469 N_Compilation_Unit_Aux,
7475 N_Package_Specification);
7476 end Has_Declarations;
7482 function Has_Denormals (E : Entity_Id) return Boolean is
7484 return Is_Floating_Point_Type (E)
7485 and then Denorm_On_Target
7486 and then not Vax_Float (E);
7489 -------------------------------------------
7490 -- Has_Discriminant_Dependent_Constraint --
7491 -------------------------------------------
7493 function Has_Discriminant_Dependent_Constraint
7494 (Comp : Entity_Id) return Boolean
7496 Comp_Decl : constant Node_Id := Parent (Comp);
7497 Subt_Indic : Node_Id;
7502 -- Discriminants can't depend on discriminants
7504 if Ekind (Comp) = E_Discriminant then
7508 Subt_Indic := Subtype_Indication (Component_Definition (Comp_Decl));
7510 if Nkind (Subt_Indic) = N_Subtype_Indication then
7511 Constr := Constraint (Subt_Indic);
7513 if Nkind (Constr) = N_Index_Or_Discriminant_Constraint then
7514 Assn := First (Constraints (Constr));
7515 while Present (Assn) loop
7516 case Nkind (Assn) is
7517 when N_Subtype_Indication |
7521 if Depends_On_Discriminant (Assn) then
7525 when N_Discriminant_Association =>
7526 if Depends_On_Discriminant (Expression (Assn)) then
7541 end Has_Discriminant_Dependent_Constraint;
7543 --------------------------
7544 -- Has_Enabled_Property --
7545 --------------------------
7547 function Has_Enabled_Property
7548 (Item_Id : Entity_Id;
7549 Property : Name_Id) return Boolean
7551 function State_Has_Enabled_Property return Boolean;
7552 -- Determine whether a state denoted by Item_Id has the property
7554 function Variable_Has_Enabled_Property return Boolean;
7555 -- Determine whether a variable denoted by Item_Id has the property
7557 --------------------------------
7558 -- State_Has_Enabled_Property --
7559 --------------------------------
7561 function State_Has_Enabled_Property return Boolean is
7562 Decl : constant Node_Id := Parent (Item_Id);
7570 -- The declaration of an external abstract state appears as an
7571 -- extension aggregate. If this is not the case, properties can never
7574 if Nkind (Decl) /= N_Extension_Aggregate then
7578 -- When External appears as a simple option, it automatically enables
7581 Opt := First (Expressions (Decl));
7582 while Present (Opt) loop
7583 if Nkind (Opt) = N_Identifier
7584 and then Chars (Opt) = Name_External
7592 -- When External specifies particular properties, inspect those and
7593 -- find the desired one (if any).
7595 Opt := First (Component_Associations (Decl));
7596 while Present (Opt) loop
7597 Opt_Nam := First (Choices (Opt));
7599 if Nkind (Opt_Nam) = N_Identifier
7600 and then Chars (Opt_Nam) = Name_External
7602 Props := Expression (Opt);
7604 -- Multiple properties appear as an aggregate
7606 if Nkind (Props) = N_Aggregate then
7608 -- Simple property form
7610 Prop := First (Expressions (Props));
7611 while Present (Prop) loop
7612 if Chars (Prop) = Property then
7619 -- Property with expression form
7621 Prop := First (Component_Associations (Props));
7622 while Present (Prop) loop
7623 Prop_Nam := First (Choices (Prop));
7625 -- The property can be represented in two ways:
7626 -- others => <value>
7627 -- <property> => <value>
7629 if Nkind (Prop_Nam) = N_Others_Choice
7630 or else (Nkind (Prop_Nam) = N_Identifier
7631 and then Chars (Prop_Nam) = Property)
7633 return Is_True (Expr_Value (Expression (Prop)));
7642 return Chars (Props) = Property;
7650 end State_Has_Enabled_Property;
7652 -----------------------------------
7653 -- Variable_Has_Enabled_Property --
7654 -----------------------------------
7656 function Variable_Has_Enabled_Property return Boolean is
7657 AR : constant Node_Id :=
7658 Get_Pragma (Item_Id, Pragma_Async_Readers);
7659 AW : constant Node_Id :=
7660 Get_Pragma (Item_Id, Pragma_Async_Writers);
7661 ER : constant Node_Id :=
7662 Get_Pragma (Item_Id, Pragma_Effective_Reads);
7663 EW : constant Node_Id :=
7664 Get_Pragma (Item_Id, Pragma_Effective_Writes);
7666 -- A non-volatile object can never possess external properties
7668 if not Is_SPARK_Volatile (Item_Id) then
7671 -- External properties related to variables come in two flavors -
7672 -- explicit and implicit. The explicit case is characterized by the
7673 -- presence of a property pragma while the implicit case lacks all
7676 elsif Property = Name_Async_Readers
7680 (No (AW) and then No (ER) and then No (EW)))
7684 elsif Property = Name_Async_Writers
7688 (No (AR) and then No (ER) and then No (EW)))
7692 elsif Property = Name_Effective_Reads
7696 (No (AR) and then No (AW) and then No (EW)))
7700 elsif Property = Name_Effective_Writes
7702 (Present (EW) or else (No (AR) and then No (AW) and then No (ER)))
7709 end Variable_Has_Enabled_Property;
7711 -- Start of processing for Has_Enabled_Property
7714 -- Abstract states and variables have a flexible scheme of specifying
7715 -- external properties.
7717 if Ekind (Item_Id) = E_Abstract_State then
7718 return State_Has_Enabled_Property;
7720 elsif Ekind (Item_Id) = E_Variable then
7721 return Variable_Has_Enabled_Property;
7723 -- Otherwise a property is enabled when the related object is volatile
7726 return Is_SPARK_Volatile (Item_Id);
7728 end Has_Enabled_Property;
7730 --------------------
7731 -- Has_Infinities --
7732 --------------------
7734 function Has_Infinities (E : Entity_Id) return Boolean is
7737 Is_Floating_Point_Type (E)
7738 and then Nkind (Scalar_Range (E)) = N_Range
7739 and then Includes_Infinities (Scalar_Range (E));
7742 --------------------
7743 -- Has_Interfaces --
7744 --------------------
7746 function Has_Interfaces
7748 Use_Full_View : Boolean := True) return Boolean
7750 Typ : Entity_Id := Base_Type (T);
7753 -- Handle concurrent types
7755 if Is_Concurrent_Type (Typ) then
7756 Typ := Corresponding_Record_Type (Typ);
7759 if not Present (Typ)
7760 or else not Is_Record_Type (Typ)
7761 or else not Is_Tagged_Type (Typ)
7766 -- Handle private types
7769 and then Present (Full_View (Typ))
7771 Typ := Full_View (Typ);
7774 -- Handle concurrent record types
7776 if Is_Concurrent_Record_Type (Typ)
7777 and then Is_Non_Empty_List (Abstract_Interface_List (Typ))
7783 if Is_Interface (Typ)
7785 (Is_Record_Type (Typ)
7786 and then Present (Interfaces (Typ))
7787 and then not Is_Empty_Elmt_List (Interfaces (Typ)))
7792 exit when Etype (Typ) = Typ
7794 -- Handle private types
7796 or else (Present (Full_View (Etype (Typ)))
7797 and then Full_View (Etype (Typ)) = Typ)
7799 -- Protect the frontend against wrong source with cyclic
7802 or else Etype (Typ) = T;
7804 -- Climb to the ancestor type handling private types
7806 if Present (Full_View (Etype (Typ))) then
7807 Typ := Full_View (Etype (Typ));
7816 ---------------------------------
7817 -- Has_No_Obvious_Side_Effects --
7818 ---------------------------------
7820 function Has_No_Obvious_Side_Effects (N : Node_Id) return Boolean is
7822 -- For now, just handle literals, constants, and non-volatile
7823 -- variables and expressions combining these with operators or
7824 -- short circuit forms.
7826 if Nkind (N) in N_Numeric_Or_String_Literal then
7829 elsif Nkind (N) = N_Character_Literal then
7832 elsif Nkind (N) in N_Unary_Op then
7833 return Has_No_Obvious_Side_Effects (Right_Opnd (N));
7835 elsif Nkind (N) in N_Binary_Op or else Nkind (N) in N_Short_Circuit then
7836 return Has_No_Obvious_Side_Effects (Left_Opnd (N))
7838 Has_No_Obvious_Side_Effects (Right_Opnd (N));
7840 elsif Nkind (N) = N_Expression_With_Actions
7842 Is_Empty_List (Actions (N))
7844 return Has_No_Obvious_Side_Effects (Expression (N));
7846 elsif Nkind (N) in N_Has_Entity then
7847 return Present (Entity (N))
7848 and then Ekind_In (Entity (N), E_Variable,
7850 E_Enumeration_Literal,
7854 and then not Is_Volatile (Entity (N));
7859 end Has_No_Obvious_Side_Effects;
7861 ------------------------
7862 -- Has_Null_Exclusion --
7863 ------------------------
7865 function Has_Null_Exclusion (N : Node_Id) return Boolean is
7868 when N_Access_Definition |
7869 N_Access_Function_Definition |
7870 N_Access_Procedure_Definition |
7871 N_Access_To_Object_Definition |
7873 N_Derived_Type_Definition |
7874 N_Function_Specification |
7875 N_Subtype_Declaration =>
7876 return Null_Exclusion_Present (N);
7878 when N_Component_Definition |
7879 N_Formal_Object_Declaration |
7880 N_Object_Renaming_Declaration =>
7881 if Present (Subtype_Mark (N)) then
7882 return Null_Exclusion_Present (N);
7883 else pragma Assert (Present (Access_Definition (N)));
7884 return Null_Exclusion_Present (Access_Definition (N));
7887 when N_Discriminant_Specification =>
7888 if Nkind (Discriminant_Type (N)) = N_Access_Definition then
7889 return Null_Exclusion_Present (Discriminant_Type (N));
7891 return Null_Exclusion_Present (N);
7894 when N_Object_Declaration =>
7895 if Nkind (Object_Definition (N)) = N_Access_Definition then
7896 return Null_Exclusion_Present (Object_Definition (N));
7898 return Null_Exclusion_Present (N);
7901 when N_Parameter_Specification =>
7902 if Nkind (Parameter_Type (N)) = N_Access_Definition then
7903 return Null_Exclusion_Present (Parameter_Type (N));
7905 return Null_Exclusion_Present (N);
7912 end Has_Null_Exclusion;
7914 ------------------------
7915 -- Has_Null_Extension --
7916 ------------------------
7918 function Has_Null_Extension (T : Entity_Id) return Boolean is
7919 B : constant Entity_Id := Base_Type (T);
7924 if Nkind (Parent (B)) = N_Full_Type_Declaration
7925 and then Present (Record_Extension_Part (Type_Definition (Parent (B))))
7927 Ext := Record_Extension_Part (Type_Definition (Parent (B)));
7929 if Present (Ext) then
7930 if Null_Present (Ext) then
7933 Comps := Component_List (Ext);
7935 -- The null component list is rewritten during analysis to
7936 -- include the parent component. Any other component indicates
7937 -- that the extension was not originally null.
7939 return Null_Present (Comps)
7940 or else No (Next (First (Component_Items (Comps))));
7949 end Has_Null_Extension;
7951 -------------------------------
7952 -- Has_Overriding_Initialize --
7953 -------------------------------
7955 function Has_Overriding_Initialize (T : Entity_Id) return Boolean is
7956 BT : constant Entity_Id := Base_Type (T);
7960 if Is_Controlled (BT) then
7961 if Is_RTU (Scope (BT), Ada_Finalization) then
7964 elsif Present (Primitive_Operations (BT)) then
7965 P := First_Elmt (Primitive_Operations (BT));
7966 while Present (P) loop
7968 Init : constant Entity_Id := Node (P);
7969 Formal : constant Entity_Id := First_Formal (Init);
7971 if Ekind (Init) = E_Procedure
7972 and then Chars (Init) = Name_Initialize
7973 and then Comes_From_Source (Init)
7974 and then Present (Formal)
7975 and then Etype (Formal) = BT
7976 and then No (Next_Formal (Formal))
7977 and then (Ada_Version < Ada_2012
7978 or else not Null_Present (Parent (Init)))
7988 -- Here if type itself does not have a non-null Initialize operation:
7989 -- check immediate ancestor.
7991 if Is_Derived_Type (BT)
7992 and then Has_Overriding_Initialize (Etype (BT))
7999 end Has_Overriding_Initialize;
8001 --------------------------------------
8002 -- Has_Preelaborable_Initialization --
8003 --------------------------------------
8005 function Has_Preelaborable_Initialization (E : Entity_Id) return Boolean is
8008 procedure Check_Components (E : Entity_Id);
8009 -- Check component/discriminant chain, sets Has_PE False if a component
8010 -- or discriminant does not meet the preelaborable initialization rules.
8012 ----------------------
8013 -- Check_Components --
8014 ----------------------
8016 procedure Check_Components (E : Entity_Id) is
8020 function Is_Preelaborable_Expression (N : Node_Id) return Boolean;
8021 -- Returns True if and only if the expression denoted by N does not
8022 -- violate restrictions on preelaborable constructs (RM-10.2.1(5-9)).
8024 ---------------------------------
8025 -- Is_Preelaborable_Expression --
8026 ---------------------------------
8028 function Is_Preelaborable_Expression (N : Node_Id) return Boolean is
8032 Comp_Type : Entity_Id;
8033 Is_Array_Aggr : Boolean;
8036 if Is_Static_Expression (N) then
8039 elsif Nkind (N) = N_Null then
8042 -- Attributes are allowed in general, even if their prefix is a
8043 -- formal type. (It seems that certain attributes known not to be
8044 -- static might not be allowed, but there are no rules to prevent
8047 elsif Nkind (N) = N_Attribute_Reference then
8050 -- The name of a discriminant evaluated within its parent type is
8051 -- defined to be preelaborable (10.2.1(8)). Note that we test for
8052 -- names that denote discriminals as well as discriminants to
8053 -- catch references occurring within init procs.
8055 elsif Is_Entity_Name (N)
8057 (Ekind (Entity (N)) = E_Discriminant
8059 ((Ekind (Entity (N)) = E_Constant
8060 or else Ekind (Entity (N)) = E_In_Parameter)
8061 and then Present (Discriminal_Link (Entity (N)))))
8065 elsif Nkind (N) = N_Qualified_Expression then
8066 return Is_Preelaborable_Expression (Expression (N));
8068 -- For aggregates we have to check that each of the associations
8069 -- is preelaborable.
8071 elsif Nkind (N) = N_Aggregate
8072 or else Nkind (N) = N_Extension_Aggregate
8074 Is_Array_Aggr := Is_Array_Type (Etype (N));
8076 if Is_Array_Aggr then
8077 Comp_Type := Component_Type (Etype (N));
8080 -- Check the ancestor part of extension aggregates, which must
8081 -- be either the name of a type that has preelaborable init or
8082 -- an expression that is preelaborable.
8084 if Nkind (N) = N_Extension_Aggregate then
8086 Anc_Part : constant Node_Id := Ancestor_Part (N);
8089 if Is_Entity_Name (Anc_Part)
8090 and then Is_Type (Entity (Anc_Part))
8092 if not Has_Preelaborable_Initialization
8098 elsif not Is_Preelaborable_Expression (Anc_Part) then
8104 -- Check positional associations
8106 Exp := First (Expressions (N));
8107 while Present (Exp) loop
8108 if not Is_Preelaborable_Expression (Exp) then
8115 -- Check named associations
8117 Assn := First (Component_Associations (N));
8118 while Present (Assn) loop
8119 Choice := First (Choices (Assn));
8120 while Present (Choice) loop
8121 if Is_Array_Aggr then
8122 if Nkind (Choice) = N_Others_Choice then
8125 elsif Nkind (Choice) = N_Range then
8126 if not Is_Static_Range (Choice) then
8130 elsif not Is_Static_Expression (Choice) then
8135 Comp_Type := Etype (Choice);
8141 -- If the association has a <> at this point, then we have
8142 -- to check whether the component's type has preelaborable
8143 -- initialization. Note that this only occurs when the
8144 -- association's corresponding component does not have a
8145 -- default expression, the latter case having already been
8146 -- expanded as an expression for the association.
8148 if Box_Present (Assn) then
8149 if not Has_Preelaborable_Initialization (Comp_Type) then
8153 -- In the expression case we check whether the expression
8154 -- is preelaborable.
8157 not Is_Preelaborable_Expression (Expression (Assn))
8165 -- If we get here then aggregate as a whole is preelaborable
8169 -- All other cases are not preelaborable
8174 end Is_Preelaborable_Expression;
8176 -- Start of processing for Check_Components
8179 -- Loop through entities of record or protected type
8182 while Present (Ent) loop
8184 -- We are interested only in components and discriminants
8191 -- Get default expression if any. If there is no declaration
8192 -- node, it means we have an internal entity. The parent and
8193 -- tag fields are examples of such entities. For such cases,
8194 -- we just test the type of the entity.
8196 if Present (Declaration_Node (Ent)) then
8197 Exp := Expression (Declaration_Node (Ent));
8200 when E_Discriminant =>
8202 -- Note: for a renamed discriminant, the Declaration_Node
8203 -- may point to the one from the ancestor, and have a
8204 -- different expression, so use the proper attribute to
8205 -- retrieve the expression from the derived constraint.
8207 Exp := Discriminant_Default_Value (Ent);
8210 goto Check_Next_Entity;
8213 -- A component has PI if it has no default expression and the
8214 -- component type has PI.
8217 if not Has_Preelaborable_Initialization (Etype (Ent)) then
8222 -- Require the default expression to be preelaborable
8224 elsif not Is_Preelaborable_Expression (Exp) then
8229 <<Check_Next_Entity>>
8232 end Check_Components;
8234 -- Start of processing for Has_Preelaborable_Initialization
8237 -- Immediate return if already marked as known preelaborable init. This
8238 -- covers types for which this function has already been called once
8239 -- and returned True (in which case the result is cached), and also
8240 -- types to which a pragma Preelaborable_Initialization applies.
8242 if Known_To_Have_Preelab_Init (E) then
8246 -- If the type is a subtype representing a generic actual type, then
8247 -- test whether its base type has preelaborable initialization since
8248 -- the subtype representing the actual does not inherit this attribute
8249 -- from the actual or formal. (but maybe it should???)
8251 if Is_Generic_Actual_Type (E) then
8252 return Has_Preelaborable_Initialization (Base_Type (E));
8255 -- All elementary types have preelaborable initialization
8257 if Is_Elementary_Type (E) then
8260 -- Array types have PI if the component type has PI
8262 elsif Is_Array_Type (E) then
8263 Has_PE := Has_Preelaborable_Initialization (Component_Type (E));
8265 -- A derived type has preelaborable initialization if its parent type
8266 -- has preelaborable initialization and (in the case of a derived record
8267 -- extension) if the non-inherited components all have preelaborable
8268 -- initialization. However, a user-defined controlled type with an
8269 -- overriding Initialize procedure does not have preelaborable
8272 elsif Is_Derived_Type (E) then
8274 -- If the derived type is a private extension then it doesn't have
8275 -- preelaborable initialization.
8277 if Ekind (Base_Type (E)) = E_Record_Type_With_Private then
8281 -- First check whether ancestor type has preelaborable initialization
8283 Has_PE := Has_Preelaborable_Initialization (Etype (Base_Type (E)));
8285 -- If OK, check extension components (if any)
8287 if Has_PE and then Is_Record_Type (E) then
8288 Check_Components (First_Entity (E));
8291 -- Check specifically for 10.2.1(11.4/2) exception: a controlled type
8292 -- with a user defined Initialize procedure does not have PI.
8295 and then Is_Controlled (E)
8296 and then Has_Overriding_Initialize (E)
8301 -- Private types not derived from a type having preelaborable init and
8302 -- that are not marked with pragma Preelaborable_Initialization do not
8303 -- have preelaborable initialization.
8305 elsif Is_Private_Type (E) then
8308 -- Record type has PI if it is non private and all components have PI
8310 elsif Is_Record_Type (E) then
8312 Check_Components (First_Entity (E));
8314 -- Protected types must not have entries, and components must meet
8315 -- same set of rules as for record components.
8317 elsif Is_Protected_Type (E) then
8318 if Has_Entries (E) then
8322 Check_Components (First_Entity (E));
8323 Check_Components (First_Private_Entity (E));
8326 -- Type System.Address always has preelaborable initialization
8328 elsif Is_RTE (E, RE_Address) then
8331 -- In all other cases, type does not have preelaborable initialization
8337 -- If type has preelaborable initialization, cache result
8340 Set_Known_To_Have_Preelab_Init (E);
8344 end Has_Preelaborable_Initialization;
8346 ---------------------------
8347 -- Has_Private_Component --
8348 ---------------------------
8350 function Has_Private_Component (Type_Id : Entity_Id) return Boolean is
8351 Btype : Entity_Id := Base_Type (Type_Id);
8352 Component : Entity_Id;
8355 if Error_Posted (Type_Id)
8356 or else Error_Posted (Btype)
8361 if Is_Class_Wide_Type (Btype) then
8362 Btype := Root_Type (Btype);
8365 if Is_Private_Type (Btype) then
8367 UT : constant Entity_Id := Underlying_Type (Btype);
8370 if No (Full_View (Btype)) then
8371 return not Is_Generic_Type (Btype)
8372 and then not Is_Generic_Type (Root_Type (Btype));
8374 return not Is_Generic_Type (Root_Type (Full_View (Btype)));
8377 return not Is_Frozen (UT) and then Has_Private_Component (UT);
8381 elsif Is_Array_Type (Btype) then
8382 return Has_Private_Component (Component_Type (Btype));
8384 elsif Is_Record_Type (Btype) then
8385 Component := First_Component (Btype);
8386 while Present (Component) loop
8387 if Has_Private_Component (Etype (Component)) then
8391 Next_Component (Component);
8396 elsif Is_Protected_Type (Btype)
8397 and then Present (Corresponding_Record_Type (Btype))
8399 return Has_Private_Component (Corresponding_Record_Type (Btype));
8404 end Has_Private_Component;
8406 ----------------------
8407 -- Has_Signed_Zeros --
8408 ----------------------
8410 function Has_Signed_Zeros (E : Entity_Id) return Boolean is
8412 return Is_Floating_Point_Type (E)
8413 and then Signed_Zeros_On_Target
8414 and then not Vax_Float (E);
8415 end Has_Signed_Zeros;
8417 -----------------------------
8418 -- Has_Static_Array_Bounds --
8419 -----------------------------
8421 function Has_Static_Array_Bounds (Typ : Node_Id) return Boolean is
8422 Ndims : constant Nat := Number_Dimensions (Typ);
8429 -- Unconstrained types do not have static bounds
8431 if not Is_Constrained (Typ) then
8435 -- First treat string literals specially, as the lower bound and length
8436 -- of string literals are not stored like those of arrays.
8438 -- A string literal always has static bounds
8440 if Ekind (Typ) = E_String_Literal_Subtype then
8444 -- Treat all dimensions in turn
8446 Index := First_Index (Typ);
8447 for Indx in 1 .. Ndims loop
8449 -- In case of an illegal index which is not a discrete type, return
8450 -- that the type is not static.
8452 if not Is_Discrete_Type (Etype (Index))
8453 or else Etype (Index) = Any_Type
8458 Get_Index_Bounds (Index, Low, High);
8460 if Error_Posted (Low) or else Error_Posted (High) then
8464 if Is_OK_Static_Expression (Low)
8466 Is_OK_Static_Expression (High)
8476 -- If we fall through the loop, all indexes matched
8479 end Has_Static_Array_Bounds;
8485 function Has_Stream (T : Entity_Id) return Boolean is
8492 elsif Is_RTE (Root_Type (T), RE_Root_Stream_Type) then
8495 elsif Is_Array_Type (T) then
8496 return Has_Stream (Component_Type (T));
8498 elsif Is_Record_Type (T) then
8499 E := First_Component (T);
8500 while Present (E) loop
8501 if Has_Stream (Etype (E)) then
8510 elsif Is_Private_Type (T) then
8511 return Has_Stream (Underlying_Type (T));
8522 function Has_Suffix (E : Entity_Id; Suffix : Character) return Boolean is
8524 Get_Name_String (Chars (E));
8525 return Name_Buffer (Name_Len) = Suffix;
8532 function Add_Suffix (E : Entity_Id; Suffix : Character) return Name_Id is
8534 Get_Name_String (Chars (E));
8535 Add_Char_To_Name_Buffer (Suffix);
8543 function Remove_Suffix (E : Entity_Id; Suffix : Character) return Name_Id is
8545 pragma Assert (Has_Suffix (E, Suffix));
8546 Get_Name_String (Chars (E));
8547 Name_Len := Name_Len - 1;
8551 --------------------------
8552 -- Has_Tagged_Component --
8553 --------------------------
8555 function Has_Tagged_Component (Typ : Entity_Id) return Boolean is
8559 if Is_Private_Type (Typ)
8560 and then Present (Underlying_Type (Typ))
8562 return Has_Tagged_Component (Underlying_Type (Typ));
8564 elsif Is_Array_Type (Typ) then
8565 return Has_Tagged_Component (Component_Type (Typ));
8567 elsif Is_Tagged_Type (Typ) then
8570 elsif Is_Record_Type (Typ) then
8571 Comp := First_Component (Typ);
8572 while Present (Comp) loop
8573 if Has_Tagged_Component (Etype (Comp)) then
8577 Next_Component (Comp);
8585 end Has_Tagged_Component;
8587 ----------------------------
8588 -- Has_Volatile_Component --
8589 ----------------------------
8591 function Has_Volatile_Component (Typ : Entity_Id) return Boolean is
8595 if Has_Volatile_Components (Typ) then
8598 elsif Is_Array_Type (Typ) then
8599 return Is_Volatile (Component_Type (Typ));
8601 elsif Is_Record_Type (Typ) then
8602 Comp := First_Component (Typ);
8603 while Present (Comp) loop
8604 if Is_Volatile_Object (Comp) then
8608 Comp := Next_Component (Comp);
8613 end Has_Volatile_Component;
8615 -------------------------
8616 -- Implementation_Kind --
8617 -------------------------
8619 function Implementation_Kind (Subp : Entity_Id) return Name_Id is
8620 Impl_Prag : constant Node_Id := Get_Rep_Pragma (Subp, Name_Implemented);
8623 pragma Assert (Present (Impl_Prag));
8624 Arg := Last (Pragma_Argument_Associations (Impl_Prag));
8625 return Chars (Get_Pragma_Arg (Arg));
8626 end Implementation_Kind;
8628 --------------------------
8629 -- Implements_Interface --
8630 --------------------------
8632 function Implements_Interface
8633 (Typ_Ent : Entity_Id;
8634 Iface_Ent : Entity_Id;
8635 Exclude_Parents : Boolean := False) return Boolean
8637 Ifaces_List : Elist_Id;
8639 Iface : Entity_Id := Base_Type (Iface_Ent);
8640 Typ : Entity_Id := Base_Type (Typ_Ent);
8643 if Is_Class_Wide_Type (Typ) then
8644 Typ := Root_Type (Typ);
8647 if not Has_Interfaces (Typ) then
8651 if Is_Class_Wide_Type (Iface) then
8652 Iface := Root_Type (Iface);
8655 Collect_Interfaces (Typ, Ifaces_List);
8657 Elmt := First_Elmt (Ifaces_List);
8658 while Present (Elmt) loop
8659 if Is_Ancestor (Node (Elmt), Typ, Use_Full_View => True)
8660 and then Exclude_Parents
8664 elsif Node (Elmt) = Iface then
8672 end Implements_Interface;
8674 ------------------------------------
8675 -- In_Assertion_Expression_Pragma --
8676 ------------------------------------
8678 function In_Assertion_Expression_Pragma (N : Node_Id) return Boolean is
8680 Prag : Node_Id := Empty;
8683 -- Climb the parent chain looking for an enclosing pragma
8686 while Present (Par) loop
8687 if Nkind (Par) = N_Pragma then
8691 -- Precondition-like pragmas are expanded into if statements, check
8692 -- the original node instead.
8694 elsif Nkind (Original_Node (Par)) = N_Pragma then
8695 Prag := Original_Node (Par);
8698 -- Prevent the search from going too far
8700 elsif Is_Body_Or_Package_Declaration (Par) then
8704 Par := Parent (Par);
8709 and then Assertion_Expression_Pragma (Get_Pragma_Id (Prag));
8710 end In_Assertion_Expression_Pragma;
8716 function In_Instance return Boolean is
8717 Curr_Unit : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
8723 and then S /= Standard_Standard
8725 if (Ekind (S) = E_Function
8726 or else Ekind (S) = E_Package
8727 or else Ekind (S) = E_Procedure)
8728 and then Is_Generic_Instance (S)
8730 -- A child instance is always compiled in the context of a parent
8731 -- instance. Nevertheless, the actuals are not analyzed in an
8732 -- instance context. We detect this case by examining the current
8733 -- compilation unit, which must be a child instance, and checking
8734 -- that it is not currently on the scope stack.
8736 if Is_Child_Unit (Curr_Unit)
8738 Nkind (Unit (Cunit (Current_Sem_Unit)))
8739 = N_Package_Instantiation
8740 and then not In_Open_Scopes (Curr_Unit)
8754 ----------------------
8755 -- In_Instance_Body --
8756 ----------------------
8758 function In_Instance_Body return Boolean is
8764 and then S /= Standard_Standard
8766 if (Ekind (S) = E_Function
8767 or else Ekind (S) = E_Procedure)
8768 and then Is_Generic_Instance (S)
8772 elsif Ekind (S) = E_Package
8773 and then In_Package_Body (S)
8774 and then Is_Generic_Instance (S)
8783 end In_Instance_Body;
8785 -----------------------------
8786 -- In_Instance_Not_Visible --
8787 -----------------------------
8789 function In_Instance_Not_Visible return Boolean is
8795 and then S /= Standard_Standard
8797 if (Ekind (S) = E_Function
8798 or else Ekind (S) = E_Procedure)
8799 and then Is_Generic_Instance (S)
8803 elsif Ekind (S) = E_Package
8804 and then (In_Package_Body (S) or else In_Private_Part (S))
8805 and then Is_Generic_Instance (S)
8814 end In_Instance_Not_Visible;
8816 ------------------------------
8817 -- In_Instance_Visible_Part --
8818 ------------------------------
8820 function In_Instance_Visible_Part return Boolean is
8826 and then S /= Standard_Standard
8828 if Ekind (S) = E_Package
8829 and then Is_Generic_Instance (S)
8830 and then not In_Package_Body (S)
8831 and then not In_Private_Part (S)
8840 end In_Instance_Visible_Part;
8842 ---------------------
8843 -- In_Package_Body --
8844 ---------------------
8846 function In_Package_Body return Boolean is
8852 and then S /= Standard_Standard
8854 if Ekind (S) = E_Package
8855 and then In_Package_Body (S)
8864 end In_Package_Body;
8866 --------------------------------
8867 -- In_Parameter_Specification --
8868 --------------------------------
8870 function In_Parameter_Specification (N : Node_Id) return Boolean is
8875 while Present (PN) loop
8876 if Nkind (PN) = N_Parameter_Specification then
8884 end In_Parameter_Specification;
8886 --------------------------
8887 -- In_Pragma_Expression --
8888 --------------------------
8890 function In_Pragma_Expression (N : Node_Id; Nam : Name_Id) return Boolean is
8897 elsif Nkind (P) = N_Pragma and then Pragma_Name (P) = Nam then
8903 end In_Pragma_Expression;
8905 -------------------------------------
8906 -- In_Reverse_Storage_Order_Object --
8907 -------------------------------------
8909 function In_Reverse_Storage_Order_Object (N : Node_Id) return Boolean is
8911 Btyp : Entity_Id := Empty;
8914 -- Climb up indexed components
8918 case Nkind (Pref) is
8919 when N_Selected_Component =>
8920 Pref := Prefix (Pref);
8923 when N_Indexed_Component =>
8924 Pref := Prefix (Pref);
8932 if Present (Pref) then
8933 Btyp := Base_Type (Etype (Pref));
8938 and then (Is_Record_Type (Btyp) or else Is_Array_Type (Btyp))
8939 and then Reverse_Storage_Order (Btyp);
8940 end In_Reverse_Storage_Order_Object;
8942 --------------------------------------
8943 -- In_Subprogram_Or_Concurrent_Unit --
8944 --------------------------------------
8946 function In_Subprogram_Or_Concurrent_Unit return Boolean is
8951 -- Use scope chain to check successively outer scopes
8957 if K in Subprogram_Kind
8958 or else K in Concurrent_Kind
8959 or else K in Generic_Subprogram_Kind
8963 elsif E = Standard_Standard then
8969 end In_Subprogram_Or_Concurrent_Unit;
8971 ---------------------
8972 -- In_Visible_Part --
8973 ---------------------
8975 function In_Visible_Part (Scope_Id : Entity_Id) return Boolean is
8978 Is_Package_Or_Generic_Package (Scope_Id)
8979 and then In_Open_Scopes (Scope_Id)
8980 and then not In_Package_Body (Scope_Id)
8981 and then not In_Private_Part (Scope_Id);
8982 end In_Visible_Part;
8984 --------------------------------
8985 -- Incomplete_Or_Private_View --
8986 --------------------------------
8988 function Incomplete_Or_Private_View (Typ : Entity_Id) return Entity_Id is
8989 function Inspect_Decls
8991 Taft : Boolean := False) return Entity_Id;
8992 -- Check whether a declarative region contains the incomplete or private
8999 function Inspect_Decls
9001 Taft : Boolean := False) return Entity_Id
9007 Decl := First (Decls);
9008 while Present (Decl) loop
9012 if Nkind (Decl) = N_Incomplete_Type_Declaration then
9013 Match := Defining_Identifier (Decl);
9017 if Nkind_In (Decl, N_Private_Extension_Declaration,
9018 N_Private_Type_Declaration)
9020 Match := Defining_Identifier (Decl);
9025 and then Present (Full_View (Match))
9026 and then Full_View (Match) = Typ
9041 -- Start of processing for Incomplete_Or_Partial_View
9044 -- Incomplete type case
9046 Prev := Current_Entity_In_Scope (Typ);
9049 and then Is_Incomplete_Type (Prev)
9050 and then Present (Full_View (Prev))
9051 and then Full_View (Prev) = Typ
9056 -- Private or Taft amendment type case
9059 Pkg : constant Entity_Id := Scope (Typ);
9060 Pkg_Decl : Node_Id := Pkg;
9063 if Ekind (Pkg) = E_Package then
9064 while Nkind (Pkg_Decl) /= N_Package_Specification loop
9065 Pkg_Decl := Parent (Pkg_Decl);
9068 -- It is knows that Typ has a private view, look for it in the
9069 -- visible declarations of the enclosing scope. A special case
9070 -- of this is when the two views have been exchanged - the full
9071 -- appears earlier than the private.
9073 if Has_Private_Declaration (Typ) then
9074 Prev := Inspect_Decls (Visible_Declarations (Pkg_Decl));
9076 -- Exchanged view case, look in the private declarations
9079 Prev := Inspect_Decls (Private_Declarations (Pkg_Decl));
9084 -- Otherwise if this is the package body, then Typ is a potential
9085 -- Taft amendment type. The incomplete view should be located in
9086 -- the private declarations of the enclosing scope.
9088 elsif In_Package_Body (Pkg) then
9089 return Inspect_Decls (Private_Declarations (Pkg_Decl), True);
9094 -- The type has no incomplete or private view
9097 end Incomplete_Or_Private_View;
9099 ---------------------------------
9100 -- Insert_Explicit_Dereference --
9101 ---------------------------------
9103 procedure Insert_Explicit_Dereference (N : Node_Id) is
9104 New_Prefix : constant Node_Id := Relocate_Node (N);
9105 Ent : Entity_Id := Empty;
9112 Save_Interps (N, New_Prefix);
9115 Make_Explicit_Dereference (Sloc (Parent (N)),
9116 Prefix => New_Prefix));
9118 Set_Etype (N, Designated_Type (Etype (New_Prefix)));
9120 if Is_Overloaded (New_Prefix) then
9122 -- The dereference is also overloaded, and its interpretations are
9123 -- the designated types of the interpretations of the original node.
9125 Set_Etype (N, Any_Type);
9127 Get_First_Interp (New_Prefix, I, It);
9128 while Present (It.Nam) loop
9131 if Is_Access_Type (T) then
9132 Add_One_Interp (N, Designated_Type (T), Designated_Type (T));
9135 Get_Next_Interp (I, It);
9141 -- Prefix is unambiguous: mark the original prefix (which might
9142 -- Come_From_Source) as a reference, since the new (relocated) one
9143 -- won't be taken into account.
9145 if Is_Entity_Name (New_Prefix) then
9146 Ent := Entity (New_Prefix);
9149 -- For a retrieval of a subcomponent of some composite object,
9150 -- retrieve the ultimate entity if there is one.
9152 elsif Nkind (New_Prefix) = N_Selected_Component
9153 or else Nkind (New_Prefix) = N_Indexed_Component
9155 Pref := Prefix (New_Prefix);
9156 while Present (Pref)
9158 (Nkind (Pref) = N_Selected_Component
9159 or else Nkind (Pref) = N_Indexed_Component)
9161 Pref := Prefix (Pref);
9164 if Present (Pref) and then Is_Entity_Name (Pref) then
9165 Ent := Entity (Pref);
9169 -- Place the reference on the entity node
9171 if Present (Ent) then
9172 Generate_Reference (Ent, Pref);
9175 end Insert_Explicit_Dereference;
9177 ------------------------------------------
9178 -- Inspect_Deferred_Constant_Completion --
9179 ------------------------------------------
9181 procedure Inspect_Deferred_Constant_Completion (Decls : List_Id) is
9185 Decl := First (Decls);
9186 while Present (Decl) loop
9188 -- Deferred constant signature
9190 if Nkind (Decl) = N_Object_Declaration
9191 and then Constant_Present (Decl)
9192 and then No (Expression (Decl))
9194 -- No need to check internally generated constants
9196 and then Comes_From_Source (Decl)
9198 -- The constant is not completed. A full object declaration or a
9199 -- pragma Import complete a deferred constant.
9201 and then not Has_Completion (Defining_Identifier (Decl))
9204 ("constant declaration requires initialization expression",
9205 Defining_Identifier (Decl));
9208 Decl := Next (Decl);
9210 end Inspect_Deferred_Constant_Completion;
9212 -----------------------------
9213 -- Is_Actual_Out_Parameter --
9214 -----------------------------
9216 function Is_Actual_Out_Parameter (N : Node_Id) return Boolean is
9220 Find_Actual (N, Formal, Call);
9221 return Present (Formal) and then Ekind (Formal) = E_Out_Parameter;
9222 end Is_Actual_Out_Parameter;
9224 -------------------------
9225 -- Is_Actual_Parameter --
9226 -------------------------
9228 function Is_Actual_Parameter (N : Node_Id) return Boolean is
9229 PK : constant Node_Kind := Nkind (Parent (N));
9233 when N_Parameter_Association =>
9234 return N = Explicit_Actual_Parameter (Parent (N));
9236 when N_Subprogram_Call =>
9237 return Is_List_Member (N)
9239 List_Containing (N) = Parameter_Associations (Parent (N));
9244 end Is_Actual_Parameter;
9246 --------------------------------
9247 -- Is_Actual_Tagged_Parameter --
9248 --------------------------------
9250 function Is_Actual_Tagged_Parameter (N : Node_Id) return Boolean is
9254 Find_Actual (N, Formal, Call);
9255 return Present (Formal) and then Is_Tagged_Type (Etype (Formal));
9256 end Is_Actual_Tagged_Parameter;
9258 ---------------------
9259 -- Is_Aliased_View --
9260 ---------------------
9262 function Is_Aliased_View (Obj : Node_Id) return Boolean is
9266 if Is_Entity_Name (Obj) then
9273 or else (Present (Renamed_Object (E))
9274 and then Is_Aliased_View (Renamed_Object (E)))))
9276 or else ((Is_Formal (E)
9277 or else Ekind (E) = E_Generic_In_Out_Parameter
9278 or else Ekind (E) = E_Generic_In_Parameter)
9279 and then Is_Tagged_Type (Etype (E)))
9281 or else (Is_Concurrent_Type (E) and then In_Open_Scopes (E))
9283 -- Current instance of type, either directly or as rewritten
9284 -- reference to the current object.
9286 or else (Is_Entity_Name (Original_Node (Obj))
9287 and then Present (Entity (Original_Node (Obj)))
9288 and then Is_Type (Entity (Original_Node (Obj))))
9290 or else (Is_Type (E) and then E = Current_Scope)
9292 or else (Is_Incomplete_Or_Private_Type (E)
9293 and then Full_View (E) = Current_Scope)
9295 -- Ada 2012 AI05-0053: the return object of an extended return
9296 -- statement is aliased if its type is immutably limited.
9298 or else (Is_Return_Object (E)
9299 and then Is_Limited_View (Etype (E)));
9301 elsif Nkind (Obj) = N_Selected_Component then
9302 return Is_Aliased (Entity (Selector_Name (Obj)));
9304 elsif Nkind (Obj) = N_Indexed_Component then
9305 return Has_Aliased_Components (Etype (Prefix (Obj)))
9307 (Is_Access_Type (Etype (Prefix (Obj)))
9308 and then Has_Aliased_Components
9309 (Designated_Type (Etype (Prefix (Obj)))));
9311 elsif Nkind_In (Obj, N_Unchecked_Type_Conversion, N_Type_Conversion) then
9312 return Is_Tagged_Type (Etype (Obj))
9313 and then Is_Aliased_View (Expression (Obj));
9315 elsif Nkind (Obj) = N_Explicit_Dereference then
9316 return Nkind (Original_Node (Obj)) /= N_Function_Call;
9321 end Is_Aliased_View;
9323 -------------------------
9324 -- Is_Ancestor_Package --
9325 -------------------------
9327 function Is_Ancestor_Package
9329 E2 : Entity_Id) return Boolean
9336 and then Par /= Standard_Standard
9346 end Is_Ancestor_Package;
9348 ----------------------
9349 -- Is_Atomic_Object --
9350 ----------------------
9352 function Is_Atomic_Object (N : Node_Id) return Boolean is
9354 function Object_Has_Atomic_Components (N : Node_Id) return Boolean;
9355 -- Determines if given object has atomic components
9357 function Is_Atomic_Prefix (N : Node_Id) return Boolean;
9358 -- If prefix is an implicit dereference, examine designated type
9360 ----------------------
9361 -- Is_Atomic_Prefix --
9362 ----------------------
9364 function Is_Atomic_Prefix (N : Node_Id) return Boolean is
9366 if Is_Access_Type (Etype (N)) then
9368 Has_Atomic_Components (Designated_Type (Etype (N)));
9370 return Object_Has_Atomic_Components (N);
9372 end Is_Atomic_Prefix;
9374 ----------------------------------
9375 -- Object_Has_Atomic_Components --
9376 ----------------------------------
9378 function Object_Has_Atomic_Components (N : Node_Id) return Boolean is
9380 if Has_Atomic_Components (Etype (N))
9381 or else Is_Atomic (Etype (N))
9385 elsif Is_Entity_Name (N)
9386 and then (Has_Atomic_Components (Entity (N))
9387 or else Is_Atomic (Entity (N)))
9391 elsif Nkind (N) = N_Selected_Component
9392 and then Is_Atomic (Entity (Selector_Name (N)))
9396 elsif Nkind (N) = N_Indexed_Component
9397 or else Nkind (N) = N_Selected_Component
9399 return Is_Atomic_Prefix (Prefix (N));
9404 end Object_Has_Atomic_Components;
9406 -- Start of processing for Is_Atomic_Object
9409 -- Predicate is not relevant to subprograms
9411 if Is_Entity_Name (N) and then Is_Overloadable (Entity (N)) then
9414 elsif Is_Atomic (Etype (N))
9415 or else (Is_Entity_Name (N) and then Is_Atomic (Entity (N)))
9419 elsif Nkind (N) = N_Selected_Component
9420 and then Is_Atomic (Entity (Selector_Name (N)))
9424 elsif Nkind (N) = N_Indexed_Component
9425 or else Nkind (N) = N_Selected_Component
9427 return Is_Atomic_Prefix (Prefix (N));
9432 end Is_Atomic_Object;
9434 -------------------------
9435 -- Is_Attribute_Result --
9436 -------------------------
9438 function Is_Attribute_Result (N : Node_Id) return Boolean is
9441 Nkind (N) = N_Attribute_Reference
9442 and then Attribute_Name (N) = Name_Result;
9443 end Is_Attribute_Result;
9445 ------------------------------------
9446 -- Is_Body_Or_Package_Declaration --
9447 ------------------------------------
9449 function Is_Body_Or_Package_Declaration (N : Node_Id) return Boolean is
9451 return Nkind_In (N, N_Entry_Body,
9453 N_Package_Declaration,
9457 end Is_Body_Or_Package_Declaration;
9459 -----------------------
9460 -- Is_Bounded_String --
9461 -----------------------
9463 function Is_Bounded_String (T : Entity_Id) return Boolean is
9464 Under : constant Entity_Id := Underlying_Type (Root_Type (T));
9467 -- Check whether T is ultimately derived from Ada.Strings.Superbounded.
9468 -- Super_String, or one of the [Wide_]Wide_ versions. This will
9469 -- be True for all the Bounded_String types in instances of the
9470 -- Generic_Bounded_Length generics, and for types derived from those.
9472 return Present (Under)
9473 and then (Is_RTE (Root_Type (Under), RO_SU_Super_String) or else
9474 Is_RTE (Root_Type (Under), RO_WI_Super_String) or else
9475 Is_RTE (Root_Type (Under), RO_WW_Super_String));
9476 end Is_Bounded_String;
9478 -------------------------
9479 -- Is_Child_Or_Sibling --
9480 -------------------------
9482 function Is_Child_Or_Sibling
9483 (Pack_1 : Entity_Id;
9484 Pack_2 : Entity_Id) return Boolean
9486 function Distance_From_Standard (Pack : Entity_Id) return Nat;
9487 -- Given an arbitrary package, return the number of "climbs" necessary
9488 -- to reach scope Standard_Standard.
9490 procedure Equalize_Depths
9491 (Pack : in out Entity_Id;
9493 Depth_To_Reach : Nat);
9494 -- Given an arbitrary package, its depth and a target depth to reach,
9495 -- climb the scope chain until the said depth is reached. The pointer
9496 -- to the package and its depth a modified during the climb.
9498 ----------------------------
9499 -- Distance_From_Standard --
9500 ----------------------------
9502 function Distance_From_Standard (Pack : Entity_Id) return Nat is
9509 while Present (Scop) and then Scop /= Standard_Standard loop
9511 Scop := Scope (Scop);
9515 end Distance_From_Standard;
9517 ---------------------
9518 -- Equalize_Depths --
9519 ---------------------
9521 procedure Equalize_Depths
9522 (Pack : in out Entity_Id;
9524 Depth_To_Reach : Nat)
9527 -- The package must be at a greater or equal depth
9529 if Depth < Depth_To_Reach then
9530 raise Program_Error;
9533 -- Climb the scope chain until the desired depth is reached
9535 while Present (Pack) and then Depth /= Depth_To_Reach loop
9536 Pack := Scope (Pack);
9539 end Equalize_Depths;
9543 P_1 : Entity_Id := Pack_1;
9544 P_1_Child : Boolean := False;
9545 P_1_Depth : Nat := Distance_From_Standard (P_1);
9546 P_2 : Entity_Id := Pack_2;
9547 P_2_Child : Boolean := False;
9548 P_2_Depth : Nat := Distance_From_Standard (P_2);
9550 -- Start of processing for Is_Child_Or_Sibling
9554 (Ekind (Pack_1) = E_Package and then Ekind (Pack_2) = E_Package);
9556 -- Both packages denote the same entity, therefore they cannot be
9557 -- children or siblings.
9562 -- One of the packages is at a deeper level than the other. Note that
9563 -- both may still come from differen hierarchies.
9571 elsif P_1_Depth > P_2_Depth then
9575 Depth_To_Reach => P_2_Depth);
9584 elsif P_2_Depth > P_1_Depth then
9588 Depth_To_Reach => P_1_Depth);
9592 -- At this stage the package pointers have been elevated to the same
9593 -- depth. If the related entities are the same, then one package is a
9594 -- potential child of the other:
9598 -- X became P_1 P_2 or vica versa
9604 return Is_Child_Unit (Pack_1);
9606 else pragma Assert (P_2_Child);
9607 return Is_Child_Unit (Pack_2);
9610 -- The packages may come from the same package chain or from entirely
9611 -- different hierarcies. To determine this, climb the scope stack until
9612 -- a common root is found.
9614 -- (root) (root 1) (root 2)
9619 while Present (P_1) and then Present (P_2) loop
9621 -- The two packages may be siblings
9624 return Is_Child_Unit (Pack_1) and then Is_Child_Unit (Pack_2);
9633 end Is_Child_Or_Sibling;
9635 -----------------------------
9636 -- Is_Concurrent_Interface --
9637 -----------------------------
9639 function Is_Concurrent_Interface (T : Entity_Id) return Boolean is
9644 (Is_Protected_Interface (T)
9645 or else Is_Synchronized_Interface (T)
9646 or else Is_Task_Interface (T));
9647 end Is_Concurrent_Interface;
9649 ---------------------------
9650 -- Is_Container_Element --
9651 ---------------------------
9653 function Is_Container_Element (Exp : Node_Id) return Boolean is
9654 Loc : constant Source_Ptr := Sloc (Exp);
9655 Pref : constant Node_Id := Prefix (Exp);
9658 -- Call to an indexing aspect
9660 Cont_Typ : Entity_Id;
9661 -- The type of the container being accessed
9663 Elem_Typ : Entity_Id;
9666 Indexing : Entity_Id;
9668 -- Indicates that constant indexing is used, and the element is thus
9671 Ref_Typ : Entity_Id;
9672 -- The reference type returned by the indexing operation
9675 -- If C is a container, in a context that imposes the element type of
9676 -- that container, the indexing notation C (X) is rewritten as:
9678 -- Indexing (C, X).Discr.all
9680 -- where Indexing is one of the indexing aspects of the container.
9681 -- If the context does not require a reference, the construct can be
9686 -- First, verify that the construct has the proper form
9688 if not Expander_Active then
9691 elsif Nkind (Pref) /= N_Selected_Component then
9694 elsif Nkind (Prefix (Pref)) /= N_Function_Call then
9698 Call := Prefix (Pref);
9699 Ref_Typ := Etype (Call);
9702 if not Has_Implicit_Dereference (Ref_Typ)
9703 or else No (First (Parameter_Associations (Call)))
9704 or else not Is_Entity_Name (Name (Call))
9709 -- Retrieve type of container object, and its iterator aspects
9711 Cont_Typ := Etype (First (Parameter_Associations (Call)));
9712 Indexing := Find_Value_Of_Aspect (Cont_Typ, Aspect_Constant_Indexing);
9715 if No (Indexing) then
9717 -- Container should have at least one indexing operation
9721 elsif Entity (Name (Call)) /= Entity (Indexing) then
9723 -- This may be a variable indexing operation
9725 Indexing := Find_Value_Of_Aspect (Cont_Typ, Aspect_Variable_Indexing);
9728 or else Entity (Name (Call)) /= Entity (Indexing)
9737 Elem_Typ := Find_Value_Of_Aspect (Cont_Typ, Aspect_Iterator_Element);
9739 if No (Elem_Typ) or else Entity (Elem_Typ) /= Etype (Exp) then
9743 -- Check that the expression is not the target of an assignment, in
9744 -- which case the rewriting is not possible.
9746 if not Is_Const then
9754 if Nkind (Parent (Par)) = N_Assignment_Statement
9755 and then Par = Name (Parent (Par))
9759 -- A renaming produces a reference, and the transformation
9762 elsif Nkind (Parent (Par)) = N_Object_Renaming_Declaration then
9766 (Nkind (Parent (Par)), N_Function_Call,
9767 N_Procedure_Call_Statement,
9768 N_Entry_Call_Statement)
9770 -- Check that the element is not part of an actual for an
9771 -- in-out parameter.
9778 F := First_Formal (Entity (Name (Parent (Par))));
9779 A := First (Parameter_Associations (Parent (Par)));
9780 while Present (F) loop
9781 if A = Par and then Ekind (F) /= E_In_Parameter then
9790 -- E_In_Parameter in a call: element is not modified.
9795 Par := Parent (Par);
9800 -- The expression has the proper form and the context requires the
9801 -- element type. Retrieve the Element function of the container and
9802 -- rewrite the construct as a call to it.
9808 Op := First_Elmt (Primitive_Operations (Cont_Typ));
9809 while Present (Op) loop
9810 exit when Chars (Node (Op)) = Name_Element;
9819 Make_Function_Call (Loc,
9820 Name => New_Occurrence_Of (Node (Op), Loc),
9821 Parameter_Associations => Parameter_Associations (Call)));
9822 Analyze_And_Resolve (Exp, Entity (Elem_Typ));
9826 end Is_Container_Element;
9828 -----------------------
9829 -- Is_Constant_Bound --
9830 -----------------------
9832 function Is_Constant_Bound (Exp : Node_Id) return Boolean is
9834 if Compile_Time_Known_Value (Exp) then
9837 elsif Is_Entity_Name (Exp) and then Present (Entity (Exp)) then
9838 return Is_Constant_Object (Entity (Exp))
9839 or else Ekind (Entity (Exp)) = E_Enumeration_Literal;
9841 elsif Nkind (Exp) in N_Binary_Op then
9842 return Is_Constant_Bound (Left_Opnd (Exp))
9843 and then Is_Constant_Bound (Right_Opnd (Exp))
9844 and then Scope (Entity (Exp)) = Standard_Standard;
9849 end Is_Constant_Bound;
9851 --------------------------------------
9852 -- Is_Controlling_Limited_Procedure --
9853 --------------------------------------
9855 function Is_Controlling_Limited_Procedure
9856 (Proc_Nam : Entity_Id) return Boolean
9858 Param_Typ : Entity_Id := Empty;
9861 if Ekind (Proc_Nam) = E_Procedure
9862 and then Present (Parameter_Specifications (Parent (Proc_Nam)))
9864 Param_Typ := Etype (Parameter_Type (First (
9865 Parameter_Specifications (Parent (Proc_Nam)))));
9867 -- In this case where an Itype was created, the procedure call has been
9870 elsif Present (Associated_Node_For_Itype (Proc_Nam))
9871 and then Present (Original_Node (Associated_Node_For_Itype (Proc_Nam)))
9873 Present (Parameter_Associations
9874 (Associated_Node_For_Itype (Proc_Nam)))
9877 Etype (First (Parameter_Associations
9878 (Associated_Node_For_Itype (Proc_Nam))));
9881 if Present (Param_Typ) then
9883 Is_Interface (Param_Typ)
9884 and then Is_Limited_Record (Param_Typ);
9888 end Is_Controlling_Limited_Procedure;
9890 -----------------------------
9891 -- Is_CPP_Constructor_Call --
9892 -----------------------------
9894 function Is_CPP_Constructor_Call (N : Node_Id) return Boolean is
9896 return Nkind (N) = N_Function_Call
9897 and then Is_CPP_Class (Etype (Etype (N)))
9898 and then Is_Constructor (Entity (Name (N)))
9899 and then Is_Imported (Entity (Name (N)));
9900 end Is_CPP_Constructor_Call;
9906 function Is_Delegate (T : Entity_Id) return Boolean is
9907 Desig_Type : Entity_Id;
9910 if VM_Target /= CLI_Target then
9914 -- Access-to-subprograms are delegates in CIL
9916 if Ekind (T) = E_Access_Subprogram_Type then
9920 if not Is_Access_Type (T) then
9922 -- A delegate is a managed pointer. If no designated type is defined
9923 -- it means that it's not a delegate.
9928 Desig_Type := Etype (Directly_Designated_Type (T));
9930 if not Is_Tagged_Type (Desig_Type) then
9934 -- Test if the type is inherited from [mscorlib]System.Delegate
9936 while Etype (Desig_Type) /= Desig_Type loop
9937 if Chars (Scope (Desig_Type)) /= No_Name
9938 and then Is_Imported (Scope (Desig_Type))
9939 and then Get_Name_String (Chars (Scope (Desig_Type))) = "delegate"
9944 Desig_Type := Etype (Desig_Type);
9950 ----------------------------------------------
9951 -- Is_Dependent_Component_Of_Mutable_Object --
9952 ----------------------------------------------
9954 function Is_Dependent_Component_Of_Mutable_Object
9955 (Object : Node_Id) return Boolean
9957 function Is_Declared_Within_Variant (Comp : Entity_Id) return Boolean;
9958 -- Returns True if and only if Comp is declared within a variant part
9960 --------------------------------
9961 -- Is_Declared_Within_Variant --
9962 --------------------------------
9964 function Is_Declared_Within_Variant (Comp : Entity_Id) return Boolean is
9965 Comp_Decl : constant Node_Id := Parent (Comp);
9966 Comp_List : constant Node_Id := Parent (Comp_Decl);
9968 return Nkind (Parent (Comp_List)) = N_Variant;
9969 end Is_Declared_Within_Variant;
9972 Prefix_Type : Entity_Id;
9973 P_Aliased : Boolean := False;
9976 Deref : Node_Id := Object;
9977 -- Dereference node, in something like X.all.Y(2)
9979 -- Start of processing for Is_Dependent_Component_Of_Mutable_Object
9982 -- Find the dereference node if any
9984 while Nkind_In (Deref, N_Indexed_Component,
9985 N_Selected_Component,
9988 Deref := Prefix (Deref);
9991 -- Ada 2005: If we have a component or slice of a dereference,
9992 -- something like X.all.Y (2), and the type of X is access-to-constant,
9993 -- Is_Variable will return False, because it is indeed a constant
9994 -- view. But it might be a view of a variable object, so we want the
9995 -- following condition to be True in that case.
9997 if Is_Variable (Object)
9998 or else (Ada_Version >= Ada_2005
9999 and then Nkind (Deref) = N_Explicit_Dereference)
10001 if Nkind (Object) = N_Selected_Component then
10002 P := Prefix (Object);
10003 Prefix_Type := Etype (P);
10005 if Is_Entity_Name (P) then
10006 if Ekind (Entity (P)) = E_Generic_In_Out_Parameter then
10007 Prefix_Type := Base_Type (Prefix_Type);
10010 if Is_Aliased (Entity (P)) then
10014 -- A discriminant check on a selected component may be expanded
10015 -- into a dereference when removing side-effects. Recover the
10016 -- original node and its type, which may be unconstrained.
10018 elsif Nkind (P) = N_Explicit_Dereference
10019 and then not (Comes_From_Source (P))
10021 P := Original_Node (P);
10022 Prefix_Type := Etype (P);
10025 -- Check for prefix being an aliased component???
10031 -- A heap object is constrained by its initial value
10033 -- Ada 2005 (AI-363): Always assume the object could be mutable in
10034 -- the dereferenced case, since the access value might denote an
10035 -- unconstrained aliased object, whereas in Ada 95 the designated
10036 -- object is guaranteed to be constrained. A worst-case assumption
10037 -- has to apply in Ada 2005 because we can't tell at compile
10038 -- time whether the object is "constrained by its initial value"
10039 -- (despite the fact that 3.10.2(26/2) and 8.5.1(5/2) are semantic
10040 -- rules (these rules are acknowledged to need fixing).
10042 if Ada_Version < Ada_2005 then
10043 if Is_Access_Type (Prefix_Type)
10044 or else Nkind (P) = N_Explicit_Dereference
10049 else pragma Assert (Ada_Version >= Ada_2005);
10050 if Is_Access_Type (Prefix_Type) then
10052 -- If the access type is pool-specific, and there is no
10053 -- constrained partial view of the designated type, then the
10054 -- designated object is known to be constrained.
10056 if Ekind (Prefix_Type) = E_Access_Type
10057 and then not Object_Type_Has_Constrained_Partial_View
10058 (Typ => Designated_Type (Prefix_Type),
10059 Scop => Current_Scope)
10063 -- Otherwise (general access type, or there is a constrained
10064 -- partial view of the designated type), we need to check
10065 -- based on the designated type.
10068 Prefix_Type := Designated_Type (Prefix_Type);
10074 Original_Record_Component (Entity (Selector_Name (Object)));
10076 -- As per AI-0017, the renaming is illegal in a generic body, even
10077 -- if the subtype is indefinite.
10079 -- Ada 2005 (AI-363): In Ada 2005 an aliased object can be mutable
10081 if not Is_Constrained (Prefix_Type)
10082 and then (not Is_Indefinite_Subtype (Prefix_Type)
10084 (Is_Generic_Type (Prefix_Type)
10085 and then Ekind (Current_Scope) = E_Generic_Package
10086 and then In_Package_Body (Current_Scope)))
10088 and then (Is_Declared_Within_Variant (Comp)
10089 or else Has_Discriminant_Dependent_Constraint (Comp))
10090 and then (not P_Aliased or else Ada_Version >= Ada_2005)
10094 -- If the prefix is of an access type at this point, then we want
10095 -- to return False, rather than calling this function recursively
10096 -- on the access object (which itself might be a discriminant-
10097 -- dependent component of some other object, but that isn't
10098 -- relevant to checking the object passed to us). This avoids
10099 -- issuing wrong errors when compiling with -gnatc, where there
10100 -- can be implicit dereferences that have not been expanded.
10102 elsif Is_Access_Type (Etype (Prefix (Object))) then
10107 Is_Dependent_Component_Of_Mutable_Object (Prefix (Object));
10110 elsif Nkind (Object) = N_Indexed_Component
10111 or else Nkind (Object) = N_Slice
10113 return Is_Dependent_Component_Of_Mutable_Object (Prefix (Object));
10115 -- A type conversion that Is_Variable is a view conversion:
10116 -- go back to the denoted object.
10118 elsif Nkind (Object) = N_Type_Conversion then
10120 Is_Dependent_Component_Of_Mutable_Object (Expression (Object));
10125 end Is_Dependent_Component_Of_Mutable_Object;
10127 ---------------------
10128 -- Is_Dereferenced --
10129 ---------------------
10131 function Is_Dereferenced (N : Node_Id) return Boolean is
10132 P : constant Node_Id := Parent (N);
10135 (Nkind (P) = N_Selected_Component
10137 Nkind (P) = N_Explicit_Dereference
10139 Nkind (P) = N_Indexed_Component
10141 Nkind (P) = N_Slice)
10142 and then Prefix (P) = N;
10143 end Is_Dereferenced;
10145 ----------------------
10146 -- Is_Descendent_Of --
10147 ----------------------
10149 function Is_Descendent_Of (T1 : Entity_Id; T2 : Entity_Id) return Boolean is
10154 pragma Assert (Nkind (T1) in N_Entity);
10155 pragma Assert (Nkind (T2) in N_Entity);
10157 T := Base_Type (T1);
10159 -- Immediate return if the types match
10164 -- Comment needed here ???
10166 elsif Ekind (T) = E_Class_Wide_Type then
10167 return Etype (T) = T2;
10175 -- Done if we found the type we are looking for
10180 -- Done if no more derivations to check
10187 -- Following test catches error cases resulting from prev errors
10189 elsif No (Etyp) then
10192 elsif Is_Private_Type (T) and then Etyp = Full_View (T) then
10195 elsif Is_Private_Type (Etyp) and then Full_View (Etyp) = T then
10199 T := Base_Type (Etyp);
10202 end Is_Descendent_Of;
10204 ----------------------------
10205 -- Is_Expression_Function --
10206 ----------------------------
10208 function Is_Expression_Function (Subp : Entity_Id) return Boolean is
10212 if Ekind (Subp) /= E_Function then
10216 Decl := Unit_Declaration_Node (Subp);
10217 return Nkind (Decl) = N_Subprogram_Declaration
10219 (Nkind (Original_Node (Decl)) = N_Expression_Function
10221 (Present (Corresponding_Body (Decl))
10223 Nkind (Original_Node
10224 (Unit_Declaration_Node
10225 (Corresponding_Body (Decl)))) =
10226 N_Expression_Function));
10228 end Is_Expression_Function;
10234 function Is_False (U : Uint) return Boolean is
10239 ---------------------------
10240 -- Is_Fixed_Model_Number --
10241 ---------------------------
10243 function Is_Fixed_Model_Number (U : Ureal; T : Entity_Id) return Boolean is
10244 S : constant Ureal := Small_Value (T);
10245 M : Urealp.Save_Mark;
10249 R := (U = UR_Trunc (U / S) * S);
10250 Urealp.Release (M);
10252 end Is_Fixed_Model_Number;
10254 -------------------------------
10255 -- Is_Fully_Initialized_Type --
10256 -------------------------------
10258 function Is_Fully_Initialized_Type (Typ : Entity_Id) return Boolean is
10260 -- In Ada2012, a scalar type with an aspect Default_Value
10261 -- is fully initialized.
10263 if Is_Scalar_Type (Typ) then
10264 return Ada_Version >= Ada_2012 and then Has_Default_Aspect (Typ);
10266 elsif Is_Access_Type (Typ) then
10269 elsif Is_Array_Type (Typ) then
10270 if Is_Fully_Initialized_Type (Component_Type (Typ))
10271 or else (Ada_Version >= Ada_2012 and then Has_Default_Aspect (Typ))
10276 -- An interesting case, if we have a constrained type one of whose
10277 -- bounds is known to be null, then there are no elements to be
10278 -- initialized, so all the elements are initialized.
10280 if Is_Constrained (Typ) then
10283 Indx_Typ : Entity_Id;
10284 Lbd, Hbd : Node_Id;
10287 Indx := First_Index (Typ);
10288 while Present (Indx) loop
10289 if Etype (Indx) = Any_Type then
10292 -- If index is a range, use directly
10294 elsif Nkind (Indx) = N_Range then
10295 Lbd := Low_Bound (Indx);
10296 Hbd := High_Bound (Indx);
10299 Indx_Typ := Etype (Indx);
10301 if Is_Private_Type (Indx_Typ) then
10302 Indx_Typ := Full_View (Indx_Typ);
10305 if No (Indx_Typ) or else Etype (Indx_Typ) = Any_Type then
10308 Lbd := Type_Low_Bound (Indx_Typ);
10309 Hbd := Type_High_Bound (Indx_Typ);
10313 if Compile_Time_Known_Value (Lbd)
10314 and then Compile_Time_Known_Value (Hbd)
10316 if Expr_Value (Hbd) < Expr_Value (Lbd) then
10326 -- If no null indexes, then type is not fully initialized
10332 elsif Is_Record_Type (Typ) then
10333 if Has_Discriminants (Typ)
10335 Present (Discriminant_Default_Value (First_Discriminant (Typ)))
10336 and then Is_Fully_Initialized_Variant (Typ)
10341 -- We consider bounded string types to be fully initialized, because
10342 -- otherwise we get false alarms when the Data component is not
10343 -- default-initialized.
10345 if Is_Bounded_String (Typ) then
10349 -- Controlled records are considered to be fully initialized if
10350 -- there is a user defined Initialize routine. This may not be
10351 -- entirely correct, but as the spec notes, we are guessing here
10352 -- what is best from the point of view of issuing warnings.
10354 if Is_Controlled (Typ) then
10356 Utyp : constant Entity_Id := Underlying_Type (Typ);
10359 if Present (Utyp) then
10361 Init : constant Entity_Id :=
10363 (Underlying_Type (Typ), Name_Initialize));
10367 and then Comes_From_Source (Init)
10369 Is_Predefined_File_Name
10370 (File_Name (Get_Source_File_Index (Sloc (Init))))
10374 elsif Has_Null_Extension (Typ)
10376 Is_Fully_Initialized_Type
10377 (Etype (Base_Type (Typ)))
10386 -- Otherwise see if all record components are initialized
10392 Ent := First_Entity (Typ);
10393 while Present (Ent) loop
10394 if Ekind (Ent) = E_Component
10395 and then (No (Parent (Ent))
10396 or else No (Expression (Parent (Ent))))
10397 and then not Is_Fully_Initialized_Type (Etype (Ent))
10399 -- Special VM case for tag components, which need to be
10400 -- defined in this case, but are never initialized as VMs
10401 -- are using other dispatching mechanisms. Ignore this
10402 -- uninitialized case. Note that this applies both to the
10403 -- uTag entry and the main vtable pointer (CPP_Class case).
10405 and then (Tagged_Type_Expansion or else not Is_Tag (Ent))
10414 -- No uninitialized components, so type is fully initialized.
10415 -- Note that this catches the case of no components as well.
10419 elsif Is_Concurrent_Type (Typ) then
10422 elsif Is_Private_Type (Typ) then
10424 U : constant Entity_Id := Underlying_Type (Typ);
10430 return Is_Fully_Initialized_Type (U);
10437 end Is_Fully_Initialized_Type;
10439 ----------------------------------
10440 -- Is_Fully_Initialized_Variant --
10441 ----------------------------------
10443 function Is_Fully_Initialized_Variant (Typ : Entity_Id) return Boolean is
10444 Loc : constant Source_Ptr := Sloc (Typ);
10445 Constraints : constant List_Id := New_List;
10446 Components : constant Elist_Id := New_Elmt_List;
10447 Comp_Elmt : Elmt_Id;
10449 Comp_List : Node_Id;
10451 Discr_Val : Node_Id;
10453 Report_Errors : Boolean;
10454 pragma Warnings (Off, Report_Errors);
10457 if Serious_Errors_Detected > 0 then
10461 if Is_Record_Type (Typ)
10462 and then Nkind (Parent (Typ)) = N_Full_Type_Declaration
10463 and then Nkind (Type_Definition (Parent (Typ))) = N_Record_Definition
10465 Comp_List := Component_List (Type_Definition (Parent (Typ)));
10467 Discr := First_Discriminant (Typ);
10468 while Present (Discr) loop
10469 if Nkind (Parent (Discr)) = N_Discriminant_Specification then
10470 Discr_Val := Expression (Parent (Discr));
10472 if Present (Discr_Val)
10473 and then Is_OK_Static_Expression (Discr_Val)
10475 Append_To (Constraints,
10476 Make_Component_Association (Loc,
10477 Choices => New_List (New_Occurrence_Of (Discr, Loc)),
10478 Expression => New_Copy (Discr_Val)));
10486 Next_Discriminant (Discr);
10491 Comp_List => Comp_List,
10492 Governed_By => Constraints,
10493 Into => Components,
10494 Report_Errors => Report_Errors);
10496 -- Check that each component present is fully initialized
10498 Comp_Elmt := First_Elmt (Components);
10499 while Present (Comp_Elmt) loop
10500 Comp_Id := Node (Comp_Elmt);
10502 if Ekind (Comp_Id) = E_Component
10503 and then (No (Parent (Comp_Id))
10504 or else No (Expression (Parent (Comp_Id))))
10505 and then not Is_Fully_Initialized_Type (Etype (Comp_Id))
10510 Next_Elmt (Comp_Elmt);
10515 elsif Is_Private_Type (Typ) then
10517 U : constant Entity_Id := Underlying_Type (Typ);
10523 return Is_Fully_Initialized_Variant (U);
10530 end Is_Fully_Initialized_Variant;
10532 ----------------------------
10533 -- Is_Inherited_Operation --
10534 ----------------------------
10536 function Is_Inherited_Operation (E : Entity_Id) return Boolean is
10537 pragma Assert (Is_Overloadable (E));
10538 Kind : constant Node_Kind := Nkind (Parent (E));
10540 return Kind = N_Full_Type_Declaration
10541 or else Kind = N_Private_Extension_Declaration
10542 or else Kind = N_Subtype_Declaration
10543 or else (Ekind (E) = E_Enumeration_Literal
10544 and then Is_Derived_Type (Etype (E)));
10545 end Is_Inherited_Operation;
10547 -------------------------------------
10548 -- Is_Inherited_Operation_For_Type --
10549 -------------------------------------
10551 function Is_Inherited_Operation_For_Type
10553 Typ : Entity_Id) return Boolean
10556 -- Check that the operation has been created by the type declaration
10558 return Is_Inherited_Operation (E)
10559 and then Defining_Identifier (Parent (E)) = Typ;
10560 end Is_Inherited_Operation_For_Type;
10566 function Is_Iterator (Typ : Entity_Id) return Boolean is
10567 Ifaces_List : Elist_Id;
10568 Iface_Elmt : Elmt_Id;
10572 if Is_Class_Wide_Type (Typ)
10574 Nam_In (Chars (Etype (Typ)), Name_Forward_Iterator,
10575 Name_Reversible_Iterator)
10577 Is_Predefined_File_Name
10578 (Unit_File_Name (Get_Source_Unit (Etype (Typ))))
10582 elsif not Is_Tagged_Type (Typ) or else not Is_Derived_Type (Typ) then
10585 elsif Present (Find_Value_Of_Aspect (Typ, Aspect_Iterable)) then
10589 Collect_Interfaces (Typ, Ifaces_List);
10591 Iface_Elmt := First_Elmt (Ifaces_List);
10592 while Present (Iface_Elmt) loop
10593 Iface := Node (Iface_Elmt);
10594 if Chars (Iface) = Name_Forward_Iterator
10596 Is_Predefined_File_Name
10597 (Unit_File_Name (Get_Source_Unit (Iface)))
10602 Next_Elmt (Iface_Elmt);
10613 function Is_Junk_Name (N : Name_Id) return Boolean is
10614 function Match (S : String) return Boolean;
10615 -- Return true if substring S is found in Name_Buffer (1 .. Name_Len)
10621 function Match (S : String) return Boolean is
10622 Slen1 : constant Integer := S'Length - 1;
10625 for J in 1 .. Name_Len - S'Length + 1 loop
10626 if Name_Buffer (J .. J + Slen1) = S then
10634 -- Start of processing for Is_Junk_Name
10637 Get_Unqualified_Decoded_Name_String (N);
10638 Set_All_Upper_Case;
10641 Match ("DISCARD") or else
10642 Match ("DUMMY") or else
10643 Match ("IGNORE") or else
10644 Match ("JUNK") or else
10652 -- We seem to have a lot of overlapping functions that do similar things
10653 -- (testing for left hand sides or lvalues???).
10655 function Is_LHS (N : Node_Id) return Is_LHS_Result is
10656 P : constant Node_Id := Parent (N);
10659 -- Return True if we are the left hand side of an assignment statement
10661 if Nkind (P) = N_Assignment_Statement then
10662 if Name (P) = N then
10668 -- Case of prefix of indexed or selected component or slice
10670 elsif Nkind_In (P, N_Indexed_Component, N_Selected_Component, N_Slice)
10671 and then N = Prefix (P)
10673 -- Here we have the case where the parent P is N.Q or N(Q .. R).
10674 -- If P is an LHS, then N is also effectively an LHS, but there
10675 -- is an important exception. If N is of an access type, then
10676 -- what we really have is N.all.Q (or N.all(Q .. R)). In either
10677 -- case this makes N.all a left hand side but not N itself.
10679 -- If we don't know the type yet, this is the case where we return
10680 -- Unknown, since the answer depends on the type which is unknown.
10682 if No (Etype (N)) then
10685 -- We have an Etype set, so we can check it
10687 elsif Is_Access_Type (Etype (N)) then
10690 -- OK, not access type case, so just test whole expression
10696 -- All other cases are not left hand sides
10703 -----------------------------
10704 -- Is_Library_Level_Entity --
10705 -----------------------------
10707 function Is_Library_Level_Entity (E : Entity_Id) return Boolean is
10709 -- The following is a small optimization, and it also properly handles
10710 -- discriminals, which in task bodies might appear in expressions before
10711 -- the corresponding procedure has been created, and which therefore do
10712 -- not have an assigned scope.
10714 if Is_Formal (E) then
10718 -- Normal test is simply that the enclosing dynamic scope is Standard
10720 return Enclosing_Dynamic_Scope (E) = Standard_Standard;
10721 end Is_Library_Level_Entity;
10723 --------------------------------
10724 -- Is_Limited_Class_Wide_Type --
10725 --------------------------------
10727 function Is_Limited_Class_Wide_Type (Typ : Entity_Id) return Boolean is
10730 Is_Class_Wide_Type (Typ)
10731 and then (Is_Limited_Type (Typ) or else From_Limited_With (Typ));
10732 end Is_Limited_Class_Wide_Type;
10734 ---------------------------------
10735 -- Is_Local_Variable_Reference --
10736 ---------------------------------
10738 function Is_Local_Variable_Reference (Expr : Node_Id) return Boolean is
10740 if not Is_Entity_Name (Expr) then
10745 Ent : constant Entity_Id := Entity (Expr);
10746 Sub : constant Entity_Id := Enclosing_Subprogram (Ent);
10748 if not Ekind_In (Ent, E_Variable, E_In_Out_Parameter) then
10751 return Present (Sub) and then Sub = Current_Subprogram;
10755 end Is_Local_Variable_Reference;
10757 -------------------------
10758 -- Is_Object_Reference --
10759 -------------------------
10761 function Is_Object_Reference (N : Node_Id) return Boolean is
10763 function Is_Internally_Generated_Renaming (N : Node_Id) return Boolean;
10764 -- Determine whether N is the name of an internally-generated renaming
10766 --------------------------------------
10767 -- Is_Internally_Generated_Renaming --
10768 --------------------------------------
10770 function Is_Internally_Generated_Renaming (N : Node_Id) return Boolean is
10775 while Present (P) loop
10776 if Nkind (P) = N_Object_Renaming_Declaration then
10777 return not Comes_From_Source (P);
10778 elsif Is_List_Member (P) then
10786 end Is_Internally_Generated_Renaming;
10788 -- Start of processing for Is_Object_Reference
10791 if Is_Entity_Name (N) then
10792 return Present (Entity (N)) and then Is_Object (Entity (N));
10796 when N_Indexed_Component | N_Slice =>
10798 Is_Object_Reference (Prefix (N))
10799 or else Is_Access_Type (Etype (Prefix (N)));
10801 -- In Ada 95, a function call is a constant object; a procedure
10804 when N_Function_Call =>
10805 return Etype (N) /= Standard_Void_Type;
10807 -- Attributes 'Input, 'Old and 'Result produce objects
10809 when N_Attribute_Reference =>
10812 (Attribute_Name (N), Name_Input, Name_Old, Name_Result);
10814 when N_Selected_Component =>
10816 Is_Object_Reference (Selector_Name (N))
10818 (Is_Object_Reference (Prefix (N))
10819 or else Is_Access_Type (Etype (Prefix (N))));
10821 when N_Explicit_Dereference =>
10824 -- A view conversion of a tagged object is an object reference
10826 when N_Type_Conversion =>
10827 return Is_Tagged_Type (Etype (Subtype_Mark (N)))
10828 and then Is_Tagged_Type (Etype (Expression (N)))
10829 and then Is_Object_Reference (Expression (N));
10831 -- An unchecked type conversion is considered to be an object if
10832 -- the operand is an object (this construction arises only as a
10833 -- result of expansion activities).
10835 when N_Unchecked_Type_Conversion =>
10838 -- Allow string literals to act as objects as long as they appear
10839 -- in internally-generated renamings. The expansion of iterators
10840 -- may generate such renamings when the range involves a string
10843 when N_String_Literal =>
10844 return Is_Internally_Generated_Renaming (Parent (N));
10846 -- AI05-0003: In Ada 2012 a qualified expression is a name.
10847 -- This allows disambiguation of function calls and the use
10848 -- of aggregates in more contexts.
10850 when N_Qualified_Expression =>
10851 if Ada_Version < Ada_2012 then
10854 return Is_Object_Reference (Expression (N))
10855 or else Nkind (Expression (N)) = N_Aggregate;
10862 end Is_Object_Reference;
10864 -----------------------------------
10865 -- Is_OK_Variable_For_Out_Formal --
10866 -----------------------------------
10868 function Is_OK_Variable_For_Out_Formal (AV : Node_Id) return Boolean is
10870 Note_Possible_Modification (AV, Sure => True);
10872 -- We must reject parenthesized variable names. Comes_From_Source is
10873 -- checked because there are currently cases where the compiler violates
10874 -- this rule (e.g. passing a task object to its controlled Initialize
10875 -- routine). This should be properly documented in sinfo???
10877 if Paren_Count (AV) > 0 and then Comes_From_Source (AV) then
10880 -- A variable is always allowed
10882 elsif Is_Variable (AV) then
10885 -- Unchecked conversions are allowed only if they come from the
10886 -- generated code, which sometimes uses unchecked conversions for out
10887 -- parameters in cases where code generation is unaffected. We tell
10888 -- source unchecked conversions by seeing if they are rewrites of
10889 -- an original Unchecked_Conversion function call, or of an explicit
10890 -- conversion of a function call or an aggregate (as may happen in the
10891 -- expansion of a packed array aggregate).
10893 elsif Nkind (AV) = N_Unchecked_Type_Conversion then
10894 if Nkind_In (Original_Node (AV), N_Function_Call, N_Aggregate) then
10897 elsif Comes_From_Source (AV)
10898 and then Nkind (Original_Node (Expression (AV))) = N_Function_Call
10902 elsif Nkind (Original_Node (AV)) = N_Type_Conversion then
10903 return Is_OK_Variable_For_Out_Formal (Expression (AV));
10909 -- Normal type conversions are allowed if argument is a variable
10911 elsif Nkind (AV) = N_Type_Conversion then
10912 if Is_Variable (Expression (AV))
10913 and then Paren_Count (Expression (AV)) = 0
10915 Note_Possible_Modification (Expression (AV), Sure => True);
10918 -- We also allow a non-parenthesized expression that raises
10919 -- constraint error if it rewrites what used to be a variable
10921 elsif Raises_Constraint_Error (Expression (AV))
10922 and then Paren_Count (Expression (AV)) = 0
10923 and then Is_Variable (Original_Node (Expression (AV)))
10927 -- Type conversion of something other than a variable
10933 -- If this node is rewritten, then test the original form, if that is
10934 -- OK, then we consider the rewritten node OK (for example, if the
10935 -- original node is a conversion, then Is_Variable will not be true
10936 -- but we still want to allow the conversion if it converts a variable).
10938 elsif Original_Node (AV) /= AV then
10940 -- In Ada 2012, the explicit dereference may be a rewritten call to a
10941 -- Reference function.
10943 if Ada_Version >= Ada_2012
10944 and then Nkind (Original_Node (AV)) = N_Function_Call
10946 Has_Implicit_Dereference (Etype (Name (Original_Node (AV))))
10951 return Is_OK_Variable_For_Out_Formal (Original_Node (AV));
10954 -- All other non-variables are rejected
10959 end Is_OK_Variable_For_Out_Formal;
10961 -----------------------------------
10962 -- Is_Partially_Initialized_Type --
10963 -----------------------------------
10965 function Is_Partially_Initialized_Type
10967 Include_Implicit : Boolean := True) return Boolean
10970 if Is_Scalar_Type (Typ) then
10973 elsif Is_Access_Type (Typ) then
10974 return Include_Implicit;
10976 elsif Is_Array_Type (Typ) then
10978 -- If component type is partially initialized, so is array type
10980 if Is_Partially_Initialized_Type
10981 (Component_Type (Typ), Include_Implicit)
10985 -- Otherwise we are only partially initialized if we are fully
10986 -- initialized (this is the empty array case, no point in us
10987 -- duplicating that code here).
10990 return Is_Fully_Initialized_Type (Typ);
10993 elsif Is_Record_Type (Typ) then
10995 -- A discriminated type is always partially initialized if in
10998 if Has_Discriminants (Typ) and then Include_Implicit then
11001 -- A tagged type is always partially initialized
11003 elsif Is_Tagged_Type (Typ) then
11006 -- Case of non-discriminated record
11012 Component_Present : Boolean := False;
11013 -- Set True if at least one component is present. If no
11014 -- components are present, then record type is fully
11015 -- initialized (another odd case, like the null array).
11018 -- Loop through components
11020 Ent := First_Entity (Typ);
11021 while Present (Ent) loop
11022 if Ekind (Ent) = E_Component then
11023 Component_Present := True;
11025 -- If a component has an initialization expression then
11026 -- the enclosing record type is partially initialized
11028 if Present (Parent (Ent))
11029 and then Present (Expression (Parent (Ent)))
11033 -- If a component is of a type which is itself partially
11034 -- initialized, then the enclosing record type is also.
11036 elsif Is_Partially_Initialized_Type
11037 (Etype (Ent), Include_Implicit)
11046 -- No initialized components found. If we found any components
11047 -- they were all uninitialized so the result is false.
11049 if Component_Present then
11052 -- But if we found no components, then all the components are
11053 -- initialized so we consider the type to be initialized.
11061 -- Concurrent types are always fully initialized
11063 elsif Is_Concurrent_Type (Typ) then
11066 -- For a private type, go to underlying type. If there is no underlying
11067 -- type then just assume this partially initialized. Not clear if this
11068 -- can happen in a non-error case, but no harm in testing for this.
11070 elsif Is_Private_Type (Typ) then
11072 U : constant Entity_Id := Underlying_Type (Typ);
11077 return Is_Partially_Initialized_Type (U, Include_Implicit);
11081 -- For any other type (are there any?) assume partially initialized
11086 end Is_Partially_Initialized_Type;
11088 ------------------------------------
11089 -- Is_Potentially_Persistent_Type --
11090 ------------------------------------
11092 function Is_Potentially_Persistent_Type (T : Entity_Id) return Boolean is
11097 -- For private type, test corresponding full type
11099 if Is_Private_Type (T) then
11100 return Is_Potentially_Persistent_Type (Full_View (T));
11102 -- Scalar types are potentially persistent
11104 elsif Is_Scalar_Type (T) then
11107 -- Record type is potentially persistent if not tagged and the types of
11108 -- all it components are potentially persistent, and no component has
11109 -- an initialization expression.
11111 elsif Is_Record_Type (T)
11112 and then not Is_Tagged_Type (T)
11113 and then not Is_Partially_Initialized_Type (T)
11115 Comp := First_Component (T);
11116 while Present (Comp) loop
11117 if not Is_Potentially_Persistent_Type (Etype (Comp)) then
11120 Next_Entity (Comp);
11126 -- Array type is potentially persistent if its component type is
11127 -- potentially persistent and if all its constraints are static.
11129 elsif Is_Array_Type (T) then
11130 if not Is_Potentially_Persistent_Type (Component_Type (T)) then
11134 Indx := First_Index (T);
11135 while Present (Indx) loop
11136 if not Is_OK_Static_Subtype (Etype (Indx)) then
11145 -- All other types are not potentially persistent
11150 end Is_Potentially_Persistent_Type;
11152 --------------------------------
11153 -- Is_Potentially_Unevaluated --
11154 --------------------------------
11156 function Is_Potentially_Unevaluated (N : Node_Id) return Boolean is
11163 while not Nkind_In (Par, N_If_Expression,
11171 Par := Parent (Par);
11173 -- If the context is not an expression, or if is the result of
11174 -- expansion of an enclosing construct (such as another attribute)
11175 -- the predicate does not apply.
11177 if Nkind (Par) not in N_Subexpr
11178 or else not Comes_From_Source (Par)
11184 if Nkind (Par) = N_If_Expression then
11185 return Is_Elsif (Par) or else Expr /= First (Expressions (Par));
11187 elsif Nkind (Par) = N_Case_Expression then
11188 return Expr /= Expression (Par);
11190 elsif Nkind_In (Par, N_And_Then, N_Or_Else) then
11191 return Expr = Right_Opnd (Par);
11193 elsif Nkind_In (Par, N_In, N_Not_In) then
11194 return Expr /= Left_Opnd (Par);
11199 end Is_Potentially_Unevaluated;
11201 ---------------------------------
11202 -- Is_Protected_Self_Reference --
11203 ---------------------------------
11205 function Is_Protected_Self_Reference (N : Node_Id) return Boolean is
11207 function In_Access_Definition (N : Node_Id) return Boolean;
11208 -- Returns true if N belongs to an access definition
11210 --------------------------
11211 -- In_Access_Definition --
11212 --------------------------
11214 function In_Access_Definition (N : Node_Id) return Boolean is
11219 while Present (P) loop
11220 if Nkind (P) = N_Access_Definition then
11228 end In_Access_Definition;
11230 -- Start of processing for Is_Protected_Self_Reference
11233 -- Verify that prefix is analyzed and has the proper form. Note that
11234 -- the attributes Elab_Spec, Elab_Body, Elab_Subp_Body and UET_Address,
11235 -- which also produce the address of an entity, do not analyze their
11236 -- prefix because they denote entities that are not necessarily visible.
11237 -- Neither of them can apply to a protected type.
11239 return Ada_Version >= Ada_2005
11240 and then Is_Entity_Name (N)
11241 and then Present (Entity (N))
11242 and then Is_Protected_Type (Entity (N))
11243 and then In_Open_Scopes (Entity (N))
11244 and then not In_Access_Definition (N);
11245 end Is_Protected_Self_Reference;
11247 -----------------------------
11248 -- Is_RCI_Pkg_Spec_Or_Body --
11249 -----------------------------
11251 function Is_RCI_Pkg_Spec_Or_Body (Cunit : Node_Id) return Boolean is
11253 function Is_RCI_Pkg_Decl_Cunit (Cunit : Node_Id) return Boolean;
11254 -- Return True if the unit of Cunit is an RCI package declaration
11256 ---------------------------
11257 -- Is_RCI_Pkg_Decl_Cunit --
11258 ---------------------------
11260 function Is_RCI_Pkg_Decl_Cunit (Cunit : Node_Id) return Boolean is
11261 The_Unit : constant Node_Id := Unit (Cunit);
11264 if Nkind (The_Unit) /= N_Package_Declaration then
11268 return Is_Remote_Call_Interface (Defining_Entity (The_Unit));
11269 end Is_RCI_Pkg_Decl_Cunit;
11271 -- Start of processing for Is_RCI_Pkg_Spec_Or_Body
11274 return Is_RCI_Pkg_Decl_Cunit (Cunit)
11276 (Nkind (Unit (Cunit)) = N_Package_Body
11277 and then Is_RCI_Pkg_Decl_Cunit (Library_Unit (Cunit)));
11278 end Is_RCI_Pkg_Spec_Or_Body;
11280 -----------------------------------------
11281 -- Is_Remote_Access_To_Class_Wide_Type --
11282 -----------------------------------------
11284 function Is_Remote_Access_To_Class_Wide_Type
11285 (E : Entity_Id) return Boolean
11288 -- A remote access to class-wide type is a general access to object type
11289 -- declared in the visible part of a Remote_Types or Remote_Call_
11292 return Ekind (E) = E_General_Access_Type
11293 and then (Is_Remote_Call_Interface (E) or else Is_Remote_Types (E));
11294 end Is_Remote_Access_To_Class_Wide_Type;
11296 -----------------------------------------
11297 -- Is_Remote_Access_To_Subprogram_Type --
11298 -----------------------------------------
11300 function Is_Remote_Access_To_Subprogram_Type
11301 (E : Entity_Id) return Boolean
11304 return (Ekind (E) = E_Access_Subprogram_Type
11305 or else (Ekind (E) = E_Record_Type
11306 and then Present (Corresponding_Remote_Type (E))))
11307 and then (Is_Remote_Call_Interface (E) or else Is_Remote_Types (E));
11308 end Is_Remote_Access_To_Subprogram_Type;
11310 --------------------
11311 -- Is_Remote_Call --
11312 --------------------
11314 function Is_Remote_Call (N : Node_Id) return Boolean is
11316 if Nkind (N) not in N_Subprogram_Call then
11318 -- An entry call cannot be remote
11322 elsif Nkind (Name (N)) in N_Has_Entity
11323 and then Is_Remote_Call_Interface (Entity (Name (N)))
11325 -- A subprogram declared in the spec of a RCI package is remote
11329 elsif Nkind (Name (N)) = N_Explicit_Dereference
11330 and then Is_Remote_Access_To_Subprogram_Type
11331 (Etype (Prefix (Name (N))))
11333 -- The dereference of a RAS is a remote call
11337 elsif Present (Controlling_Argument (N))
11338 and then Is_Remote_Access_To_Class_Wide_Type
11339 (Etype (Controlling_Argument (N)))
11341 -- Any primitive operation call with a controlling argument of
11342 -- a RACW type is a remote call.
11347 -- All other calls are local calls
11350 end Is_Remote_Call;
11352 ----------------------
11353 -- Is_Renamed_Entry --
11354 ----------------------
11356 function Is_Renamed_Entry (Proc_Nam : Entity_Id) return Boolean is
11357 Orig_Node : Node_Id := Empty;
11358 Subp_Decl : Node_Id := Parent (Parent (Proc_Nam));
11360 function Is_Entry (Nam : Node_Id) return Boolean;
11361 -- Determine whether Nam is an entry. Traverse selectors if there are
11362 -- nested selected components.
11368 function Is_Entry (Nam : Node_Id) return Boolean is
11370 if Nkind (Nam) = N_Selected_Component then
11371 return Is_Entry (Selector_Name (Nam));
11374 return Ekind (Entity (Nam)) = E_Entry;
11377 -- Start of processing for Is_Renamed_Entry
11380 if Present (Alias (Proc_Nam)) then
11381 Subp_Decl := Parent (Parent (Alias (Proc_Nam)));
11384 -- Look for a rewritten subprogram renaming declaration
11386 if Nkind (Subp_Decl) = N_Subprogram_Declaration
11387 and then Present (Original_Node (Subp_Decl))
11389 Orig_Node := Original_Node (Subp_Decl);
11392 -- The rewritten subprogram is actually an entry
11394 if Present (Orig_Node)
11395 and then Nkind (Orig_Node) = N_Subprogram_Renaming_Declaration
11396 and then Is_Entry (Name (Orig_Node))
11402 end Is_Renamed_Entry;
11404 ----------------------------
11405 -- Is_Reversible_Iterator --
11406 ----------------------------
11408 function Is_Reversible_Iterator (Typ : Entity_Id) return Boolean is
11409 Ifaces_List : Elist_Id;
11410 Iface_Elmt : Elmt_Id;
11414 if Is_Class_Wide_Type (Typ)
11415 and then Chars (Etype (Typ)) = Name_Reversible_Iterator
11417 Is_Predefined_File_Name
11418 (Unit_File_Name (Get_Source_Unit (Etype (Typ))))
11422 elsif not Is_Tagged_Type (Typ)
11423 or else not Is_Derived_Type (Typ)
11428 Collect_Interfaces (Typ, Ifaces_List);
11430 Iface_Elmt := First_Elmt (Ifaces_List);
11431 while Present (Iface_Elmt) loop
11432 Iface := Node (Iface_Elmt);
11433 if Chars (Iface) = Name_Reversible_Iterator
11435 Is_Predefined_File_Name
11436 (Unit_File_Name (Get_Source_Unit (Iface)))
11441 Next_Elmt (Iface_Elmt);
11446 end Is_Reversible_Iterator;
11448 ----------------------
11449 -- Is_Selector_Name --
11450 ----------------------
11452 function Is_Selector_Name (N : Node_Id) return Boolean is
11454 if not Is_List_Member (N) then
11456 P : constant Node_Id := Parent (N);
11457 K : constant Node_Kind := Nkind (P);
11460 (K = N_Expanded_Name or else
11461 K = N_Generic_Association or else
11462 K = N_Parameter_Association or else
11463 K = N_Selected_Component)
11464 and then Selector_Name (P) = N;
11469 L : constant List_Id := List_Containing (N);
11470 P : constant Node_Id := Parent (L);
11472 return (Nkind (P) = N_Discriminant_Association
11473 and then Selector_Names (P) = L)
11475 (Nkind (P) = N_Component_Association
11476 and then Choices (P) = L);
11479 end Is_Selector_Name;
11481 ----------------------------------
11482 -- Is_SPARK_Initialization_Expr --
11483 ----------------------------------
11485 function Is_SPARK_Initialization_Expr (N : Node_Id) return Boolean is
11488 Comp_Assn : Node_Id;
11489 Orig_N : constant Node_Id := Original_Node (N);
11494 if not Comes_From_Source (Orig_N) then
11498 pragma Assert (Nkind (Orig_N) in N_Subexpr);
11500 case Nkind (Orig_N) is
11501 when N_Character_Literal |
11502 N_Integer_Literal |
11504 N_String_Literal =>
11507 when N_Identifier |
11509 if Is_Entity_Name (Orig_N)
11510 and then Present (Entity (Orig_N)) -- needed in some cases
11512 case Ekind (Entity (Orig_N)) is
11514 E_Enumeration_Literal |
11519 if Is_Type (Entity (Orig_N)) then
11527 when N_Qualified_Expression |
11528 N_Type_Conversion =>
11529 Is_Ok := Is_SPARK_Initialization_Expr (Expression (Orig_N));
11532 Is_Ok := Is_SPARK_Initialization_Expr (Right_Opnd (Orig_N));
11536 N_Membership_Test =>
11537 Is_Ok := Is_SPARK_Initialization_Expr (Left_Opnd (Orig_N))
11538 and then Is_SPARK_Initialization_Expr (Right_Opnd (Orig_N));
11541 N_Extension_Aggregate =>
11542 if Nkind (Orig_N) = N_Extension_Aggregate then
11543 Is_Ok := Is_SPARK_Initialization_Expr (Ancestor_Part (Orig_N));
11546 Expr := First (Expressions (Orig_N));
11547 while Present (Expr) loop
11548 if not Is_SPARK_Initialization_Expr (Expr) then
11556 Comp_Assn := First (Component_Associations (Orig_N));
11557 while Present (Comp_Assn) loop
11558 Expr := Expression (Comp_Assn);
11559 if Present (Expr) -- needed for box association
11560 and then not Is_SPARK_Initialization_Expr (Expr)
11569 when N_Attribute_Reference =>
11570 if Nkind (Prefix (Orig_N)) in N_Subexpr then
11571 Is_Ok := Is_SPARK_Initialization_Expr (Prefix (Orig_N));
11574 Expr := First (Expressions (Orig_N));
11575 while Present (Expr) loop
11576 if not Is_SPARK_Initialization_Expr (Expr) then
11584 -- Selected components might be expanded named not yet resolved, so
11585 -- default on the safe side. (Eg on sparklex.ads)
11587 when N_Selected_Component =>
11596 end Is_SPARK_Initialization_Expr;
11598 -------------------------------
11599 -- Is_SPARK_Object_Reference --
11600 -------------------------------
11602 function Is_SPARK_Object_Reference (N : Node_Id) return Boolean is
11604 if Is_Entity_Name (N) then
11605 return Present (Entity (N))
11607 (Ekind_In (Entity (N), E_Constant, E_Variable)
11608 or else Ekind (Entity (N)) in Formal_Kind);
11612 when N_Selected_Component =>
11613 return Is_SPARK_Object_Reference (Prefix (N));
11619 end Is_SPARK_Object_Reference;
11621 -----------------------
11622 -- Is_SPARK_Volatile --
11623 -----------------------
11625 function Is_SPARK_Volatile (Id : Entity_Id) return Boolean is
11627 return Is_Volatile (Id) or else Is_Volatile (Etype (Id));
11628 end Is_SPARK_Volatile;
11630 ------------------------------
11631 -- Is_SPARK_Volatile_Object --
11632 ------------------------------
11634 function Is_SPARK_Volatile_Object (N : Node_Id) return Boolean is
11636 if Is_Entity_Name (N) then
11637 return Is_SPARK_Volatile (Entity (N));
11639 elsif Nkind (N) = N_Expanded_Name then
11640 return Is_SPARK_Volatile (Entity (N));
11642 elsif Nkind (N) = N_Indexed_Component then
11643 return Is_SPARK_Volatile_Object (Prefix (N));
11645 elsif Nkind (N) = N_Selected_Component then
11647 Is_SPARK_Volatile_Object (Prefix (N))
11649 Is_SPARK_Volatile_Object (Selector_Name (N));
11654 end Is_SPARK_Volatile_Object;
11660 function Is_Statement (N : Node_Id) return Boolean is
11663 Nkind (N) in N_Statement_Other_Than_Procedure_Call
11664 or else Nkind (N) = N_Procedure_Call_Statement;
11667 --------------------------------------------------
11668 -- Is_Subprogram_Stub_Without_Prior_Declaration --
11669 --------------------------------------------------
11671 function Is_Subprogram_Stub_Without_Prior_Declaration
11672 (N : Node_Id) return Boolean
11675 -- A subprogram stub without prior declaration serves as declaration for
11676 -- the actual subprogram body. As such, it has an attached defining
11677 -- entity of E_[Generic_]Function or E_[Generic_]Procedure.
11679 return Nkind (N) = N_Subprogram_Body_Stub
11680 and then Ekind (Defining_Entity (N)) /= E_Subprogram_Body;
11681 end Is_Subprogram_Stub_Without_Prior_Declaration;
11683 ---------------------------------
11684 -- Is_Synchronized_Tagged_Type --
11685 ---------------------------------
11687 function Is_Synchronized_Tagged_Type (E : Entity_Id) return Boolean is
11688 Kind : constant Entity_Kind := Ekind (Base_Type (E));
11691 -- A task or protected type derived from an interface is a tagged type.
11692 -- Such a tagged type is called a synchronized tagged type, as are
11693 -- synchronized interfaces and private extensions whose declaration
11694 -- includes the reserved word synchronized.
11696 return (Is_Tagged_Type (E)
11697 and then (Kind = E_Task_Type
11698 or else Kind = E_Protected_Type))
11701 and then Is_Synchronized_Interface (E))
11703 (Ekind (E) = E_Record_Type_With_Private
11704 and then Nkind (Parent (E)) = N_Private_Extension_Declaration
11705 and then (Synchronized_Present (Parent (E))
11706 or else Is_Synchronized_Interface (Etype (E))));
11707 end Is_Synchronized_Tagged_Type;
11713 function Is_Transfer (N : Node_Id) return Boolean is
11714 Kind : constant Node_Kind := Nkind (N);
11717 if Kind = N_Simple_Return_Statement
11719 Kind = N_Extended_Return_Statement
11721 Kind = N_Goto_Statement
11723 Kind = N_Raise_Statement
11725 Kind = N_Requeue_Statement
11729 elsif (Kind = N_Exit_Statement or else Kind in N_Raise_xxx_Error)
11730 and then No (Condition (N))
11734 elsif Kind = N_Procedure_Call_Statement
11735 and then Is_Entity_Name (Name (N))
11736 and then Present (Entity (Name (N)))
11737 and then No_Return (Entity (Name (N)))
11741 elsif Nkind (Original_Node (N)) = N_Raise_Statement then
11753 function Is_True (U : Uint) return Boolean is
11758 --------------------------------------
11759 -- Is_Unchecked_Conversion_Instance --
11760 --------------------------------------
11762 function Is_Unchecked_Conversion_Instance (Id : Entity_Id) return Boolean is
11763 Gen_Par : Entity_Id;
11766 -- Look for a function whose generic parent is the predefined intrinsic
11767 -- function Unchecked_Conversion.
11769 if Ekind (Id) = E_Function then
11770 Gen_Par := Generic_Parent (Parent (Id));
11774 and then Chars (Gen_Par) = Name_Unchecked_Conversion
11775 and then Is_Intrinsic_Subprogram (Gen_Par)
11776 and then Is_Predefined_File_Name
11777 (Unit_File_Name (Get_Source_Unit (Gen_Par)));
11781 end Is_Unchecked_Conversion_Instance;
11783 -------------------------------
11784 -- Is_Universal_Numeric_Type --
11785 -------------------------------
11787 function Is_Universal_Numeric_Type (T : Entity_Id) return Boolean is
11789 return T = Universal_Integer or else T = Universal_Real;
11790 end Is_Universal_Numeric_Type;
11792 -------------------
11793 -- Is_Value_Type --
11794 -------------------
11796 function Is_Value_Type (T : Entity_Id) return Boolean is
11798 return VM_Target = CLI_Target
11799 and then Nkind (T) in N_Has_Chars
11800 and then Chars (T) /= No_Name
11801 and then Get_Name_String (Chars (T)) = "valuetype";
11804 ----------------------------
11805 -- Is_Variable_Size_Array --
11806 ----------------------------
11808 function Is_Variable_Size_Array (E : Entity_Id) return Boolean is
11812 pragma Assert (Is_Array_Type (E));
11814 -- Check if some index is initialized with a non-constant value
11816 Idx := First_Index (E);
11817 while Present (Idx) loop
11818 if Nkind (Idx) = N_Range then
11819 if not Is_Constant_Bound (Low_Bound (Idx))
11820 or else not Is_Constant_Bound (High_Bound (Idx))
11826 Idx := Next_Index (Idx);
11830 end Is_Variable_Size_Array;
11832 -----------------------------
11833 -- Is_Variable_Size_Record --
11834 -----------------------------
11836 function Is_Variable_Size_Record (E : Entity_Id) return Boolean is
11838 Comp_Typ : Entity_Id;
11841 pragma Assert (Is_Record_Type (E));
11843 Comp := First_Entity (E);
11844 while Present (Comp) loop
11845 Comp_Typ := Etype (Comp);
11847 -- Recursive call if the record type has discriminants
11849 if Is_Record_Type (Comp_Typ)
11850 and then Has_Discriminants (Comp_Typ)
11851 and then Is_Variable_Size_Record (Comp_Typ)
11855 elsif Is_Array_Type (Comp_Typ)
11856 and then Is_Variable_Size_Array (Comp_Typ)
11861 Next_Entity (Comp);
11865 end Is_Variable_Size_Record;
11867 ---------------------
11868 -- Is_VMS_Operator --
11869 ---------------------
11871 function Is_VMS_Operator (Op : Entity_Id) return Boolean is
11873 -- The VMS operators are declared in a child of System that is loaded
11874 -- through pragma Extend_System. In some rare cases a program is run
11875 -- with this extension but without indicating that the target is VMS.
11877 return Ekind (Op) = E_Function
11878 and then Is_Intrinsic_Subprogram (Op)
11880 ((Present_System_Aux and then Scope (Op) = System_Aux_Id)
11883 and then Scope (Scope (Op)) = RTU_Entity (System)));
11884 end Is_VMS_Operator;
11890 function Is_Variable
11892 Use_Original_Node : Boolean := True) return Boolean
11894 Orig_Node : Node_Id;
11896 function In_Protected_Function (E : Entity_Id) return Boolean;
11897 -- Within a protected function, the private components of the enclosing
11898 -- protected type are constants. A function nested within a (protected)
11899 -- procedure is not itself protected. Within the body of a protected
11900 -- function the current instance of the protected type is a constant.
11902 function Is_Variable_Prefix (P : Node_Id) return Boolean;
11903 -- Prefixes can involve implicit dereferences, in which case we must
11904 -- test for the case of a reference of a constant access type, which can
11905 -- can never be a variable.
11907 ---------------------------
11908 -- In_Protected_Function --
11909 ---------------------------
11911 function In_Protected_Function (E : Entity_Id) return Boolean is
11916 -- E is the current instance of a type
11918 if Is_Type (E) then
11927 if not Is_Protected_Type (Prot) then
11931 S := Current_Scope;
11932 while Present (S) and then S /= Prot loop
11933 if Ekind (S) = E_Function and then Scope (S) = Prot then
11942 end In_Protected_Function;
11944 ------------------------
11945 -- Is_Variable_Prefix --
11946 ------------------------
11948 function Is_Variable_Prefix (P : Node_Id) return Boolean is
11950 if Is_Access_Type (Etype (P)) then
11951 return not Is_Access_Constant (Root_Type (Etype (P)));
11953 -- For the case of an indexed component whose prefix has a packed
11954 -- array type, the prefix has been rewritten into a type conversion.
11955 -- Determine variable-ness from the converted expression.
11957 elsif Nkind (P) = N_Type_Conversion
11958 and then not Comes_From_Source (P)
11959 and then Is_Array_Type (Etype (P))
11960 and then Is_Packed (Etype (P))
11962 return Is_Variable (Expression (P));
11965 return Is_Variable (P);
11967 end Is_Variable_Prefix;
11969 -- Start of processing for Is_Variable
11972 -- Check if we perform the test on the original node since this may be a
11973 -- test of syntactic categories which must not be disturbed by whatever
11974 -- rewriting might have occurred. For example, an aggregate, which is
11975 -- certainly NOT a variable, could be turned into a variable by
11978 if Use_Original_Node then
11979 Orig_Node := Original_Node (N);
11984 -- Definitely OK if Assignment_OK is set. Since this is something that
11985 -- only gets set for expanded nodes, the test is on N, not Orig_Node.
11987 if Nkind (N) in N_Subexpr and then Assignment_OK (N) then
11990 -- Normally we go to the original node, but there is one exception where
11991 -- we use the rewritten node, namely when it is an explicit dereference.
11992 -- The generated code may rewrite a prefix which is an access type with
11993 -- an explicit dereference. The dereference is a variable, even though
11994 -- the original node may not be (since it could be a constant of the
11997 -- In Ada 2005 we have a further case to consider: the prefix may be a
11998 -- function call given in prefix notation. The original node appears to
11999 -- be a selected component, but we need to examine the call.
12001 elsif Nkind (N) = N_Explicit_Dereference
12002 and then Nkind (Orig_Node) /= N_Explicit_Dereference
12003 and then Present (Etype (Orig_Node))
12004 and then Is_Access_Type (Etype (Orig_Node))
12006 -- Note that if the prefix is an explicit dereference that does not
12007 -- come from source, we must check for a rewritten function call in
12008 -- prefixed notation before other forms of rewriting, to prevent a
12012 (Nkind (Orig_Node) = N_Function_Call
12013 and then not Is_Access_Constant (Etype (Prefix (N))))
12015 Is_Variable_Prefix (Original_Node (Prefix (N)));
12017 -- in Ada 2012, the dereference may have been added for a type with
12018 -- a declared implicit dereference aspect.
12020 elsif Nkind (N) = N_Explicit_Dereference
12021 and then Present (Etype (Orig_Node))
12022 and then Ada_Version >= Ada_2012
12023 and then Has_Implicit_Dereference (Etype (Orig_Node))
12027 -- A function call is never a variable
12029 elsif Nkind (N) = N_Function_Call then
12032 -- All remaining checks use the original node
12034 elsif Is_Entity_Name (Orig_Node)
12035 and then Present (Entity (Orig_Node))
12038 E : constant Entity_Id := Entity (Orig_Node);
12039 K : constant Entity_Kind := Ekind (E);
12042 return (K = E_Variable
12043 and then Nkind (Parent (E)) /= N_Exception_Handler)
12044 or else (K = E_Component
12045 and then not In_Protected_Function (E))
12046 or else K = E_Out_Parameter
12047 or else K = E_In_Out_Parameter
12048 or else K = E_Generic_In_Out_Parameter
12050 -- Current instance of type. If this is a protected type, check
12051 -- we are not within the body of one of its protected functions.
12053 or else (Is_Type (E)
12054 and then In_Open_Scopes (E)
12055 and then not In_Protected_Function (E))
12057 or else (Is_Incomplete_Or_Private_Type (E)
12058 and then In_Open_Scopes (Full_View (E)));
12062 case Nkind (Orig_Node) is
12063 when N_Indexed_Component | N_Slice =>
12064 return Is_Variable_Prefix (Prefix (Orig_Node));
12066 when N_Selected_Component =>
12067 return (Is_Variable (Selector_Name (Orig_Node))
12068 and then Is_Variable_Prefix (Prefix (Orig_Node)))
12070 (Nkind (N) = N_Expanded_Name
12071 and then Scope (Entity (N)) = Entity (Prefix (N)));
12073 -- For an explicit dereference, the type of the prefix cannot
12074 -- be an access to constant or an access to subprogram.
12076 when N_Explicit_Dereference =>
12078 Typ : constant Entity_Id := Etype (Prefix (Orig_Node));
12080 return Is_Access_Type (Typ)
12081 and then not Is_Access_Constant (Root_Type (Typ))
12082 and then Ekind (Typ) /= E_Access_Subprogram_Type;
12085 -- The type conversion is the case where we do not deal with the
12086 -- context dependent special case of an actual parameter. Thus
12087 -- the type conversion is only considered a variable for the
12088 -- purposes of this routine if the target type is tagged. However,
12089 -- a type conversion is considered to be a variable if it does not
12090 -- come from source (this deals for example with the conversions
12091 -- of expressions to their actual subtypes).
12093 when N_Type_Conversion =>
12094 return Is_Variable (Expression (Orig_Node))
12096 (not Comes_From_Source (Orig_Node)
12098 (Is_Tagged_Type (Etype (Subtype_Mark (Orig_Node)))
12100 Is_Tagged_Type (Etype (Expression (Orig_Node)))));
12102 -- GNAT allows an unchecked type conversion as a variable. This
12103 -- only affects the generation of internal expanded code, since
12104 -- calls to instantiations of Unchecked_Conversion are never
12105 -- considered variables (since they are function calls).
12107 when N_Unchecked_Type_Conversion =>
12108 return Is_Variable (Expression (Orig_Node));
12116 ---------------------------
12117 -- Is_Visibly_Controlled --
12118 ---------------------------
12120 function Is_Visibly_Controlled (T : Entity_Id) return Boolean is
12121 Root : constant Entity_Id := Root_Type (T);
12123 return Chars (Scope (Root)) = Name_Finalization
12124 and then Chars (Scope (Scope (Root))) = Name_Ada
12125 and then Scope (Scope (Scope (Root))) = Standard_Standard;
12126 end Is_Visibly_Controlled;
12128 ------------------------
12129 -- Is_Volatile_Object --
12130 ------------------------
12132 function Is_Volatile_Object (N : Node_Id) return Boolean is
12134 function Is_Volatile_Prefix (N : Node_Id) return Boolean;
12135 -- If prefix is an implicit dereference, examine designated type
12137 function Object_Has_Volatile_Components (N : Node_Id) return Boolean;
12138 -- Determines if given object has volatile components
12140 ------------------------
12141 -- Is_Volatile_Prefix --
12142 ------------------------
12144 function Is_Volatile_Prefix (N : Node_Id) return Boolean is
12145 Typ : constant Entity_Id := Etype (N);
12148 if Is_Access_Type (Typ) then
12150 Dtyp : constant Entity_Id := Designated_Type (Typ);
12153 return Is_Volatile (Dtyp)
12154 or else Has_Volatile_Components (Dtyp);
12158 return Object_Has_Volatile_Components (N);
12160 end Is_Volatile_Prefix;
12162 ------------------------------------
12163 -- Object_Has_Volatile_Components --
12164 ------------------------------------
12166 function Object_Has_Volatile_Components (N : Node_Id) return Boolean is
12167 Typ : constant Entity_Id := Etype (N);
12170 if Is_Volatile (Typ)
12171 or else Has_Volatile_Components (Typ)
12175 elsif Is_Entity_Name (N)
12176 and then (Has_Volatile_Components (Entity (N))
12177 or else Is_Volatile (Entity (N)))
12181 elsif Nkind (N) = N_Indexed_Component
12182 or else Nkind (N) = N_Selected_Component
12184 return Is_Volatile_Prefix (Prefix (N));
12189 end Object_Has_Volatile_Components;
12191 -- Start of processing for Is_Volatile_Object
12194 if Nkind (N) = N_Defining_Identifier then
12195 return Is_Volatile (N) or else Is_Volatile (Etype (N));
12197 elsif Nkind (N) = N_Expanded_Name then
12198 return Is_Volatile_Object (Entity (N));
12200 elsif Is_Volatile (Etype (N))
12201 or else (Is_Entity_Name (N) and then Is_Volatile (Entity (N)))
12205 elsif Nkind_In (N, N_Indexed_Component, N_Selected_Component)
12206 and then Is_Volatile_Prefix (Prefix (N))
12210 elsif Nkind (N) = N_Selected_Component
12211 and then Is_Volatile (Entity (Selector_Name (N)))
12218 end Is_Volatile_Object;
12220 ---------------------------
12221 -- Itype_Has_Declaration --
12222 ---------------------------
12224 function Itype_Has_Declaration (Id : Entity_Id) return Boolean is
12226 pragma Assert (Is_Itype (Id));
12227 return Present (Parent (Id))
12228 and then Nkind_In (Parent (Id), N_Full_Type_Declaration,
12229 N_Subtype_Declaration)
12230 and then Defining_Entity (Parent (Id)) = Id;
12231 end Itype_Has_Declaration;
12233 -------------------------
12234 -- Kill_Current_Values --
12235 -------------------------
12237 procedure Kill_Current_Values
12239 Last_Assignment_Only : Boolean := False)
12242 if Is_Assignable (Ent) then
12243 Set_Last_Assignment (Ent, Empty);
12246 if Is_Object (Ent) then
12247 if not Last_Assignment_Only then
12249 Set_Current_Value (Ent, Empty);
12251 if not Can_Never_Be_Null (Ent) then
12252 Set_Is_Known_Non_Null (Ent, False);
12255 Set_Is_Known_Null (Ent, False);
12257 -- Reset Is_Known_Valid unless type is always valid, or if we have
12258 -- a loop parameter (loop parameters are always valid, since their
12259 -- bounds are defined by the bounds given in the loop header).
12261 if not Is_Known_Valid (Etype (Ent))
12262 and then Ekind (Ent) /= E_Loop_Parameter
12264 Set_Is_Known_Valid (Ent, False);
12268 end Kill_Current_Values;
12270 procedure Kill_Current_Values (Last_Assignment_Only : Boolean := False) is
12273 procedure Kill_Current_Values_For_Entity_Chain (E : Entity_Id);
12274 -- Clear current value for entity E and all entities chained to E
12276 ------------------------------------------
12277 -- Kill_Current_Values_For_Entity_Chain --
12278 ------------------------------------------
12280 procedure Kill_Current_Values_For_Entity_Chain (E : Entity_Id) is
12284 while Present (Ent) loop
12285 Kill_Current_Values (Ent, Last_Assignment_Only);
12288 end Kill_Current_Values_For_Entity_Chain;
12290 -- Start of processing for Kill_Current_Values
12293 -- Kill all saved checks, a special case of killing saved values
12295 if not Last_Assignment_Only then
12299 -- Loop through relevant scopes, which includes the current scope and
12300 -- any parent scopes if the current scope is a block or a package.
12302 S := Current_Scope;
12305 -- Clear current values of all entities in current scope
12307 Kill_Current_Values_For_Entity_Chain (First_Entity (S));
12309 -- If scope is a package, also clear current values of all private
12310 -- entities in the scope.
12312 if Is_Package_Or_Generic_Package (S)
12313 or else Is_Concurrent_Type (S)
12315 Kill_Current_Values_For_Entity_Chain (First_Private_Entity (S));
12318 -- If this is a not a subprogram, deal with parents
12320 if not Is_Subprogram (S) then
12322 exit Scope_Loop when S = Standard_Standard;
12326 end loop Scope_Loop;
12327 end Kill_Current_Values;
12329 --------------------------
12330 -- Kill_Size_Check_Code --
12331 --------------------------
12333 procedure Kill_Size_Check_Code (E : Entity_Id) is
12335 if (Ekind (E) = E_Constant or else Ekind (E) = E_Variable)
12336 and then Present (Size_Check_Code (E))
12338 Remove (Size_Check_Code (E));
12339 Set_Size_Check_Code (E, Empty);
12341 end Kill_Size_Check_Code;
12343 --------------------------
12344 -- Known_To_Be_Assigned --
12345 --------------------------
12347 function Known_To_Be_Assigned (N : Node_Id) return Boolean is
12348 P : constant Node_Id := Parent (N);
12353 -- Test left side of assignment
12355 when N_Assignment_Statement =>
12356 return N = Name (P);
12358 -- Function call arguments are never lvalues
12360 when N_Function_Call =>
12363 -- Positional parameter for procedure or accept call
12365 when N_Procedure_Call_Statement |
12374 Proc := Get_Subprogram_Entity (P);
12380 -- If we are not a list member, something is strange, so
12381 -- be conservative and return False.
12383 if not Is_List_Member (N) then
12387 -- We are going to find the right formal by stepping forward
12388 -- through the formals, as we step backwards in the actuals.
12390 Form := First_Formal (Proc);
12393 -- If no formal, something is weird, so be conservative
12394 -- and return False.
12401 exit when No (Act);
12402 Next_Formal (Form);
12405 return Ekind (Form) /= E_In_Parameter;
12408 -- Named parameter for procedure or accept call
12410 when N_Parameter_Association =>
12416 Proc := Get_Subprogram_Entity (Parent (P));
12422 -- Loop through formals to find the one that matches
12424 Form := First_Formal (Proc);
12426 -- If no matching formal, that's peculiar, some kind of
12427 -- previous error, so return False to be conservative.
12428 -- Actually this also happens in legal code in the case
12429 -- where P is a parameter association for an Extra_Formal???
12435 -- Else test for match
12437 if Chars (Form) = Chars (Selector_Name (P)) then
12438 return Ekind (Form) /= E_In_Parameter;
12441 Next_Formal (Form);
12445 -- Test for appearing in a conversion that itself appears
12446 -- in an lvalue context, since this should be an lvalue.
12448 when N_Type_Conversion =>
12449 return Known_To_Be_Assigned (P);
12451 -- All other references are definitely not known to be modifications
12457 end Known_To_Be_Assigned;
12459 ---------------------------
12460 -- Last_Source_Statement --
12461 ---------------------------
12463 function Last_Source_Statement (HSS : Node_Id) return Node_Id is
12467 N := Last (Statements (HSS));
12468 while Present (N) loop
12469 exit when Comes_From_Source (N);
12474 end Last_Source_Statement;
12476 ----------------------------------
12477 -- Matching_Static_Array_Bounds --
12478 ----------------------------------
12480 function Matching_Static_Array_Bounds
12482 R_Typ : Node_Id) return Boolean
12484 L_Ndims : constant Nat := Number_Dimensions (L_Typ);
12485 R_Ndims : constant Nat := Number_Dimensions (R_Typ);
12497 if L_Ndims /= R_Ndims then
12501 -- Unconstrained types do not have static bounds
12503 if not Is_Constrained (L_Typ) or else not Is_Constrained (R_Typ) then
12507 -- First treat specially the first dimension, as the lower bound and
12508 -- length of string literals are not stored like those of arrays.
12510 if Ekind (L_Typ) = E_String_Literal_Subtype then
12511 L_Low := String_Literal_Low_Bound (L_Typ);
12512 L_Len := String_Literal_Length (L_Typ);
12514 L_Index := First_Index (L_Typ);
12515 Get_Index_Bounds (L_Index, L_Low, L_High);
12517 if Is_OK_Static_Expression (L_Low)
12518 and then Is_OK_Static_Expression (L_High)
12520 if Expr_Value (L_High) < Expr_Value (L_Low) then
12523 L_Len := (Expr_Value (L_High) - Expr_Value (L_Low)) + 1;
12530 if Ekind (R_Typ) = E_String_Literal_Subtype then
12531 R_Low := String_Literal_Low_Bound (R_Typ);
12532 R_Len := String_Literal_Length (R_Typ);
12534 R_Index := First_Index (R_Typ);
12535 Get_Index_Bounds (R_Index, R_Low, R_High);
12537 if Is_OK_Static_Expression (R_Low)
12538 and then Is_OK_Static_Expression (R_High)
12540 if Expr_Value (R_High) < Expr_Value (R_Low) then
12543 R_Len := (Expr_Value (R_High) - Expr_Value (R_Low)) + 1;
12550 if Is_OK_Static_Expression (L_Low)
12551 and then Is_OK_Static_Expression (R_Low)
12552 and then Expr_Value (L_Low) = Expr_Value (R_Low)
12553 and then L_Len = R_Len
12560 -- Then treat all other dimensions
12562 for Indx in 2 .. L_Ndims loop
12566 Get_Index_Bounds (L_Index, L_Low, L_High);
12567 Get_Index_Bounds (R_Index, R_Low, R_High);
12569 if Is_OK_Static_Expression (L_Low)
12570 and then Is_OK_Static_Expression (L_High)
12571 and then Is_OK_Static_Expression (R_Low)
12572 and then Is_OK_Static_Expression (R_High)
12573 and then Expr_Value (L_Low) = Expr_Value (R_Low)
12574 and then Expr_Value (L_High) = Expr_Value (R_High)
12582 -- If we fall through the loop, all indexes matched
12585 end Matching_Static_Array_Bounds;
12587 -------------------
12588 -- May_Be_Lvalue --
12589 -------------------
12591 function May_Be_Lvalue (N : Node_Id) return Boolean is
12592 P : constant Node_Id := Parent (N);
12597 -- Test left side of assignment
12599 when N_Assignment_Statement =>
12600 return N = Name (P);
12602 -- Test prefix of component or attribute. Note that the prefix of an
12603 -- explicit or implicit dereference cannot be an l-value.
12605 when N_Attribute_Reference =>
12606 return N = Prefix (P)
12607 and then Name_Implies_Lvalue_Prefix (Attribute_Name (P));
12609 -- For an expanded name, the name is an lvalue if the expanded name
12610 -- is an lvalue, but the prefix is never an lvalue, since it is just
12611 -- the scope where the name is found.
12613 when N_Expanded_Name =>
12614 if N = Prefix (P) then
12615 return May_Be_Lvalue (P);
12620 -- For a selected component A.B, A is certainly an lvalue if A.B is.
12621 -- B is a little interesting, if we have A.B := 3, there is some
12622 -- discussion as to whether B is an lvalue or not, we choose to say
12623 -- it is. Note however that A is not an lvalue if it is of an access
12624 -- type since this is an implicit dereference.
12626 when N_Selected_Component =>
12628 and then Present (Etype (N))
12629 and then Is_Access_Type (Etype (N))
12633 return May_Be_Lvalue (P);
12636 -- For an indexed component or slice, the index or slice bounds is
12637 -- never an lvalue. The prefix is an lvalue if the indexed component
12638 -- or slice is an lvalue, except if it is an access type, where we
12639 -- have an implicit dereference.
12641 when N_Indexed_Component | N_Slice =>
12643 or else (Present (Etype (N)) and then Is_Access_Type (Etype (N)))
12647 return May_Be_Lvalue (P);
12650 -- Prefix of a reference is an lvalue if the reference is an lvalue
12652 when N_Reference =>
12653 return May_Be_Lvalue (P);
12655 -- Prefix of explicit dereference is never an lvalue
12657 when N_Explicit_Dereference =>
12660 -- Positional parameter for subprogram, entry, or accept call.
12661 -- In older versions of Ada function call arguments are never
12662 -- lvalues. In Ada 2012 functions can have in-out parameters.
12664 when N_Subprogram_Call |
12665 N_Entry_Call_Statement |
12668 if Nkind (P) = N_Function_Call and then Ada_Version < Ada_2012 then
12672 -- The following mechanism is clumsy and fragile. A single flag
12673 -- set in Resolve_Actuals would be preferable ???
12681 Proc := Get_Subprogram_Entity (P);
12687 -- If we are not a list member, something is strange, so be
12688 -- conservative and return True.
12690 if not Is_List_Member (N) then
12694 -- We are going to find the right formal by stepping forward
12695 -- through the formals, as we step backwards in the actuals.
12697 Form := First_Formal (Proc);
12700 -- If no formal, something is weird, so be conservative and
12708 exit when No (Act);
12709 Next_Formal (Form);
12712 return Ekind (Form) /= E_In_Parameter;
12715 -- Named parameter for procedure or accept call
12717 when N_Parameter_Association =>
12723 Proc := Get_Subprogram_Entity (Parent (P));
12729 -- Loop through formals to find the one that matches
12731 Form := First_Formal (Proc);
12733 -- If no matching formal, that's peculiar, some kind of
12734 -- previous error, so return True to be conservative.
12735 -- Actually happens with legal code for an unresolved call
12736 -- where we may get the wrong homonym???
12742 -- Else test for match
12744 if Chars (Form) = Chars (Selector_Name (P)) then
12745 return Ekind (Form) /= E_In_Parameter;
12748 Next_Formal (Form);
12752 -- Test for appearing in a conversion that itself appears in an
12753 -- lvalue context, since this should be an lvalue.
12755 when N_Type_Conversion =>
12756 return May_Be_Lvalue (P);
12758 -- Test for appearance in object renaming declaration
12760 when N_Object_Renaming_Declaration =>
12763 -- All other references are definitely not lvalues
12771 -----------------------
12772 -- Mark_Coextensions --
12773 -----------------------
12775 procedure Mark_Coextensions (Context_Nod : Node_Id; Root_Nod : Node_Id) is
12776 Is_Dynamic : Boolean;
12777 -- Indicates whether the context causes nested coextensions to be
12778 -- dynamic or static
12780 function Mark_Allocator (N : Node_Id) return Traverse_Result;
12781 -- Recognize an allocator node and label it as a dynamic coextension
12783 --------------------
12784 -- Mark_Allocator --
12785 --------------------
12787 function Mark_Allocator (N : Node_Id) return Traverse_Result is
12789 if Nkind (N) = N_Allocator then
12791 Set_Is_Dynamic_Coextension (N);
12793 -- If the allocator expression is potentially dynamic, it may
12794 -- be expanded out of order and require dynamic allocation
12795 -- anyway, so we treat the coextension itself as dynamic.
12796 -- Potential optimization ???
12798 elsif Nkind (Expression (N)) = N_Qualified_Expression
12799 and then Nkind (Expression (Expression (N))) = N_Op_Concat
12801 Set_Is_Dynamic_Coextension (N);
12803 Set_Is_Static_Coextension (N);
12808 end Mark_Allocator;
12810 procedure Mark_Allocators is new Traverse_Proc (Mark_Allocator);
12812 -- Start of processing Mark_Coextensions
12815 case Nkind (Context_Nod) is
12817 -- Comment here ???
12819 when N_Assignment_Statement =>
12820 Is_Dynamic := Nkind (Expression (Context_Nod)) = N_Allocator;
12822 -- An allocator that is a component of a returned aggregate
12823 -- must be dynamic.
12825 when N_Simple_Return_Statement =>
12827 Expr : constant Node_Id := Expression (Context_Nod);
12830 Nkind (Expr) = N_Allocator
12832 (Nkind (Expr) = N_Qualified_Expression
12833 and then Nkind (Expression (Expr)) = N_Aggregate);
12836 -- An alloctor within an object declaration in an extended return
12837 -- statement is of necessity dynamic.
12839 when N_Object_Declaration =>
12840 Is_Dynamic := Nkind (Root_Nod) = N_Allocator
12842 Nkind (Parent (Context_Nod)) = N_Extended_Return_Statement;
12844 -- This routine should not be called for constructs which may not
12845 -- contain coextensions.
12848 raise Program_Error;
12851 Mark_Allocators (Root_Nod);
12852 end Mark_Coextensions;
12858 function Must_Inline (Subp : Entity_Id) return Boolean is
12861 (Optimization_Level = 0
12863 -- AAMP and VM targets have no support for inlining in the backend.
12864 -- Hence we do as much inlining as possible in the front end.
12866 or else AAMP_On_Target
12867 or else VM_Target /= No_VM)
12868 and then Has_Pragma_Inline (Subp)
12869 and then (Has_Pragma_Inline_Always (Subp) or else Front_End_Inlining);
12872 ----------------------
12873 -- Needs_One_Actual --
12874 ----------------------
12876 function Needs_One_Actual (E : Entity_Id) return Boolean is
12877 Formal : Entity_Id;
12880 -- Ada 2005 or later, and formals present
12882 if Ada_Version >= Ada_2005 and then Present (First_Formal (E)) then
12883 Formal := Next_Formal (First_Formal (E));
12884 while Present (Formal) loop
12885 if No (Default_Value (Formal)) then
12889 Next_Formal (Formal);
12894 -- Ada 83/95 or no formals
12899 end Needs_One_Actual;
12901 ------------------------
12902 -- New_Copy_List_Tree --
12903 ------------------------
12905 function New_Copy_List_Tree (List : List_Id) return List_Id is
12910 if List = No_List then
12917 while Present (E) loop
12918 Append (New_Copy_Tree (E), NL);
12924 end New_Copy_List_Tree;
12926 -------------------
12927 -- New_Copy_Tree --
12928 -------------------
12930 use Atree.Unchecked_Access;
12931 use Atree_Private_Part;
12933 -- Our approach here requires a two pass traversal of the tree. The
12934 -- first pass visits all nodes that eventually will be copied looking
12935 -- for defining Itypes. If any defining Itypes are found, then they are
12936 -- copied, and an entry is added to the replacement map. In the second
12937 -- phase, the tree is copied, using the replacement map to replace any
12938 -- Itype references within the copied tree.
12940 -- The following hash tables are used if the Map supplied has more
12941 -- than hash threshold entries to speed up access to the map. If
12942 -- there are fewer entries, then the map is searched sequentially
12943 -- (because setting up a hash table for only a few entries takes
12944 -- more time than it saves.
12946 function New_Copy_Hash (E : Entity_Id) return NCT_Header_Num;
12947 -- Hash function used for hash operations
12949 -------------------
12950 -- New_Copy_Hash --
12951 -------------------
12953 function New_Copy_Hash (E : Entity_Id) return NCT_Header_Num is
12955 return Nat (E) mod (NCT_Header_Num'Last + 1);
12962 -- The hash table NCT_Assoc associates old entities in the table
12963 -- with their corresponding new entities (i.e. the pairs of entries
12964 -- presented in the original Map argument are Key-Element pairs).
12966 package NCT_Assoc is new Simple_HTable (
12967 Header_Num => NCT_Header_Num,
12968 Element => Entity_Id,
12969 No_Element => Empty,
12971 Hash => New_Copy_Hash,
12972 Equal => Types."=");
12974 ---------------------
12975 -- NCT_Itype_Assoc --
12976 ---------------------
12978 -- The hash table NCT_Itype_Assoc contains entries only for those
12979 -- old nodes which have a non-empty Associated_Node_For_Itype set.
12980 -- The key is the associated node, and the element is the new node
12981 -- itself (NOT the associated node for the new node).
12983 package NCT_Itype_Assoc is new Simple_HTable (
12984 Header_Num => NCT_Header_Num,
12985 Element => Entity_Id,
12986 No_Element => Empty,
12988 Hash => New_Copy_Hash,
12989 Equal => Types."=");
12991 -- Start of processing for New_Copy_Tree function
12993 function New_Copy_Tree
12995 Map : Elist_Id := No_Elist;
12996 New_Sloc : Source_Ptr := No_Location;
12997 New_Scope : Entity_Id := Empty) return Node_Id
12999 Actual_Map : Elist_Id := Map;
13000 -- This is the actual map for the copy. It is initialized with the
13001 -- given elements, and then enlarged as required for Itypes that are
13002 -- copied during the first phase of the copy operation. The visit
13003 -- procedures add elements to this map as Itypes are encountered.
13004 -- The reason we cannot use Map directly, is that it may well be
13005 -- (and normally is) initialized to No_Elist, and if we have mapped
13006 -- entities, we have to reset it to point to a real Elist.
13008 function Assoc (N : Node_Or_Entity_Id) return Node_Id;
13009 -- Called during second phase to map entities into their corresponding
13010 -- copies using Actual_Map. If the argument is not an entity, or is not
13011 -- in Actual_Map, then it is returned unchanged.
13013 procedure Build_NCT_Hash_Tables;
13014 -- Builds hash tables (number of elements >= threshold value)
13016 function Copy_Elist_With_Replacement
13017 (Old_Elist : Elist_Id) return Elist_Id;
13018 -- Called during second phase to copy element list doing replacements
13020 procedure Copy_Itype_With_Replacement (New_Itype : Entity_Id);
13021 -- Called during the second phase to process a copied Itype. The actual
13022 -- copy happened during the first phase (so that we could make the entry
13023 -- in the mapping), but we still have to deal with the descendents of
13024 -- the copied Itype and copy them where necessary.
13026 function Copy_List_With_Replacement (Old_List : List_Id) return List_Id;
13027 -- Called during second phase to copy list doing replacements
13029 function Copy_Node_With_Replacement (Old_Node : Node_Id) return Node_Id;
13030 -- Called during second phase to copy node doing replacements
13032 procedure Visit_Elist (E : Elist_Id);
13033 -- Called during first phase to visit all elements of an Elist
13035 procedure Visit_Field (F : Union_Id; N : Node_Id);
13036 -- Visit a single field, recursing to call Visit_Node or Visit_List
13037 -- if the field is a syntactic descendent of the current node (i.e.
13038 -- its parent is Node N).
13040 procedure Visit_Itype (Old_Itype : Entity_Id);
13041 -- Called during first phase to visit subsidiary fields of a defining
13042 -- Itype, and also create a copy and make an entry in the replacement
13043 -- map for the new copy.
13045 procedure Visit_List (L : List_Id);
13046 -- Called during first phase to visit all elements of a List
13048 procedure Visit_Node (N : Node_Or_Entity_Id);
13049 -- Called during first phase to visit a node and all its subtrees
13055 function Assoc (N : Node_Or_Entity_Id) return Node_Id is
13060 if not Has_Extension (N) or else No (Actual_Map) then
13063 elsif NCT_Hash_Tables_Used then
13064 Ent := NCT_Assoc.Get (Entity_Id (N));
13066 if Present (Ent) then
13072 -- No hash table used, do serial search
13075 E := First_Elmt (Actual_Map);
13076 while Present (E) loop
13077 if Node (E) = N then
13078 return Node (Next_Elmt (E));
13080 E := Next_Elmt (Next_Elmt (E));
13088 ---------------------------
13089 -- Build_NCT_Hash_Tables --
13090 ---------------------------
13092 procedure Build_NCT_Hash_Tables is
13096 if NCT_Hash_Table_Setup then
13098 NCT_Itype_Assoc.Reset;
13101 Elmt := First_Elmt (Actual_Map);
13102 while Present (Elmt) loop
13103 Ent := Node (Elmt);
13105 -- Get new entity, and associate old and new
13108 NCT_Assoc.Set (Ent, Node (Elmt));
13110 if Is_Type (Ent) then
13112 Anode : constant Entity_Id :=
13113 Associated_Node_For_Itype (Ent);
13116 if Present (Anode) then
13118 -- Enter a link between the associated node of the
13119 -- old Itype and the new Itype, for updating later
13120 -- when node is copied.
13122 NCT_Itype_Assoc.Set (Anode, Node (Elmt));
13130 NCT_Hash_Tables_Used := True;
13131 NCT_Hash_Table_Setup := True;
13132 end Build_NCT_Hash_Tables;
13134 ---------------------------------
13135 -- Copy_Elist_With_Replacement --
13136 ---------------------------------
13138 function Copy_Elist_With_Replacement
13139 (Old_Elist : Elist_Id) return Elist_Id
13142 New_Elist : Elist_Id;
13145 if No (Old_Elist) then
13149 New_Elist := New_Elmt_List;
13151 M := First_Elmt (Old_Elist);
13152 while Present (M) loop
13153 Append_Elmt (Copy_Node_With_Replacement (Node (M)), New_Elist);
13159 end Copy_Elist_With_Replacement;
13161 ---------------------------------
13162 -- Copy_Itype_With_Replacement --
13163 ---------------------------------
13165 -- This routine exactly parallels its phase one analog Visit_Itype,
13167 procedure Copy_Itype_With_Replacement (New_Itype : Entity_Id) is
13169 -- Translate Next_Entity, Scope and Etype fields, in case they
13170 -- reference entities that have been mapped into copies.
13172 Set_Next_Entity (New_Itype, Assoc (Next_Entity (New_Itype)));
13173 Set_Etype (New_Itype, Assoc (Etype (New_Itype)));
13175 if Present (New_Scope) then
13176 Set_Scope (New_Itype, New_Scope);
13178 Set_Scope (New_Itype, Assoc (Scope (New_Itype)));
13181 -- Copy referenced fields
13183 if Is_Discrete_Type (New_Itype) then
13184 Set_Scalar_Range (New_Itype,
13185 Copy_Node_With_Replacement (Scalar_Range (New_Itype)));
13187 elsif Has_Discriminants (Base_Type (New_Itype)) then
13188 Set_Discriminant_Constraint (New_Itype,
13189 Copy_Elist_With_Replacement
13190 (Discriminant_Constraint (New_Itype)));
13192 elsif Is_Array_Type (New_Itype) then
13193 if Present (First_Index (New_Itype)) then
13194 Set_First_Index (New_Itype,
13195 First (Copy_List_With_Replacement
13196 (List_Containing (First_Index (New_Itype)))));
13199 if Is_Packed (New_Itype) then
13200 Set_Packed_Array_Impl_Type (New_Itype,
13201 Copy_Node_With_Replacement
13202 (Packed_Array_Impl_Type (New_Itype)));
13205 end Copy_Itype_With_Replacement;
13207 --------------------------------
13208 -- Copy_List_With_Replacement --
13209 --------------------------------
13211 function Copy_List_With_Replacement
13212 (Old_List : List_Id) return List_Id
13214 New_List : List_Id;
13218 if Old_List = No_List then
13222 New_List := Empty_List;
13224 E := First (Old_List);
13225 while Present (E) loop
13226 Append (Copy_Node_With_Replacement (E), New_List);
13232 end Copy_List_With_Replacement;
13234 --------------------------------
13235 -- Copy_Node_With_Replacement --
13236 --------------------------------
13238 function Copy_Node_With_Replacement
13239 (Old_Node : Node_Id) return Node_Id
13241 New_Node : Node_Id;
13243 procedure Adjust_Named_Associations
13244 (Old_Node : Node_Id;
13245 New_Node : Node_Id);
13246 -- If a call node has named associations, these are chained through
13247 -- the First_Named_Actual, Next_Named_Actual links. These must be
13248 -- propagated separately to the new parameter list, because these
13249 -- are not syntactic fields.
13251 function Copy_Field_With_Replacement
13252 (Field : Union_Id) return Union_Id;
13253 -- Given Field, which is a field of Old_Node, return a copy of it
13254 -- if it is a syntactic field (i.e. its parent is Node), setting
13255 -- the parent of the copy to poit to New_Node. Otherwise returns
13256 -- the field (possibly mapped if it is an entity).
13258 -------------------------------
13259 -- Adjust_Named_Associations --
13260 -------------------------------
13262 procedure Adjust_Named_Associations
13263 (Old_Node : Node_Id;
13264 New_Node : Node_Id)
13269 Old_Next : Node_Id;
13270 New_Next : Node_Id;
13273 Old_E := First (Parameter_Associations (Old_Node));
13274 New_E := First (Parameter_Associations (New_Node));
13275 while Present (Old_E) loop
13276 if Nkind (Old_E) = N_Parameter_Association
13277 and then Present (Next_Named_Actual (Old_E))
13279 if First_Named_Actual (Old_Node)
13280 = Explicit_Actual_Parameter (Old_E)
13282 Set_First_Named_Actual
13283 (New_Node, Explicit_Actual_Parameter (New_E));
13286 -- Now scan parameter list from the beginning,to locate
13287 -- next named actual, which can be out of order.
13289 Old_Next := First (Parameter_Associations (Old_Node));
13290 New_Next := First (Parameter_Associations (New_Node));
13292 while Nkind (Old_Next) /= N_Parameter_Association
13293 or else Explicit_Actual_Parameter (Old_Next)
13294 /= Next_Named_Actual (Old_E)
13300 Set_Next_Named_Actual
13301 (New_E, Explicit_Actual_Parameter (New_Next));
13307 end Adjust_Named_Associations;
13309 ---------------------------------
13310 -- Copy_Field_With_Replacement --
13311 ---------------------------------
13313 function Copy_Field_With_Replacement
13314 (Field : Union_Id) return Union_Id
13317 if Field = Union_Id (Empty) then
13320 elsif Field in Node_Range then
13322 Old_N : constant Node_Id := Node_Id (Field);
13326 -- If syntactic field, as indicated by the parent pointer
13327 -- being set, then copy the referenced node recursively.
13329 if Parent (Old_N) = Old_Node then
13330 New_N := Copy_Node_With_Replacement (Old_N);
13332 if New_N /= Old_N then
13333 Set_Parent (New_N, New_Node);
13336 -- For semantic fields, update possible entity reference
13337 -- from the replacement map.
13340 New_N := Assoc (Old_N);
13343 return Union_Id (New_N);
13346 elsif Field in List_Range then
13348 Old_L : constant List_Id := List_Id (Field);
13352 -- If syntactic field, as indicated by the parent pointer,
13353 -- then recursively copy the entire referenced list.
13355 if Parent (Old_L) = Old_Node then
13356 New_L := Copy_List_With_Replacement (Old_L);
13357 Set_Parent (New_L, New_Node);
13359 -- For semantic list, just returned unchanged
13365 return Union_Id (New_L);
13368 -- Anything other than a list or a node is returned unchanged
13373 end Copy_Field_With_Replacement;
13375 -- Start of processing for Copy_Node_With_Replacement
13378 if Old_Node <= Empty_Or_Error then
13381 elsif Has_Extension (Old_Node) then
13382 return Assoc (Old_Node);
13385 New_Node := New_Copy (Old_Node);
13387 -- If the node we are copying is the associated node of a
13388 -- previously copied Itype, then adjust the associated node
13389 -- of the copy of that Itype accordingly.
13391 if Present (Actual_Map) then
13397 -- Case of hash table used
13399 if NCT_Hash_Tables_Used then
13400 Ent := NCT_Itype_Assoc.Get (Old_Node);
13402 if Present (Ent) then
13403 Set_Associated_Node_For_Itype (Ent, New_Node);
13406 -- Case of no hash table used
13409 E := First_Elmt (Actual_Map);
13410 while Present (E) loop
13411 if Is_Itype (Node (E))
13413 Old_Node = Associated_Node_For_Itype (Node (E))
13415 Set_Associated_Node_For_Itype
13416 (Node (Next_Elmt (E)), New_Node);
13419 E := Next_Elmt (Next_Elmt (E));
13425 -- Recursively copy descendents
13428 (New_Node, Copy_Field_With_Replacement (Field1 (New_Node)));
13430 (New_Node, Copy_Field_With_Replacement (Field2 (New_Node)));
13432 (New_Node, Copy_Field_With_Replacement (Field3 (New_Node)));
13434 (New_Node, Copy_Field_With_Replacement (Field4 (New_Node)));
13436 (New_Node, Copy_Field_With_Replacement (Field5 (New_Node)));
13438 -- Adjust Sloc of new node if necessary
13440 if New_Sloc /= No_Location then
13441 Set_Sloc (New_Node, New_Sloc);
13443 -- If we adjust the Sloc, then we are essentially making
13444 -- a completely new node, so the Comes_From_Source flag
13445 -- should be reset to the proper default value.
13447 Nodes.Table (New_Node).Comes_From_Source :=
13448 Default_Node.Comes_From_Source;
13451 -- If the node is call and has named associations,
13452 -- set the corresponding links in the copy.
13454 if (Nkind (Old_Node) = N_Function_Call
13455 or else Nkind (Old_Node) = N_Entry_Call_Statement
13457 Nkind (Old_Node) = N_Procedure_Call_Statement)
13458 and then Present (First_Named_Actual (Old_Node))
13460 Adjust_Named_Associations (Old_Node, New_Node);
13463 -- Reset First_Real_Statement for Handled_Sequence_Of_Statements.
13464 -- The replacement mechanism applies to entities, and is not used
13465 -- here. Eventually we may need a more general graph-copying
13466 -- routine. For now, do a sequential search to find desired node.
13468 if Nkind (Old_Node) = N_Handled_Sequence_Of_Statements
13469 and then Present (First_Real_Statement (Old_Node))
13472 Old_F : constant Node_Id := First_Real_Statement (Old_Node);
13476 N1 := First (Statements (Old_Node));
13477 N2 := First (Statements (New_Node));
13479 while N1 /= Old_F loop
13484 Set_First_Real_Statement (New_Node, N2);
13489 -- All done, return copied node
13492 end Copy_Node_With_Replacement;
13498 procedure Visit_Elist (E : Elist_Id) is
13501 if Present (E) then
13502 Elmt := First_Elmt (E);
13504 while Elmt /= No_Elmt loop
13505 Visit_Node (Node (Elmt));
13515 procedure Visit_Field (F : Union_Id; N : Node_Id) is
13517 if F = Union_Id (Empty) then
13520 elsif F in Node_Range then
13522 -- Copy node if it is syntactic, i.e. its parent pointer is
13523 -- set to point to the field that referenced it (certain
13524 -- Itypes will also meet this criterion, which is fine, since
13525 -- these are clearly Itypes that do need to be copied, since
13526 -- we are copying their parent.)
13528 if Parent (Node_Id (F)) = N then
13529 Visit_Node (Node_Id (F));
13532 -- Another case, if we are pointing to an Itype, then we want
13533 -- to copy it if its associated node is somewhere in the tree
13536 -- Note: the exclusion of self-referential copies is just an
13537 -- optimization, since the search of the already copied list
13538 -- would catch it, but it is a common case (Etype pointing
13539 -- to itself for an Itype that is a base type).
13541 elsif Has_Extension (Node_Id (F))
13542 and then Is_Itype (Entity_Id (F))
13543 and then Node_Id (F) /= N
13549 P := Associated_Node_For_Itype (Node_Id (F));
13550 while Present (P) loop
13552 Visit_Node (Node_Id (F));
13559 -- An Itype whose parent is not being copied definitely
13560 -- should NOT be copied, since it does not belong in any
13561 -- sense to the copied subtree.
13567 elsif F in List_Range
13568 and then Parent (List_Id (F)) = N
13570 Visit_List (List_Id (F));
13579 procedure Visit_Itype (Old_Itype : Entity_Id) is
13580 New_Itype : Entity_Id;
13585 -- Itypes that describe the designated type of access to subprograms
13586 -- have the structure of subprogram declarations, with signatures,
13587 -- etc. Either we duplicate the signatures completely, or choose to
13588 -- share such itypes, which is fine because their elaboration will
13589 -- have no side effects.
13591 if Ekind (Old_Itype) = E_Subprogram_Type then
13595 New_Itype := New_Copy (Old_Itype);
13597 -- The new Itype has all the attributes of the old one, and
13598 -- we just copy the contents of the entity. However, the back-end
13599 -- needs different names for debugging purposes, so we create a
13600 -- new internal name for it in all cases.
13602 Set_Chars (New_Itype, New_Internal_Name ('T'));
13604 -- If our associated node is an entity that has already been copied,
13605 -- then set the associated node of the copy to point to the right
13606 -- copy. If we have copied an Itype that is itself the associated
13607 -- node of some previously copied Itype, then we set the right
13608 -- pointer in the other direction.
13610 if Present (Actual_Map) then
13612 -- Case of hash tables used
13614 if NCT_Hash_Tables_Used then
13616 Ent := NCT_Assoc.Get (Associated_Node_For_Itype (Old_Itype));
13618 if Present (Ent) then
13619 Set_Associated_Node_For_Itype (New_Itype, Ent);
13622 Ent := NCT_Itype_Assoc.Get (Old_Itype);
13623 if Present (Ent) then
13624 Set_Associated_Node_For_Itype (Ent, New_Itype);
13626 -- If the hash table has no association for this Itype and
13627 -- its associated node, enter one now.
13630 NCT_Itype_Assoc.Set
13631 (Associated_Node_For_Itype (Old_Itype), New_Itype);
13634 -- Case of hash tables not used
13637 E := First_Elmt (Actual_Map);
13638 while Present (E) loop
13639 if Associated_Node_For_Itype (Old_Itype) = Node (E) then
13640 Set_Associated_Node_For_Itype
13641 (New_Itype, Node (Next_Elmt (E)));
13644 if Is_Type (Node (E))
13646 Old_Itype = Associated_Node_For_Itype (Node (E))
13648 Set_Associated_Node_For_Itype
13649 (Node (Next_Elmt (E)), New_Itype);
13652 E := Next_Elmt (Next_Elmt (E));
13657 if Present (Freeze_Node (New_Itype)) then
13658 Set_Is_Frozen (New_Itype, False);
13659 Set_Freeze_Node (New_Itype, Empty);
13662 -- Add new association to map
13664 if No (Actual_Map) then
13665 Actual_Map := New_Elmt_List;
13668 Append_Elmt (Old_Itype, Actual_Map);
13669 Append_Elmt (New_Itype, Actual_Map);
13671 if NCT_Hash_Tables_Used then
13672 NCT_Assoc.Set (Old_Itype, New_Itype);
13675 NCT_Table_Entries := NCT_Table_Entries + 1;
13677 if NCT_Table_Entries > NCT_Hash_Threshold then
13678 Build_NCT_Hash_Tables;
13682 -- If a record subtype is simply copied, the entity list will be
13683 -- shared. Thus cloned_Subtype must be set to indicate the sharing.
13685 if Ekind_In (Old_Itype, E_Record_Subtype, E_Class_Wide_Subtype) then
13686 Set_Cloned_Subtype (New_Itype, Old_Itype);
13689 -- Visit descendents that eventually get copied
13691 Visit_Field (Union_Id (Etype (Old_Itype)), Old_Itype);
13693 if Is_Discrete_Type (Old_Itype) then
13694 Visit_Field (Union_Id (Scalar_Range (Old_Itype)), Old_Itype);
13696 elsif Has_Discriminants (Base_Type (Old_Itype)) then
13697 -- ??? This should involve call to Visit_Field
13698 Visit_Elist (Discriminant_Constraint (Old_Itype));
13700 elsif Is_Array_Type (Old_Itype) then
13701 if Present (First_Index (Old_Itype)) then
13702 Visit_Field (Union_Id (List_Containing
13703 (First_Index (Old_Itype))),
13707 if Is_Packed (Old_Itype) then
13708 Visit_Field (Union_Id (Packed_Array_Impl_Type (Old_Itype)),
13718 procedure Visit_List (L : List_Id) is
13721 if L /= No_List then
13724 while Present (N) loop
13735 procedure Visit_Node (N : Node_Or_Entity_Id) is
13737 -- Start of processing for Visit_Node
13740 -- Handle case of an Itype, which must be copied
13742 if Has_Extension (N)
13743 and then Is_Itype (N)
13745 -- Nothing to do if already in the list. This can happen with an
13746 -- Itype entity that appears more than once in the tree.
13747 -- Note that we do not want to visit descendents in this case.
13749 -- Test for already in list when hash table is used
13751 if NCT_Hash_Tables_Used then
13752 if Present (NCT_Assoc.Get (Entity_Id (N))) then
13756 -- Test for already in list when hash table not used
13762 if Present (Actual_Map) then
13763 E := First_Elmt (Actual_Map);
13764 while Present (E) loop
13765 if Node (E) = N then
13768 E := Next_Elmt (Next_Elmt (E));
13778 -- Visit descendents
13780 Visit_Field (Field1 (N), N);
13781 Visit_Field (Field2 (N), N);
13782 Visit_Field (Field3 (N), N);
13783 Visit_Field (Field4 (N), N);
13784 Visit_Field (Field5 (N), N);
13787 -- Start of processing for New_Copy_Tree
13792 -- See if we should use hash table
13794 if No (Actual_Map) then
13795 NCT_Hash_Tables_Used := False;
13802 NCT_Table_Entries := 0;
13804 Elmt := First_Elmt (Actual_Map);
13805 while Present (Elmt) loop
13806 NCT_Table_Entries := NCT_Table_Entries + 1;
13811 if NCT_Table_Entries > NCT_Hash_Threshold then
13812 Build_NCT_Hash_Tables;
13814 NCT_Hash_Tables_Used := False;
13819 -- Hash table set up if required, now start phase one by visiting
13820 -- top node (we will recursively visit the descendents).
13822 Visit_Node (Source);
13824 -- Now the second phase of the copy can start. First we process
13825 -- all the mapped entities, copying their descendents.
13827 if Present (Actual_Map) then
13830 New_Itype : Entity_Id;
13832 Elmt := First_Elmt (Actual_Map);
13833 while Present (Elmt) loop
13835 New_Itype := Node (Elmt);
13836 Copy_Itype_With_Replacement (New_Itype);
13842 -- Now we can copy the actual tree
13844 return Copy_Node_With_Replacement (Source);
13847 -------------------------
13848 -- New_External_Entity --
13849 -------------------------
13851 function New_External_Entity
13852 (Kind : Entity_Kind;
13853 Scope_Id : Entity_Id;
13854 Sloc_Value : Source_Ptr;
13855 Related_Id : Entity_Id;
13856 Suffix : Character;
13857 Suffix_Index : Nat := 0;
13858 Prefix : Character := ' ') return Entity_Id
13860 N : constant Entity_Id :=
13861 Make_Defining_Identifier (Sloc_Value,
13863 (Chars (Related_Id), Suffix, Suffix_Index, Prefix));
13866 Set_Ekind (N, Kind);
13867 Set_Is_Internal (N, True);
13868 Append_Entity (N, Scope_Id);
13869 Set_Public_Status (N);
13871 if Kind in Type_Kind then
13872 Init_Size_Align (N);
13876 end New_External_Entity;
13878 -------------------------
13879 -- New_Internal_Entity --
13880 -------------------------
13882 function New_Internal_Entity
13883 (Kind : Entity_Kind;
13884 Scope_Id : Entity_Id;
13885 Sloc_Value : Source_Ptr;
13886 Id_Char : Character) return Entity_Id
13888 N : constant Entity_Id := Make_Temporary (Sloc_Value, Id_Char);
13891 Set_Ekind (N, Kind);
13892 Set_Is_Internal (N, True);
13893 Append_Entity (N, Scope_Id);
13895 if Kind in Type_Kind then
13896 Init_Size_Align (N);
13900 end New_Internal_Entity;
13906 function Next_Actual (Actual_Id : Node_Id) return Node_Id is
13910 -- If we are pointing at a positional parameter, it is a member of a
13911 -- node list (the list of parameters), and the next parameter is the
13912 -- next node on the list, unless we hit a parameter association, then
13913 -- we shift to using the chain whose head is the First_Named_Actual in
13914 -- the parent, and then is threaded using the Next_Named_Actual of the
13915 -- Parameter_Association. All this fiddling is because the original node
13916 -- list is in the textual call order, and what we need is the
13917 -- declaration order.
13919 if Is_List_Member (Actual_Id) then
13920 N := Next (Actual_Id);
13922 if Nkind (N) = N_Parameter_Association then
13923 return First_Named_Actual (Parent (Actual_Id));
13929 return Next_Named_Actual (Parent (Actual_Id));
13933 procedure Next_Actual (Actual_Id : in out Node_Id) is
13935 Actual_Id := Next_Actual (Actual_Id);
13938 ---------------------
13939 -- No_Scalar_Parts --
13940 ---------------------
13942 function No_Scalar_Parts (T : Entity_Id) return Boolean is
13946 if Is_Scalar_Type (T) then
13949 elsif Is_Array_Type (T) then
13950 return No_Scalar_Parts (Component_Type (T));
13952 elsif Is_Record_Type (T) or else Has_Discriminants (T) then
13953 C := First_Component_Or_Discriminant (T);
13954 while Present (C) loop
13955 if not No_Scalar_Parts (Etype (C)) then
13958 Next_Component_Or_Discriminant (C);
13964 end No_Scalar_Parts;
13966 -----------------------
13967 -- Normalize_Actuals --
13968 -----------------------
13970 -- Chain actuals according to formals of subprogram. If there are no named
13971 -- associations, the chain is simply the list of Parameter Associations,
13972 -- since the order is the same as the declaration order. If there are named
13973 -- associations, then the First_Named_Actual field in the N_Function_Call
13974 -- or N_Procedure_Call_Statement node points to the Parameter_Association
13975 -- node for the parameter that comes first in declaration order. The
13976 -- remaining named parameters are then chained in declaration order using
13977 -- Next_Named_Actual.
13979 -- This routine also verifies that the number of actuals is compatible with
13980 -- the number and default values of formals, but performs no type checking
13981 -- (type checking is done by the caller).
13983 -- If the matching succeeds, Success is set to True and the caller proceeds
13984 -- with type-checking. If the match is unsuccessful, then Success is set to
13985 -- False, and the caller attempts a different interpretation, if there is
13988 -- If the flag Report is on, the call is not overloaded, and a failure to
13989 -- match can be reported here, rather than in the caller.
13991 procedure Normalize_Actuals
13995 Success : out Boolean)
13997 Actuals : constant List_Id := Parameter_Associations (N);
13998 Actual : Node_Id := Empty;
13999 Formal : Entity_Id;
14000 Last : Node_Id := Empty;
14001 First_Named : Node_Id := Empty;
14004 Formals_To_Match : Integer := 0;
14005 Actuals_To_Match : Integer := 0;
14007 procedure Chain (A : Node_Id);
14008 -- Add named actual at the proper place in the list, using the
14009 -- Next_Named_Actual link.
14011 function Reporting return Boolean;
14012 -- Determines if an error is to be reported. To report an error, we
14013 -- need Report to be True, and also we do not report errors caused
14014 -- by calls to init procs that occur within other init procs. Such
14015 -- errors must always be cascaded errors, since if all the types are
14016 -- declared correctly, the compiler will certainly build decent calls.
14022 procedure Chain (A : Node_Id) is
14026 -- Call node points to first actual in list
14028 Set_First_Named_Actual (N, Explicit_Actual_Parameter (A));
14031 Set_Next_Named_Actual (Last, Explicit_Actual_Parameter (A));
14035 Set_Next_Named_Actual (Last, Empty);
14042 function Reporting return Boolean is
14047 elsif not Within_Init_Proc then
14050 elsif Is_Init_Proc (Entity (Name (N))) then
14058 -- Start of processing for Normalize_Actuals
14061 if Is_Access_Type (S) then
14063 -- The name in the call is a function call that returns an access
14064 -- to subprogram. The designated type has the list of formals.
14066 Formal := First_Formal (Designated_Type (S));
14068 Formal := First_Formal (S);
14071 while Present (Formal) loop
14072 Formals_To_Match := Formals_To_Match + 1;
14073 Next_Formal (Formal);
14076 -- Find if there is a named association, and verify that no positional
14077 -- associations appear after named ones.
14079 if Present (Actuals) then
14080 Actual := First (Actuals);
14083 while Present (Actual)
14084 and then Nkind (Actual) /= N_Parameter_Association
14086 Actuals_To_Match := Actuals_To_Match + 1;
14090 if No (Actual) and Actuals_To_Match = Formals_To_Match then
14092 -- Most common case: positional notation, no defaults
14097 elsif Actuals_To_Match > Formals_To_Match then
14099 -- Too many actuals: will not work
14102 if Is_Entity_Name (Name (N)) then
14103 Error_Msg_N ("too many arguments in call to&", Name (N));
14105 Error_Msg_N ("too many arguments in call", N);
14113 First_Named := Actual;
14115 while Present (Actual) loop
14116 if Nkind (Actual) /= N_Parameter_Association then
14118 ("positional parameters not allowed after named ones", Actual);
14123 Actuals_To_Match := Actuals_To_Match + 1;
14129 if Present (Actuals) then
14130 Actual := First (Actuals);
14133 Formal := First_Formal (S);
14134 while Present (Formal) loop
14136 -- Match the formals in order. If the corresponding actual is
14137 -- positional, nothing to do. Else scan the list of named actuals
14138 -- to find the one with the right name.
14140 if Present (Actual)
14141 and then Nkind (Actual) /= N_Parameter_Association
14144 Actuals_To_Match := Actuals_To_Match - 1;
14145 Formals_To_Match := Formals_To_Match - 1;
14148 -- For named parameters, search the list of actuals to find
14149 -- one that matches the next formal name.
14151 Actual := First_Named;
14153 while Present (Actual) loop
14154 if Chars (Selector_Name (Actual)) = Chars (Formal) then
14157 Actuals_To_Match := Actuals_To_Match - 1;
14158 Formals_To_Match := Formals_To_Match - 1;
14166 if Ekind (Formal) /= E_In_Parameter
14167 or else No (Default_Value (Formal))
14170 if (Comes_From_Source (S)
14171 or else Sloc (S) = Standard_Location)
14172 and then Is_Overloadable (S)
14176 (Nkind (Parent (N)) = N_Procedure_Call_Statement
14178 (Nkind (Parent (N)) = N_Function_Call
14180 Nkind (Parent (N)) = N_Parameter_Association))
14181 and then Ekind (S) /= E_Function
14183 Set_Etype (N, Etype (S));
14185 Error_Msg_Name_1 := Chars (S);
14186 Error_Msg_Sloc := Sloc (S);
14188 ("missing argument for parameter & " &
14189 "in call to % declared #", N, Formal);
14192 elsif Is_Overloadable (S) then
14193 Error_Msg_Name_1 := Chars (S);
14195 -- Point to type derivation that generated the
14198 Error_Msg_Sloc := Sloc (Parent (S));
14201 ("missing argument for parameter & " &
14202 "in call to % (inherited) #", N, Formal);
14206 ("missing argument for parameter &", N, Formal);
14214 Formals_To_Match := Formals_To_Match - 1;
14219 Next_Formal (Formal);
14222 if Formals_To_Match = 0 and then Actuals_To_Match = 0 then
14229 -- Find some superfluous named actual that did not get
14230 -- attached to the list of associations.
14232 Actual := First (Actuals);
14233 while Present (Actual) loop
14234 if Nkind (Actual) = N_Parameter_Association
14235 and then Actual /= Last
14236 and then No (Next_Named_Actual (Actual))
14238 Error_Msg_N ("unmatched actual & in call",
14239 Selector_Name (Actual));
14250 end Normalize_Actuals;
14252 --------------------------------
14253 -- Note_Possible_Modification --
14254 --------------------------------
14256 procedure Note_Possible_Modification (N : Node_Id; Sure : Boolean) is
14257 Modification_Comes_From_Source : constant Boolean :=
14258 Comes_From_Source (Parent (N));
14264 -- Loop to find referenced entity, if there is one
14270 if Is_Entity_Name (Exp) then
14271 Ent := Entity (Exp);
14273 -- If the entity is missing, it is an undeclared identifier,
14274 -- and there is nothing to annotate.
14280 elsif Nkind (Exp) = N_Explicit_Dereference then
14282 P : constant Node_Id := Prefix (Exp);
14285 -- In formal verification mode, keep track of all reads and
14286 -- writes through explicit dereferences.
14288 if GNATprove_Mode then
14289 SPARK_Specific.Generate_Dereference (N, 'm');
14292 if Nkind (P) = N_Selected_Component
14293 and then Present (Entry_Formal (Entity (Selector_Name (P))))
14295 -- Case of a reference to an entry formal
14297 Ent := Entry_Formal (Entity (Selector_Name (P)));
14299 elsif Nkind (P) = N_Identifier
14300 and then Nkind (Parent (Entity (P))) = N_Object_Declaration
14301 and then Present (Expression (Parent (Entity (P))))
14302 and then Nkind (Expression (Parent (Entity (P)))) =
14305 -- Case of a reference to a value on which side effects have
14308 Exp := Prefix (Expression (Parent (Entity (P))));
14316 elsif Nkind_In (Exp, N_Type_Conversion,
14317 N_Unchecked_Type_Conversion)
14319 Exp := Expression (Exp);
14322 elsif Nkind_In (Exp, N_Slice,
14323 N_Indexed_Component,
14324 N_Selected_Component)
14326 -- Special check, if the prefix is an access type, then return
14327 -- since we are modifying the thing pointed to, not the prefix.
14328 -- When we are expanding, most usually the prefix is replaced
14329 -- by an explicit dereference, and this test is not needed, but
14330 -- in some cases (notably -gnatc mode and generics) when we do
14331 -- not do full expansion, we need this special test.
14333 if Is_Access_Type (Etype (Prefix (Exp))) then
14336 -- Otherwise go to prefix and keep going
14339 Exp := Prefix (Exp);
14343 -- All other cases, not a modification
14349 -- Now look for entity being referenced
14351 if Present (Ent) then
14352 if Is_Object (Ent) then
14353 if Comes_From_Source (Exp)
14354 or else Modification_Comes_From_Source
14356 -- Give warning if pragma unmodified given and we are
14357 -- sure this is a modification.
14359 if Has_Pragma_Unmodified (Ent) and then Sure then
14361 ("??pragma Unmodified given for &!", N, Ent);
14364 Set_Never_Set_In_Source (Ent, False);
14367 Set_Is_True_Constant (Ent, False);
14368 Set_Current_Value (Ent, Empty);
14369 Set_Is_Known_Null (Ent, False);
14371 if not Can_Never_Be_Null (Ent) then
14372 Set_Is_Known_Non_Null (Ent, False);
14375 -- Follow renaming chain
14377 if (Ekind (Ent) = E_Variable or else Ekind (Ent) = E_Constant)
14378 and then Present (Renamed_Object (Ent))
14380 Exp := Renamed_Object (Ent);
14382 -- If the entity is the loop variable in an iteration over
14383 -- a container, retrieve container expression to indicate
14384 -- possible modificastion.
14386 if Present (Related_Expression (Ent))
14387 and then Nkind (Parent (Related_Expression (Ent))) =
14388 N_Iterator_Specification
14390 Exp := Original_Node (Related_Expression (Ent));
14395 -- The expression may be the renaming of a subcomponent of an
14396 -- array or container. The assignment to the subcomponent is
14397 -- a modification of the container.
14399 elsif Comes_From_Source (Original_Node (Exp))
14400 and then Nkind_In (Original_Node (Exp), N_Selected_Component,
14401 N_Indexed_Component)
14403 Exp := Prefix (Original_Node (Exp));
14407 -- Generate a reference only if the assignment comes from
14408 -- source. This excludes, for example, calls to a dispatching
14409 -- assignment operation when the left-hand side is tagged. In
14410 -- GNATprove mode, we need those references also on generated
14411 -- code, as these are used to compute the local effects of
14414 if Modification_Comes_From_Source or GNATprove_Mode then
14415 Generate_Reference (Ent, Exp, 'm');
14417 -- If the target of the assignment is the bound variable
14418 -- in an iterator, indicate that the corresponding array
14419 -- or container is also modified.
14421 if Ada_Version >= Ada_2012
14423 Nkind (Parent (Ent)) = N_Iterator_Specification
14426 Domain : constant Node_Id := Name (Parent (Ent));
14429 -- TBD : in the full version of the construct, the
14430 -- domain of iteration can be given by an expression.
14432 if Is_Entity_Name (Domain) then
14433 Generate_Reference (Entity (Domain), Exp, 'm');
14434 Set_Is_True_Constant (Entity (Domain), False);
14435 Set_Never_Set_In_Source (Entity (Domain), False);
14441 Check_Nested_Access (Ent);
14446 -- If we are sure this is a modification from source, and we know
14447 -- this modifies a constant, then give an appropriate warning.
14449 if Overlays_Constant (Ent)
14450 and then Modification_Comes_From_Source
14454 A : constant Node_Id := Address_Clause (Ent);
14456 if Present (A) then
14458 Exp : constant Node_Id := Expression (A);
14460 if Nkind (Exp) = N_Attribute_Reference
14461 and then Attribute_Name (Exp) = Name_Address
14462 and then Is_Entity_Name (Prefix (Exp))
14464 Error_Msg_Sloc := Sloc (A);
14466 ("constant& may be modified via address "
14467 & "clause#??", N, Entity (Prefix (Exp)));
14480 end Note_Possible_Modification;
14482 -------------------------
14483 -- Object_Access_Level --
14484 -------------------------
14486 -- Returns the static accessibility level of the view denoted by Obj. Note
14487 -- that the value returned is the result of a call to Scope_Depth. Only
14488 -- scope depths associated with dynamic scopes can actually be returned.
14489 -- Since only relative levels matter for accessibility checking, the fact
14490 -- that the distance between successive levels of accessibility is not
14491 -- always one is immaterial (invariant: if level(E2) is deeper than
14492 -- level(E1), then Scope_Depth(E1) < Scope_Depth(E2)).
14494 function Object_Access_Level (Obj : Node_Id) return Uint is
14495 function Is_Interface_Conversion (N : Node_Id) return Boolean;
14496 -- Determine whether N is a construct of the form
14497 -- Some_Type (Operand._tag'Address)
14498 -- This construct appears in the context of dispatching calls.
14500 function Reference_To (Obj : Node_Id) return Node_Id;
14501 -- An explicit dereference is created when removing side-effects from
14502 -- expressions for constraint checking purposes. In this case a local
14503 -- access type is created for it. The correct access level is that of
14504 -- the original source node. We detect this case by noting that the
14505 -- prefix of the dereference is created by an object declaration whose
14506 -- initial expression is a reference.
14508 -----------------------------
14509 -- Is_Interface_Conversion --
14510 -----------------------------
14512 function Is_Interface_Conversion (N : Node_Id) return Boolean is
14515 Nkind (N) = N_Unchecked_Type_Conversion
14516 and then Nkind (Expression (N)) = N_Attribute_Reference
14517 and then Attribute_Name (Expression (N)) = Name_Address;
14518 end Is_Interface_Conversion;
14524 function Reference_To (Obj : Node_Id) return Node_Id is
14525 Pref : constant Node_Id := Prefix (Obj);
14527 if Is_Entity_Name (Pref)
14528 and then Nkind (Parent (Entity (Pref))) = N_Object_Declaration
14529 and then Present (Expression (Parent (Entity (Pref))))
14530 and then Nkind (Expression (Parent (Entity (Pref)))) = N_Reference
14532 return (Prefix (Expression (Parent (Entity (Pref)))));
14542 -- Start of processing for Object_Access_Level
14545 if Nkind (Obj) = N_Defining_Identifier
14546 or else Is_Entity_Name (Obj)
14548 if Nkind (Obj) = N_Defining_Identifier then
14554 if Is_Prival (E) then
14555 E := Prival_Link (E);
14558 -- If E is a type then it denotes a current instance. For this case
14559 -- we add one to the normal accessibility level of the type to ensure
14560 -- that current instances are treated as always being deeper than
14561 -- than the level of any visible named access type (see 3.10.2(21)).
14563 if Is_Type (E) then
14564 return Type_Access_Level (E) + 1;
14566 elsif Present (Renamed_Object (E)) then
14567 return Object_Access_Level (Renamed_Object (E));
14569 -- Similarly, if E is a component of the current instance of a
14570 -- protected type, any instance of it is assumed to be at a deeper
14571 -- level than the type. For a protected object (whose type is an
14572 -- anonymous protected type) its components are at the same level
14573 -- as the type itself.
14575 elsif not Is_Overloadable (E)
14576 and then Ekind (Scope (E)) = E_Protected_Type
14577 and then Comes_From_Source (Scope (E))
14579 return Type_Access_Level (Scope (E)) + 1;
14582 return Scope_Depth (Enclosing_Dynamic_Scope (E));
14585 elsif Nkind (Obj) = N_Selected_Component then
14586 if Is_Access_Type (Etype (Prefix (Obj))) then
14587 return Type_Access_Level (Etype (Prefix (Obj)));
14589 return Object_Access_Level (Prefix (Obj));
14592 elsif Nkind (Obj) = N_Indexed_Component then
14593 if Is_Access_Type (Etype (Prefix (Obj))) then
14594 return Type_Access_Level (Etype (Prefix (Obj)));
14596 return Object_Access_Level (Prefix (Obj));
14599 elsif Nkind (Obj) = N_Explicit_Dereference then
14601 -- If the prefix is a selected access discriminant then we make a
14602 -- recursive call on the prefix, which will in turn check the level
14603 -- of the prefix object of the selected discriminant.
14605 if Nkind (Prefix (Obj)) = N_Selected_Component
14606 and then Ekind (Etype (Prefix (Obj))) = E_Anonymous_Access_Type
14608 Ekind (Entity (Selector_Name (Prefix (Obj)))) = E_Discriminant
14610 return Object_Access_Level (Prefix (Obj));
14612 -- Detect an interface conversion in the context of a dispatching
14613 -- call. Use the original form of the conversion to find the access
14614 -- level of the operand.
14616 elsif Is_Interface (Etype (Obj))
14617 and then Is_Interface_Conversion (Prefix (Obj))
14618 and then Nkind (Original_Node (Obj)) = N_Type_Conversion
14620 return Object_Access_Level (Original_Node (Obj));
14622 elsif not Comes_From_Source (Obj) then
14624 Ref : constant Node_Id := Reference_To (Obj);
14626 if Present (Ref) then
14627 return Object_Access_Level (Ref);
14629 return Type_Access_Level (Etype (Prefix (Obj)));
14634 return Type_Access_Level (Etype (Prefix (Obj)));
14637 elsif Nkind_In (Obj, N_Type_Conversion, N_Unchecked_Type_Conversion) then
14638 return Object_Access_Level (Expression (Obj));
14640 elsif Nkind (Obj) = N_Function_Call then
14642 -- Function results are objects, so we get either the access level of
14643 -- the function or, in the case of an indirect call, the level of the
14644 -- access-to-subprogram type. (This code is used for Ada 95, but it
14645 -- looks wrong, because it seems that we should be checking the level
14646 -- of the call itself, even for Ada 95. However, using the Ada 2005
14647 -- version of the code causes regressions in several tests that are
14648 -- compiled with -gnat95. ???)
14650 if Ada_Version < Ada_2005 then
14651 if Is_Entity_Name (Name (Obj)) then
14652 return Subprogram_Access_Level (Entity (Name (Obj)));
14654 return Type_Access_Level (Etype (Prefix (Name (Obj))));
14657 -- For Ada 2005, the level of the result object of a function call is
14658 -- defined to be the level of the call's innermost enclosing master.
14659 -- We determine that by querying the depth of the innermost enclosing
14663 Return_Master_Scope_Depth_Of_Call : declare
14665 function Innermost_Master_Scope_Depth
14666 (N : Node_Id) return Uint;
14667 -- Returns the scope depth of the given node's innermost
14668 -- enclosing dynamic scope (effectively the accessibility
14669 -- level of the innermost enclosing master).
14671 ----------------------------------
14672 -- Innermost_Master_Scope_Depth --
14673 ----------------------------------
14675 function Innermost_Master_Scope_Depth
14676 (N : Node_Id) return Uint
14678 Node_Par : Node_Id := Parent (N);
14681 -- Locate the nearest enclosing node (by traversing Parents)
14682 -- that Defining_Entity can be applied to, and return the
14683 -- depth of that entity's nearest enclosing dynamic scope.
14685 while Present (Node_Par) loop
14686 case Nkind (Node_Par) is
14687 when N_Component_Declaration |
14688 N_Entry_Declaration |
14689 N_Formal_Object_Declaration |
14690 N_Formal_Type_Declaration |
14691 N_Full_Type_Declaration |
14692 N_Incomplete_Type_Declaration |
14693 N_Loop_Parameter_Specification |
14694 N_Object_Declaration |
14695 N_Protected_Type_Declaration |
14696 N_Private_Extension_Declaration |
14697 N_Private_Type_Declaration |
14698 N_Subtype_Declaration |
14699 N_Function_Specification |
14700 N_Procedure_Specification |
14701 N_Task_Type_Declaration |
14703 N_Generic_Instantiation |
14705 N_Implicit_Label_Declaration |
14706 N_Package_Declaration |
14707 N_Single_Task_Declaration |
14708 N_Subprogram_Declaration |
14709 N_Generic_Declaration |
14710 N_Renaming_Declaration |
14711 N_Block_Statement |
14712 N_Formal_Subprogram_Declaration |
14713 N_Abstract_Subprogram_Declaration |
14715 N_Exception_Declaration |
14716 N_Formal_Package_Declaration |
14717 N_Number_Declaration |
14718 N_Package_Specification |
14719 N_Parameter_Specification |
14720 N_Single_Protected_Declaration |
14724 (Nearest_Dynamic_Scope
14725 (Defining_Entity (Node_Par)));
14731 Node_Par := Parent (Node_Par);
14734 pragma Assert (False);
14736 -- Should never reach the following return
14738 return Scope_Depth (Current_Scope) + 1;
14739 end Innermost_Master_Scope_Depth;
14741 -- Start of processing for Return_Master_Scope_Depth_Of_Call
14744 return Innermost_Master_Scope_Depth (Obj);
14745 end Return_Master_Scope_Depth_Of_Call;
14748 -- For convenience we handle qualified expressions, even though they
14749 -- aren't technically object names.
14751 elsif Nkind (Obj) = N_Qualified_Expression then
14752 return Object_Access_Level (Expression (Obj));
14754 -- Otherwise return the scope level of Standard. (If there are cases
14755 -- that fall through to this point they will be treated as having
14756 -- global accessibility for now. ???)
14759 return Scope_Depth (Standard_Standard);
14761 end Object_Access_Level;
14763 --------------------------
14764 -- Original_Aspect_Name --
14765 --------------------------
14767 function Original_Aspect_Name (N : Node_Id) return Name_Id is
14772 pragma Assert (Nkind_In (N, N_Aspect_Specification, N_Pragma));
14775 if Is_Rewrite_Substitution (Pras)
14776 and then Nkind (Original_Node (Pras)) = N_Pragma
14778 Pras := Original_Node (Pras);
14781 -- Case where we came from aspect specication
14783 if Nkind (Pras) = N_Pragma and then From_Aspect_Specification (Pras) then
14784 Pras := Corresponding_Aspect (Pras);
14787 -- Get name from aspect or pragma
14789 if Nkind (Pras) = N_Pragma then
14790 Name := Pragma_Name (Pras);
14792 Name := Chars (Identifier (Pras));
14795 -- Deal with 'Class
14797 if Class_Present (Pras) then
14800 -- Names that need converting to special _xxx form
14808 Name := Name_uPost;
14810 when Name_Invariant =>
14811 Name := Name_uInvariant;
14813 when Name_Type_Invariant |
14814 Name_Type_Invariant_Class =>
14815 Name := Name_uType_Invariant;
14817 -- Nothing to do for other cases (e.g. a Check that derived
14818 -- from Pre_Class and has the flag set). Also we do nothing
14819 -- if the name is already in special _xxx form.
14827 end Original_Aspect_Name;
14829 --------------------------------------
14830 -- Original_Corresponding_Operation --
14831 --------------------------------------
14833 function Original_Corresponding_Operation (S : Entity_Id) return Entity_Id
14835 Typ : constant Entity_Id := Find_Dispatching_Type (S);
14838 -- If S is an inherited primitive S2 the original corresponding
14839 -- operation of S is the original corresponding operation of S2
14841 if Present (Alias (S))
14842 and then Find_Dispatching_Type (Alias (S)) /= Typ
14844 return Original_Corresponding_Operation (Alias (S));
14846 -- If S overrides an inherited subprogram S2 the original corresponding
14847 -- operation of S is the original corresponding operation of S2
14849 elsif Present (Overridden_Operation (S)) then
14850 return Original_Corresponding_Operation (Overridden_Operation (S));
14852 -- otherwise it is S itself
14857 end Original_Corresponding_Operation;
14859 -----------------------
14860 -- Private_Component --
14861 -----------------------
14863 function Private_Component (Type_Id : Entity_Id) return Entity_Id is
14864 Ancestor : constant Entity_Id := Base_Type (Type_Id);
14866 function Trace_Components
14868 Check : Boolean) return Entity_Id;
14869 -- Recursive function that does the work, and checks against circular
14870 -- definition for each subcomponent type.
14872 ----------------------
14873 -- Trace_Components --
14874 ----------------------
14876 function Trace_Components
14878 Check : Boolean) return Entity_Id
14880 Btype : constant Entity_Id := Base_Type (T);
14881 Component : Entity_Id;
14883 Candidate : Entity_Id := Empty;
14886 if Check and then Btype = Ancestor then
14887 Error_Msg_N ("circular type definition", Type_Id);
14891 if Is_Private_Type (Btype)
14892 and then not Is_Generic_Type (Btype)
14894 if Present (Full_View (Btype))
14895 and then Is_Record_Type (Full_View (Btype))
14896 and then not Is_Frozen (Btype)
14898 -- To indicate that the ancestor depends on a private type, the
14899 -- current Btype is sufficient. However, to check for circular
14900 -- definition we must recurse on the full view.
14902 Candidate := Trace_Components (Full_View (Btype), True);
14904 if Candidate = Any_Type then
14914 elsif Is_Array_Type (Btype) then
14915 return Trace_Components (Component_Type (Btype), True);
14917 elsif Is_Record_Type (Btype) then
14918 Component := First_Entity (Btype);
14919 while Present (Component)
14920 and then Comes_From_Source (Component)
14922 -- Skip anonymous types generated by constrained components
14924 if not Is_Type (Component) then
14925 P := Trace_Components (Etype (Component), True);
14927 if Present (P) then
14928 if P = Any_Type then
14936 Next_Entity (Component);
14944 end Trace_Components;
14946 -- Start of processing for Private_Component
14949 return Trace_Components (Type_Id, False);
14950 end Private_Component;
14952 ---------------------------
14953 -- Primitive_Names_Match --
14954 ---------------------------
14956 function Primitive_Names_Match (E1, E2 : Entity_Id) return Boolean is
14958 function Non_Internal_Name (E : Entity_Id) return Name_Id;
14959 -- Given an internal name, returns the corresponding non-internal name
14961 ------------------------
14962 -- Non_Internal_Name --
14963 ------------------------
14965 function Non_Internal_Name (E : Entity_Id) return Name_Id is
14967 Get_Name_String (Chars (E));
14968 Name_Len := Name_Len - 1;
14970 end Non_Internal_Name;
14972 -- Start of processing for Primitive_Names_Match
14975 pragma Assert (Present (E1) and then Present (E2));
14977 return Chars (E1) = Chars (E2)
14979 (not Is_Internal_Name (Chars (E1))
14980 and then Is_Internal_Name (Chars (E2))
14981 and then Non_Internal_Name (E2) = Chars (E1))
14983 (not Is_Internal_Name (Chars (E2))
14984 and then Is_Internal_Name (Chars (E1))
14985 and then Non_Internal_Name (E1) = Chars (E2))
14987 (Is_Predefined_Dispatching_Operation (E1)
14988 and then Is_Predefined_Dispatching_Operation (E2)
14989 and then Same_TSS (E1, E2))
14991 (Is_Init_Proc (E1) and then Is_Init_Proc (E2));
14992 end Primitive_Names_Match;
14994 -----------------------
14995 -- Process_End_Label --
14996 -----------------------
14998 procedure Process_End_Label
15007 Label_Ref : Boolean;
15008 -- Set True if reference to end label itself is required
15011 -- Gets set to the operator symbol or identifier that references the
15012 -- entity Ent. For the child unit case, this is the identifier from the
15013 -- designator. For other cases, this is simply Endl.
15015 procedure Generate_Parent_Ref (N : Node_Id; E : Entity_Id);
15016 -- N is an identifier node that appears as a parent unit reference in
15017 -- the case where Ent is a child unit. This procedure generates an
15018 -- appropriate cross-reference entry. E is the corresponding entity.
15020 -------------------------
15021 -- Generate_Parent_Ref --
15022 -------------------------
15024 procedure Generate_Parent_Ref (N : Node_Id; E : Entity_Id) is
15026 -- If names do not match, something weird, skip reference
15028 if Chars (E) = Chars (N) then
15030 -- Generate the reference. We do NOT consider this as a reference
15031 -- for unreferenced symbol purposes.
15033 Generate_Reference (E, N, 'r', Set_Ref => False, Force => True);
15035 if Style_Check then
15036 Style.Check_Identifier (N, E);
15039 end Generate_Parent_Ref;
15041 -- Start of processing for Process_End_Label
15044 -- If no node, ignore. This happens in some error situations, and
15045 -- also for some internally generated structures where no end label
15046 -- references are required in any case.
15052 -- Nothing to do if no End_Label, happens for internally generated
15053 -- constructs where we don't want an end label reference anyway. Also
15054 -- nothing to do if Endl is a string literal, which means there was
15055 -- some prior error (bad operator symbol)
15057 Endl := End_Label (N);
15059 if No (Endl) or else Nkind (Endl) = N_String_Literal then
15063 -- Reference node is not in extended main source unit
15065 if not In_Extended_Main_Source_Unit (N) then
15067 -- Generally we do not collect references except for the extended
15068 -- main source unit. The one exception is the 'e' entry for a
15069 -- package spec, where it is useful for a client to have the
15070 -- ending information to define scopes.
15076 Label_Ref := False;
15078 -- For this case, we can ignore any parent references, but we
15079 -- need the package name itself for the 'e' entry.
15081 if Nkind (Endl) = N_Designator then
15082 Endl := Identifier (Endl);
15086 -- Reference is in extended main source unit
15091 -- For designator, generate references for the parent entries
15093 if Nkind (Endl) = N_Designator then
15095 -- Generate references for the prefix if the END line comes from
15096 -- source (otherwise we do not need these references) We climb the
15097 -- scope stack to find the expected entities.
15099 if Comes_From_Source (Endl) then
15100 Nam := Name (Endl);
15101 Scop := Current_Scope;
15102 while Nkind (Nam) = N_Selected_Component loop
15103 Scop := Scope (Scop);
15104 exit when No (Scop);
15105 Generate_Parent_Ref (Selector_Name (Nam), Scop);
15106 Nam := Prefix (Nam);
15109 if Present (Scop) then
15110 Generate_Parent_Ref (Nam, Scope (Scop));
15114 Endl := Identifier (Endl);
15118 -- If the end label is not for the given entity, then either we have
15119 -- some previous error, or this is a generic instantiation for which
15120 -- we do not need to make a cross-reference in this case anyway. In
15121 -- either case we simply ignore the call.
15123 if Chars (Ent) /= Chars (Endl) then
15127 -- If label was really there, then generate a normal reference and then
15128 -- adjust the location in the end label to point past the name (which
15129 -- should almost always be the semicolon).
15131 Loc := Sloc (Endl);
15133 if Comes_From_Source (Endl) then
15135 -- If a label reference is required, then do the style check and
15136 -- generate an l-type cross-reference entry for the label
15139 if Style_Check then
15140 Style.Check_Identifier (Endl, Ent);
15143 Generate_Reference (Ent, Endl, 'l', Set_Ref => False);
15146 -- Set the location to point past the label (normally this will
15147 -- mean the semicolon immediately following the label). This is
15148 -- done for the sake of the 'e' or 't' entry generated below.
15150 Get_Decoded_Name_String (Chars (Endl));
15151 Set_Sloc (Endl, Sloc (Endl) + Source_Ptr (Name_Len));
15154 -- In SPARK mode, no missing label is allowed for packages and
15155 -- subprogram bodies. Detect those cases by testing whether
15156 -- Process_End_Label was called for a body (Typ = 't') or a package.
15158 if Restriction_Check_Required (SPARK_05)
15159 and then (Typ = 't' or else Ekind (Ent) = E_Package)
15161 Error_Msg_Node_1 := Endl;
15162 Check_SPARK_Restriction ("`END &` required", Endl, Force => True);
15166 -- Now generate the e/t reference
15168 Generate_Reference (Ent, Endl, Typ, Set_Ref => False, Force => True);
15170 -- Restore Sloc, in case modified above, since we have an identifier
15171 -- and the normal Sloc should be left set in the tree.
15173 Set_Sloc (Endl, Loc);
15174 end Process_End_Label;
15180 function Referenced (Id : Entity_Id; Expr : Node_Id) return Boolean is
15181 Seen : Boolean := False;
15183 function Is_Reference (N : Node_Id) return Traverse_Result;
15184 -- Determine whether node N denotes a reference to Id. If this is the
15185 -- case, set global flag Seen to True and stop the traversal.
15191 function Is_Reference (N : Node_Id) return Traverse_Result is
15193 if Is_Entity_Name (N)
15194 and then Present (Entity (N))
15195 and then Entity (N) = Id
15204 procedure Inspect_Expression is new Traverse_Proc (Is_Reference);
15206 -- Start of processing for Referenced
15209 Inspect_Expression (Expr);
15213 ------------------------------------
15214 -- References_Generic_Formal_Type --
15215 ------------------------------------
15217 function References_Generic_Formal_Type (N : Node_Id) return Boolean is
15219 function Process (N : Node_Id) return Traverse_Result;
15220 -- Process one node in search for generic formal type
15226 function Process (N : Node_Id) return Traverse_Result is
15228 if Nkind (N) in N_Has_Entity then
15230 E : constant Entity_Id := Entity (N);
15232 if Present (E) then
15233 if Is_Generic_Type (E) then
15235 elsif Present (Etype (E))
15236 and then Is_Generic_Type (Etype (E))
15247 function Traverse is new Traverse_Func (Process);
15248 -- Traverse tree to look for generic type
15251 if Inside_A_Generic then
15252 return Traverse (N) = Abandon;
15256 end References_Generic_Formal_Type;
15258 --------------------
15259 -- Remove_Homonym --
15260 --------------------
15262 procedure Remove_Homonym (E : Entity_Id) is
15263 Prev : Entity_Id := Empty;
15267 if E = Current_Entity (E) then
15268 if Present (Homonym (E)) then
15269 Set_Current_Entity (Homonym (E));
15271 Set_Name_Entity_Id (Chars (E), Empty);
15275 H := Current_Entity (E);
15276 while Present (H) and then H /= E loop
15281 -- If E is not on the homonym chain, nothing to do
15283 if Present (H) then
15284 Set_Homonym (Prev, Homonym (E));
15287 end Remove_Homonym;
15289 ---------------------
15290 -- Rep_To_Pos_Flag --
15291 ---------------------
15293 function Rep_To_Pos_Flag (E : Entity_Id; Loc : Source_Ptr) return Node_Id is
15295 return New_Occurrence_Of
15296 (Boolean_Literals (not Range_Checks_Suppressed (E)), Loc);
15297 end Rep_To_Pos_Flag;
15299 --------------------
15300 -- Require_Entity --
15301 --------------------
15303 procedure Require_Entity (N : Node_Id) is
15305 if Is_Entity_Name (N) and then No (Entity (N)) then
15306 if Total_Errors_Detected /= 0 then
15307 Set_Entity (N, Any_Id);
15309 raise Program_Error;
15312 end Require_Entity;
15314 -------------------------------
15315 -- Requires_State_Refinement --
15316 -------------------------------
15318 function Requires_State_Refinement
15319 (Spec_Id : Entity_Id;
15320 Body_Id : Entity_Id) return Boolean
15322 function Mode_Is_Off (Prag : Node_Id) return Boolean;
15323 -- Given pragma SPARK_Mode, determine whether the mode is Off
15329 function Mode_Is_Off (Prag : Node_Id) return Boolean is
15333 -- The default SPARK mode is On
15339 Mode := Get_Pragma_Arg (First (Pragma_Argument_Associations (Prag)));
15341 -- Then the pragma lacks an argument, the default mode is On
15346 return Chars (Mode) = Name_Off;
15350 -- Start of processing for Requires_State_Refinement
15353 -- A package that does not define at least one abstract state cannot
15354 -- possibly require refinement.
15356 if No (Abstract_States (Spec_Id)) then
15359 -- The package instroduces a single null state which does not merit
15362 elsif Has_Null_Abstract_State (Spec_Id) then
15365 -- Check whether the package body is subject to pragma SPARK_Mode. If
15366 -- it is and the mode is Off, the package body is considered to be in
15367 -- regular Ada and does not require refinement.
15369 elsif Mode_Is_Off (SPARK_Pragma (Body_Id)) then
15372 -- The body's SPARK_Mode may be inherited from a similar pragma that
15373 -- appears in the private declarations of the spec. The pragma we are
15374 -- interested appears as the second entry in SPARK_Pragma.
15376 elsif Present (SPARK_Pragma (Spec_Id))
15377 and then Mode_Is_Off (Next_Pragma (SPARK_Pragma (Spec_Id)))
15381 -- The spec defines at least one abstract state and the body has no way
15382 -- of circumventing the refinement.
15387 end Requires_State_Refinement;
15389 ------------------------------
15390 -- Requires_Transient_Scope --
15391 ------------------------------
15393 -- A transient scope is required when variable-sized temporaries are
15394 -- allocated in the primary or secondary stack, or when finalization
15395 -- actions must be generated before the next instruction.
15397 function Requires_Transient_Scope (Id : Entity_Id) return Boolean is
15398 Typ : constant Entity_Id := Underlying_Type (Id);
15400 -- Start of processing for Requires_Transient_Scope
15403 -- This is a private type which is not completed yet. This can only
15404 -- happen in a default expression (of a formal parameter or of a
15405 -- record component). Do not expand transient scope in this case
15410 -- Do not expand transient scope for non-existent procedure return
15412 elsif Typ = Standard_Void_Type then
15415 -- Elementary types do not require a transient scope
15417 elsif Is_Elementary_Type (Typ) then
15420 -- Generally, indefinite subtypes require a transient scope, since the
15421 -- back end cannot generate temporaries, since this is not a valid type
15422 -- for declaring an object. It might be possible to relax this in the
15423 -- future, e.g. by declaring the maximum possible space for the type.
15425 elsif Is_Indefinite_Subtype (Typ) then
15428 -- Functions returning tagged types may dispatch on result so their
15429 -- returned value is allocated on the secondary stack. Controlled
15430 -- type temporaries need finalization.
15432 elsif Is_Tagged_Type (Typ)
15433 or else Has_Controlled_Component (Typ)
15435 return not Is_Value_Type (Typ);
15439 elsif Is_Record_Type (Typ) then
15443 Comp := First_Entity (Typ);
15444 while Present (Comp) loop
15445 if Ekind (Comp) = E_Component
15446 and then Requires_Transient_Scope (Etype (Comp))
15450 Next_Entity (Comp);
15457 -- String literal types never require transient scope
15459 elsif Ekind (Typ) = E_String_Literal_Subtype then
15462 -- Array type. Note that we already know that this is a constrained
15463 -- array, since unconstrained arrays will fail the indefinite test.
15465 elsif Is_Array_Type (Typ) then
15467 -- If component type requires a transient scope, the array does too
15469 if Requires_Transient_Scope (Component_Type (Typ)) then
15472 -- Otherwise, we only need a transient scope if the size depends on
15473 -- the value of one or more discriminants.
15476 return Size_Depends_On_Discriminant (Typ);
15479 -- All other cases do not require a transient scope
15484 end Requires_Transient_Scope;
15486 --------------------------
15487 -- Reset_Analyzed_Flags --
15488 --------------------------
15490 procedure Reset_Analyzed_Flags (N : Node_Id) is
15492 function Clear_Analyzed (N : Node_Id) return Traverse_Result;
15493 -- Function used to reset Analyzed flags in tree. Note that we do
15494 -- not reset Analyzed flags in entities, since there is no need to
15495 -- reanalyze entities, and indeed, it is wrong to do so, since it
15496 -- can result in generating auxiliary stuff more than once.
15498 --------------------
15499 -- Clear_Analyzed --
15500 --------------------
15502 function Clear_Analyzed (N : Node_Id) return Traverse_Result is
15504 if not Has_Extension (N) then
15505 Set_Analyzed (N, False);
15509 end Clear_Analyzed;
15511 procedure Reset_Analyzed is new Traverse_Proc (Clear_Analyzed);
15513 -- Start of processing for Reset_Analyzed_Flags
15516 Reset_Analyzed (N);
15517 end Reset_Analyzed_Flags;
15519 ------------------------
15520 -- Restore_SPARK_Mode --
15521 ------------------------
15523 procedure Restore_SPARK_Mode (Mode : SPARK_Mode_Type) is
15525 SPARK_Mode := Mode;
15526 end Restore_SPARK_Mode;
15528 --------------------------------
15529 -- Returns_Unconstrained_Type --
15530 --------------------------------
15532 function Returns_Unconstrained_Type (Subp : Entity_Id) return Boolean is
15534 return Ekind (Subp) = E_Function
15535 and then not Is_Scalar_Type (Etype (Subp))
15536 and then not Is_Access_Type (Etype (Subp))
15537 and then not Is_Constrained (Etype (Subp));
15538 end Returns_Unconstrained_Type;
15540 ----------------------------
15541 -- Root_Type_Of_Full_View --
15542 ----------------------------
15544 function Root_Type_Of_Full_View (T : Entity_Id) return Entity_Id is
15545 Rtyp : constant Entity_Id := Root_Type (T);
15548 -- The root type of the full view may itself be a private type. Keep
15549 -- looking for the ultimate derivation parent.
15551 if Is_Private_Type (Rtyp) and then Present (Full_View (Rtyp)) then
15552 return Root_Type_Of_Full_View (Full_View (Rtyp));
15556 end Root_Type_Of_Full_View;
15558 ---------------------------
15559 -- Safe_To_Capture_Value --
15560 ---------------------------
15562 function Safe_To_Capture_Value
15565 Cond : Boolean := False) return Boolean
15568 -- The only entities for which we track constant values are variables
15569 -- which are not renamings, constants, out parameters, and in out
15570 -- parameters, so check if we have this case.
15572 -- Note: it may seem odd to track constant values for constants, but in
15573 -- fact this routine is used for other purposes than simply capturing
15574 -- the value. In particular, the setting of Known[_Non]_Null.
15576 if (Ekind (Ent) = E_Variable and then No (Renamed_Object (Ent)))
15578 Ekind (Ent) = E_Constant
15580 Ekind (Ent) = E_Out_Parameter
15582 Ekind (Ent) = E_In_Out_Parameter
15586 -- For conditionals, we also allow loop parameters and all formals,
15587 -- including in parameters.
15591 (Ekind (Ent) = E_Loop_Parameter
15593 Ekind (Ent) = E_In_Parameter)
15597 -- For all other cases, not just unsafe, but impossible to capture
15598 -- Current_Value, since the above are the only entities which have
15599 -- Current_Value fields.
15605 -- Skip if volatile or aliased, since funny things might be going on in
15606 -- these cases which we cannot necessarily track. Also skip any variable
15607 -- for which an address clause is given, or whose address is taken. Also
15608 -- never capture value of library level variables (an attempt to do so
15609 -- can occur in the case of package elaboration code).
15611 if Treat_As_Volatile (Ent)
15612 or else Is_Aliased (Ent)
15613 or else Present (Address_Clause (Ent))
15614 or else Address_Taken (Ent)
15615 or else (Is_Library_Level_Entity (Ent)
15616 and then Ekind (Ent) = E_Variable)
15621 -- OK, all above conditions are met. We also require that the scope of
15622 -- the reference be the same as the scope of the entity, not counting
15623 -- packages and blocks and loops.
15626 E_Scope : constant Entity_Id := Scope (Ent);
15627 R_Scope : Entity_Id;
15630 R_Scope := Current_Scope;
15631 while R_Scope /= Standard_Standard loop
15632 exit when R_Scope = E_Scope;
15634 if not Ekind_In (R_Scope, E_Package, E_Block, E_Loop) then
15637 R_Scope := Scope (R_Scope);
15642 -- We also require that the reference does not appear in a context
15643 -- where it is not sure to be executed (i.e. a conditional context
15644 -- or an exception handler). We skip this if Cond is True, since the
15645 -- capturing of values from conditional tests handles this ok.
15658 -- Seems dubious that case expressions are not handled here ???
15661 while Present (P) loop
15662 if Nkind (P) = N_If_Statement
15663 or else Nkind (P) = N_Case_Statement
15664 or else (Nkind (P) in N_Short_Circuit
15665 and then Desc = Right_Opnd (P))
15666 or else (Nkind (P) = N_If_Expression
15667 and then Desc /= First (Expressions (P)))
15668 or else Nkind (P) = N_Exception_Handler
15669 or else Nkind (P) = N_Selective_Accept
15670 or else Nkind (P) = N_Conditional_Entry_Call
15671 or else Nkind (P) = N_Timed_Entry_Call
15672 or else Nkind (P) = N_Asynchronous_Select
15679 -- A special Ada 2012 case: the original node may be part
15680 -- of the else_actions of a conditional expression, in which
15681 -- case it might not have been expanded yet, and appears in
15682 -- a non-syntactic list of actions. In that case it is clearly
15683 -- not safe to save a value.
15686 and then Is_List_Member (Desc)
15687 and then No (Parent (List_Containing (Desc)))
15695 -- OK, looks safe to set value
15698 end Safe_To_Capture_Value;
15704 function Same_Name (N1, N2 : Node_Id) return Boolean is
15705 K1 : constant Node_Kind := Nkind (N1);
15706 K2 : constant Node_Kind := Nkind (N2);
15709 if (K1 = N_Identifier or else K1 = N_Defining_Identifier)
15710 and then (K2 = N_Identifier or else K2 = N_Defining_Identifier)
15712 return Chars (N1) = Chars (N2);
15714 elsif (K1 = N_Selected_Component or else K1 = N_Expanded_Name)
15715 and then (K2 = N_Selected_Component or else K2 = N_Expanded_Name)
15717 return Same_Name (Selector_Name (N1), Selector_Name (N2))
15718 and then Same_Name (Prefix (N1), Prefix (N2));
15729 function Same_Object (Node1, Node2 : Node_Id) return Boolean is
15730 N1 : constant Node_Id := Original_Node (Node1);
15731 N2 : constant Node_Id := Original_Node (Node2);
15732 -- We do the tests on original nodes, since we are most interested
15733 -- in the original source, not any expansion that got in the way.
15735 K1 : constant Node_Kind := Nkind (N1);
15736 K2 : constant Node_Kind := Nkind (N2);
15739 -- First case, both are entities with same entity
15741 if K1 in N_Has_Entity and then K2 in N_Has_Entity then
15743 EN1 : constant Entity_Id := Entity (N1);
15744 EN2 : constant Entity_Id := Entity (N2);
15746 if Present (EN1) and then Present (EN2)
15747 and then (Ekind_In (EN1, E_Variable, E_Constant)
15748 or else Is_Formal (EN1))
15756 -- Second case, selected component with same selector, same record
15758 if K1 = N_Selected_Component
15759 and then K2 = N_Selected_Component
15760 and then Chars (Selector_Name (N1)) = Chars (Selector_Name (N2))
15762 return Same_Object (Prefix (N1), Prefix (N2));
15764 -- Third case, indexed component with same subscripts, same array
15766 elsif K1 = N_Indexed_Component
15767 and then K2 = N_Indexed_Component
15768 and then Same_Object (Prefix (N1), Prefix (N2))
15773 E1 := First (Expressions (N1));
15774 E2 := First (Expressions (N2));
15775 while Present (E1) loop
15776 if not Same_Value (E1, E2) then
15787 -- Fourth case, slice of same array with same bounds
15790 and then K2 = N_Slice
15791 and then Nkind (Discrete_Range (N1)) = N_Range
15792 and then Nkind (Discrete_Range (N2)) = N_Range
15793 and then Same_Value (Low_Bound (Discrete_Range (N1)),
15794 Low_Bound (Discrete_Range (N2)))
15795 and then Same_Value (High_Bound (Discrete_Range (N1)),
15796 High_Bound (Discrete_Range (N2)))
15798 return Same_Name (Prefix (N1), Prefix (N2));
15800 -- All other cases, not clearly the same object
15811 function Same_Type (T1, T2 : Entity_Id) return Boolean is
15816 elsif not Is_Constrained (T1)
15817 and then not Is_Constrained (T2)
15818 and then Base_Type (T1) = Base_Type (T2)
15822 -- For now don't bother with case of identical constraints, to be
15823 -- fiddled with later on perhaps (this is only used for optimization
15824 -- purposes, so it is not critical to do a best possible job)
15835 function Same_Value (Node1, Node2 : Node_Id) return Boolean is
15837 if Compile_Time_Known_Value (Node1)
15838 and then Compile_Time_Known_Value (Node2)
15839 and then Expr_Value (Node1) = Expr_Value (Node2)
15842 elsif Same_Object (Node1, Node2) then
15849 -----------------------------
15850 -- Save_SPARK_Mode_And_Set --
15851 -----------------------------
15853 procedure Save_SPARK_Mode_And_Set
15854 (Context : Entity_Id;
15855 Mode : out SPARK_Mode_Type)
15858 -- Save the current mode in effect
15860 Mode := SPARK_Mode;
15862 -- Do not consider illegal or partially decorated constructs
15864 if Ekind (Context) = E_Void or else Error_Posted (Context) then
15867 elsif Present (SPARK_Pragma (Context)) then
15868 SPARK_Mode := Get_SPARK_Mode_From_Pragma (SPARK_Pragma (Context));
15870 end Save_SPARK_Mode_And_Set;
15872 ------------------------
15873 -- Scope_Is_Transient --
15874 ------------------------
15876 function Scope_Is_Transient return Boolean is
15878 return Scope_Stack.Table (Scope_Stack.Last).Is_Transient;
15879 end Scope_Is_Transient;
15885 function Scope_Within (Scope1, Scope2 : Entity_Id) return Boolean is
15890 while Scop /= Standard_Standard loop
15891 Scop := Scope (Scop);
15893 if Scop = Scope2 then
15901 --------------------------
15902 -- Scope_Within_Or_Same --
15903 --------------------------
15905 function Scope_Within_Or_Same (Scope1, Scope2 : Entity_Id) return Boolean is
15910 while Scop /= Standard_Standard loop
15911 if Scop = Scope2 then
15914 Scop := Scope (Scop);
15919 end Scope_Within_Or_Same;
15921 --------------------
15922 -- Set_Convention --
15923 --------------------
15925 procedure Set_Convention (E : Entity_Id; Val : Snames.Convention_Id) is
15927 Basic_Set_Convention (E, Val);
15930 and then Is_Access_Subprogram_Type (Base_Type (E))
15931 and then Has_Foreign_Convention (E)
15933 Set_Can_Use_Internal_Rep (E, False);
15936 -- If E is an object or component, and the type of E is an anonymous
15937 -- access type with no convention set, then also set the convention of
15938 -- the anonymous access type. We do not do this for anonymous protected
15939 -- types, since protected types always have the default convention.
15941 if Present (Etype (E))
15942 and then (Is_Object (E)
15943 or else Ekind (E) = E_Component
15945 -- Allow E_Void (happens for pragma Convention appearing
15946 -- in the middle of a record applying to a component)
15948 or else Ekind (E) = E_Void)
15951 Typ : constant Entity_Id := Etype (E);
15954 if Ekind_In (Typ, E_Anonymous_Access_Type,
15955 E_Anonymous_Access_Subprogram_Type)
15956 and then not Has_Convention_Pragma (Typ)
15958 Basic_Set_Convention (Typ, Val);
15959 Set_Has_Convention_Pragma (Typ);
15961 -- And for the access subprogram type, deal similarly with the
15962 -- designated E_Subprogram_Type if it is also internal (which
15965 if Ekind (Typ) = E_Anonymous_Access_Subprogram_Type then
15967 Dtype : constant Entity_Id := Designated_Type (Typ);
15969 if Ekind (Dtype) = E_Subprogram_Type
15970 and then Is_Itype (Dtype)
15971 and then not Has_Convention_Pragma (Dtype)
15973 Basic_Set_Convention (Dtype, Val);
15974 Set_Has_Convention_Pragma (Dtype);
15981 end Set_Convention;
15983 ------------------------
15984 -- Set_Current_Entity --
15985 ------------------------
15987 -- The given entity is to be set as the currently visible definition of its
15988 -- associated name (i.e. the Node_Id associated with its name). All we have
15989 -- to do is to get the name from the identifier, and then set the
15990 -- associated Node_Id to point to the given entity.
15992 procedure Set_Current_Entity (E : Entity_Id) is
15994 Set_Name_Entity_Id (Chars (E), E);
15995 end Set_Current_Entity;
15997 ---------------------------
15998 -- Set_Debug_Info_Needed --
15999 ---------------------------
16001 procedure Set_Debug_Info_Needed (T : Entity_Id) is
16003 procedure Set_Debug_Info_Needed_If_Not_Set (E : Entity_Id);
16004 pragma Inline (Set_Debug_Info_Needed_If_Not_Set);
16005 -- Used to set debug info in a related node if not set already
16007 --------------------------------------
16008 -- Set_Debug_Info_Needed_If_Not_Set --
16009 --------------------------------------
16011 procedure Set_Debug_Info_Needed_If_Not_Set (E : Entity_Id) is
16014 and then not Needs_Debug_Info (E)
16016 Set_Debug_Info_Needed (E);
16018 -- For a private type, indicate that the full view also needs
16019 -- debug information.
16022 and then Is_Private_Type (E)
16023 and then Present (Full_View (E))
16025 Set_Debug_Info_Needed (Full_View (E));
16028 end Set_Debug_Info_Needed_If_Not_Set;
16030 -- Start of processing for Set_Debug_Info_Needed
16033 -- Nothing to do if argument is Empty or has Debug_Info_Off set, which
16034 -- indicates that Debug_Info_Needed is never required for the entity.
16037 or else Debug_Info_Off (T)
16042 -- Set flag in entity itself. Note that we will go through the following
16043 -- circuitry even if the flag is already set on T. That's intentional,
16044 -- it makes sure that the flag will be set in subsidiary entities.
16046 Set_Needs_Debug_Info (T);
16048 -- Set flag on subsidiary entities if not set already
16050 if Is_Object (T) then
16051 Set_Debug_Info_Needed_If_Not_Set (Etype (T));
16053 elsif Is_Type (T) then
16054 Set_Debug_Info_Needed_If_Not_Set (Etype (T));
16056 if Is_Record_Type (T) then
16058 Ent : Entity_Id := First_Entity (T);
16060 while Present (Ent) loop
16061 Set_Debug_Info_Needed_If_Not_Set (Ent);
16066 -- For a class wide subtype, we also need debug information
16067 -- for the equivalent type.
16069 if Ekind (T) = E_Class_Wide_Subtype then
16070 Set_Debug_Info_Needed_If_Not_Set (Equivalent_Type (T));
16073 elsif Is_Array_Type (T) then
16074 Set_Debug_Info_Needed_If_Not_Set (Component_Type (T));
16077 Indx : Node_Id := First_Index (T);
16079 while Present (Indx) loop
16080 Set_Debug_Info_Needed_If_Not_Set (Etype (Indx));
16081 Indx := Next_Index (Indx);
16085 -- For a packed array type, we also need debug information for
16086 -- the type used to represent the packed array. Conversely, we
16087 -- also need it for the former if we need it for the latter.
16089 if Is_Packed (T) then
16090 Set_Debug_Info_Needed_If_Not_Set (Packed_Array_Impl_Type (T));
16093 if Is_Packed_Array_Impl_Type (T) then
16094 Set_Debug_Info_Needed_If_Not_Set (Original_Array_Type (T));
16097 elsif Is_Access_Type (T) then
16098 Set_Debug_Info_Needed_If_Not_Set (Directly_Designated_Type (T));
16100 elsif Is_Private_Type (T) then
16101 Set_Debug_Info_Needed_If_Not_Set (Full_View (T));
16103 elsif Is_Protected_Type (T) then
16104 Set_Debug_Info_Needed_If_Not_Set (Corresponding_Record_Type (T));
16107 end Set_Debug_Info_Needed;
16109 ----------------------------
16110 -- Set_Entity_With_Checks --
16111 ----------------------------
16113 procedure Set_Entity_With_Checks (N : Node_Id; Val : Entity_Id) is
16114 Val_Actual : Entity_Id;
16116 Post_Node : Node_Id;
16119 -- Unconditionally set the entity
16121 Set_Entity (N, Val);
16123 -- The node to post on is the selector in the case of an expanded name,
16124 -- and otherwise the node itself.
16126 if Nkind (N) = N_Expanded_Name then
16127 Post_Node := Selector_Name (N);
16132 -- Check for violation of No_Fixed_IO
16134 if Restriction_Check_Required (No_Fixed_IO)
16136 ((RTU_Loaded (Ada_Text_IO)
16137 and then (Is_RTE (Val, RE_Decimal_IO)
16139 Is_RTE (Val, RE_Fixed_IO)))
16142 (RTU_Loaded (Ada_Wide_Text_IO)
16143 and then (Is_RTE (Val, RO_WT_Decimal_IO)
16145 Is_RTE (Val, RO_WT_Fixed_IO)))
16148 (RTU_Loaded (Ada_Wide_Wide_Text_IO)
16149 and then (Is_RTE (Val, RO_WW_Decimal_IO)
16151 Is_RTE (Val, RO_WW_Fixed_IO))))
16153 -- A special extra check, don't complain about a reference from within
16154 -- the Ada.Interrupts package itself!
16156 and then not In_Same_Extended_Unit (N, Val)
16158 Check_Restriction (No_Fixed_IO, Post_Node);
16161 -- Remaining checks are only done on source nodes. Note that we test
16162 -- for violation of No_Fixed_IO even on non-source nodes, because the
16163 -- cases for checking violations of this restriction are instantiations
16164 -- where the reference in the instance has Comes_From_Source False.
16166 if not Comes_From_Source (N) then
16170 -- Check for violation of No_Abort_Statements, which is triggered by
16171 -- call to Ada.Task_Identification.Abort_Task.
16173 if Restriction_Check_Required (No_Abort_Statements)
16174 and then (Is_RTE (Val, RE_Abort_Task))
16176 -- A special extra check, don't complain about a reference from within
16177 -- the Ada.Task_Identification package itself!
16179 and then not In_Same_Extended_Unit (N, Val)
16181 Check_Restriction (No_Abort_Statements, Post_Node);
16184 if Val = Standard_Long_Long_Integer then
16185 Check_Restriction (No_Long_Long_Integers, Post_Node);
16188 -- Check for violation of No_Dynamic_Attachment
16190 if Restriction_Check_Required (No_Dynamic_Attachment)
16191 and then RTU_Loaded (Ada_Interrupts)
16192 and then (Is_RTE (Val, RE_Is_Reserved) or else
16193 Is_RTE (Val, RE_Is_Attached) or else
16194 Is_RTE (Val, RE_Current_Handler) or else
16195 Is_RTE (Val, RE_Attach_Handler) or else
16196 Is_RTE (Val, RE_Exchange_Handler) or else
16197 Is_RTE (Val, RE_Detach_Handler) or else
16198 Is_RTE (Val, RE_Reference))
16200 -- A special extra check, don't complain about a reference from within
16201 -- the Ada.Interrupts package itself!
16203 and then not In_Same_Extended_Unit (N, Val)
16205 Check_Restriction (No_Dynamic_Attachment, Post_Node);
16208 -- Check for No_Implementation_Identifiers
16210 if Restriction_Check_Required (No_Implementation_Identifiers) then
16212 -- We have an implementation defined entity if it is marked as
16213 -- implementation defined, or is defined in a package marked as
16214 -- implementation defined. However, library packages themselves
16215 -- are excluded (we don't want to flag Interfaces itself, just
16216 -- the entities within it).
16218 if (Is_Implementation_Defined (Val)
16220 Is_Implementation_Defined (Scope (Val)))
16221 and then not (Ekind_In (Val, E_Package, E_Generic_Package)
16222 and then Is_Library_Level_Entity (Val))
16224 Check_Restriction (No_Implementation_Identifiers, Post_Node);
16228 -- Do the style check
16231 and then not Suppress_Style_Checks (Val)
16232 and then not In_Instance
16234 if Nkind (N) = N_Identifier then
16236 elsif Nkind (N) = N_Expanded_Name then
16237 Nod := Selector_Name (N);
16242 -- A special situation arises for derived operations, where we want
16243 -- to do the check against the parent (since the Sloc of the derived
16244 -- operation points to the derived type declaration itself).
16247 while not Comes_From_Source (Val_Actual)
16248 and then Nkind (Val_Actual) in N_Entity
16249 and then (Ekind (Val_Actual) = E_Enumeration_Literal
16250 or else Is_Subprogram (Val_Actual)
16251 or else Is_Generic_Subprogram (Val_Actual))
16252 and then Present (Alias (Val_Actual))
16254 Val_Actual := Alias (Val_Actual);
16257 -- Renaming declarations for generic actuals do not come from source,
16258 -- and have a different name from that of the entity they rename, so
16259 -- there is no style check to perform here.
16261 if Chars (Nod) = Chars (Val_Actual) then
16262 Style.Check_Identifier (Nod, Val_Actual);
16266 Set_Entity (N, Val);
16267 end Set_Entity_With_Checks;
16269 ------------------------
16270 -- Set_Name_Entity_Id --
16271 ------------------------
16273 procedure Set_Name_Entity_Id (Id : Name_Id; Val : Entity_Id) is
16275 Set_Name_Table_Info (Id, Int (Val));
16276 end Set_Name_Entity_Id;
16278 ---------------------
16279 -- Set_Next_Actual --
16280 ---------------------
16282 procedure Set_Next_Actual (Ass1_Id : Node_Id; Ass2_Id : Node_Id) is
16284 if Nkind (Parent (Ass1_Id)) = N_Parameter_Association then
16285 Set_First_Named_Actual (Parent (Ass1_Id), Ass2_Id);
16287 end Set_Next_Actual;
16289 ----------------------------------
16290 -- Set_Optimize_Alignment_Flags --
16291 ----------------------------------
16293 procedure Set_Optimize_Alignment_Flags (E : Entity_Id) is
16295 if Optimize_Alignment = 'S' then
16296 Set_Optimize_Alignment_Space (E);
16297 elsif Optimize_Alignment = 'T' then
16298 Set_Optimize_Alignment_Time (E);
16300 end Set_Optimize_Alignment_Flags;
16302 -----------------------
16303 -- Set_Public_Status --
16304 -----------------------
16306 procedure Set_Public_Status (Id : Entity_Id) is
16307 S : constant Entity_Id := Current_Scope;
16309 function Within_HSS_Or_If (E : Entity_Id) return Boolean;
16310 -- Determines if E is defined within handled statement sequence or
16311 -- an if statement, returns True if so, False otherwise.
16313 ----------------------
16314 -- Within_HSS_Or_If --
16315 ----------------------
16317 function Within_HSS_Or_If (E : Entity_Id) return Boolean is
16320 N := Declaration_Node (E);
16327 elsif Nkind_In (N, N_Handled_Sequence_Of_Statements,
16333 end Within_HSS_Or_If;
16335 -- Start of processing for Set_Public_Status
16338 -- Everything in the scope of Standard is public
16340 if S = Standard_Standard then
16341 Set_Is_Public (Id);
16343 -- Entity is definitely not public if enclosing scope is not public
16345 elsif not Is_Public (S) then
16348 -- An object or function declaration that occurs in a handled sequence
16349 -- of statements or within an if statement is the declaration for a
16350 -- temporary object or local subprogram generated by the expander. It
16351 -- never needs to be made public and furthermore, making it public can
16352 -- cause back end problems.
16354 elsif Nkind_In (Parent (Id), N_Object_Declaration,
16355 N_Function_Specification)
16356 and then Within_HSS_Or_If (Id)
16360 -- Entities in public packages or records are public
16362 elsif Ekind (S) = E_Package or Is_Record_Type (S) then
16363 Set_Is_Public (Id);
16365 -- The bounds of an entry family declaration can generate object
16366 -- declarations that are visible to the back-end, e.g. in the
16367 -- the declaration of a composite type that contains tasks.
16369 elsif Is_Concurrent_Type (S)
16370 and then not Has_Completion (S)
16371 and then Nkind (Parent (Id)) = N_Object_Declaration
16373 Set_Is_Public (Id);
16375 end Set_Public_Status;
16377 -----------------------------
16378 -- Set_Referenced_Modified --
16379 -----------------------------
16381 procedure Set_Referenced_Modified (N : Node_Id; Out_Param : Boolean) is
16385 -- Deal with indexed or selected component where prefix is modified
16387 if Nkind_In (N, N_Indexed_Component, N_Selected_Component) then
16388 Pref := Prefix (N);
16390 -- If prefix is access type, then it is the designated object that is
16391 -- being modified, which means we have no entity to set the flag on.
16393 if No (Etype (Pref)) or else Is_Access_Type (Etype (Pref)) then
16396 -- Otherwise chase the prefix
16399 Set_Referenced_Modified (Pref, Out_Param);
16402 -- Otherwise see if we have an entity name (only other case to process)
16404 elsif Is_Entity_Name (N) and then Present (Entity (N)) then
16405 Set_Referenced_As_LHS (Entity (N), not Out_Param);
16406 Set_Referenced_As_Out_Parameter (Entity (N), Out_Param);
16408 end Set_Referenced_Modified;
16410 ----------------------------
16411 -- Set_Scope_Is_Transient --
16412 ----------------------------
16414 procedure Set_Scope_Is_Transient (V : Boolean := True) is
16416 Scope_Stack.Table (Scope_Stack.Last).Is_Transient := V;
16417 end Set_Scope_Is_Transient;
16419 -------------------
16420 -- Set_Size_Info --
16421 -------------------
16423 procedure Set_Size_Info (T1, T2 : Entity_Id) is
16425 -- We copy Esize, but not RM_Size, since in general RM_Size is
16426 -- subtype specific and does not get inherited by all subtypes.
16428 Set_Esize (T1, Esize (T2));
16429 Set_Has_Biased_Representation (T1, Has_Biased_Representation (T2));
16431 if Is_Discrete_Or_Fixed_Point_Type (T1)
16433 Is_Discrete_Or_Fixed_Point_Type (T2)
16435 Set_Is_Unsigned_Type (T1, Is_Unsigned_Type (T2));
16438 Set_Alignment (T1, Alignment (T2));
16441 --------------------
16442 -- Static_Boolean --
16443 --------------------
16445 function Static_Boolean (N : Node_Id) return Uint is
16447 Analyze_And_Resolve (N, Standard_Boolean);
16450 or else Error_Posted (N)
16451 or else Etype (N) = Any_Type
16456 if Is_Static_Expression (N) then
16457 if not Raises_Constraint_Error (N) then
16458 return Expr_Value (N);
16463 elsif Etype (N) = Any_Type then
16467 Flag_Non_Static_Expr
16468 ("static boolean expression required here", N);
16471 end Static_Boolean;
16473 --------------------
16474 -- Static_Integer --
16475 --------------------
16477 function Static_Integer (N : Node_Id) return Uint is
16479 Analyze_And_Resolve (N, Any_Integer);
16482 or else Error_Posted (N)
16483 or else Etype (N) = Any_Type
16488 if Is_Static_Expression (N) then
16489 if not Raises_Constraint_Error (N) then
16490 return Expr_Value (N);
16495 elsif Etype (N) = Any_Type then
16499 Flag_Non_Static_Expr
16500 ("static integer expression required here", N);
16503 end Static_Integer;
16505 --------------------------
16506 -- Statically_Different --
16507 --------------------------
16509 function Statically_Different (E1, E2 : Node_Id) return Boolean is
16510 R1 : constant Node_Id := Get_Referenced_Object (E1);
16511 R2 : constant Node_Id := Get_Referenced_Object (E2);
16513 return Is_Entity_Name (R1)
16514 and then Is_Entity_Name (R2)
16515 and then Entity (R1) /= Entity (R2)
16516 and then not Is_Formal (Entity (R1))
16517 and then not Is_Formal (Entity (R2));
16518 end Statically_Different;
16520 --------------------------------------
16521 -- Subject_To_Loop_Entry_Attributes --
16522 --------------------------------------
16524 function Subject_To_Loop_Entry_Attributes (N : Node_Id) return Boolean is
16530 -- The expansion mechanism transform a loop subject to at least one
16531 -- 'Loop_Entry attribute into a conditional block. Infinite loops lack
16532 -- the conditional part.
16534 if Nkind_In (Stmt, N_Block_Statement, N_If_Statement)
16535 and then Nkind (Original_Node (N)) = N_Loop_Statement
16537 Stmt := Original_Node (N);
16541 Nkind (Stmt) = N_Loop_Statement
16542 and then Present (Identifier (Stmt))
16543 and then Present (Entity (Identifier (Stmt)))
16544 and then Has_Loop_Entry_Attributes (Entity (Identifier (Stmt)));
16545 end Subject_To_Loop_Entry_Attributes;
16547 -----------------------------
16548 -- Subprogram_Access_Level --
16549 -----------------------------
16551 function Subprogram_Access_Level (Subp : Entity_Id) return Uint is
16553 if Present (Alias (Subp)) then
16554 return Subprogram_Access_Level (Alias (Subp));
16556 return Scope_Depth (Enclosing_Dynamic_Scope (Subp));
16558 end Subprogram_Access_Level;
16560 -------------------------------
16561 -- Support_Atomic_Primitives --
16562 -------------------------------
16564 function Support_Atomic_Primitives (Typ : Entity_Id) return Boolean is
16568 -- Verify the alignment of Typ is known
16570 if not Known_Alignment (Typ) then
16574 if Known_Static_Esize (Typ) then
16575 Size := UI_To_Int (Esize (Typ));
16577 -- If the Esize (Object_Size) is unknown at compile time, look at the
16578 -- RM_Size (Value_Size) which may have been set by an explicit rep item.
16580 elsif Known_Static_RM_Size (Typ) then
16581 Size := UI_To_Int (RM_Size (Typ));
16583 -- Otherwise, the size is considered to be unknown.
16589 -- Check that the size of the component is 8, 16, 32 or 64 bits and that
16590 -- Typ is properly aligned.
16593 when 8 | 16 | 32 | 64 =>
16594 return Size = UI_To_Int (Alignment (Typ)) * 8;
16598 end Support_Atomic_Primitives;
16604 procedure Trace_Scope (N : Node_Id; E : Entity_Id; Msg : String) is
16606 if Debug_Flag_W then
16607 for J in 0 .. Scope_Stack.Last loop
16612 Write_Name (Chars (E));
16613 Write_Str (" from ");
16614 Write_Location (Sloc (N));
16619 -----------------------
16620 -- Transfer_Entities --
16621 -----------------------
16623 procedure Transfer_Entities (From : Entity_Id; To : Entity_Id) is
16624 Ent : Entity_Id := First_Entity (From);
16631 if (Last_Entity (To)) = Empty then
16632 Set_First_Entity (To, Ent);
16634 Set_Next_Entity (Last_Entity (To), Ent);
16637 Set_Last_Entity (To, Last_Entity (From));
16639 while Present (Ent) loop
16640 Set_Scope (Ent, To);
16642 if not Is_Public (Ent) then
16643 Set_Public_Status (Ent);
16646 and then Ekind (Ent) = E_Record_Subtype
16649 -- The components of the propagated Itype must be public
16655 Comp := First_Entity (Ent);
16656 while Present (Comp) loop
16657 Set_Is_Public (Comp);
16658 Next_Entity (Comp);
16667 Set_First_Entity (From, Empty);
16668 Set_Last_Entity (From, Empty);
16669 end Transfer_Entities;
16671 -----------------------
16672 -- Type_Access_Level --
16673 -----------------------
16675 function Type_Access_Level (Typ : Entity_Id) return Uint is
16679 Btyp := Base_Type (Typ);
16681 -- Ada 2005 (AI-230): For most cases of anonymous access types, we
16682 -- simply use the level where the type is declared. This is true for
16683 -- stand-alone object declarations, and for anonymous access types
16684 -- associated with components the level is the same as that of the
16685 -- enclosing composite type. However, special treatment is needed for
16686 -- the cases of access parameters, return objects of an anonymous access
16687 -- type, and, in Ada 95, access discriminants of limited types.
16689 if Is_Access_Type (Btyp) then
16690 if Ekind (Btyp) = E_Anonymous_Access_Type then
16692 -- If the type is a nonlocal anonymous access type (such as for
16693 -- an access parameter) we treat it as being declared at the
16694 -- library level to ensure that names such as X.all'access don't
16695 -- fail static accessibility checks.
16697 if not Is_Local_Anonymous_Access (Typ) then
16698 return Scope_Depth (Standard_Standard);
16700 -- If this is a return object, the accessibility level is that of
16701 -- the result subtype of the enclosing function. The test here is
16702 -- little complicated, because we have to account for extended
16703 -- return statements that have been rewritten as blocks, in which
16704 -- case we have to find and the Is_Return_Object attribute of the
16705 -- itype's associated object. It would be nice to find a way to
16706 -- simplify this test, but it doesn't seem worthwhile to add a new
16707 -- flag just for purposes of this test. ???
16709 elsif Ekind (Scope (Btyp)) = E_Return_Statement
16712 and then Nkind (Associated_Node_For_Itype (Btyp)) =
16713 N_Object_Declaration
16714 and then Is_Return_Object
16715 (Defining_Identifier
16716 (Associated_Node_For_Itype (Btyp))))
16722 Scop := Scope (Scope (Btyp));
16723 while Present (Scop) loop
16724 exit when Ekind (Scop) = E_Function;
16725 Scop := Scope (Scop);
16728 -- Treat the return object's type as having the level of the
16729 -- function's result subtype (as per RM05-6.5(5.3/2)).
16731 return Type_Access_Level (Etype (Scop));
16736 Btyp := Root_Type (Btyp);
16738 -- The accessibility level of anonymous access types associated with
16739 -- discriminants is that of the current instance of the type, and
16740 -- that's deeper than the type itself (AARM 3.10.2 (12.3.21)).
16742 -- AI-402: access discriminants have accessibility based on the
16743 -- object rather than the type in Ada 2005, so the above paragraph
16746 -- ??? Needs completion with rules from AI-416
16748 if Ada_Version <= Ada_95
16749 and then Ekind (Typ) = E_Anonymous_Access_Type
16750 and then Present (Associated_Node_For_Itype (Typ))
16751 and then Nkind (Associated_Node_For_Itype (Typ)) =
16752 N_Discriminant_Specification
16754 return Scope_Depth (Enclosing_Dynamic_Scope (Btyp)) + 1;
16758 -- Return library level for a generic formal type. This is done because
16759 -- RM(10.3.2) says that "The statically deeper relationship does not
16760 -- apply to ... a descendant of a generic formal type". Rather than
16761 -- checking at each point where a static accessibility check is
16762 -- performed to see if we are dealing with a formal type, this rule is
16763 -- implemented by having Type_Access_Level and Deepest_Type_Access_Level
16764 -- return extreme values for a formal type; Deepest_Type_Access_Level
16765 -- returns Int'Last. By calling the appropriate function from among the
16766 -- two, we ensure that the static accessibility check will pass if we
16767 -- happen to run into a formal type. More specifically, we should call
16768 -- Deepest_Type_Access_Level instead of Type_Access_Level whenever the
16769 -- call occurs as part of a static accessibility check and the error
16770 -- case is the case where the type's level is too shallow (as opposed
16773 if Is_Generic_Type (Root_Type (Btyp)) then
16774 return Scope_Depth (Standard_Standard);
16777 return Scope_Depth (Enclosing_Dynamic_Scope (Btyp));
16778 end Type_Access_Level;
16780 ------------------------------------
16781 -- Type_Without_Stream_Operation --
16782 ------------------------------------
16784 function Type_Without_Stream_Operation
16786 Op : TSS_Name_Type := TSS_Null) return Entity_Id
16788 BT : constant Entity_Id := Base_Type (T);
16789 Op_Missing : Boolean;
16792 if not Restriction_Active (No_Default_Stream_Attributes) then
16796 if Is_Elementary_Type (T) then
16797 if Op = TSS_Null then
16799 No (TSS (BT, TSS_Stream_Read))
16800 or else No (TSS (BT, TSS_Stream_Write));
16803 Op_Missing := No (TSS (BT, Op));
16812 elsif Is_Array_Type (T) then
16813 return Type_Without_Stream_Operation (Component_Type (T), Op);
16815 elsif Is_Record_Type (T) then
16821 Comp := First_Component (T);
16822 while Present (Comp) loop
16823 C_Typ := Type_Without_Stream_Operation (Etype (Comp), Op);
16825 if Present (C_Typ) then
16829 Next_Component (Comp);
16835 elsif Is_Private_Type (T)
16836 and then Present (Full_View (T))
16838 return Type_Without_Stream_Operation (Full_View (T), Op);
16842 end Type_Without_Stream_Operation;
16844 ----------------------------
16845 -- Unique_Defining_Entity --
16846 ----------------------------
16848 function Unique_Defining_Entity (N : Node_Id) return Entity_Id is
16850 return Unique_Entity (Defining_Entity (N));
16851 end Unique_Defining_Entity;
16853 -------------------
16854 -- Unique_Entity --
16855 -------------------
16857 function Unique_Entity (E : Entity_Id) return Entity_Id is
16858 U : Entity_Id := E;
16864 if Present (Full_View (E)) then
16865 U := Full_View (E);
16869 if Present (Full_View (E)) then
16870 U := Full_View (E);
16873 when E_Package_Body =>
16876 if Nkind (P) = N_Defining_Program_Unit_Name then
16880 U := Corresponding_Spec (P);
16882 when E_Subprogram_Body =>
16885 if Nkind (P) = N_Defining_Program_Unit_Name then
16891 if Nkind (P) = N_Subprogram_Body_Stub then
16892 if Present (Library_Unit (P)) then
16894 -- Get to the function or procedure (generic) entity through
16895 -- the body entity.
16898 Unique_Entity (Defining_Entity (Get_Body_From_Stub (P)));
16901 U := Corresponding_Spec (P);
16904 when Formal_Kind =>
16905 if Present (Spec_Entity (E)) then
16906 U := Spec_Entity (E);
16920 function Unique_Name (E : Entity_Id) return String is
16922 -- Names of E_Subprogram_Body or E_Package_Body entities are not
16923 -- reliable, as they may not include the overloading suffix. Instead,
16924 -- when looking for the name of E or one of its enclosing scope, we get
16925 -- the name of the corresponding Unique_Entity.
16927 function Get_Scoped_Name (E : Entity_Id) return String;
16928 -- Return the name of E prefixed by all the names of the scopes to which
16929 -- E belongs, except for Standard.
16931 ---------------------
16932 -- Get_Scoped_Name --
16933 ---------------------
16935 function Get_Scoped_Name (E : Entity_Id) return String is
16936 Name : constant String := Get_Name_String (Chars (E));
16938 if Has_Fully_Qualified_Name (E)
16939 or else Scope (E) = Standard_Standard
16943 return Get_Scoped_Name (Unique_Entity (Scope (E))) & "__" & Name;
16945 end Get_Scoped_Name;
16947 -- Start of processing for Unique_Name
16950 if E = Standard_Standard then
16951 return Get_Name_String (Name_Standard);
16953 elsif Scope (E) = Standard_Standard
16954 and then not (Ekind (E) = E_Package or else Is_Subprogram (E))
16956 return Get_Name_String (Name_Standard) & "__" &
16957 Get_Name_String (Chars (E));
16959 elsif Ekind (E) = E_Enumeration_Literal then
16960 return Unique_Name (Etype (E)) & "__" & Get_Name_String (Chars (E));
16963 return Get_Scoped_Name (Unique_Entity (E));
16967 ---------------------
16968 -- Unit_Is_Visible --
16969 ---------------------
16971 function Unit_Is_Visible (U : Entity_Id) return Boolean is
16972 Curr : constant Node_Id := Cunit (Current_Sem_Unit);
16973 Curr_Entity : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
16975 function Unit_In_Parent_Context (Par_Unit : Node_Id) return Boolean;
16976 -- For a child unit, check whether unit appears in a with_clause
16979 function Unit_In_Context (Comp_Unit : Node_Id) return Boolean;
16980 -- Scan the context clause of one compilation unit looking for a
16981 -- with_clause for the unit in question.
16983 ----------------------------
16984 -- Unit_In_Parent_Context --
16985 ----------------------------
16987 function Unit_In_Parent_Context (Par_Unit : Node_Id) return Boolean is
16989 if Unit_In_Context (Par_Unit) then
16992 elsif Is_Child_Unit (Defining_Entity (Unit (Par_Unit))) then
16993 return Unit_In_Parent_Context (Parent_Spec (Unit (Par_Unit)));
16998 end Unit_In_Parent_Context;
17000 ---------------------
17001 -- Unit_In_Context --
17002 ---------------------
17004 function Unit_In_Context (Comp_Unit : Node_Id) return Boolean is
17008 Clause := First (Context_Items (Comp_Unit));
17009 while Present (Clause) loop
17010 if Nkind (Clause) = N_With_Clause then
17011 if Library_Unit (Clause) = U then
17014 -- The with_clause may denote a renaming of the unit we are
17015 -- looking for, eg. Text_IO which renames Ada.Text_IO.
17018 Renamed_Entity (Entity (Name (Clause))) =
17019 Defining_Entity (Unit (U))
17029 end Unit_In_Context;
17031 -- Start of processing for Unit_Is_Visible
17034 -- The currrent unit is directly visible
17039 elsif Unit_In_Context (Curr) then
17042 -- If the current unit is a body, check the context of the spec
17044 elsif Nkind (Unit (Curr)) = N_Package_Body
17046 (Nkind (Unit (Curr)) = N_Subprogram_Body
17047 and then not Acts_As_Spec (Unit (Curr)))
17049 if Unit_In_Context (Library_Unit (Curr)) then
17054 -- If the spec is a child unit, examine the parents
17056 if Is_Child_Unit (Curr_Entity) then
17057 if Nkind (Unit (Curr)) in N_Unit_Body then
17059 Unit_In_Parent_Context
17060 (Parent_Spec (Unit (Library_Unit (Curr))));
17062 return Unit_In_Parent_Context (Parent_Spec (Unit (Curr)));
17068 end Unit_Is_Visible;
17070 ------------------------------
17071 -- Universal_Interpretation --
17072 ------------------------------
17074 function Universal_Interpretation (Opnd : Node_Id) return Entity_Id is
17075 Index : Interp_Index;
17079 -- The argument may be a formal parameter of an operator or subprogram
17080 -- with multiple interpretations, or else an expression for an actual.
17082 if Nkind (Opnd) = N_Defining_Identifier
17083 or else not Is_Overloaded (Opnd)
17085 if Etype (Opnd) = Universal_Integer
17086 or else Etype (Opnd) = Universal_Real
17088 return Etype (Opnd);
17094 Get_First_Interp (Opnd, Index, It);
17095 while Present (It.Typ) loop
17096 if It.Typ = Universal_Integer
17097 or else It.Typ = Universal_Real
17102 Get_Next_Interp (Index, It);
17107 end Universal_Interpretation;
17113 function Unqualify (Expr : Node_Id) return Node_Id is
17115 -- Recurse to handle unlikely case of multiple levels of qualification
17117 if Nkind (Expr) = N_Qualified_Expression then
17118 return Unqualify (Expression (Expr));
17120 -- Normal case, not a qualified expression
17127 -----------------------
17128 -- Visible_Ancestors --
17129 -----------------------
17131 function Visible_Ancestors (Typ : Entity_Id) return Elist_Id is
17137 pragma Assert (Is_Record_Type (Typ)
17138 and then Is_Tagged_Type (Typ));
17140 -- Collect all the parents and progenitors of Typ. If the full-view of
17141 -- private parents and progenitors is available then it is used to
17142 -- generate the list of visible ancestors; otherwise their partial
17143 -- view is added to the resulting list.
17148 Use_Full_View => True);
17152 Ifaces_List => List_2,
17153 Exclude_Parents => True,
17154 Use_Full_View => True);
17156 -- Join the two lists. Avoid duplications because an interface may
17157 -- simultaneously be parent and progenitor of a type.
17159 Elmt := First_Elmt (List_2);
17160 while Present (Elmt) loop
17161 Append_Unique_Elmt (Node (Elmt), List_1);
17166 end Visible_Ancestors;
17168 ----------------------
17169 -- Within_Init_Proc --
17170 ----------------------
17172 function Within_Init_Proc return Boolean is
17176 S := Current_Scope;
17177 while not Is_Overloadable (S) loop
17178 if S = Standard_Standard then
17185 return Is_Init_Proc (S);
17186 end Within_Init_Proc;
17192 function Within_Scope (E : Entity_Id; S : Entity_Id) return Boolean is
17199 elsif SE = Standard_Standard then
17211 procedure Wrong_Type (Expr : Node_Id; Expected_Type : Entity_Id) is
17212 Found_Type : constant Entity_Id := First_Subtype (Etype (Expr));
17213 Expec_Type : constant Entity_Id := First_Subtype (Expected_Type);
17215 Matching_Field : Entity_Id;
17216 -- Entity to give a more precise suggestion on how to write a one-
17217 -- element positional aggregate.
17219 function Has_One_Matching_Field return Boolean;
17220 -- Determines if Expec_Type is a record type with a single component or
17221 -- discriminant whose type matches the found type or is one dimensional
17222 -- array whose component type matches the found type. In the case of
17223 -- one discriminant, we ignore the variant parts. That's not accurate,
17224 -- but good enough for the warning.
17226 ----------------------------
17227 -- Has_One_Matching_Field --
17228 ----------------------------
17230 function Has_One_Matching_Field return Boolean is
17234 Matching_Field := Empty;
17236 if Is_Array_Type (Expec_Type)
17237 and then Number_Dimensions (Expec_Type) = 1
17239 Covers (Etype (Component_Type (Expec_Type)), Found_Type)
17241 -- Use type name if available. This excludes multidimensional
17242 -- arrays and anonymous arrays.
17244 if Comes_From_Source (Expec_Type) then
17245 Matching_Field := Expec_Type;
17247 -- For an assignment, use name of target
17249 elsif Nkind (Parent (Expr)) = N_Assignment_Statement
17250 and then Is_Entity_Name (Name (Parent (Expr)))
17252 Matching_Field := Entity (Name (Parent (Expr)));
17257 elsif not Is_Record_Type (Expec_Type) then
17261 E := First_Entity (Expec_Type);
17266 elsif not Ekind_In (E, E_Discriminant, E_Component)
17267 or else Nam_In (Chars (E), Name_uTag, Name_uParent)
17276 if not Covers (Etype (E), Found_Type) then
17279 elsif Present (Next_Entity (E))
17280 and then (Ekind (E) = E_Component
17281 or else Ekind (Next_Entity (E)) = E_Discriminant)
17286 Matching_Field := E;
17290 end Has_One_Matching_Field;
17292 -- Start of processing for Wrong_Type
17295 -- Don't output message if either type is Any_Type, or if a message
17296 -- has already been posted for this node. We need to do the latter
17297 -- check explicitly (it is ordinarily done in Errout), because we
17298 -- are using ! to force the output of the error messages.
17300 if Expec_Type = Any_Type
17301 or else Found_Type = Any_Type
17302 or else Error_Posted (Expr)
17306 -- If one of the types is a Taft-Amendment type and the other it its
17307 -- completion, it must be an illegal use of a TAT in the spec, for
17308 -- which an error was already emitted. Avoid cascaded errors.
17310 elsif Is_Incomplete_Type (Expec_Type)
17311 and then Has_Completion_In_Body (Expec_Type)
17312 and then Full_View (Expec_Type) = Etype (Expr)
17316 elsif Is_Incomplete_Type (Etype (Expr))
17317 and then Has_Completion_In_Body (Etype (Expr))
17318 and then Full_View (Etype (Expr)) = Expec_Type
17322 -- In an instance, there is an ongoing problem with completion of
17323 -- type derived from private types. Their structure is what Gigi
17324 -- expects, but the Etype is the parent type rather than the
17325 -- derived private type itself. Do not flag error in this case. The
17326 -- private completion is an entity without a parent, like an Itype.
17327 -- Similarly, full and partial views may be incorrect in the instance.
17328 -- There is no simple way to insure that it is consistent ???
17330 elsif In_Instance then
17331 if Etype (Etype (Expr)) = Etype (Expected_Type)
17333 (Has_Private_Declaration (Expected_Type)
17334 or else Has_Private_Declaration (Etype (Expr)))
17335 and then No (Parent (Expected_Type))
17341 -- An interesting special check. If the expression is parenthesized
17342 -- and its type corresponds to the type of the sole component of the
17343 -- expected record type, or to the component type of the expected one
17344 -- dimensional array type, then assume we have a bad aggregate attempt.
17346 if Nkind (Expr) in N_Subexpr
17347 and then Paren_Count (Expr) /= 0
17348 and then Has_One_Matching_Field
17350 Error_Msg_N ("positional aggregate cannot have one component", Expr);
17351 if Present (Matching_Field) then
17352 if Is_Array_Type (Expec_Type) then
17354 ("\write instead `&''First ='> ...`", Expr, Matching_Field);
17358 ("\write instead `& ='> ...`", Expr, Matching_Field);
17362 -- Another special check, if we are looking for a pool-specific access
17363 -- type and we found an E_Access_Attribute_Type, then we have the case
17364 -- of an Access attribute being used in a context which needs a pool-
17365 -- specific type, which is never allowed. The one extra check we make
17366 -- is that the expected designated type covers the Found_Type.
17368 elsif Is_Access_Type (Expec_Type)
17369 and then Ekind (Found_Type) = E_Access_Attribute_Type
17370 and then Ekind (Base_Type (Expec_Type)) /= E_General_Access_Type
17371 and then Ekind (Base_Type (Expec_Type)) /= E_Anonymous_Access_Type
17373 (Designated_Type (Expec_Type), Designated_Type (Found_Type))
17375 Error_Msg_N -- CODEFIX
17376 ("result must be general access type!", Expr);
17377 Error_Msg_NE -- CODEFIX
17378 ("add ALL to }!", Expr, Expec_Type);
17380 -- Another special check, if the expected type is an integer type,
17381 -- but the expression is of type System.Address, and the parent is
17382 -- an addition or subtraction operation whose left operand is the
17383 -- expression in question and whose right operand is of an integral
17384 -- type, then this is an attempt at address arithmetic, so give
17385 -- appropriate message.
17387 elsif Is_Integer_Type (Expec_Type)
17388 and then Is_RTE (Found_Type, RE_Address)
17389 and then (Nkind (Parent (Expr)) = N_Op_Add
17391 Nkind (Parent (Expr)) = N_Op_Subtract)
17392 and then Expr = Left_Opnd (Parent (Expr))
17393 and then Is_Integer_Type (Etype (Right_Opnd (Parent (Expr))))
17396 ("address arithmetic not predefined in package System",
17399 ("\possible missing with/use of System.Storage_Elements",
17403 -- If the expected type is an anonymous access type, as for access
17404 -- parameters and discriminants, the error is on the designated types.
17406 elsif Ekind (Expec_Type) = E_Anonymous_Access_Type then
17407 if Comes_From_Source (Expec_Type) then
17408 Error_Msg_NE ("expected}!", Expr, Expec_Type);
17411 ("expected an access type with designated}",
17412 Expr, Designated_Type (Expec_Type));
17415 if Is_Access_Type (Found_Type)
17416 and then not Comes_From_Source (Found_Type)
17419 ("\\found an access type with designated}!",
17420 Expr, Designated_Type (Found_Type));
17422 if From_Limited_With (Found_Type) then
17423 Error_Msg_NE ("\\found incomplete}!", Expr, Found_Type);
17424 Error_Msg_Qual_Level := 99;
17425 Error_Msg_NE -- CODEFIX
17426 ("\\missing `WITH &;", Expr, Scope (Found_Type));
17427 Error_Msg_Qual_Level := 0;
17429 Error_Msg_NE ("found}!", Expr, Found_Type);
17433 -- Normal case of one type found, some other type expected
17436 -- If the names of the two types are the same, see if some number
17437 -- of levels of qualification will help. Don't try more than three
17438 -- levels, and if we get to standard, it's no use (and probably
17439 -- represents an error in the compiler) Also do not bother with
17440 -- internal scope names.
17443 Expec_Scope : Entity_Id;
17444 Found_Scope : Entity_Id;
17447 Expec_Scope := Expec_Type;
17448 Found_Scope := Found_Type;
17450 for Levels in Int range 0 .. 3 loop
17451 if Chars (Expec_Scope) /= Chars (Found_Scope) then
17452 Error_Msg_Qual_Level := Levels;
17456 Expec_Scope := Scope (Expec_Scope);
17457 Found_Scope := Scope (Found_Scope);
17459 exit when Expec_Scope = Standard_Standard
17460 or else Found_Scope = Standard_Standard
17461 or else not Comes_From_Source (Expec_Scope)
17462 or else not Comes_From_Source (Found_Scope);
17466 if Is_Record_Type (Expec_Type)
17467 and then Present (Corresponding_Remote_Type (Expec_Type))
17469 Error_Msg_NE ("expected}!", Expr,
17470 Corresponding_Remote_Type (Expec_Type));
17472 Error_Msg_NE ("expected}!", Expr, Expec_Type);
17475 if Is_Entity_Name (Expr)
17476 and then Is_Package_Or_Generic_Package (Entity (Expr))
17478 Error_Msg_N ("\\found package name!", Expr);
17480 elsif Is_Entity_Name (Expr)
17482 (Ekind (Entity (Expr)) = E_Procedure
17484 Ekind (Entity (Expr)) = E_Generic_Procedure)
17486 if Ekind (Expec_Type) = E_Access_Subprogram_Type then
17488 ("found procedure name, possibly missing Access attribute!",
17492 ("\\found procedure name instead of function!", Expr);
17495 elsif Nkind (Expr) = N_Function_Call
17496 and then Ekind (Expec_Type) = E_Access_Subprogram_Type
17497 and then Etype (Designated_Type (Expec_Type)) = Etype (Expr)
17498 and then No (Parameter_Associations (Expr))
17501 ("found function name, possibly missing Access attribute!",
17504 -- Catch common error: a prefix or infix operator which is not
17505 -- directly visible because the type isn't.
17507 elsif Nkind (Expr) in N_Op
17508 and then Is_Overloaded (Expr)
17509 and then not Is_Immediately_Visible (Expec_Type)
17510 and then not Is_Potentially_Use_Visible (Expec_Type)
17511 and then not In_Use (Expec_Type)
17512 and then Has_Compatible_Type (Right_Opnd (Expr), Expec_Type)
17515 ("operator of the type is not directly visible!", Expr);
17517 elsif Ekind (Found_Type) = E_Void
17518 and then Present (Parent (Found_Type))
17519 and then Nkind (Parent (Found_Type)) = N_Full_Type_Declaration
17521 Error_Msg_NE ("\\found premature usage of}!", Expr, Found_Type);
17524 Error_Msg_NE ("\\found}!", Expr, Found_Type);
17527 -- A special check for cases like M1 and M2 = 0 where M1 and M2 are
17528 -- of the same modular type, and (M1 and M2) = 0 was intended.
17530 if Expec_Type = Standard_Boolean
17531 and then Is_Modular_Integer_Type (Found_Type)
17532 and then Nkind_In (Parent (Expr), N_Op_And, N_Op_Or, N_Op_Xor)
17533 and then Nkind (Right_Opnd (Parent (Expr))) in N_Op_Compare
17536 Op : constant Node_Id := Right_Opnd (Parent (Expr));
17537 L : constant Node_Id := Left_Opnd (Op);
17538 R : constant Node_Id := Right_Opnd (Op);
17540 -- The case for the message is when the left operand of the
17541 -- comparison is the same modular type, or when it is an
17542 -- integer literal (or other universal integer expression),
17543 -- which would have been typed as the modular type if the
17544 -- parens had been there.
17546 if (Etype (L) = Found_Type
17548 Etype (L) = Universal_Integer)
17549 and then Is_Integer_Type (Etype (R))
17552 ("\\possible missing parens for modular operation", Expr);
17557 -- Reset error message qualification indication
17559 Error_Msg_Qual_Level := 0;