1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Treepr; -- ???For debugging code below
28 with Aspects; use Aspects;
29 with Casing; use Casing;
30 with Checks; use Checks;
31 with Debug; use Debug;
32 with Elists; use Elists;
33 with Errout; use Errout;
34 with Erroutc; use Erroutc;
35 with Exp_Ch11; use Exp_Ch11;
36 with Exp_Util; use Exp_Util;
37 with Fname; use Fname;
38 with Freeze; use Freeze;
40 with Lib.Xref; use Lib.Xref;
41 with Namet.Sp; use Namet.Sp;
42 with Nlists; use Nlists;
43 with Nmake; use Nmake;
44 with Output; use Output;
45 with Restrict; use Restrict;
46 with Rident; use Rident;
47 with Rtsfind; use Rtsfind;
49 with Sem_Aux; use Sem_Aux;
50 with Sem_Attr; use Sem_Attr;
51 with Sem_Ch6; use Sem_Ch6;
52 with Sem_Ch8; use Sem_Ch8;
53 with Sem_Disp; use Sem_Disp;
54 with Sem_Elab; use Sem_Elab;
55 with Sem_Eval; use Sem_Eval;
56 with Sem_Prag; use Sem_Prag;
57 with Sem_Res; use Sem_Res;
58 with Sem_Warn; use Sem_Warn;
59 with Sem_Type; use Sem_Type;
60 with Sinfo; use Sinfo;
61 with Sinput; use Sinput;
62 with Stand; use Stand;
64 with Stringt; use Stringt;
65 with Targparm; use Targparm;
66 with Tbuild; use Tbuild;
67 with Ttypes; use Ttypes;
68 with Uname; use Uname;
70 with GNAT.HTable; use GNAT.HTable;
72 package body Sem_Util is
74 ---------------------------
75 -- Local Data Structures --
76 ---------------------------
78 Invalid_Binder_Values : array (Scalar_Id) of Entity_Id := (others => Empty);
79 -- A collection to hold the entities of the variables declared in package
80 -- System.Scalar_Values which describe the invalid values of scalar types.
82 Invalid_Binder_Values_Set : Boolean := False;
83 -- This flag prevents multiple attempts to initialize Invalid_Binder_Values
85 Invalid_Floats : array (Float_Scalar_Id) of Ureal := (others => No_Ureal);
86 -- A collection to hold the invalid values of float types as specified by
87 -- pragma Initialize_Scalars.
89 Invalid_Integers : array (Integer_Scalar_Id) of Uint := (others => No_Uint);
90 -- A collection to hold the invalid values of integer types as specified
91 -- by pragma Initialize_Scalars.
93 -----------------------
94 -- Local Subprograms --
95 -----------------------
97 function Build_Component_Subtype
100 T : Entity_Id) return Node_Id;
101 -- This function builds the subtype for Build_Actual_Subtype_Of_Component
102 -- and Build_Discriminal_Subtype_Of_Component. C is a list of constraints,
103 -- Loc is the source location, T is the original subtype.
105 procedure Examine_Array_Bounds
107 All_Static : out Boolean;
108 Has_Empty : out Boolean);
109 -- Inspect the index constraints of array type Typ. Flag All_Static is set
110 -- when all ranges are static. Flag Has_Empty is set only when All_Static
111 -- is set and indicates that at least one range is empty.
113 function Has_Enabled_Property
114 (Item_Id : Entity_Id;
115 Property : Name_Id) return Boolean;
116 -- Subsidiary to routines Async_xxx_Enabled and Effective_xxx_Enabled.
117 -- Determine whether an abstract state or a variable denoted by entity
118 -- Item_Id has enabled property Property.
120 function Has_Null_Extension (T : Entity_Id) return Boolean;
121 -- T is a derived tagged type. Check whether the type extension is null.
122 -- If the parent type is fully initialized, T can be treated as such.
124 function Is_Fully_Initialized_Variant (Typ : Entity_Id) return Boolean;
125 -- Subsidiary to Is_Fully_Initialized_Type. For an unconstrained type
126 -- with discriminants whose default values are static, examine only the
127 -- components in the selected variant to determine whether all of them
130 type Null_Status_Kind is
132 -- This value indicates that a subexpression is known to have a null
133 -- value at compile time.
136 -- This value indicates that a subexpression is known to have a non-null
137 -- value at compile time.
140 -- This value indicates that it cannot be determined at compile time
141 -- whether a subexpression yields a null or non-null value.
143 function Null_Status (N : Node_Id) return Null_Status_Kind;
144 -- Determine whether subexpression N of an access type yields a null value,
145 -- a non-null value, or the value cannot be determined at compile time. The
146 -- routine does not take simple flow diagnostics into account, it relies on
147 -- static facts such as the presence of null exclusions.
149 function Old_Requires_Transient_Scope (Id : Entity_Id) return Boolean;
150 function New_Requires_Transient_Scope (Id : Entity_Id) return Boolean;
151 -- ???We retain the old and new algorithms for Requires_Transient_Scope for
152 -- the time being. New_Requires_Transient_Scope is used by default; the
153 -- debug switch -gnatdQ can be used to do Old_Requires_Transient_Scope
154 -- instead. The intent is to use this temporarily to measure before/after
155 -- efficiency. Note: when this temporary code is removed, the documentation
156 -- of dQ in debug.adb should be removed.
158 procedure Results_Differ
162 -- ???Debugging code. Called when the Old_Val and New_Val differ. This
163 -- routine will be removed eventially when New_Requires_Transient_Scope
164 -- becomes Requires_Transient_Scope and Old_Requires_Transient_Scope is
167 function Subprogram_Name (N : Node_Id) return String;
168 -- Return the fully qualified name of the enclosing subprogram for the
169 -- given node N, with file:line:col information appended, e.g.
170 -- "subp:file:line:col", corresponding to the source location of the
171 -- body of the subprogram.
173 ------------------------------
174 -- Abstract_Interface_List --
175 ------------------------------
177 function Abstract_Interface_List (Typ : Entity_Id) return List_Id is
181 if Is_Concurrent_Type (Typ) then
183 -- If we are dealing with a synchronized subtype, go to the base
184 -- type, whose declaration has the interface list.
186 Nod := Declaration_Node (Base_Type (Typ));
188 if Nkind_In (Nod, N_Full_Type_Declaration,
189 N_Private_Type_Declaration)
194 elsif Ekind (Typ) = E_Record_Type_With_Private then
195 if Nkind (Parent (Typ)) = N_Full_Type_Declaration then
196 Nod := Type_Definition (Parent (Typ));
198 elsif Nkind (Parent (Typ)) = N_Private_Type_Declaration then
199 if Present (Full_View (Typ))
201 Nkind (Parent (Full_View (Typ))) = N_Full_Type_Declaration
203 Nod := Type_Definition (Parent (Full_View (Typ)));
205 -- If the full-view is not available we cannot do anything else
206 -- here (the source has errors).
212 -- Support for generic formals with interfaces is still missing ???
214 elsif Nkind (Parent (Typ)) = N_Formal_Type_Declaration then
219 (Nkind (Parent (Typ)) = N_Private_Extension_Declaration);
223 elsif Ekind (Typ) = E_Record_Subtype then
224 Nod := Type_Definition (Parent (Etype (Typ)));
226 elsif Ekind (Typ) = E_Record_Subtype_With_Private then
228 -- Recurse, because parent may still be a private extension. Also
229 -- note that the full view of the subtype or the full view of its
230 -- base type may (both) be unavailable.
232 return Abstract_Interface_List (Etype (Typ));
234 elsif Ekind (Typ) = E_Record_Type then
235 if Nkind (Parent (Typ)) = N_Formal_Type_Declaration then
236 Nod := Formal_Type_Definition (Parent (Typ));
238 Nod := Type_Definition (Parent (Typ));
241 -- Otherwise the type is of a kind which does not implement interfaces
247 return Interface_List (Nod);
248 end Abstract_Interface_List;
250 --------------------------------
251 -- Add_Access_Type_To_Process --
252 --------------------------------
254 procedure Add_Access_Type_To_Process (E : Entity_Id; A : Entity_Id) is
258 Ensure_Freeze_Node (E);
259 L := Access_Types_To_Process (Freeze_Node (E));
263 Set_Access_Types_To_Process (Freeze_Node (E), L);
267 end Add_Access_Type_To_Process;
269 --------------------------
270 -- Add_Block_Identifier --
271 --------------------------
273 procedure Add_Block_Identifier (N : Node_Id; Id : out Entity_Id) is
274 Loc : constant Source_Ptr := Sloc (N);
277 pragma Assert (Nkind (N) = N_Block_Statement);
279 -- The block already has a label, return its entity
281 if Present (Identifier (N)) then
282 Id := Entity (Identifier (N));
284 -- Create a new block label and set its attributes
287 Id := New_Internal_Entity (E_Block, Current_Scope, Loc, 'B');
288 Set_Etype (Id, Standard_Void_Type);
291 Set_Identifier (N, New_Occurrence_Of (Id, Loc));
292 Set_Block_Node (Id, Identifier (N));
294 end Add_Block_Identifier;
296 ----------------------------
297 -- Add_Global_Declaration --
298 ----------------------------
300 procedure Add_Global_Declaration (N : Node_Id) is
301 Aux_Node : constant Node_Id := Aux_Decls_Node (Cunit (Current_Sem_Unit));
304 if No (Declarations (Aux_Node)) then
305 Set_Declarations (Aux_Node, New_List);
308 Append_To (Declarations (Aux_Node), N);
310 end Add_Global_Declaration;
312 --------------------------------
313 -- Address_Integer_Convert_OK --
314 --------------------------------
316 function Address_Integer_Convert_OK (T1, T2 : Entity_Id) return Boolean is
318 if Allow_Integer_Address
319 and then ((Is_Descendant_Of_Address (T1)
320 and then Is_Private_Type (T1)
321 and then Is_Integer_Type (T2))
323 (Is_Descendant_Of_Address (T2)
324 and then Is_Private_Type (T2)
325 and then Is_Integer_Type (T1)))
331 end Address_Integer_Convert_OK;
337 function Address_Value (N : Node_Id) return Node_Id is
342 -- For constant, get constant expression
344 if Is_Entity_Name (Expr)
345 and then Ekind (Entity (Expr)) = E_Constant
347 Expr := Constant_Value (Entity (Expr));
349 -- For unchecked conversion, get result to convert
351 elsif Nkind (Expr) = N_Unchecked_Type_Conversion then
352 Expr := Expression (Expr);
354 -- For (common case) of To_Address call, get argument
356 elsif Nkind (Expr) = N_Function_Call
357 and then Is_Entity_Name (Name (Expr))
358 and then Is_RTE (Entity (Name (Expr)), RE_To_Address)
360 Expr := First (Parameter_Associations (Expr));
362 if Nkind (Expr) = N_Parameter_Association then
363 Expr := Explicit_Actual_Parameter (Expr);
366 -- We finally have the real expression
380 -- For now, just 8/16/32/64
382 function Addressable (V : Uint) return Boolean is
384 return V = Uint_8 or else
390 function Addressable (V : Int) return Boolean is
398 ---------------------------------
399 -- Aggregate_Constraint_Checks --
400 ---------------------------------
402 procedure Aggregate_Constraint_Checks
404 Check_Typ : Entity_Id)
406 Exp_Typ : constant Entity_Id := Etype (Exp);
409 if Raises_Constraint_Error (Exp) then
413 -- Ada 2005 (AI-230): Generate a conversion to an anonymous access
414 -- component's type to force the appropriate accessibility checks.
416 -- Ada 2005 (AI-231): Generate conversion to the null-excluding type to
417 -- force the corresponding run-time check
419 if Is_Access_Type (Check_Typ)
420 and then Is_Local_Anonymous_Access (Check_Typ)
422 Rewrite (Exp, Convert_To (Check_Typ, Relocate_Node (Exp)));
423 Analyze_And_Resolve (Exp, Check_Typ);
424 Check_Unset_Reference (Exp);
427 -- What follows is really expansion activity, so check that expansion
428 -- is on and is allowed. In GNATprove mode, we also want check flags to
429 -- be added in the tree, so that the formal verification can rely on
430 -- those to be present. In GNATprove mode for formal verification, some
431 -- treatment typically only done during expansion needs to be performed
432 -- on the tree, but it should not be applied inside generics. Otherwise,
433 -- this breaks the name resolution mechanism for generic instances.
435 if not Expander_Active
436 and (Inside_A_Generic or not Full_Analysis or not GNATprove_Mode)
441 if Is_Access_Type (Check_Typ)
442 and then Can_Never_Be_Null (Check_Typ)
443 and then not Can_Never_Be_Null (Exp_Typ)
445 Install_Null_Excluding_Check (Exp);
448 -- First check if we have to insert discriminant checks
450 if Has_Discriminants (Exp_Typ) then
451 Apply_Discriminant_Check (Exp, Check_Typ);
453 -- Next emit length checks for array aggregates
455 elsif Is_Array_Type (Exp_Typ) then
456 Apply_Length_Check (Exp, Check_Typ);
458 -- Finally emit scalar and string checks. If we are dealing with a
459 -- scalar literal we need to check by hand because the Etype of
460 -- literals is not necessarily correct.
462 elsif Is_Scalar_Type (Exp_Typ)
463 and then Compile_Time_Known_Value (Exp)
465 if Is_Out_Of_Range (Exp, Base_Type (Check_Typ)) then
466 Apply_Compile_Time_Constraint_Error
467 (Exp, "value not in range of}??", CE_Range_Check_Failed,
468 Ent => Base_Type (Check_Typ),
469 Typ => Base_Type (Check_Typ));
471 elsif Is_Out_Of_Range (Exp, Check_Typ) then
472 Apply_Compile_Time_Constraint_Error
473 (Exp, "value not in range of}??", CE_Range_Check_Failed,
477 elsif not Range_Checks_Suppressed (Check_Typ) then
478 Apply_Scalar_Range_Check (Exp, Check_Typ);
481 -- Verify that target type is also scalar, to prevent view anomalies
482 -- in instantiations.
484 elsif (Is_Scalar_Type (Exp_Typ)
485 or else Nkind (Exp) = N_String_Literal)
486 and then Is_Scalar_Type (Check_Typ)
487 and then Exp_Typ /= Check_Typ
489 if Is_Entity_Name (Exp)
490 and then Ekind (Entity (Exp)) = E_Constant
492 -- If expression is a constant, it is worthwhile checking whether
493 -- it is a bound of the type.
495 if (Is_Entity_Name (Type_Low_Bound (Check_Typ))
496 and then Entity (Exp) = Entity (Type_Low_Bound (Check_Typ)))
498 (Is_Entity_Name (Type_High_Bound (Check_Typ))
499 and then Entity (Exp) = Entity (Type_High_Bound (Check_Typ)))
504 Rewrite (Exp, Convert_To (Check_Typ, Relocate_Node (Exp)));
505 Analyze_And_Resolve (Exp, Check_Typ);
506 Check_Unset_Reference (Exp);
509 -- Could use a comment on this case ???
512 Rewrite (Exp, Convert_To (Check_Typ, Relocate_Node (Exp)));
513 Analyze_And_Resolve (Exp, Check_Typ);
514 Check_Unset_Reference (Exp);
518 end Aggregate_Constraint_Checks;
520 -----------------------
521 -- Alignment_In_Bits --
522 -----------------------
524 function Alignment_In_Bits (E : Entity_Id) return Uint is
526 return Alignment (E) * System_Storage_Unit;
527 end Alignment_In_Bits;
529 --------------------------------------
530 -- All_Composite_Constraints_Static --
531 --------------------------------------
533 function All_Composite_Constraints_Static
534 (Constr : Node_Id) return Boolean
537 if No (Constr) or else Error_Posted (Constr) then
541 case Nkind (Constr) is
543 if Nkind (Constr) in N_Has_Entity
544 and then Present (Entity (Constr))
546 if Is_Type (Entity (Constr)) then
548 not Is_Discrete_Type (Entity (Constr))
549 or else Is_OK_Static_Subtype (Entity (Constr));
552 elsif Nkind (Constr) = N_Range then
554 Is_OK_Static_Expression (Low_Bound (Constr))
556 Is_OK_Static_Expression (High_Bound (Constr));
558 elsif Nkind (Constr) = N_Attribute_Reference
559 and then Attribute_Name (Constr) = Name_Range
562 Is_OK_Static_Expression
563 (Type_Low_Bound (Etype (Prefix (Constr))))
565 Is_OK_Static_Expression
566 (Type_High_Bound (Etype (Prefix (Constr))));
570 not Present (Etype (Constr)) -- previous error
571 or else not Is_Discrete_Type (Etype (Constr))
572 or else Is_OK_Static_Expression (Constr);
574 when N_Discriminant_Association =>
575 return All_Composite_Constraints_Static (Expression (Constr));
577 when N_Range_Constraint =>
579 All_Composite_Constraints_Static (Range_Expression (Constr));
581 when N_Index_Or_Discriminant_Constraint =>
583 One_Cstr : Entity_Id;
585 One_Cstr := First (Constraints (Constr));
586 while Present (One_Cstr) loop
587 if not All_Composite_Constraints_Static (One_Cstr) then
597 when N_Subtype_Indication =>
599 All_Composite_Constraints_Static (Subtype_Mark (Constr))
601 All_Composite_Constraints_Static (Constraint (Constr));
606 end All_Composite_Constraints_Static;
608 ------------------------
609 -- Append_Entity_Name --
610 ------------------------
612 procedure Append_Entity_Name (Buf : in out Bounded_String; E : Entity_Id) is
613 Temp : Bounded_String;
615 procedure Inner (E : Entity_Id);
616 -- Inner recursive routine, keep outer routine nonrecursive to ease
617 -- debugging when we get strange results from this routine.
623 procedure Inner (E : Entity_Id) is
627 -- If entity has an internal name, skip by it, and print its scope.
628 -- Note that we strip a final R from the name before the test; this
629 -- is needed for some cases of instantiations.
632 E_Name : Bounded_String;
635 Append (E_Name, Chars (E));
637 if E_Name.Chars (E_Name.Length) = 'R' then
638 E_Name.Length := E_Name.Length - 1;
641 if Is_Internal_Name (E_Name) then
649 -- Just print entity name if its scope is at the outer level
651 if Scop = Standard_Standard then
654 -- If scope comes from source, write scope and entity
656 elsif Comes_From_Source (Scop) then
657 Append_Entity_Name (Temp, Scop);
660 -- If in wrapper package skip past it
662 elsif Present (Scop) and then Is_Wrapper_Package (Scop) then
663 Append_Entity_Name (Temp, Scope (Scop));
666 -- Otherwise nothing to output (happens in unnamed block statements)
675 E_Name : Bounded_String;
678 Append_Unqualified_Decoded (E_Name, Chars (E));
680 -- Remove trailing upper-case letters from the name (useful for
681 -- dealing with some cases of internal names generated in the case
682 -- of references from within a generic).
684 while E_Name.Length > 1
685 and then E_Name.Chars (E_Name.Length) in 'A' .. 'Z'
687 E_Name.Length := E_Name.Length - 1;
690 -- Adjust casing appropriately (gets name from source if possible)
692 Adjust_Name_Case (E_Name, Sloc (E));
693 Append (Temp, E_Name);
697 -- Start of processing for Append_Entity_Name
702 end Append_Entity_Name;
704 ---------------------------------
705 -- Append_Inherited_Subprogram --
706 ---------------------------------
708 procedure Append_Inherited_Subprogram (S : Entity_Id) is
709 Par : constant Entity_Id := Alias (S);
710 -- The parent subprogram
712 Scop : constant Entity_Id := Scope (Par);
713 -- The scope of definition of the parent subprogram
715 Typ : constant Entity_Id := Defining_Entity (Parent (S));
716 -- The derived type of which S is a primitive operation
722 if Ekind (Current_Scope) = E_Package
723 and then In_Private_Part (Current_Scope)
724 and then Has_Private_Declaration (Typ)
725 and then Is_Tagged_Type (Typ)
726 and then Scop = Current_Scope
728 -- The inherited operation is available at the earliest place after
729 -- the derived type declaration (RM 7.3.1 (6/1)). This is only
730 -- relevant for type extensions. If the parent operation appears
731 -- after the type extension, the operation is not visible.
734 (Visible_Declarations
735 (Package_Specification (Current_Scope)));
736 while Present (Decl) loop
737 if Nkind (Decl) = N_Private_Extension_Declaration
738 and then Defining_Entity (Decl) = Typ
740 if Sloc (Decl) > Sloc (Par) then
741 Next_E := Next_Entity (Par);
742 Link_Entities (Par, S);
743 Link_Entities (S, Next_E);
755 -- If partial view is not a type extension, or it appears before the
756 -- subprogram declaration, insert normally at end of entity list.
758 Append_Entity (S, Current_Scope);
759 end Append_Inherited_Subprogram;
761 -----------------------------------------
762 -- Apply_Compile_Time_Constraint_Error --
763 -----------------------------------------
765 procedure Apply_Compile_Time_Constraint_Error
768 Reason : RT_Exception_Code;
769 Ent : Entity_Id := Empty;
770 Typ : Entity_Id := Empty;
771 Loc : Source_Ptr := No_Location;
772 Rep : Boolean := True;
773 Warn : Boolean := False)
775 Stat : constant Boolean := Is_Static_Expression (N);
776 R_Stat : constant Node_Id :=
777 Make_Raise_Constraint_Error (Sloc (N), Reason => Reason);
788 (Compile_Time_Constraint_Error (N, Msg, Ent, Loc, Warn => Warn));
790 -- In GNATprove mode, do not replace the node with an exception raised.
791 -- In such a case, either the call to Compile_Time_Constraint_Error
792 -- issues an error which stops analysis, or it issues a warning in
793 -- a few cases where a suitable check flag is set for GNATprove to
794 -- generate a check message.
796 if not Rep or GNATprove_Mode then
800 -- Now we replace the node by an N_Raise_Constraint_Error node
801 -- This does not need reanalyzing, so set it as analyzed now.
804 Set_Analyzed (N, True);
807 Set_Raises_Constraint_Error (N);
809 -- Now deal with possible local raise handling
811 Possible_Local_Raise (N, Standard_Constraint_Error);
813 -- If the original expression was marked as static, the result is
814 -- still marked as static, but the Raises_Constraint_Error flag is
815 -- always set so that further static evaluation is not attempted.
818 Set_Is_Static_Expression (N);
820 end Apply_Compile_Time_Constraint_Error;
822 ---------------------------
823 -- Async_Readers_Enabled --
824 ---------------------------
826 function Async_Readers_Enabled (Id : Entity_Id) return Boolean is
828 return Has_Enabled_Property (Id, Name_Async_Readers);
829 end Async_Readers_Enabled;
831 ---------------------------
832 -- Async_Writers_Enabled --
833 ---------------------------
835 function Async_Writers_Enabled (Id : Entity_Id) return Boolean is
837 return Has_Enabled_Property (Id, Name_Async_Writers);
838 end Async_Writers_Enabled;
840 --------------------------------------
841 -- Available_Full_View_Of_Component --
842 --------------------------------------
844 function Available_Full_View_Of_Component (T : Entity_Id) return Boolean is
845 ST : constant Entity_Id := Scope (T);
846 SCT : constant Entity_Id := Scope (Component_Type (T));
848 return In_Open_Scopes (ST)
849 and then In_Open_Scopes (SCT)
850 and then Scope_Depth (ST) >= Scope_Depth (SCT);
851 end Available_Full_View_Of_Component;
857 procedure Bad_Attribute
860 Warn : Boolean := False)
863 Error_Msg_Warn := Warn;
864 Error_Msg_N ("unrecognized attribute&<<", N);
866 -- Check for possible misspelling
868 Error_Msg_Name_1 := First_Attribute_Name;
869 while Error_Msg_Name_1 <= Last_Attribute_Name loop
870 if Is_Bad_Spelling_Of (Nam, Error_Msg_Name_1) then
871 Error_Msg_N -- CODEFIX
872 ("\possible misspelling of %<<", N);
876 Error_Msg_Name_1 := Error_Msg_Name_1 + 1;
880 --------------------------------
881 -- Bad_Predicated_Subtype_Use --
882 --------------------------------
884 procedure Bad_Predicated_Subtype_Use
888 Suggest_Static : Boolean := False)
893 -- Avoid cascaded errors
895 if Error_Posted (N) then
899 if Inside_A_Generic then
900 Gen := Current_Scope;
901 while Present (Gen) and then Ekind (Gen) /= E_Generic_Package loop
909 if Is_Generic_Formal (Typ) and then Is_Discrete_Type (Typ) then
910 Set_No_Predicate_On_Actual (Typ);
913 elsif Has_Predicates (Typ) then
914 if Is_Generic_Actual_Type (Typ) then
916 -- The restriction on loop parameters is only that the type
917 -- should have no dynamic predicates.
919 if Nkind (Parent (N)) = N_Loop_Parameter_Specification
920 and then not Has_Dynamic_Predicate_Aspect (Typ)
921 and then Is_OK_Static_Subtype (Typ)
926 Gen := Current_Scope;
927 while not Is_Generic_Instance (Gen) loop
931 pragma Assert (Present (Gen));
933 if Ekind (Gen) = E_Package and then In_Package_Body (Gen) then
934 Error_Msg_Warn := SPARK_Mode /= On;
935 Error_Msg_FE (Msg & "<<", N, Typ);
936 Error_Msg_F ("\Program_Error [<<", N);
939 Make_Raise_Program_Error (Sloc (N),
940 Reason => PE_Bad_Predicated_Generic_Type));
943 Error_Msg_FE (Msg & "<<", N, Typ);
947 Error_Msg_FE (Msg, N, Typ);
950 -- Emit an optional suggestion on how to remedy the error if the
951 -- context warrants it.
953 if Suggest_Static and then Has_Static_Predicate (Typ) then
954 Error_Msg_FE ("\predicate of & should be marked static", N, Typ);
957 end Bad_Predicated_Subtype_Use;
959 -----------------------------------------
960 -- Bad_Unordered_Enumeration_Reference --
961 -----------------------------------------
963 function Bad_Unordered_Enumeration_Reference
965 T : Entity_Id) return Boolean
968 return Is_Enumeration_Type (T)
969 and then Warn_On_Unordered_Enumeration_Type
970 and then not Is_Generic_Type (T)
971 and then Comes_From_Source (N)
972 and then not Has_Pragma_Ordered (T)
973 and then not In_Same_Extended_Unit (N, T);
974 end Bad_Unordered_Enumeration_Reference;
976 ----------------------------
977 -- Begin_Keyword_Location --
978 ----------------------------
980 function Begin_Keyword_Location (N : Node_Id) return Source_Ptr is
984 pragma Assert (Nkind_In (N, N_Block_Statement,
990 HSS := Handled_Statement_Sequence (N);
992 -- When the handled sequence of statements comes from source, the
993 -- location of the "begin" keyword is that of the sequence itself.
994 -- Note that an internal construct may inherit a source sequence.
996 if Comes_From_Source (HSS) then
999 -- The parser generates an internal handled sequence of statements to
1000 -- capture the location of the "begin" keyword if present in the source.
1001 -- Since there are no source statements, the location of the "begin"
1002 -- keyword is effectively that of the "end" keyword.
1004 elsif Comes_From_Source (N) then
1007 -- Otherwise the construct is internal and should carry the location of
1008 -- the original construct which prompted its creation.
1013 end Begin_Keyword_Location;
1015 --------------------------
1016 -- Build_Actual_Subtype --
1017 --------------------------
1019 function Build_Actual_Subtype
1021 N : Node_Or_Entity_Id) return Node_Id
1024 -- Normally Sloc (N), but may point to corresponding body in some cases
1026 Constraints : List_Id;
1032 Disc_Type : Entity_Id;
1038 if Nkind (N) = N_Defining_Identifier then
1039 Obj := New_Occurrence_Of (N, Loc);
1041 -- If this is a formal parameter of a subprogram declaration, and
1042 -- we are compiling the body, we want the declaration for the
1043 -- actual subtype to carry the source position of the body, to
1044 -- prevent anomalies in gdb when stepping through the code.
1046 if Is_Formal (N) then
1048 Decl : constant Node_Id := Unit_Declaration_Node (Scope (N));
1050 if Nkind (Decl) = N_Subprogram_Declaration
1051 and then Present (Corresponding_Body (Decl))
1053 Loc := Sloc (Corresponding_Body (Decl));
1062 if Is_Array_Type (T) then
1063 Constraints := New_List;
1064 for J in 1 .. Number_Dimensions (T) loop
1066 -- Build an array subtype declaration with the nominal subtype and
1067 -- the bounds of the actual. Add the declaration in front of the
1068 -- local declarations for the subprogram, for analysis before any
1069 -- reference to the formal in the body.
1072 Make_Attribute_Reference (Loc,
1074 Duplicate_Subexpr_No_Checks (Obj, Name_Req => True),
1075 Attribute_Name => Name_First,
1076 Expressions => New_List (
1077 Make_Integer_Literal (Loc, J)));
1080 Make_Attribute_Reference (Loc,
1082 Duplicate_Subexpr_No_Checks (Obj, Name_Req => True),
1083 Attribute_Name => Name_Last,
1084 Expressions => New_List (
1085 Make_Integer_Literal (Loc, J)));
1087 Append (Make_Range (Loc, Lo, Hi), Constraints);
1090 -- If the type has unknown discriminants there is no constrained
1091 -- subtype to build. This is never called for a formal or for a
1092 -- lhs, so returning the type is ok ???
1094 elsif Has_Unknown_Discriminants (T) then
1098 Constraints := New_List;
1100 -- Type T is a generic derived type, inherit the discriminants from
1103 if Is_Private_Type (T)
1104 and then No (Full_View (T))
1106 -- T was flagged as an error if it was declared as a formal
1107 -- derived type with known discriminants. In this case there
1108 -- is no need to look at the parent type since T already carries
1109 -- its own discriminants.
1111 and then not Error_Posted (T)
1113 Disc_Type := Etype (Base_Type (T));
1118 Discr := First_Discriminant (Disc_Type);
1119 while Present (Discr) loop
1120 Append_To (Constraints,
1121 Make_Selected_Component (Loc,
1123 Duplicate_Subexpr_No_Checks (Obj),
1124 Selector_Name => New_Occurrence_Of (Discr, Loc)));
1125 Next_Discriminant (Discr);
1129 Subt := Make_Temporary (Loc, 'S', Related_Node => N);
1130 Set_Is_Internal (Subt);
1133 Make_Subtype_Declaration (Loc,
1134 Defining_Identifier => Subt,
1135 Subtype_Indication =>
1136 Make_Subtype_Indication (Loc,
1137 Subtype_Mark => New_Occurrence_Of (T, Loc),
1139 Make_Index_Or_Discriminant_Constraint (Loc,
1140 Constraints => Constraints)));
1142 Mark_Rewrite_Insertion (Decl);
1144 end Build_Actual_Subtype;
1146 ---------------------------------------
1147 -- Build_Actual_Subtype_Of_Component --
1148 ---------------------------------------
1150 function Build_Actual_Subtype_Of_Component
1152 N : Node_Id) return Node_Id
1154 Loc : constant Source_Ptr := Sloc (N);
1155 P : constant Node_Id := Prefix (N);
1158 Index_Typ : Entity_Id;
1160 Desig_Typ : Entity_Id;
1161 -- This is either a copy of T, or if T is an access type, then it is
1162 -- the directly designated type of this access type.
1164 function Build_Actual_Array_Constraint return List_Id;
1165 -- If one or more of the bounds of the component depends on
1166 -- discriminants, build actual constraint using the discriminants
1169 function Build_Actual_Record_Constraint return List_Id;
1170 -- Similar to previous one, for discriminated components constrained
1171 -- by the discriminant of the enclosing object.
1173 -----------------------------------
1174 -- Build_Actual_Array_Constraint --
1175 -----------------------------------
1177 function Build_Actual_Array_Constraint return List_Id is
1178 Constraints : constant List_Id := New_List;
1186 Indx := First_Index (Desig_Typ);
1187 while Present (Indx) loop
1188 Old_Lo := Type_Low_Bound (Etype (Indx));
1189 Old_Hi := Type_High_Bound (Etype (Indx));
1191 if Denotes_Discriminant (Old_Lo) then
1193 Make_Selected_Component (Loc,
1194 Prefix => New_Copy_Tree (P),
1195 Selector_Name => New_Occurrence_Of (Entity (Old_Lo), Loc));
1198 Lo := New_Copy_Tree (Old_Lo);
1200 -- The new bound will be reanalyzed in the enclosing
1201 -- declaration. For literal bounds that come from a type
1202 -- declaration, the type of the context must be imposed, so
1203 -- insure that analysis will take place. For non-universal
1204 -- types this is not strictly necessary.
1206 Set_Analyzed (Lo, False);
1209 if Denotes_Discriminant (Old_Hi) then
1211 Make_Selected_Component (Loc,
1212 Prefix => New_Copy_Tree (P),
1213 Selector_Name => New_Occurrence_Of (Entity (Old_Hi), Loc));
1216 Hi := New_Copy_Tree (Old_Hi);
1217 Set_Analyzed (Hi, False);
1220 Append (Make_Range (Loc, Lo, Hi), Constraints);
1225 end Build_Actual_Array_Constraint;
1227 ------------------------------------
1228 -- Build_Actual_Record_Constraint --
1229 ------------------------------------
1231 function Build_Actual_Record_Constraint return List_Id is
1232 Constraints : constant List_Id := New_List;
1237 D := First_Elmt (Discriminant_Constraint (Desig_Typ));
1238 while Present (D) loop
1239 if Denotes_Discriminant (Node (D)) then
1240 D_Val := Make_Selected_Component (Loc,
1241 Prefix => New_Copy_Tree (P),
1242 Selector_Name => New_Occurrence_Of (Entity (Node (D)), Loc));
1245 D_Val := New_Copy_Tree (Node (D));
1248 Append (D_Val, Constraints);
1253 end Build_Actual_Record_Constraint;
1255 -- Start of processing for Build_Actual_Subtype_Of_Component
1258 -- Why the test for Spec_Expression mode here???
1260 if In_Spec_Expression then
1263 -- More comments for the rest of this body would be good ???
1265 elsif Nkind (N) = N_Explicit_Dereference then
1266 if Is_Composite_Type (T)
1267 and then not Is_Constrained (T)
1268 and then not (Is_Class_Wide_Type (T)
1269 and then Is_Constrained (Root_Type (T)))
1270 and then not Has_Unknown_Discriminants (T)
1272 -- If the type of the dereference is already constrained, it is an
1275 if Is_Array_Type (Etype (N))
1276 and then Is_Constrained (Etype (N))
1280 Remove_Side_Effects (P);
1281 return Build_Actual_Subtype (T, N);
1288 if Ekind (T) = E_Access_Subtype then
1289 Desig_Typ := Designated_Type (T);
1294 if Ekind (Desig_Typ) = E_Array_Subtype then
1295 Id := First_Index (Desig_Typ);
1296 while Present (Id) loop
1297 Index_Typ := Underlying_Type (Etype (Id));
1299 if Denotes_Discriminant (Type_Low_Bound (Index_Typ))
1301 Denotes_Discriminant (Type_High_Bound (Index_Typ))
1303 Remove_Side_Effects (P);
1305 Build_Component_Subtype
1306 (Build_Actual_Array_Constraint, Loc, Base_Type (T));
1312 elsif Is_Composite_Type (Desig_Typ)
1313 and then Has_Discriminants (Desig_Typ)
1314 and then not Has_Unknown_Discriminants (Desig_Typ)
1316 if Is_Private_Type (Desig_Typ)
1317 and then No (Discriminant_Constraint (Desig_Typ))
1319 Desig_Typ := Full_View (Desig_Typ);
1322 D := First_Elmt (Discriminant_Constraint (Desig_Typ));
1323 while Present (D) loop
1324 if Denotes_Discriminant (Node (D)) then
1325 Remove_Side_Effects (P);
1327 Build_Component_Subtype (
1328 Build_Actual_Record_Constraint, Loc, Base_Type (T));
1335 -- If none of the above, the actual and nominal subtypes are the same
1338 end Build_Actual_Subtype_Of_Component;
1340 ---------------------------------
1341 -- Build_Class_Wide_Clone_Body --
1342 ---------------------------------
1344 procedure Build_Class_Wide_Clone_Body
1345 (Spec_Id : Entity_Id;
1348 Loc : constant Source_Ptr := Sloc (Bod);
1349 Clone_Id : constant Entity_Id := Class_Wide_Clone (Spec_Id);
1350 Clone_Body : Node_Id;
1353 -- The declaration of the class-wide clone was created when the
1354 -- corresponding class-wide condition was analyzed.
1357 Make_Subprogram_Body (Loc,
1359 Copy_Subprogram_Spec (Parent (Clone_Id)),
1360 Declarations => Declarations (Bod),
1361 Handled_Statement_Sequence => Handled_Statement_Sequence (Bod));
1363 -- The new operation is internal and overriding indicators do not apply
1364 -- (the original primitive may have carried one).
1366 Set_Must_Override (Specification (Clone_Body), False);
1368 -- If the subprogram body is the proper body of a stub, insert the
1369 -- subprogram after the stub, i.e. the same declarative region as
1370 -- the original sugprogram.
1372 if Nkind (Parent (Bod)) = N_Subunit then
1373 Insert_After (Corresponding_Stub (Parent (Bod)), Clone_Body);
1376 Insert_Before (Bod, Clone_Body);
1379 Analyze (Clone_Body);
1380 end Build_Class_Wide_Clone_Body;
1382 ---------------------------------
1383 -- Build_Class_Wide_Clone_Call --
1384 ---------------------------------
1386 function Build_Class_Wide_Clone_Call
1389 Spec_Id : Entity_Id;
1390 Spec : Node_Id) return Node_Id
1392 Clone_Id : constant Entity_Id := Class_Wide_Clone (Spec_Id);
1393 Par_Type : constant Entity_Id := Find_Dispatching_Type (Spec_Id);
1399 New_F_Spec : Entity_Id;
1400 New_Formal : Entity_Id;
1403 Actuals := Empty_List;
1404 Formal := First_Formal (Spec_Id);
1405 New_F_Spec := First (Parameter_Specifications (Spec));
1407 -- Build parameter association for call to class-wide clone.
1409 while Present (Formal) loop
1410 New_Formal := Defining_Identifier (New_F_Spec);
1412 -- If controlling argument and operation is inherited, add conversion
1413 -- to parent type for the call.
1415 if Etype (Formal) = Par_Type
1416 and then not Is_Empty_List (Decls)
1419 Make_Type_Conversion (Loc,
1420 New_Occurrence_Of (Par_Type, Loc),
1421 New_Occurrence_Of (New_Formal, Loc)));
1424 Append_To (Actuals, New_Occurrence_Of (New_Formal, Loc));
1427 Next_Formal (Formal);
1431 if Ekind (Spec_Id) = E_Procedure then
1433 Make_Procedure_Call_Statement (Loc,
1434 Name => New_Occurrence_Of (Clone_Id, Loc),
1435 Parameter_Associations => Actuals);
1438 Make_Simple_Return_Statement (Loc,
1440 Make_Function_Call (Loc,
1441 Name => New_Occurrence_Of (Clone_Id, Loc),
1442 Parameter_Associations => Actuals));
1446 Make_Subprogram_Body (Loc,
1448 Copy_Subprogram_Spec (Spec),
1449 Declarations => Decls,
1450 Handled_Statement_Sequence =>
1451 Make_Handled_Sequence_Of_Statements (Loc,
1452 Statements => New_List (Call),
1453 End_Label => Make_Identifier (Loc, Chars (Spec_Id))));
1456 end Build_Class_Wide_Clone_Call;
1458 ---------------------------------
1459 -- Build_Class_Wide_Clone_Decl --
1460 ---------------------------------
1462 procedure Build_Class_Wide_Clone_Decl (Spec_Id : Entity_Id) is
1463 Loc : constant Source_Ptr := Sloc (Spec_Id);
1464 Clone_Id : constant Entity_Id :=
1465 Make_Defining_Identifier (Loc,
1466 New_External_Name (Chars (Spec_Id), Suffix => "CL"));
1472 Spec := Copy_Subprogram_Spec (Parent (Spec_Id));
1473 Set_Must_Override (Spec, False);
1474 Set_Must_Not_Override (Spec, False);
1475 Set_Defining_Unit_Name (Spec, Clone_Id);
1477 Decl := Make_Subprogram_Declaration (Loc, Spec);
1478 Append (Decl, List_Containing (Unit_Declaration_Node (Spec_Id)));
1480 -- Link clone to original subprogram, for use when building body and
1481 -- wrapper call to inherited operation.
1483 Set_Class_Wide_Clone (Spec_Id, Clone_Id);
1484 end Build_Class_Wide_Clone_Decl;
1486 -----------------------------
1487 -- Build_Component_Subtype --
1488 -----------------------------
1490 function Build_Component_Subtype
1493 T : Entity_Id) return Node_Id
1499 -- Unchecked_Union components do not require component subtypes
1501 if Is_Unchecked_Union (T) then
1505 Subt := Make_Temporary (Loc, 'S');
1506 Set_Is_Internal (Subt);
1509 Make_Subtype_Declaration (Loc,
1510 Defining_Identifier => Subt,
1511 Subtype_Indication =>
1512 Make_Subtype_Indication (Loc,
1513 Subtype_Mark => New_Occurrence_Of (Base_Type (T), Loc),
1515 Make_Index_Or_Discriminant_Constraint (Loc,
1516 Constraints => C)));
1518 Mark_Rewrite_Insertion (Decl);
1520 end Build_Component_Subtype;
1522 ---------------------------
1523 -- Build_Default_Subtype --
1524 ---------------------------
1526 function Build_Default_Subtype
1528 N : Node_Id) return Entity_Id
1530 Loc : constant Source_Ptr := Sloc (N);
1534 -- The base type that is to be constrained by the defaults
1537 if not Has_Discriminants (T) or else Is_Constrained (T) then
1541 Bas := Base_Type (T);
1543 -- If T is non-private but its base type is private, this is the
1544 -- completion of a subtype declaration whose parent type is private
1545 -- (see Complete_Private_Subtype in Sem_Ch3). The proper discriminants
1546 -- are to be found in the full view of the base. Check that the private
1547 -- status of T and its base differ.
1549 if Is_Private_Type (Bas)
1550 and then not Is_Private_Type (T)
1551 and then Present (Full_View (Bas))
1553 Bas := Full_View (Bas);
1556 Disc := First_Discriminant (T);
1558 if No (Discriminant_Default_Value (Disc)) then
1563 Act : constant Entity_Id := Make_Temporary (Loc, 'S');
1564 Constraints : constant List_Id := New_List;
1568 while Present (Disc) loop
1569 Append_To (Constraints,
1570 New_Copy_Tree (Discriminant_Default_Value (Disc)));
1571 Next_Discriminant (Disc);
1575 Make_Subtype_Declaration (Loc,
1576 Defining_Identifier => Act,
1577 Subtype_Indication =>
1578 Make_Subtype_Indication (Loc,
1579 Subtype_Mark => New_Occurrence_Of (Bas, Loc),
1581 Make_Index_Or_Discriminant_Constraint (Loc,
1582 Constraints => Constraints)));
1584 Insert_Action (N, Decl);
1586 -- If the context is a component declaration the subtype declaration
1587 -- will be analyzed when the enclosing type is frozen, otherwise do
1590 if Ekind (Current_Scope) /= E_Record_Type then
1596 end Build_Default_Subtype;
1598 --------------------------------------------
1599 -- Build_Discriminal_Subtype_Of_Component --
1600 --------------------------------------------
1602 function Build_Discriminal_Subtype_Of_Component
1603 (T : Entity_Id) return Node_Id
1605 Loc : constant Source_Ptr := Sloc (T);
1609 function Build_Discriminal_Array_Constraint return List_Id;
1610 -- If one or more of the bounds of the component depends on
1611 -- discriminants, build actual constraint using the discriminants
1614 function Build_Discriminal_Record_Constraint return List_Id;
1615 -- Similar to previous one, for discriminated components constrained by
1616 -- the discriminant of the enclosing object.
1618 ----------------------------------------
1619 -- Build_Discriminal_Array_Constraint --
1620 ----------------------------------------
1622 function Build_Discriminal_Array_Constraint return List_Id is
1623 Constraints : constant List_Id := New_List;
1631 Indx := First_Index (T);
1632 while Present (Indx) loop
1633 Old_Lo := Type_Low_Bound (Etype (Indx));
1634 Old_Hi := Type_High_Bound (Etype (Indx));
1636 if Denotes_Discriminant (Old_Lo) then
1637 Lo := New_Occurrence_Of (Discriminal (Entity (Old_Lo)), Loc);
1640 Lo := New_Copy_Tree (Old_Lo);
1643 if Denotes_Discriminant (Old_Hi) then
1644 Hi := New_Occurrence_Of (Discriminal (Entity (Old_Hi)), Loc);
1647 Hi := New_Copy_Tree (Old_Hi);
1650 Append (Make_Range (Loc, Lo, Hi), Constraints);
1655 end Build_Discriminal_Array_Constraint;
1657 -----------------------------------------
1658 -- Build_Discriminal_Record_Constraint --
1659 -----------------------------------------
1661 function Build_Discriminal_Record_Constraint return List_Id is
1662 Constraints : constant List_Id := New_List;
1667 D := First_Elmt (Discriminant_Constraint (T));
1668 while Present (D) loop
1669 if Denotes_Discriminant (Node (D)) then
1671 New_Occurrence_Of (Discriminal (Entity (Node (D))), Loc);
1673 D_Val := New_Copy_Tree (Node (D));
1676 Append (D_Val, Constraints);
1681 end Build_Discriminal_Record_Constraint;
1683 -- Start of processing for Build_Discriminal_Subtype_Of_Component
1686 if Ekind (T) = E_Array_Subtype then
1687 Id := First_Index (T);
1688 while Present (Id) loop
1689 if Denotes_Discriminant (Type_Low_Bound (Etype (Id)))
1691 Denotes_Discriminant (Type_High_Bound (Etype (Id)))
1693 return Build_Component_Subtype
1694 (Build_Discriminal_Array_Constraint, Loc, T);
1700 elsif Ekind (T) = E_Record_Subtype
1701 and then Has_Discriminants (T)
1702 and then not Has_Unknown_Discriminants (T)
1704 D := First_Elmt (Discriminant_Constraint (T));
1705 while Present (D) loop
1706 if Denotes_Discriminant (Node (D)) then
1707 return Build_Component_Subtype
1708 (Build_Discriminal_Record_Constraint, Loc, T);
1715 -- If none of the above, the actual and nominal subtypes are the same
1718 end Build_Discriminal_Subtype_Of_Component;
1720 ------------------------------
1721 -- Build_Elaboration_Entity --
1722 ------------------------------
1724 procedure Build_Elaboration_Entity (N : Node_Id; Spec_Id : Entity_Id) is
1725 Loc : constant Source_Ptr := Sloc (N);
1727 Elab_Ent : Entity_Id;
1729 procedure Set_Package_Name (Ent : Entity_Id);
1730 -- Given an entity, sets the fully qualified name of the entity in
1731 -- Name_Buffer, with components separated by double underscores. This
1732 -- is a recursive routine that climbs the scope chain to Standard.
1734 ----------------------
1735 -- Set_Package_Name --
1736 ----------------------
1738 procedure Set_Package_Name (Ent : Entity_Id) is
1740 if Scope (Ent) /= Standard_Standard then
1741 Set_Package_Name (Scope (Ent));
1744 Nam : constant String := Get_Name_String (Chars (Ent));
1746 Name_Buffer (Name_Len + 1) := '_';
1747 Name_Buffer (Name_Len + 2) := '_';
1748 Name_Buffer (Name_Len + 3 .. Name_Len + Nam'Length + 2) := Nam;
1749 Name_Len := Name_Len + Nam'Length + 2;
1753 Get_Name_String (Chars (Ent));
1755 end Set_Package_Name;
1757 -- Start of processing for Build_Elaboration_Entity
1760 -- Ignore call if already constructed
1762 if Present (Elaboration_Entity (Spec_Id)) then
1765 -- Ignore in ASIS mode, elaboration entity is not in source and plays
1766 -- no role in analysis.
1768 elsif ASIS_Mode then
1771 -- Do not generate an elaboration entity in GNATprove move because the
1772 -- elaboration counter is a form of expansion.
1774 elsif GNATprove_Mode then
1777 -- See if we need elaboration entity
1779 -- We always need an elaboration entity when preserving control flow, as
1780 -- we want to remain explicit about the unit's elaboration order.
1782 elsif Opt.Suppress_Control_Flow_Optimizations then
1785 -- We always need an elaboration entity for the dynamic elaboration
1786 -- model, since it is needed to properly generate the PE exception for
1787 -- access before elaboration.
1789 elsif Dynamic_Elaboration_Checks then
1792 -- For the static model, we don't need the elaboration counter if this
1793 -- unit is sure to have no elaboration code, since that means there
1794 -- is no elaboration unit to be called. Note that we can't just decide
1795 -- after the fact by looking to see whether there was elaboration code,
1796 -- because that's too late to make this decision.
1798 elsif Restriction_Active (No_Elaboration_Code) then
1801 -- Similarly, for the static model, we can skip the elaboration counter
1802 -- if we have the No_Multiple_Elaboration restriction, since for the
1803 -- static model, that's the only purpose of the counter (to avoid
1804 -- multiple elaboration).
1806 elsif Restriction_Active (No_Multiple_Elaboration) then
1810 -- Here we need the elaboration entity
1812 -- Construct name of elaboration entity as xxx_E, where xxx is the unit
1813 -- name with dots replaced by double underscore. We have to manually
1814 -- construct this name, since it will be elaborated in the outer scope,
1815 -- and thus will not have the unit name automatically prepended.
1817 Set_Package_Name (Spec_Id);
1818 Add_Str_To_Name_Buffer ("_E");
1820 -- Create elaboration counter
1822 Elab_Ent := Make_Defining_Identifier (Loc, Chars => Name_Find);
1823 Set_Elaboration_Entity (Spec_Id, Elab_Ent);
1826 Make_Object_Declaration (Loc,
1827 Defining_Identifier => Elab_Ent,
1828 Object_Definition =>
1829 New_Occurrence_Of (Standard_Short_Integer, Loc),
1830 Expression => Make_Integer_Literal (Loc, Uint_0));
1832 Push_Scope (Standard_Standard);
1833 Add_Global_Declaration (Decl);
1836 -- Reset True_Constant indication, since we will indeed assign a value
1837 -- to the variable in the binder main. We also kill the Current_Value
1838 -- and Last_Assignment fields for the same reason.
1840 Set_Is_True_Constant (Elab_Ent, False);
1841 Set_Current_Value (Elab_Ent, Empty);
1842 Set_Last_Assignment (Elab_Ent, Empty);
1844 -- We do not want any further qualification of the name (if we did not
1845 -- do this, we would pick up the name of the generic package in the case
1846 -- of a library level generic instantiation).
1848 Set_Has_Qualified_Name (Elab_Ent);
1849 Set_Has_Fully_Qualified_Name (Elab_Ent);
1850 end Build_Elaboration_Entity;
1852 --------------------------------
1853 -- Build_Explicit_Dereference --
1854 --------------------------------
1856 procedure Build_Explicit_Dereference
1860 Loc : constant Source_Ptr := Sloc (Expr);
1865 -- An entity of a type with a reference aspect is overloaded with
1866 -- both interpretations: with and without the dereference. Now that
1867 -- the dereference is made explicit, set the type of the node properly,
1868 -- to prevent anomalies in the backend. Same if the expression is an
1869 -- overloaded function call whose return type has a reference aspect.
1871 if Is_Entity_Name (Expr) then
1872 Set_Etype (Expr, Etype (Entity (Expr)));
1874 -- The designated entity will not be examined again when resolving
1875 -- the dereference, so generate a reference to it now.
1877 Generate_Reference (Entity (Expr), Expr);
1879 elsif Nkind (Expr) = N_Function_Call then
1881 -- If the name of the indexing function is overloaded, locate the one
1882 -- whose return type has an implicit dereference on the desired
1883 -- discriminant, and set entity and type of function call.
1885 if Is_Overloaded (Name (Expr)) then
1886 Get_First_Interp (Name (Expr), I, It);
1888 while Present (It.Nam) loop
1889 if Ekind ((It.Typ)) = E_Record_Type
1890 and then First_Entity ((It.Typ)) = Disc
1892 Set_Entity (Name (Expr), It.Nam);
1893 Set_Etype (Name (Expr), Etype (It.Nam));
1897 Get_Next_Interp (I, It);
1901 -- Set type of call from resolved function name.
1903 Set_Etype (Expr, Etype (Name (Expr)));
1906 Set_Is_Overloaded (Expr, False);
1908 -- The expression will often be a generalized indexing that yields a
1909 -- container element that is then dereferenced, in which case the
1910 -- generalized indexing call is also non-overloaded.
1912 if Nkind (Expr) = N_Indexed_Component
1913 and then Present (Generalized_Indexing (Expr))
1915 Set_Is_Overloaded (Generalized_Indexing (Expr), False);
1919 Make_Explicit_Dereference (Loc,
1921 Make_Selected_Component (Loc,
1922 Prefix => Relocate_Node (Expr),
1923 Selector_Name => New_Occurrence_Of (Disc, Loc))));
1924 Set_Etype (Prefix (Expr), Etype (Disc));
1925 Set_Etype (Expr, Designated_Type (Etype (Disc)));
1926 end Build_Explicit_Dereference;
1928 ---------------------------
1929 -- Build_Overriding_Spec --
1930 ---------------------------
1932 function Build_Overriding_Spec
1934 Typ : Entity_Id) return Node_Id
1936 Loc : constant Source_Ptr := Sloc (Typ);
1937 Par_Typ : constant Entity_Id := Find_Dispatching_Type (Op);
1938 Spec : constant Node_Id := Specification (Unit_Declaration_Node (Op));
1940 Formal_Spec : Node_Id;
1941 Formal_Type : Node_Id;
1945 New_Spec := Copy_Subprogram_Spec (Spec);
1947 Formal_Spec := First (Parameter_Specifications (New_Spec));
1948 while Present (Formal_Spec) loop
1949 Formal_Type := Parameter_Type (Formal_Spec);
1951 if Is_Entity_Name (Formal_Type)
1952 and then Entity (Formal_Type) = Par_Typ
1954 Rewrite (Formal_Type, New_Occurrence_Of (Typ, Loc));
1957 -- Nothing needs to be done for access parameters
1963 end Build_Overriding_Spec;
1965 -----------------------------------
1966 -- Cannot_Raise_Constraint_Error --
1967 -----------------------------------
1969 function Cannot_Raise_Constraint_Error (Expr : Node_Id) return Boolean is
1971 if Compile_Time_Known_Value (Expr) then
1974 elsif Do_Range_Check (Expr) then
1977 elsif Raises_Constraint_Error (Expr) then
1981 case Nkind (Expr) is
1982 when N_Identifier =>
1985 when N_Expanded_Name =>
1988 when N_Selected_Component =>
1989 return not Do_Discriminant_Check (Expr);
1991 when N_Attribute_Reference =>
1992 if Do_Overflow_Check (Expr) then
1995 elsif No (Expressions (Expr)) then
2003 N := First (Expressions (Expr));
2004 while Present (N) loop
2005 if Cannot_Raise_Constraint_Error (N) then
2016 when N_Type_Conversion =>
2017 if Do_Overflow_Check (Expr)
2018 or else Do_Length_Check (Expr)
2019 or else Do_Tag_Check (Expr)
2023 return Cannot_Raise_Constraint_Error (Expression (Expr));
2026 when N_Unchecked_Type_Conversion =>
2027 return Cannot_Raise_Constraint_Error (Expression (Expr));
2030 if Do_Overflow_Check (Expr) then
2033 return Cannot_Raise_Constraint_Error (Right_Opnd (Expr));
2040 if Do_Division_Check (Expr)
2042 Do_Overflow_Check (Expr)
2047 Cannot_Raise_Constraint_Error (Left_Opnd (Expr))
2049 Cannot_Raise_Constraint_Error (Right_Opnd (Expr));
2068 | N_Op_Shift_Right_Arithmetic
2072 if Do_Overflow_Check (Expr) then
2076 Cannot_Raise_Constraint_Error (Left_Opnd (Expr))
2078 Cannot_Raise_Constraint_Error (Right_Opnd (Expr));
2085 end Cannot_Raise_Constraint_Error;
2087 -----------------------------------------
2088 -- Check_Dynamically_Tagged_Expression --
2089 -----------------------------------------
2091 procedure Check_Dynamically_Tagged_Expression
2094 Related_Nod : Node_Id)
2097 pragma Assert (Is_Tagged_Type (Typ));
2099 -- In order to avoid spurious errors when analyzing the expanded code,
2100 -- this check is done only for nodes that come from source and for
2101 -- actuals of generic instantiations.
2103 if (Comes_From_Source (Related_Nod)
2104 or else In_Generic_Actual (Expr))
2105 and then (Is_Class_Wide_Type (Etype (Expr))
2106 or else Is_Dynamically_Tagged (Expr))
2107 and then not Is_Class_Wide_Type (Typ)
2109 Error_Msg_N ("dynamically tagged expression not allowed!", Expr);
2111 end Check_Dynamically_Tagged_Expression;
2113 --------------------------
2114 -- Check_Fully_Declared --
2115 --------------------------
2117 procedure Check_Fully_Declared (T : Entity_Id; N : Node_Id) is
2119 if Ekind (T) = E_Incomplete_Type then
2121 -- Ada 2005 (AI-50217): If the type is available through a limited
2122 -- with_clause, verify that its full view has been analyzed.
2124 if From_Limited_With (T)
2125 and then Present (Non_Limited_View (T))
2126 and then Ekind (Non_Limited_View (T)) /= E_Incomplete_Type
2128 -- The non-limited view is fully declared
2134 ("premature usage of incomplete}", N, First_Subtype (T));
2137 -- Need comments for these tests ???
2139 elsif Has_Private_Component (T)
2140 and then not Is_Generic_Type (Root_Type (T))
2141 and then not In_Spec_Expression
2143 -- Special case: if T is the anonymous type created for a single
2144 -- task or protected object, use the name of the source object.
2146 if Is_Concurrent_Type (T)
2147 and then not Comes_From_Source (T)
2148 and then Nkind (N) = N_Object_Declaration
2151 ("type of& has incomplete component",
2152 N, Defining_Identifier (N));
2155 ("premature usage of incomplete}",
2156 N, First_Subtype (T));
2159 end Check_Fully_Declared;
2161 -------------------------------------------
2162 -- Check_Function_With_Address_Parameter --
2163 -------------------------------------------
2165 procedure Check_Function_With_Address_Parameter (Subp_Id : Entity_Id) is
2170 F := First_Formal (Subp_Id);
2171 while Present (F) loop
2174 if Is_Private_Type (T) and then Present (Full_View (T)) then
2178 if Is_Descendant_Of_Address (T) or else Is_Limited_Type (T) then
2179 Set_Is_Pure (Subp_Id, False);
2185 end Check_Function_With_Address_Parameter;
2187 -------------------------------------
2188 -- Check_Function_Writable_Actuals --
2189 -------------------------------------
2191 procedure Check_Function_Writable_Actuals (N : Node_Id) is
2192 Writable_Actuals_List : Elist_Id := No_Elist;
2193 Identifiers_List : Elist_Id := No_Elist;
2194 Aggr_Error_Node : Node_Id := Empty;
2195 Error_Node : Node_Id := Empty;
2197 procedure Collect_Identifiers (N : Node_Id);
2198 -- In a single traversal of subtree N collect in Writable_Actuals_List
2199 -- all the actuals of functions with writable actuals, and in the list
2200 -- Identifiers_List collect all the identifiers that are not actuals of
2201 -- functions with writable actuals. If a writable actual is referenced
2202 -- twice as writable actual then Error_Node is set to reference its
2203 -- second occurrence, the error is reported, and the tree traversal
2206 procedure Preanalyze_Without_Errors (N : Node_Id);
2207 -- Preanalyze N without reporting errors. Very dubious, you can't just
2208 -- go analyzing things more than once???
2210 -------------------------
2211 -- Collect_Identifiers --
2212 -------------------------
2214 procedure Collect_Identifiers (N : Node_Id) is
2216 function Check_Node (N : Node_Id) return Traverse_Result;
2217 -- Process a single node during the tree traversal to collect the
2218 -- writable actuals of functions and all the identifiers which are
2219 -- not writable actuals of functions.
2221 function Contains (List : Elist_Id; N : Node_Id) return Boolean;
2222 -- Returns True if List has a node whose Entity is Entity (N)
2228 function Check_Node (N : Node_Id) return Traverse_Result is
2229 Is_Writable_Actual : Boolean := False;
2233 if Nkind (N) = N_Identifier then
2235 -- No analysis possible if the entity is not decorated
2237 if No (Entity (N)) then
2240 -- Don't collect identifiers of packages, called functions, etc
2242 elsif Ekind_In (Entity (N), E_Package,
2249 -- For rewritten nodes, continue the traversal in the original
2250 -- subtree. Needed to handle aggregates in original expressions
2251 -- extracted from the tree by Remove_Side_Effects.
2253 elsif Is_Rewrite_Substitution (N) then
2254 Collect_Identifiers (Original_Node (N));
2257 -- For now we skip aggregate discriminants, since they require
2258 -- performing the analysis in two phases to identify conflicts:
2259 -- first one analyzing discriminants and second one analyzing
2260 -- the rest of components (since at run time, discriminants are
2261 -- evaluated prior to components): too much computation cost
2262 -- to identify a corner case???
2264 elsif Nkind (Parent (N)) = N_Component_Association
2265 and then Nkind_In (Parent (Parent (N)),
2267 N_Extension_Aggregate)
2270 Choice : constant Node_Id := First (Choices (Parent (N)));
2273 if Ekind (Entity (N)) = E_Discriminant then
2276 elsif Expression (Parent (N)) = N
2277 and then Nkind (Choice) = N_Identifier
2278 and then Ekind (Entity (Choice)) = E_Discriminant
2284 -- Analyze if N is a writable actual of a function
2286 elsif Nkind (Parent (N)) = N_Function_Call then
2288 Call : constant Node_Id := Parent (N);
2293 Id := Get_Called_Entity (Call);
2295 -- In case of previous error, no check is possible
2301 if Ekind_In (Id, E_Function, E_Generic_Function)
2302 and then Has_Out_Or_In_Out_Parameter (Id)
2304 Formal := First_Formal (Id);
2305 Actual := First_Actual (Call);
2306 while Present (Actual) and then Present (Formal) loop
2308 if Ekind_In (Formal, E_Out_Parameter,
2311 Is_Writable_Actual := True;
2317 Next_Formal (Formal);
2318 Next_Actual (Actual);
2324 if Is_Writable_Actual then
2326 -- Skip checking the error in non-elementary types since
2327 -- RM 6.4.1(6.15/3) is restricted to elementary types, but
2328 -- store this actual in Writable_Actuals_List since it is
2329 -- needed to perform checks on other constructs that have
2330 -- arbitrary order of evaluation (for example, aggregates).
2332 if not Is_Elementary_Type (Etype (N)) then
2333 if not Contains (Writable_Actuals_List, N) then
2334 Append_New_Elmt (N, To => Writable_Actuals_List);
2337 -- Second occurrence of an elementary type writable actual
2339 elsif Contains (Writable_Actuals_List, N) then
2341 -- Report the error on the second occurrence of the
2342 -- identifier. We cannot assume that N is the second
2343 -- occurrence (according to their location in the
2344 -- sources), since Traverse_Func walks through Field2
2345 -- last (see comment in the body of Traverse_Func).
2351 Elmt := First_Elmt (Writable_Actuals_List);
2352 while Present (Elmt)
2353 and then Entity (Node (Elmt)) /= Entity (N)
2358 if Sloc (N) > Sloc (Node (Elmt)) then
2361 Error_Node := Node (Elmt);
2365 ("value may be affected by call to & "
2366 & "because order of evaluation is arbitrary",
2371 -- First occurrence of a elementary type writable actual
2374 Append_New_Elmt (N, To => Writable_Actuals_List);
2378 if Identifiers_List = No_Elist then
2379 Identifiers_List := New_Elmt_List;
2382 Append_Unique_Elmt (N, Identifiers_List);
2395 N : Node_Id) return Boolean
2397 pragma Assert (Nkind (N) in N_Has_Entity);
2402 if List = No_Elist then
2406 Elmt := First_Elmt (List);
2407 while Present (Elmt) loop
2408 if Entity (Node (Elmt)) = Entity (N) then
2422 procedure Do_Traversal is new Traverse_Proc (Check_Node);
2423 -- The traversal procedure
2425 -- Start of processing for Collect_Identifiers
2428 if Present (Error_Node) then
2432 if Nkind (N) in N_Subexpr and then Is_OK_Static_Expression (N) then
2437 end Collect_Identifiers;
2439 -------------------------------
2440 -- Preanalyze_Without_Errors --
2441 -------------------------------
2443 procedure Preanalyze_Without_Errors (N : Node_Id) is
2444 Status : constant Boolean := Get_Ignore_Errors;
2446 Set_Ignore_Errors (True);
2448 Set_Ignore_Errors (Status);
2449 end Preanalyze_Without_Errors;
2451 -- Start of processing for Check_Function_Writable_Actuals
2454 -- The check only applies to Ada 2012 code on which Check_Actuals has
2455 -- been set, and only to constructs that have multiple constituents
2456 -- whose order of evaluation is not specified by the language.
2458 if Ada_Version < Ada_2012
2459 or else not Check_Actuals (N)
2460 or else (not (Nkind (N) in N_Op)
2461 and then not (Nkind (N) in N_Membership_Test)
2462 and then not Nkind_In (N, N_Range,
2464 N_Extension_Aggregate,
2465 N_Full_Type_Declaration,
2467 N_Procedure_Call_Statement,
2468 N_Entry_Call_Statement))
2469 or else (Nkind (N) = N_Full_Type_Declaration
2470 and then not Is_Record_Type (Defining_Identifier (N)))
2472 -- In addition, this check only applies to source code, not to code
2473 -- generated by constraint checks.
2475 or else not Comes_From_Source (N)
2480 -- If a construct C has two or more direct constituents that are names
2481 -- or expressions whose evaluation may occur in an arbitrary order, at
2482 -- least one of which contains a function call with an in out or out
2483 -- parameter, then the construct is legal only if: for each name N that
2484 -- is passed as a parameter of mode in out or out to some inner function
2485 -- call C2 (not including the construct C itself), there is no other
2486 -- name anywhere within a direct constituent of the construct C other
2487 -- than the one containing C2, that is known to refer to the same
2488 -- object (RM 6.4.1(6.17/3)).
2492 Collect_Identifiers (Low_Bound (N));
2493 Collect_Identifiers (High_Bound (N));
2495 when N_Membership_Test
2502 Collect_Identifiers (Left_Opnd (N));
2504 if Present (Right_Opnd (N)) then
2505 Collect_Identifiers (Right_Opnd (N));
2508 if Nkind_In (N, N_In, N_Not_In)
2509 and then Present (Alternatives (N))
2511 Expr := First (Alternatives (N));
2512 while Present (Expr) loop
2513 Collect_Identifiers (Expr);
2520 when N_Full_Type_Declaration =>
2522 function Get_Record_Part (N : Node_Id) return Node_Id;
2523 -- Return the record part of this record type definition
2525 function Get_Record_Part (N : Node_Id) return Node_Id is
2526 Type_Def : constant Node_Id := Type_Definition (N);
2528 if Nkind (Type_Def) = N_Derived_Type_Definition then
2529 return Record_Extension_Part (Type_Def);
2533 end Get_Record_Part;
2536 Def_Id : Entity_Id := Defining_Identifier (N);
2537 Rec : Node_Id := Get_Record_Part (N);
2540 -- No need to perform any analysis if the record has no
2543 if No (Rec) or else No (Component_List (Rec)) then
2547 -- Collect the identifiers starting from the deepest
2548 -- derivation. Done to report the error in the deepest
2552 if Present (Component_List (Rec)) then
2553 Comp := First (Component_Items (Component_List (Rec)));
2554 while Present (Comp) loop
2555 if Nkind (Comp) = N_Component_Declaration
2556 and then Present (Expression (Comp))
2558 Collect_Identifiers (Expression (Comp));
2565 exit when No (Underlying_Type (Etype (Def_Id)))
2566 or else Base_Type (Underlying_Type (Etype (Def_Id)))
2569 Def_Id := Base_Type (Underlying_Type (Etype (Def_Id)));
2570 Rec := Get_Record_Part (Parent (Def_Id));
2574 when N_Entry_Call_Statement
2578 Id : constant Entity_Id := Get_Called_Entity (N);
2583 Formal := First_Formal (Id);
2584 Actual := First_Actual (N);
2585 while Present (Actual) and then Present (Formal) loop
2586 if Ekind_In (Formal, E_Out_Parameter,
2589 Collect_Identifiers (Actual);
2592 Next_Formal (Formal);
2593 Next_Actual (Actual);
2598 | N_Extension_Aggregate
2603 Comp_Expr : Node_Id;
2606 -- Handle the N_Others_Choice of array aggregates with static
2607 -- bounds. There is no need to perform this analysis in
2608 -- aggregates without static bounds since we cannot evaluate
2609 -- if the N_Others_Choice covers several elements. There is
2610 -- no need to handle the N_Others choice of record aggregates
2611 -- since at this stage it has been already expanded by
2612 -- Resolve_Record_Aggregate.
2614 if Is_Array_Type (Etype (N))
2615 and then Nkind (N) = N_Aggregate
2616 and then Present (Aggregate_Bounds (N))
2617 and then Compile_Time_Known_Bounds (Etype (N))
2618 and then Expr_Value (High_Bound (Aggregate_Bounds (N)))
2620 Expr_Value (Low_Bound (Aggregate_Bounds (N)))
2623 Count_Components : Uint := Uint_0;
2624 Num_Components : Uint;
2625 Others_Assoc : Node_Id;
2626 Others_Choice : Node_Id := Empty;
2627 Others_Box_Present : Boolean := False;
2630 -- Count positional associations
2632 if Present (Expressions (N)) then
2633 Comp_Expr := First (Expressions (N));
2634 while Present (Comp_Expr) loop
2635 Count_Components := Count_Components + 1;
2640 -- Count the rest of elements and locate the N_Others
2643 Assoc := First (Component_Associations (N));
2644 while Present (Assoc) loop
2645 Choice := First (Choices (Assoc));
2646 while Present (Choice) loop
2647 if Nkind (Choice) = N_Others_Choice then
2648 Others_Assoc := Assoc;
2649 Others_Choice := Choice;
2650 Others_Box_Present := Box_Present (Assoc);
2652 -- Count several components
2654 elsif Nkind_In (Choice, N_Range,
2655 N_Subtype_Indication)
2656 or else (Is_Entity_Name (Choice)
2657 and then Is_Type (Entity (Choice)))
2662 Get_Index_Bounds (Choice, L, H);
2664 (Compile_Time_Known_Value (L)
2665 and then Compile_Time_Known_Value (H));
2668 + Expr_Value (H) - Expr_Value (L) + 1;
2671 -- Count single component. No other case available
2672 -- since we are handling an aggregate with static
2676 pragma Assert (Is_OK_Static_Expression (Choice)
2677 or else Nkind (Choice) = N_Identifier
2678 or else Nkind (Choice) = N_Integer_Literal);
2680 Count_Components := Count_Components + 1;
2690 Expr_Value (High_Bound (Aggregate_Bounds (N))) -
2691 Expr_Value (Low_Bound (Aggregate_Bounds (N))) + 1;
2693 pragma Assert (Count_Components <= Num_Components);
2695 -- Handle the N_Others choice if it covers several
2698 if Present (Others_Choice)
2699 and then (Num_Components - Count_Components) > 1
2701 if not Others_Box_Present then
2703 -- At this stage, if expansion is active, the
2704 -- expression of the others choice has not been
2705 -- analyzed. Hence we generate a duplicate and
2706 -- we analyze it silently to have available the
2707 -- minimum decoration required to collect the
2710 if not Expander_Active then
2711 Comp_Expr := Expression (Others_Assoc);
2714 New_Copy_Tree (Expression (Others_Assoc));
2715 Preanalyze_Without_Errors (Comp_Expr);
2718 Collect_Identifiers (Comp_Expr);
2720 if Writable_Actuals_List /= No_Elist then
2722 -- As suggested by Robert, at current stage we
2723 -- report occurrences of this case as warnings.
2726 ("writable function parameter may affect "
2727 & "value in other component because order "
2728 & "of evaluation is unspecified??",
2729 Node (First_Elmt (Writable_Actuals_List)));
2735 -- For an array aggregate, a discrete_choice_list that has
2736 -- a nonstatic range is considered as two or more separate
2737 -- occurrences of the expression (RM 6.4.1(20/3)).
2739 elsif Is_Array_Type (Etype (N))
2740 and then Nkind (N) = N_Aggregate
2741 and then Present (Aggregate_Bounds (N))
2742 and then not Compile_Time_Known_Bounds (Etype (N))
2744 -- Collect identifiers found in the dynamic bounds
2747 Count_Components : Natural := 0;
2748 Low, High : Node_Id;
2751 Assoc := First (Component_Associations (N));
2752 while Present (Assoc) loop
2753 Choice := First (Choices (Assoc));
2754 while Present (Choice) loop
2755 if Nkind_In (Choice, N_Range,
2756 N_Subtype_Indication)
2757 or else (Is_Entity_Name (Choice)
2758 and then Is_Type (Entity (Choice)))
2760 Get_Index_Bounds (Choice, Low, High);
2762 if not Compile_Time_Known_Value (Low) then
2763 Collect_Identifiers (Low);
2765 if No (Aggr_Error_Node) then
2766 Aggr_Error_Node := Low;
2770 if not Compile_Time_Known_Value (High) then
2771 Collect_Identifiers (High);
2773 if No (Aggr_Error_Node) then
2774 Aggr_Error_Node := High;
2778 -- The RM rule is violated if there is more than
2779 -- a single choice in a component association.
2782 Count_Components := Count_Components + 1;
2784 if No (Aggr_Error_Node)
2785 and then Count_Components > 1
2787 Aggr_Error_Node := Choice;
2790 if not Compile_Time_Known_Value (Choice) then
2791 Collect_Identifiers (Choice);
2803 -- Handle ancestor part of extension aggregates
2805 if Nkind (N) = N_Extension_Aggregate then
2806 Collect_Identifiers (Ancestor_Part (N));
2809 -- Handle positional associations
2811 if Present (Expressions (N)) then
2812 Comp_Expr := First (Expressions (N));
2813 while Present (Comp_Expr) loop
2814 if not Is_OK_Static_Expression (Comp_Expr) then
2815 Collect_Identifiers (Comp_Expr);
2822 -- Handle discrete associations
2824 if Present (Component_Associations (N)) then
2825 Assoc := First (Component_Associations (N));
2826 while Present (Assoc) loop
2828 if not Box_Present (Assoc) then
2829 Choice := First (Choices (Assoc));
2830 while Present (Choice) loop
2832 -- For now we skip discriminants since it requires
2833 -- performing the analysis in two phases: first one
2834 -- analyzing discriminants and second one analyzing
2835 -- the rest of components since discriminants are
2836 -- evaluated prior to components: too much extra
2837 -- work to detect a corner case???
2839 if Nkind (Choice) in N_Has_Entity
2840 and then Present (Entity (Choice))
2841 and then Ekind (Entity (Choice)) = E_Discriminant
2845 elsif Box_Present (Assoc) then
2849 if not Analyzed (Expression (Assoc)) then
2851 New_Copy_Tree (Expression (Assoc));
2852 Set_Parent (Comp_Expr, Parent (N));
2853 Preanalyze_Without_Errors (Comp_Expr);
2855 Comp_Expr := Expression (Assoc);
2858 Collect_Identifiers (Comp_Expr);
2874 -- No further action needed if we already reported an error
2876 if Present (Error_Node) then
2880 -- Check violation of RM 6.20/3 in aggregates
2882 if Present (Aggr_Error_Node)
2883 and then Writable_Actuals_List /= No_Elist
2886 ("value may be affected by call in other component because they "
2887 & "are evaluated in unspecified order",
2888 Node (First_Elmt (Writable_Actuals_List)));
2892 -- Check if some writable argument of a function is referenced
2894 if Writable_Actuals_List /= No_Elist
2895 and then Identifiers_List /= No_Elist
2902 Elmt_1 := First_Elmt (Writable_Actuals_List);
2903 while Present (Elmt_1) loop
2904 Elmt_2 := First_Elmt (Identifiers_List);
2905 while Present (Elmt_2) loop
2906 if Entity (Node (Elmt_1)) = Entity (Node (Elmt_2)) then
2907 case Nkind (Parent (Node (Elmt_2))) is
2909 | N_Component_Association
2910 | N_Component_Declaration
2913 ("value may be affected by call in other "
2914 & "component because they are evaluated "
2915 & "in unspecified order",
2922 ("value may be affected by call in other "
2923 & "alternative because they are evaluated "
2924 & "in unspecified order",
2929 ("value of actual may be affected by call in "
2930 & "other actual because they are evaluated "
2931 & "in unspecified order",
2943 end Check_Function_Writable_Actuals;
2945 --------------------------------
2946 -- Check_Implicit_Dereference --
2947 --------------------------------
2949 procedure Check_Implicit_Dereference (N : Node_Id; Typ : Entity_Id) is
2955 if Nkind (N) = N_Indexed_Component
2956 and then Present (Generalized_Indexing (N))
2958 Nam := Generalized_Indexing (N);
2963 if Ada_Version < Ada_2012
2964 or else not Has_Implicit_Dereference (Base_Type (Typ))
2968 elsif not Comes_From_Source (N)
2969 and then Nkind (N) /= N_Indexed_Component
2973 elsif Is_Entity_Name (Nam) and then Is_Type (Entity (Nam)) then
2977 Disc := First_Discriminant (Typ);
2978 while Present (Disc) loop
2979 if Has_Implicit_Dereference (Disc) then
2980 Desig := Designated_Type (Etype (Disc));
2981 Add_One_Interp (Nam, Disc, Desig);
2983 -- If the node is a generalized indexing, add interpretation
2984 -- to that node as well, for subsequent resolution.
2986 if Nkind (N) = N_Indexed_Component then
2987 Add_One_Interp (N, Disc, Desig);
2990 -- If the operation comes from a generic unit and the context
2991 -- is a selected component, the selector name may be global
2992 -- and set in the instance already. Remove the entity to
2993 -- force resolution of the selected component, and the
2994 -- generation of an explicit dereference if needed.
2997 and then Nkind (Parent (Nam)) = N_Selected_Component
2999 Set_Entity (Selector_Name (Parent (Nam)), Empty);
3005 Next_Discriminant (Disc);
3008 end Check_Implicit_Dereference;
3010 ----------------------------------
3011 -- Check_Internal_Protected_Use --
3012 ----------------------------------
3014 procedure Check_Internal_Protected_Use (N : Node_Id; Nam : Entity_Id) is
3022 while Present (S) loop
3023 if S = Standard_Standard then
3026 elsif Ekind (S) = E_Function
3027 and then Ekind (Scope (S)) = E_Protected_Type
3037 and then Scope (Nam) = Prot
3038 and then Ekind (Nam) /= E_Function
3040 -- An indirect function call (e.g. a callback within a protected
3041 -- function body) is not statically illegal. If the access type is
3042 -- anonymous and is the type of an access parameter, the scope of Nam
3043 -- will be the protected type, but it is not a protected operation.
3045 if Ekind (Nam) = E_Subprogram_Type
3046 and then Nkind (Associated_Node_For_Itype (Nam)) =
3047 N_Function_Specification
3051 elsif Nkind (N) = N_Subprogram_Renaming_Declaration then
3053 ("within protected function cannot use protected procedure in "
3054 & "renaming or as generic actual", N);
3056 elsif Nkind (N) = N_Attribute_Reference then
3058 ("within protected function cannot take access of protected "
3063 ("within protected function, protected object is constant", N);
3065 ("\cannot call operation that may modify it", N);
3069 -- Verify that an internal call does not appear within a precondition
3070 -- of a protected operation. This implements AI12-0166.
3071 -- The precondition aspect has been rewritten as a pragma Precondition
3072 -- and we check whether the scope of the called subprogram is the same
3073 -- as that of the entity to which the aspect applies.
3075 if Convention (Nam) = Convention_Protected then
3081 while Present (P) loop
3082 if Nkind (P) = N_Pragma
3083 and then Chars (Pragma_Identifier (P)) = Name_Precondition
3084 and then From_Aspect_Specification (P)
3086 Scope (Entity (Corresponding_Aspect (P))) = Scope (Nam)
3089 ("internal call cannot appear in precondition of "
3090 & "protected operation", N);
3093 elsif Nkind (P) = N_Pragma
3094 and then Chars (Pragma_Identifier (P)) = Name_Contract_Cases
3096 -- Check whether call is in a case guard. It is legal in a
3100 while Present (P) loop
3101 if Nkind (Parent (P)) = N_Component_Association
3102 and then P /= Expression (Parent (P))
3105 ("internal call cannot appear in case guard in a "
3106 & "contract case", N);
3114 elsif Nkind (P) = N_Parameter_Specification
3115 and then Scope (Current_Scope) = Scope (Nam)
3116 and then Nkind_In (Parent (P), N_Entry_Declaration,
3117 N_Subprogram_Declaration)
3120 ("internal call cannot appear in default for formal of "
3121 & "protected operation", N);
3129 end Check_Internal_Protected_Use;
3131 ---------------------------------------
3132 -- Check_Later_Vs_Basic_Declarations --
3133 ---------------------------------------
3135 procedure Check_Later_Vs_Basic_Declarations
3137 During_Parsing : Boolean)
3139 Body_Sloc : Source_Ptr;
3142 function Is_Later_Declarative_Item (Decl : Node_Id) return Boolean;
3143 -- Return whether Decl is considered as a declarative item.
3144 -- When During_Parsing is True, the semantics of Ada 83 is followed.
3145 -- When During_Parsing is False, the semantics of SPARK is followed.
3147 -------------------------------
3148 -- Is_Later_Declarative_Item --
3149 -------------------------------
3151 function Is_Later_Declarative_Item (Decl : Node_Id) return Boolean is
3153 if Nkind (Decl) in N_Later_Decl_Item then
3156 elsif Nkind (Decl) = N_Pragma then
3159 elsif During_Parsing then
3162 -- In SPARK, a package declaration is not considered as a later
3163 -- declarative item.
3165 elsif Nkind (Decl) = N_Package_Declaration then
3168 -- In SPARK, a renaming is considered as a later declarative item
3170 elsif Nkind (Decl) in N_Renaming_Declaration then
3176 end Is_Later_Declarative_Item;
3178 -- Start of processing for Check_Later_Vs_Basic_Declarations
3181 Decl := First (Decls);
3183 -- Loop through sequence of basic declarative items
3185 Outer : while Present (Decl) loop
3186 if not Nkind_In (Decl, N_Subprogram_Body, N_Package_Body, N_Task_Body)
3187 and then Nkind (Decl) not in N_Body_Stub
3191 -- Once a body is encountered, we only allow later declarative
3192 -- items. The inner loop checks the rest of the list.
3195 Body_Sloc := Sloc (Decl);
3197 Inner : while Present (Decl) loop
3198 if not Is_Later_Declarative_Item (Decl) then
3199 if During_Parsing then
3200 if Ada_Version = Ada_83 then
3201 Error_Msg_Sloc := Body_Sloc;
3203 ("(Ada 83) decl cannot appear after body#", Decl);
3206 Error_Msg_Sloc := Body_Sloc;
3207 Check_SPARK_05_Restriction
3208 ("decl cannot appear after body#", Decl);
3216 end Check_Later_Vs_Basic_Declarations;
3218 ---------------------------
3219 -- Check_No_Hidden_State --
3220 ---------------------------
3222 procedure Check_No_Hidden_State (Id : Entity_Id) is
3223 Context : Entity_Id := Empty;
3224 Not_Visible : Boolean := False;
3228 pragma Assert (Ekind_In (Id, E_Abstract_State, E_Variable));
3230 -- Nothing to do for internally-generated abstract states and variables
3231 -- because they do not represent the hidden state of the source unit.
3233 if not Comes_From_Source (Id) then
3237 -- Find the proper context where the object or state appears
3240 while Present (Scop) loop
3243 -- Keep track of the context's visibility
3245 Not_Visible := Not_Visible or else In_Private_Part (Context);
3247 -- Prevent the search from going too far
3249 if Context = Standard_Standard then
3252 -- Objects and states that appear immediately within a subprogram or
3253 -- inside a construct nested within a subprogram do not introduce a
3254 -- hidden state. They behave as local variable declarations.
3256 elsif Is_Subprogram (Context) then
3259 -- When examining a package body, use the entity of the spec as it
3260 -- carries the abstract state declarations.
3262 elsif Ekind (Context) = E_Package_Body then
3263 Context := Spec_Entity (Context);
3266 -- Stop the traversal when a package subject to a null abstract state
3269 if Ekind_In (Context, E_Generic_Package, E_Package)
3270 and then Has_Null_Abstract_State (Context)
3275 Scop := Scope (Scop);
3278 -- At this point we know that there is at least one package with a null
3279 -- abstract state in visibility. Emit an error message unconditionally
3280 -- if the entity being processed is a state because the placement of the
3281 -- related package is irrelevant. This is not the case for objects as
3282 -- the intermediate context matters.
3284 if Present (Context)
3285 and then (Ekind (Id) = E_Abstract_State or else Not_Visible)
3287 Error_Msg_N ("cannot introduce hidden state &", Id);
3288 Error_Msg_NE ("\package & has null abstract state", Id, Context);
3290 end Check_No_Hidden_State;
3292 ----------------------------------------
3293 -- Check_Nonvolatile_Function_Profile --
3294 ----------------------------------------
3296 procedure Check_Nonvolatile_Function_Profile (Func_Id : Entity_Id) is
3300 -- Inspect all formal parameters
3302 Formal := First_Formal (Func_Id);
3303 while Present (Formal) loop
3304 if Is_Effectively_Volatile (Etype (Formal)) then
3306 ("nonvolatile function & cannot have a volatile parameter",
3310 Next_Formal (Formal);
3313 -- Inspect the return type
3315 if Is_Effectively_Volatile (Etype (Func_Id)) then
3317 ("nonvolatile function & cannot have a volatile return type",
3318 Result_Definition (Parent (Func_Id)), Func_Id);
3320 end Check_Nonvolatile_Function_Profile;
3322 -----------------------------
3323 -- Check_Part_Of_Reference --
3324 -----------------------------
3326 procedure Check_Part_Of_Reference (Var_Id : Entity_Id; Ref : Node_Id) is
3327 function Is_Enclosing_Package_Body
3328 (Body_Decl : Node_Id;
3329 Obj_Id : Entity_Id) return Boolean;
3330 pragma Inline (Is_Enclosing_Package_Body);
3331 -- Determine whether package body Body_Decl or its corresponding spec
3332 -- immediately encloses the declaration of object Obj_Id.
3334 function Is_Internal_Declaration_Or_Body
3335 (Decl : Node_Id) return Boolean;
3336 pragma Inline (Is_Internal_Declaration_Or_Body);
3337 -- Determine whether declaration or body denoted by Decl is internal
3339 function Is_Single_Declaration_Or_Body
3341 Conc_Typ : Entity_Id) return Boolean;
3342 pragma Inline (Is_Single_Declaration_Or_Body);
3343 -- Determine whether protected/task declaration or body denoted by Decl
3344 -- belongs to single concurrent type Conc_Typ.
3346 function Is_Single_Task_Pragma
3348 Task_Typ : Entity_Id) return Boolean;
3349 pragma Inline (Is_Single_Task_Pragma);
3350 -- Determine whether pragma Prag belongs to single task type Task_Typ
3352 -------------------------------
3353 -- Is_Enclosing_Package_Body --
3354 -------------------------------
3356 function Is_Enclosing_Package_Body
3357 (Body_Decl : Node_Id;
3358 Obj_Id : Entity_Id) return Boolean
3360 Obj_Context : Node_Id;
3363 -- Find the context of the object declaration
3365 Obj_Context := Parent (Declaration_Node (Obj_Id));
3367 if Nkind (Obj_Context) = N_Package_Specification then
3368 Obj_Context := Parent (Obj_Context);
3371 -- The object appears immediately within the package body
3373 if Obj_Context = Body_Decl then
3376 -- The object appears immediately within the corresponding spec
3378 elsif Nkind (Obj_Context) = N_Package_Declaration
3379 and then Unit_Declaration_Node (Corresponding_Spec (Body_Decl)) =
3386 end Is_Enclosing_Package_Body;
3388 -------------------------------------
3389 -- Is_Internal_Declaration_Or_Body --
3390 -------------------------------------
3392 function Is_Internal_Declaration_Or_Body
3393 (Decl : Node_Id) return Boolean
3396 if Comes_From_Source (Decl) then
3399 -- A body generated for an expression function which has not been
3400 -- inserted into the tree yet (In_Spec_Expression is True) is not
3401 -- considered internal.
3403 elsif Nkind (Decl) = N_Subprogram_Body
3404 and then Was_Expression_Function (Decl)
3405 and then not In_Spec_Expression
3411 end Is_Internal_Declaration_Or_Body;
3413 -----------------------------------
3414 -- Is_Single_Declaration_Or_Body --
3415 -----------------------------------
3417 function Is_Single_Declaration_Or_Body
3419 Conc_Typ : Entity_Id) return Boolean
3421 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Decl);
3425 Present (Anonymous_Object (Spec_Id))
3426 and then Anonymous_Object (Spec_Id) = Conc_Typ;
3427 end Is_Single_Declaration_Or_Body;
3429 ---------------------------
3430 -- Is_Single_Task_Pragma --
3431 ---------------------------
3433 function Is_Single_Task_Pragma
3435 Task_Typ : Entity_Id) return Boolean
3437 Decl : constant Node_Id := Find_Related_Declaration_Or_Body (Prag);
3440 -- To qualify, the pragma must be associated with single task type
3444 Is_Single_Task_Object (Task_Typ)
3445 and then Nkind (Decl) = N_Object_Declaration
3446 and then Defining_Entity (Decl) = Task_Typ;
3447 end Is_Single_Task_Pragma;
3451 Conc_Obj : constant Entity_Id := Encapsulating_State (Var_Id);
3456 -- Start of processing for Check_Part_Of_Reference
3459 -- Nothing to do when the variable was recorded, but did not become a
3460 -- constituent of a single concurrent type.
3462 if No (Conc_Obj) then
3466 -- Traverse the parent chain looking for a suitable context for the
3467 -- reference to the concurrent constituent.
3470 Par := Parent (Prev);
3471 while Present (Par) loop
3472 if Nkind (Par) = N_Pragma then
3473 Prag_Nam := Pragma_Name (Par);
3475 -- A concurrent constituent is allowed to appear in pragmas
3476 -- Initial_Condition and Initializes as this is part of the
3477 -- elaboration checks for the constituent (SPARK RM 9(3)).
3479 if Nam_In (Prag_Nam, Name_Initial_Condition, Name_Initializes) then
3482 -- When the reference appears within pragma Depends or Global,
3483 -- check whether the pragma applies to a single task type. Note
3484 -- that the pragma may not encapsulated by the type definition,
3485 -- but this is still a valid context.
3487 elsif Nam_In (Prag_Nam, Name_Depends, Name_Global)
3488 and then Is_Single_Task_Pragma (Par, Conc_Obj)
3493 -- The reference appears somewhere in the definition of a single
3494 -- concurrent type (SPARK RM 9(3)).
3496 elsif Nkind_In (Par, N_Single_Protected_Declaration,
3497 N_Single_Task_Declaration)
3498 and then Defining_Entity (Par) = Conc_Obj
3502 -- The reference appears within the declaration or body of a single
3503 -- concurrent type (SPARK RM 9(3)).
3505 elsif Nkind_In (Par, N_Protected_Body,
3506 N_Protected_Type_Declaration,
3508 N_Task_Type_Declaration)
3509 and then Is_Single_Declaration_Or_Body (Par, Conc_Obj)
3513 -- The reference appears within the statement list of the object's
3514 -- immediately enclosing package (SPARK RM 9(3)).
3516 elsif Nkind (Par) = N_Package_Body
3517 and then Nkind (Prev) = N_Handled_Sequence_Of_Statements
3518 and then Is_Enclosing_Package_Body (Par, Var_Id)
3522 -- The reference has been relocated within an internally generated
3523 -- package or subprogram. Assume that the reference is legal as the
3524 -- real check was already performed in the original context of the
3527 elsif Nkind_In (Par, N_Package_Body,
3528 N_Package_Declaration,
3530 N_Subprogram_Declaration)
3531 and then Is_Internal_Declaration_Or_Body (Par)
3535 -- The reference has been relocated to an inlined body for GNATprove.
3536 -- Assume that the reference is legal as the real check was already
3537 -- performed in the original context of the reference.
3539 elsif GNATprove_Mode
3540 and then Nkind (Par) = N_Subprogram_Body
3541 and then Chars (Defining_Entity (Par)) = Name_uParent
3547 Par := Parent (Prev);
3550 -- At this point it is known that the reference does not appear within a
3554 ("reference to variable & cannot appear in this context", Ref, Var_Id);
3555 Error_Msg_Name_1 := Chars (Var_Id);
3557 if Is_Single_Protected_Object (Conc_Obj) then
3559 ("\% is constituent of single protected type &", Ref, Conc_Obj);
3563 ("\% is constituent of single task type &", Ref, Conc_Obj);
3565 end Check_Part_Of_Reference;
3567 ------------------------------------------
3568 -- Check_Potentially_Blocking_Operation --
3569 ------------------------------------------
3571 procedure Check_Potentially_Blocking_Operation (N : Node_Id) is
3575 -- N is one of the potentially blocking operations listed in 9.5.1(8).
3576 -- When pragma Detect_Blocking is active, the run time will raise
3577 -- Program_Error. Here we only issue a warning, since we generally
3578 -- support the use of potentially blocking operations in the absence
3581 -- Indirect blocking through a subprogram call cannot be diagnosed
3582 -- statically without interprocedural analysis, so we do not attempt
3585 S := Scope (Current_Scope);
3586 while Present (S) and then S /= Standard_Standard loop
3587 if Is_Protected_Type (S) then
3589 ("potentially blocking operation in protected operation??", N);
3595 end Check_Potentially_Blocking_Operation;
3597 ------------------------------------
3598 -- Check_Previous_Null_Procedure --
3599 ------------------------------------
3601 procedure Check_Previous_Null_Procedure
3606 if Ekind (Prev) = E_Procedure
3607 and then Nkind (Parent (Prev)) = N_Procedure_Specification
3608 and then Null_Present (Parent (Prev))
3610 Error_Msg_Sloc := Sloc (Prev);
3612 ("declaration cannot complete previous null procedure#", Decl);
3614 end Check_Previous_Null_Procedure;
3616 ---------------------------------
3617 -- Check_Result_And_Post_State --
3618 ---------------------------------
3620 procedure Check_Result_And_Post_State (Subp_Id : Entity_Id) is
3621 procedure Check_Result_And_Post_State_In_Pragma
3623 Result_Seen : in out Boolean);
3624 -- Determine whether pragma Prag mentions attribute 'Result and whether
3625 -- the pragma contains an expression that evaluates differently in pre-
3626 -- and post-state. Prag is a [refined] postcondition or a contract-cases
3627 -- pragma. Result_Seen is set when the pragma mentions attribute 'Result
3629 function Has_In_Out_Parameter (Subp_Id : Entity_Id) return Boolean;
3630 -- Determine whether subprogram Subp_Id contains at least one IN OUT
3631 -- formal parameter.
3633 -------------------------------------------
3634 -- Check_Result_And_Post_State_In_Pragma --
3635 -------------------------------------------
3637 procedure Check_Result_And_Post_State_In_Pragma
3639 Result_Seen : in out Boolean)
3641 procedure Check_Conjunct (Expr : Node_Id);
3642 -- Check an individual conjunct in a conjunction of Boolean
3643 -- expressions, connected by "and" or "and then" operators.
3645 procedure Check_Conjuncts (Expr : Node_Id);
3646 -- Apply the post-state check to every conjunct in an expression, in
3647 -- case this is a conjunction of Boolean expressions. Otherwise apply
3648 -- it to the expression as a whole.
3650 procedure Check_Expression (Expr : Node_Id);
3651 -- Perform the 'Result and post-state checks on a given expression
3653 function Is_Function_Result (N : Node_Id) return Traverse_Result;
3654 -- Attempt to find attribute 'Result in a subtree denoted by N
3656 function Is_Trivial_Boolean (N : Node_Id) return Boolean;
3657 -- Determine whether source node N denotes "True" or "False"
3659 function Mentions_Post_State (N : Node_Id) return Boolean;
3660 -- Determine whether a subtree denoted by N mentions any construct
3661 -- that denotes a post-state.
3663 procedure Check_Function_Result is
3664 new Traverse_Proc (Is_Function_Result);
3666 --------------------
3667 -- Check_Conjunct --
3668 --------------------
3670 procedure Check_Conjunct (Expr : Node_Id) is
3671 function Adjust_Message (Msg : String) return String;
3672 -- Prepend a prefix to the input message Msg denoting that the
3673 -- message applies to a conjunct in the expression, when this
3676 function Applied_On_Conjunct return Boolean;
3677 -- Returns True if the message applies to a conjunct in the
3678 -- expression, instead of the whole expression.
3680 function Has_Global_Output (Subp : Entity_Id) return Boolean;
3681 -- Returns True if Subp has an output in its Global contract
3683 function Has_No_Output (Subp : Entity_Id) return Boolean;
3684 -- Returns True if Subp has no declared output: no function
3685 -- result, no output parameter, and no output in its Global
3688 --------------------
3689 -- Adjust_Message --
3690 --------------------
3692 function Adjust_Message (Msg : String) return String is
3694 if Applied_On_Conjunct then
3695 return "conjunct in " & Msg;
3701 -------------------------
3702 -- Applied_On_Conjunct --
3703 -------------------------
3705 function Applied_On_Conjunct return Boolean is
3707 -- Expr is the conjunct of an enclosing "and" expression
3709 return Nkind (Parent (Expr)) in N_Subexpr
3711 -- or Expr is a conjunct of an enclosing "and then"
3712 -- expression in a postcondition aspect that was split into
3713 -- multiple pragmas. The first conjunct has the "and then"
3714 -- expression as Original_Node, and other conjuncts have
3715 -- Split_PCC set to True.
3717 or else Nkind (Original_Node (Expr)) = N_And_Then
3718 or else Split_PPC (Prag);
3719 end Applied_On_Conjunct;
3721 -----------------------
3722 -- Has_Global_Output --
3723 -----------------------
3725 function Has_Global_Output (Subp : Entity_Id) return Boolean is
3726 Global : constant Node_Id := Get_Pragma (Subp, Pragma_Global);
3735 List := Expression (Get_Argument (Global, Subp));
3737 -- Empty list (no global items) or single global item
3738 -- declaration (only input items).
3740 if Nkind_In (List, N_Null,
3743 N_Selected_Component)
3747 -- Simple global list (only input items) or moded global list
3750 elsif Nkind (List) = N_Aggregate then
3751 if Present (Expressions (List)) then
3755 Assoc := First (Component_Associations (List));
3756 while Present (Assoc) loop
3757 if Chars (First (Choices (Assoc))) /= Name_Input then
3767 -- To accommodate partial decoration of disabled SPARK
3768 -- features, this routine may be called with illegal input.
3769 -- If this is the case, do not raise Program_Error.
3774 end Has_Global_Output;
3780 function Has_No_Output (Subp : Entity_Id) return Boolean is
3784 -- A function has its result as output
3786 if Ekind (Subp) = E_Function then
3790 -- An OUT or IN OUT parameter is an output
3792 Param := First_Formal (Subp);
3793 while Present (Param) loop
3794 if Ekind_In (Param, E_Out_Parameter, E_In_Out_Parameter) then
3798 Next_Formal (Param);
3801 -- An item of mode Output or In_Out in the Global contract is
3804 if Has_Global_Output (Subp) then
3814 -- Error node when reporting a warning on a (refined)
3817 -- Start of processing for Check_Conjunct
3820 if Applied_On_Conjunct then
3826 -- Do not report missing reference to outcome in postcondition if
3827 -- either the postcondition is trivially True or False, or if the
3828 -- subprogram is ghost and has no declared output.
3830 if not Is_Trivial_Boolean (Expr)
3831 and then not Mentions_Post_State (Expr)
3832 and then not (Is_Ghost_Entity (Subp_Id)
3833 and then Has_No_Output (Subp_Id))
3835 if Pragma_Name (Prag) = Name_Contract_Cases then
3836 Error_Msg_NE (Adjust_Message
3837 ("contract case does not check the outcome of calling "
3838 & "&?T?"), Expr, Subp_Id);
3840 elsif Pragma_Name (Prag) = Name_Refined_Post then
3841 Error_Msg_NE (Adjust_Message
3842 ("refined postcondition does not check the outcome of "
3843 & "calling &?T?"), Err_Node, Subp_Id);
3846 Error_Msg_NE (Adjust_Message
3847 ("postcondition does not check the outcome of calling "
3848 & "&?T?"), Err_Node, Subp_Id);
3853 ---------------------
3854 -- Check_Conjuncts --
3855 ---------------------
3857 procedure Check_Conjuncts (Expr : Node_Id) is
3859 if Nkind_In (Expr, N_Op_And, N_And_Then) then
3860 Check_Conjuncts (Left_Opnd (Expr));
3861 Check_Conjuncts (Right_Opnd (Expr));
3863 Check_Conjunct (Expr);
3865 end Check_Conjuncts;
3867 ----------------------
3868 -- Check_Expression --
3869 ----------------------
3871 procedure Check_Expression (Expr : Node_Id) is
3873 if not Is_Trivial_Boolean (Expr) then
3874 Check_Function_Result (Expr);
3875 Check_Conjuncts (Expr);
3877 end Check_Expression;
3879 ------------------------
3880 -- Is_Function_Result --
3881 ------------------------
3883 function Is_Function_Result (N : Node_Id) return Traverse_Result is
3885 if Is_Attribute_Result (N) then
3886 Result_Seen := True;
3889 -- Warn on infinite recursion if call is to current function
3891 elsif Nkind (N) = N_Function_Call
3892 and then Is_Entity_Name (Name (N))
3893 and then Entity (Name (N)) = Subp_Id
3894 and then not Is_Potentially_Unevaluated (N)
3897 ("call to & within its postcondition will lead to infinite "
3898 & "recursion?", N, Subp_Id);
3901 -- Continue the traversal
3906 end Is_Function_Result;
3908 ------------------------
3909 -- Is_Trivial_Boolean --
3910 ------------------------
3912 function Is_Trivial_Boolean (N : Node_Id) return Boolean is
3915 Comes_From_Source (N)
3916 and then Is_Entity_Name (N)
3917 and then (Entity (N) = Standard_True
3919 Entity (N) = Standard_False);
3920 end Is_Trivial_Boolean;
3922 -------------------------
3923 -- Mentions_Post_State --
3924 -------------------------
3926 function Mentions_Post_State (N : Node_Id) return Boolean is
3927 Post_State_Seen : Boolean := False;
3929 function Is_Post_State (N : Node_Id) return Traverse_Result;
3930 -- Attempt to find a construct that denotes a post-state. If this
3931 -- is the case, set flag Post_State_Seen.
3937 function Is_Post_State (N : Node_Id) return Traverse_Result is
3941 if Nkind_In (N, N_Explicit_Dereference, N_Function_Call) then
3942 Post_State_Seen := True;
3945 elsif Nkind_In (N, N_Expanded_Name, N_Identifier) then
3948 -- Treat an undecorated reference as OK
3952 -- A reference to an assignable entity is considered a
3953 -- change in the post-state of a subprogram.
3955 or else Ekind_In (Ent, E_Generic_In_Out_Parameter,
3960 -- The reference may be modified through a dereference
3962 or else (Is_Access_Type (Etype (Ent))
3963 and then Nkind (Parent (N)) =
3964 N_Selected_Component)
3966 Post_State_Seen := True;
3970 elsif Nkind (N) = N_Attribute_Reference then
3971 if Attribute_Name (N) = Name_Old then
3974 elsif Attribute_Name (N) = Name_Result then
3975 Post_State_Seen := True;
3983 procedure Find_Post_State is new Traverse_Proc (Is_Post_State);
3985 -- Start of processing for Mentions_Post_State
3988 Find_Post_State (N);
3990 return Post_State_Seen;
3991 end Mentions_Post_State;
3995 Expr : constant Node_Id :=
3997 (First (Pragma_Argument_Associations (Prag)));
3998 Nam : constant Name_Id := Pragma_Name (Prag);
4001 -- Start of processing for Check_Result_And_Post_State_In_Pragma
4004 -- Examine all consequences
4006 if Nam = Name_Contract_Cases then
4007 CCase := First (Component_Associations (Expr));
4008 while Present (CCase) loop
4009 Check_Expression (Expression (CCase));
4014 -- Examine the expression of a postcondition
4016 else pragma Assert (Nam_In (Nam, Name_Postcondition,
4017 Name_Refined_Post));
4018 Check_Expression (Expr);
4020 end Check_Result_And_Post_State_In_Pragma;
4022 --------------------------
4023 -- Has_In_Out_Parameter --
4024 --------------------------
4026 function Has_In_Out_Parameter (Subp_Id : Entity_Id) return Boolean is
4030 -- Traverse the formals looking for an IN OUT parameter
4032 Formal := First_Formal (Subp_Id);
4033 while Present (Formal) loop
4034 if Ekind (Formal) = E_In_Out_Parameter then
4038 Next_Formal (Formal);
4042 end Has_In_Out_Parameter;
4046 Items : constant Node_Id := Contract (Subp_Id);
4047 Subp_Decl : constant Node_Id := Unit_Declaration_Node (Subp_Id);
4048 Case_Prag : Node_Id := Empty;
4049 Post_Prag : Node_Id := Empty;
4051 Seen_In_Case : Boolean := False;
4052 Seen_In_Post : Boolean := False;
4053 Spec_Id : Entity_Id;
4055 -- Start of processing for Check_Result_And_Post_State
4058 -- The lack of attribute 'Result or a post-state is classified as a
4059 -- suspicious contract. Do not perform the check if the corresponding
4060 -- swich is not set.
4062 if not Warn_On_Suspicious_Contract then
4065 -- Nothing to do if there is no contract
4067 elsif No (Items) then
4071 -- Retrieve the entity of the subprogram spec (if any)
4073 if Nkind (Subp_Decl) = N_Subprogram_Body
4074 and then Present (Corresponding_Spec (Subp_Decl))
4076 Spec_Id := Corresponding_Spec (Subp_Decl);
4078 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
4079 and then Present (Corresponding_Spec_Of_Stub (Subp_Decl))
4081 Spec_Id := Corresponding_Spec_Of_Stub (Subp_Decl);
4087 -- Examine all postconditions for attribute 'Result and a post-state
4089 Prag := Pre_Post_Conditions (Items);
4090 while Present (Prag) loop
4091 if Nam_In (Pragma_Name_Unmapped (Prag),
4092 Name_Postcondition, Name_Refined_Post)
4093 and then not Error_Posted (Prag)
4096 Check_Result_And_Post_State_In_Pragma (Prag, Seen_In_Post);
4099 Prag := Next_Pragma (Prag);
4102 -- Examine the contract cases of the subprogram for attribute 'Result
4103 -- and a post-state.
4105 Prag := Contract_Test_Cases (Items);
4106 while Present (Prag) loop
4107 if Pragma_Name (Prag) = Name_Contract_Cases
4108 and then not Error_Posted (Prag)
4111 Check_Result_And_Post_State_In_Pragma (Prag, Seen_In_Case);
4114 Prag := Next_Pragma (Prag);
4117 -- Do not emit any errors if the subprogram is not a function
4119 if not Ekind_In (Spec_Id, E_Function, E_Generic_Function) then
4122 -- Regardless of whether the function has postconditions or contract
4123 -- cases, or whether they mention attribute 'Result, an IN OUT formal
4124 -- parameter is always treated as a result.
4126 elsif Has_In_Out_Parameter (Spec_Id) then
4129 -- The function has both a postcondition and contract cases and they do
4130 -- not mention attribute 'Result.
4132 elsif Present (Case_Prag)
4133 and then not Seen_In_Case
4134 and then Present (Post_Prag)
4135 and then not Seen_In_Post
4138 ("neither postcondition nor contract cases mention function "
4139 & "result?T?", Post_Prag);
4141 -- The function has contract cases only and they do not mention
4142 -- attribute 'Result.
4144 elsif Present (Case_Prag) and then not Seen_In_Case then
4145 Error_Msg_N ("contract cases do not mention result?T?", Case_Prag);
4147 -- The function has postconditions only and they do not mention
4148 -- attribute 'Result.
4150 elsif Present (Post_Prag) and then not Seen_In_Post then
4152 ("postcondition does not mention function result?T?", Post_Prag);
4154 end Check_Result_And_Post_State;
4156 -----------------------------
4157 -- Check_State_Refinements --
4158 -----------------------------
4160 procedure Check_State_Refinements
4162 Is_Main_Unit : Boolean := False)
4164 procedure Check_Package (Pack : Node_Id);
4165 -- Verify that all abstract states of a [generic] package denoted by its
4166 -- declarative node Pack have proper refinement. Recursively verify the
4167 -- visible and private declarations of the [generic] package for other
4170 procedure Check_Packages_In (Decls : List_Id);
4171 -- Seek out [generic] package declarations within declarative list Decls
4172 -- and verify the status of their abstract state refinement.
4174 function SPARK_Mode_Is_Off (N : Node_Id) return Boolean;
4175 -- Determine whether construct N is subject to pragma SPARK_Mode Off
4181 procedure Check_Package (Pack : Node_Id) is
4182 Body_Id : constant Entity_Id := Corresponding_Body (Pack);
4183 Spec : constant Node_Id := Specification (Pack);
4184 States : constant Elist_Id :=
4185 Abstract_States (Defining_Entity (Pack));
4187 State_Elmt : Elmt_Id;
4188 State_Id : Entity_Id;
4191 -- Do not verify proper state refinement when the package is subject
4192 -- to pragma SPARK_Mode Off because this disables the requirement for
4193 -- state refinement.
4195 if SPARK_Mode_Is_Off (Pack) then
4198 -- State refinement can only occur in a completing package body. Do
4199 -- not verify proper state refinement when the body is subject to
4200 -- pragma SPARK_Mode Off because this disables the requirement for
4201 -- state refinement.
4203 elsif Present (Body_Id)
4204 and then SPARK_Mode_Is_Off (Unit_Declaration_Node (Body_Id))
4208 -- Do not verify proper state refinement when the package is an
4209 -- instance as this check was already performed in the generic.
4211 elsif Present (Generic_Parent (Spec)) then
4214 -- Otherwise examine the contents of the package
4217 if Present (States) then
4218 State_Elmt := First_Elmt (States);
4219 while Present (State_Elmt) loop
4220 State_Id := Node (State_Elmt);
4222 -- Emit an error when a non-null state lacks any form of
4225 if not Is_Null_State (State_Id)
4226 and then not Has_Null_Refinement (State_Id)
4227 and then not Has_Non_Null_Refinement (State_Id)
4229 Error_Msg_N ("state & requires refinement", State_Id);
4232 Next_Elmt (State_Elmt);
4236 Check_Packages_In (Visible_Declarations (Spec));
4237 Check_Packages_In (Private_Declarations (Spec));
4241 -----------------------
4242 -- Check_Packages_In --
4243 -----------------------
4245 procedure Check_Packages_In (Decls : List_Id) is
4249 if Present (Decls) then
4250 Decl := First (Decls);
4251 while Present (Decl) loop
4252 if Nkind_In (Decl, N_Generic_Package_Declaration,
4253 N_Package_Declaration)
4255 Check_Package (Decl);
4261 end Check_Packages_In;
4263 -----------------------
4264 -- SPARK_Mode_Is_Off --
4265 -----------------------
4267 function SPARK_Mode_Is_Off (N : Node_Id) return Boolean is
4268 Id : constant Entity_Id := Defining_Entity (N);
4269 Prag : constant Node_Id := SPARK_Pragma (Id);
4272 -- Default the mode to "off" when the context is an instance and all
4273 -- SPARK_Mode pragmas found within are to be ignored.
4275 if Ignore_SPARK_Mode_Pragmas (Id) then
4281 and then Get_SPARK_Mode_From_Annotation (Prag) = Off;
4283 end SPARK_Mode_Is_Off;
4285 -- Start of processing for Check_State_Refinements
4288 -- A block may declare a nested package
4290 if Nkind (Context) = N_Block_Statement then
4291 Check_Packages_In (Declarations (Context));
4293 -- An entry, protected, subprogram, or task body may declare a nested
4296 elsif Nkind_In (Context, N_Entry_Body,
4301 -- Do not verify proper state refinement when the body is subject to
4302 -- pragma SPARK_Mode Off because this disables the requirement for
4303 -- state refinement.
4305 if not SPARK_Mode_Is_Off (Context) then
4306 Check_Packages_In (Declarations (Context));
4309 -- A package body may declare a nested package
4311 elsif Nkind (Context) = N_Package_Body then
4312 Check_Package (Unit_Declaration_Node (Corresponding_Spec (Context)));
4314 -- Do not verify proper state refinement when the body is subject to
4315 -- pragma SPARK_Mode Off because this disables the requirement for
4316 -- state refinement.
4318 if not SPARK_Mode_Is_Off (Context) then
4319 Check_Packages_In (Declarations (Context));
4322 -- A library level [generic] package may declare a nested package
4324 elsif Nkind_In (Context, N_Generic_Package_Declaration,
4325 N_Package_Declaration)
4326 and then Is_Main_Unit
4328 Check_Package (Context);
4330 end Check_State_Refinements;
4332 ------------------------------
4333 -- Check_Unprotected_Access --
4334 ------------------------------
4336 procedure Check_Unprotected_Access
4340 Cont_Encl_Typ : Entity_Id;
4341 Pref_Encl_Typ : Entity_Id;
4343 function Enclosing_Protected_Type (Obj : Node_Id) return Entity_Id;
4344 -- Check whether Obj is a private component of a protected object.
4345 -- Return the protected type where the component resides, Empty
4348 function Is_Public_Operation return Boolean;
4349 -- Verify that the enclosing operation is callable from outside the
4350 -- protected object, to minimize false positives.
4352 ------------------------------
4353 -- Enclosing_Protected_Type --
4354 ------------------------------
4356 function Enclosing_Protected_Type (Obj : Node_Id) return Entity_Id is
4358 if Is_Entity_Name (Obj) then
4360 Ent : Entity_Id := Entity (Obj);
4363 -- The object can be a renaming of a private component, use
4364 -- the original record component.
4366 if Is_Prival (Ent) then
4367 Ent := Prival_Link (Ent);
4370 if Is_Protected_Type (Scope (Ent)) then
4376 -- For indexed and selected components, recursively check the prefix
4378 if Nkind_In (Obj, N_Indexed_Component, N_Selected_Component) then
4379 return Enclosing_Protected_Type (Prefix (Obj));
4381 -- The object does not denote a protected component
4386 end Enclosing_Protected_Type;
4388 -------------------------
4389 -- Is_Public_Operation --
4390 -------------------------
4392 function Is_Public_Operation return Boolean is
4398 while Present (S) and then S /= Pref_Encl_Typ loop
4399 if Scope (S) = Pref_Encl_Typ then
4400 E := First_Entity (Pref_Encl_Typ);
4402 and then E /= First_Private_Entity (Pref_Encl_Typ)
4416 end Is_Public_Operation;
4418 -- Start of processing for Check_Unprotected_Access
4421 if Nkind (Expr) = N_Attribute_Reference
4422 and then Attribute_Name (Expr) = Name_Unchecked_Access
4424 Cont_Encl_Typ := Enclosing_Protected_Type (Context);
4425 Pref_Encl_Typ := Enclosing_Protected_Type (Prefix (Expr));
4427 -- Check whether we are trying to export a protected component to a
4428 -- context with an equal or lower access level.
4430 if Present (Pref_Encl_Typ)
4431 and then No (Cont_Encl_Typ)
4432 and then Is_Public_Operation
4433 and then Scope_Depth (Pref_Encl_Typ) >=
4434 Object_Access_Level (Context)
4437 ("??possible unprotected access to protected data", Expr);
4440 end Check_Unprotected_Access;
4442 ------------------------------
4443 -- Check_Unused_Body_States --
4444 ------------------------------
4446 procedure Check_Unused_Body_States (Body_Id : Entity_Id) is
4447 procedure Process_Refinement_Clause
4450 -- Inspect all constituents of refinement clause Clause and remove any
4451 -- matches from body state list States.
4453 procedure Report_Unused_Body_States (States : Elist_Id);
4454 -- Emit errors for each abstract state or object found in list States
4456 -------------------------------
4457 -- Process_Refinement_Clause --
4458 -------------------------------
4460 procedure Process_Refinement_Clause
4464 procedure Process_Constituent (Constit : Node_Id);
4465 -- Remove constituent Constit from body state list States
4467 -------------------------
4468 -- Process_Constituent --
4469 -------------------------
4471 procedure Process_Constituent (Constit : Node_Id) is
4472 Constit_Id : Entity_Id;
4475 -- Guard against illegal constituents. Only abstract states and
4476 -- objects can appear on the right hand side of a refinement.
4478 if Is_Entity_Name (Constit) then
4479 Constit_Id := Entity_Of (Constit);
4481 if Present (Constit_Id)
4482 and then Ekind_In (Constit_Id, E_Abstract_State,
4486 Remove (States, Constit_Id);
4489 end Process_Constituent;
4495 -- Start of processing for Process_Refinement_Clause
4498 if Nkind (Clause) = N_Component_Association then
4499 Constit := Expression (Clause);
4501 -- Multiple constituents appear as an aggregate
4503 if Nkind (Constit) = N_Aggregate then
4504 Constit := First (Expressions (Constit));
4505 while Present (Constit) loop
4506 Process_Constituent (Constit);
4510 -- Various forms of a single constituent
4513 Process_Constituent (Constit);
4516 end Process_Refinement_Clause;
4518 -------------------------------
4519 -- Report_Unused_Body_States --
4520 -------------------------------
4522 procedure Report_Unused_Body_States (States : Elist_Id) is
4523 Posted : Boolean := False;
4524 State_Elmt : Elmt_Id;
4525 State_Id : Entity_Id;
4528 if Present (States) then
4529 State_Elmt := First_Elmt (States);
4530 while Present (State_Elmt) loop
4531 State_Id := Node (State_Elmt);
4533 -- Constants are part of the hidden state of a package, but the
4534 -- compiler cannot determine whether they have variable input
4535 -- (SPARK RM 7.1.1(2)) and cannot classify them properly as a
4536 -- hidden state. Do not emit an error when a constant does not
4537 -- participate in a state refinement, even though it acts as a
4540 if Ekind (State_Id) = E_Constant then
4543 -- Generate an error message of the form:
4545 -- body of package ... has unused hidden states
4546 -- abstract state ... defined at ...
4547 -- variable ... defined at ...
4553 ("body of package & has unused hidden states", Body_Id);
4556 Error_Msg_Sloc := Sloc (State_Id);
4558 if Ekind (State_Id) = E_Abstract_State then
4560 ("\abstract state & defined #", Body_Id, State_Id);
4563 SPARK_Msg_NE ("\variable & defined #", Body_Id, State_Id);
4567 Next_Elmt (State_Elmt);
4570 end Report_Unused_Body_States;
4574 Prag : constant Node_Id := Get_Pragma (Body_Id, Pragma_Refined_State);
4575 Spec_Id : constant Entity_Id := Spec_Entity (Body_Id);
4579 -- Start of processing for Check_Unused_Body_States
4582 -- Inspect the clauses of pragma Refined_State and determine whether all
4583 -- visible states declared within the package body participate in the
4586 if Present (Prag) then
4587 Clause := Expression (Get_Argument (Prag, Spec_Id));
4588 States := Collect_Body_States (Body_Id);
4590 -- Multiple non-null state refinements appear as an aggregate
4592 if Nkind (Clause) = N_Aggregate then
4593 Clause := First (Component_Associations (Clause));
4594 while Present (Clause) loop
4595 Process_Refinement_Clause (Clause, States);
4599 -- Various forms of a single state refinement
4602 Process_Refinement_Clause (Clause, States);
4605 -- Ensure that all abstract states and objects declared in the
4606 -- package body state space are utilized as constituents.
4608 Report_Unused_Body_States (States);
4610 end Check_Unused_Body_States;
4616 function Choice_List (N : Node_Id) return List_Id is
4618 if Nkind (N) = N_Iterated_Component_Association then
4619 return Discrete_Choices (N);
4625 -------------------------
4626 -- Collect_Body_States --
4627 -------------------------
4629 function Collect_Body_States (Body_Id : Entity_Id) return Elist_Id is
4630 function Is_Visible_Object (Obj_Id : Entity_Id) return Boolean;
4631 -- Determine whether object Obj_Id is a suitable visible state of a
4634 procedure Collect_Visible_States
4635 (Pack_Id : Entity_Id;
4636 States : in out Elist_Id);
4637 -- Gather the entities of all abstract states and objects declared in
4638 -- the visible state space of package Pack_Id.
4640 ----------------------------
4641 -- Collect_Visible_States --
4642 ----------------------------
4644 procedure Collect_Visible_States
4645 (Pack_Id : Entity_Id;
4646 States : in out Elist_Id)
4648 Item_Id : Entity_Id;
4651 -- Traverse the entity chain of the package and inspect all visible
4654 Item_Id := First_Entity (Pack_Id);
4655 while Present (Item_Id) and then not In_Private_Part (Item_Id) loop
4657 -- Do not consider internally generated items as those cannot be
4658 -- named and participate in refinement.
4660 if not Comes_From_Source (Item_Id) then
4663 elsif Ekind (Item_Id) = E_Abstract_State then
4664 Append_New_Elmt (Item_Id, States);
4666 elsif Ekind_In (Item_Id, E_Constant, E_Variable)
4667 and then Is_Visible_Object (Item_Id)
4669 Append_New_Elmt (Item_Id, States);
4671 -- Recursively gather the visible states of a nested package
4673 elsif Ekind (Item_Id) = E_Package then
4674 Collect_Visible_States (Item_Id, States);
4677 Next_Entity (Item_Id);
4679 end Collect_Visible_States;
4681 -----------------------
4682 -- Is_Visible_Object --
4683 -----------------------
4685 function Is_Visible_Object (Obj_Id : Entity_Id) return Boolean is
4687 -- Objects that map generic formals to their actuals are not visible
4688 -- from outside the generic instantiation.
4690 if Present (Corresponding_Generic_Association
4691 (Declaration_Node (Obj_Id)))
4695 -- Constituents of a single protected/task type act as components of
4696 -- the type and are not visible from outside the type.
4698 elsif Ekind (Obj_Id) = E_Variable
4699 and then Present (Encapsulating_State (Obj_Id))
4700 and then Is_Single_Concurrent_Object (Encapsulating_State (Obj_Id))
4707 end Is_Visible_Object;
4711 Body_Decl : constant Node_Id := Unit_Declaration_Node (Body_Id);
4713 Item_Id : Entity_Id;
4714 States : Elist_Id := No_Elist;
4716 -- Start of processing for Collect_Body_States
4719 -- Inspect the declarations of the body looking for source objects,
4720 -- packages and package instantiations. Note that even though this
4721 -- processing is very similar to Collect_Visible_States, a package
4722 -- body does not have a First/Next_Entity list.
4724 Decl := First (Declarations (Body_Decl));
4725 while Present (Decl) loop
4727 -- Capture source objects as internally generated temporaries cannot
4728 -- be named and participate in refinement.
4730 if Nkind (Decl) = N_Object_Declaration then
4731 Item_Id := Defining_Entity (Decl);
4733 if Comes_From_Source (Item_Id)
4734 and then Is_Visible_Object (Item_Id)
4736 Append_New_Elmt (Item_Id, States);
4739 -- Capture the visible abstract states and objects of a source
4740 -- package [instantiation].
4742 elsif Nkind (Decl) = N_Package_Declaration then
4743 Item_Id := Defining_Entity (Decl);
4745 if Comes_From_Source (Item_Id) then
4746 Collect_Visible_States (Item_Id, States);
4754 end Collect_Body_States;
4756 ------------------------
4757 -- Collect_Interfaces --
4758 ------------------------
4760 procedure Collect_Interfaces
4762 Ifaces_List : out Elist_Id;
4763 Exclude_Parents : Boolean := False;
4764 Use_Full_View : Boolean := True)
4766 procedure Collect (Typ : Entity_Id);
4767 -- Subsidiary subprogram used to traverse the whole list
4768 -- of directly and indirectly implemented interfaces
4774 procedure Collect (Typ : Entity_Id) is
4775 Ancestor : Entity_Id;
4783 -- Handle private types and subtypes
4786 and then Is_Private_Type (Typ)
4787 and then Present (Full_View (Typ))
4789 Full_T := Full_View (Typ);
4791 if Ekind (Full_T) = E_Record_Subtype then
4792 Full_T := Etype (Typ);
4794 if Present (Full_View (Full_T)) then
4795 Full_T := Full_View (Full_T);
4800 -- Include the ancestor if we are generating the whole list of
4801 -- abstract interfaces.
4803 if Etype (Full_T) /= Typ
4805 -- Protect the frontend against wrong sources. For example:
4808 -- type A is tagged null record;
4809 -- type B is new A with private;
4810 -- type C is new A with private;
4812 -- type B is new C with null record;
4813 -- type C is new B with null record;
4816 and then Etype (Full_T) /= T
4818 Ancestor := Etype (Full_T);
4821 if Is_Interface (Ancestor) and then not Exclude_Parents then
4822 Append_Unique_Elmt (Ancestor, Ifaces_List);
4826 -- Traverse the graph of ancestor interfaces
4828 if Is_Non_Empty_List (Abstract_Interface_List (Full_T)) then
4829 Id := First (Abstract_Interface_List (Full_T));
4830 while Present (Id) loop
4831 Iface := Etype (Id);
4833 -- Protect against wrong uses. For example:
4834 -- type I is interface;
4835 -- type O is tagged null record;
4836 -- type Wrong is new I and O with null record; -- ERROR
4838 if Is_Interface (Iface) then
4840 and then Etype (T) /= T
4841 and then Interface_Present_In_Ancestor (Etype (T), Iface)
4846 Append_Unique_Elmt (Iface, Ifaces_List);
4855 -- Start of processing for Collect_Interfaces
4858 pragma Assert (Is_Tagged_Type (T) or else Is_Concurrent_Type (T));
4859 Ifaces_List := New_Elmt_List;
4861 end Collect_Interfaces;
4863 ----------------------------------
4864 -- Collect_Interface_Components --
4865 ----------------------------------
4867 procedure Collect_Interface_Components
4868 (Tagged_Type : Entity_Id;
4869 Components_List : out Elist_Id)
4871 procedure Collect (Typ : Entity_Id);
4872 -- Subsidiary subprogram used to climb to the parents
4878 procedure Collect (Typ : Entity_Id) is
4879 Tag_Comp : Entity_Id;
4880 Parent_Typ : Entity_Id;
4883 -- Handle private types
4885 if Present (Full_View (Etype (Typ))) then
4886 Parent_Typ := Full_View (Etype (Typ));
4888 Parent_Typ := Etype (Typ);
4891 if Parent_Typ /= Typ
4893 -- Protect the frontend against wrong sources. For example:
4896 -- type A is tagged null record;
4897 -- type B is new A with private;
4898 -- type C is new A with private;
4900 -- type B is new C with null record;
4901 -- type C is new B with null record;
4904 and then Parent_Typ /= Tagged_Type
4906 Collect (Parent_Typ);
4909 -- Collect the components containing tags of secondary dispatch
4912 Tag_Comp := Next_Tag_Component (First_Tag_Component (Typ));
4913 while Present (Tag_Comp) loop
4914 pragma Assert (Present (Related_Type (Tag_Comp)));
4915 Append_Elmt (Tag_Comp, Components_List);
4917 Tag_Comp := Next_Tag_Component (Tag_Comp);
4921 -- Start of processing for Collect_Interface_Components
4924 pragma Assert (Ekind (Tagged_Type) = E_Record_Type
4925 and then Is_Tagged_Type (Tagged_Type));
4927 Components_List := New_Elmt_List;
4928 Collect (Tagged_Type);
4929 end Collect_Interface_Components;
4931 -----------------------------
4932 -- Collect_Interfaces_Info --
4933 -----------------------------
4935 procedure Collect_Interfaces_Info
4937 Ifaces_List : out Elist_Id;
4938 Components_List : out Elist_Id;
4939 Tags_List : out Elist_Id)
4941 Comps_List : Elist_Id;
4942 Comp_Elmt : Elmt_Id;
4943 Comp_Iface : Entity_Id;
4944 Iface_Elmt : Elmt_Id;
4947 function Search_Tag (Iface : Entity_Id) return Entity_Id;
4948 -- Search for the secondary tag associated with the interface type
4949 -- Iface that is implemented by T.
4955 function Search_Tag (Iface : Entity_Id) return Entity_Id is
4958 if not Is_CPP_Class (T) then
4959 ADT := Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (T))));
4961 ADT := Next_Elmt (First_Elmt (Access_Disp_Table (T)));
4965 and then Is_Tag (Node (ADT))
4966 and then Related_Type (Node (ADT)) /= Iface
4968 -- Skip secondary dispatch table referencing thunks to user
4969 -- defined primitives covered by this interface.
4971 pragma Assert (Has_Suffix (Node (ADT), 'P'));
4974 -- Skip secondary dispatch tables of Ada types
4976 if not Is_CPP_Class (T) then
4978 -- Skip secondary dispatch table referencing thunks to
4979 -- predefined primitives.
4981 pragma Assert (Has_Suffix (Node (ADT), 'Y'));
4984 -- Skip secondary dispatch table referencing user-defined
4985 -- primitives covered by this interface.
4987 pragma Assert (Has_Suffix (Node (ADT), 'D'));
4990 -- Skip secondary dispatch table referencing predefined
4993 pragma Assert (Has_Suffix (Node (ADT), 'Z'));
4998 pragma Assert (Is_Tag (Node (ADT)));
5002 -- Start of processing for Collect_Interfaces_Info
5005 Collect_Interfaces (T, Ifaces_List);
5006 Collect_Interface_Components (T, Comps_List);
5008 -- Search for the record component and tag associated with each
5009 -- interface type of T.
5011 Components_List := New_Elmt_List;
5012 Tags_List := New_Elmt_List;
5014 Iface_Elmt := First_Elmt (Ifaces_List);
5015 while Present (Iface_Elmt) loop
5016 Iface := Node (Iface_Elmt);
5018 -- Associate the primary tag component and the primary dispatch table
5019 -- with all the interfaces that are parents of T
5021 if Is_Ancestor (Iface, T, Use_Full_View => True) then
5022 Append_Elmt (First_Tag_Component (T), Components_List);
5023 Append_Elmt (Node (First_Elmt (Access_Disp_Table (T))), Tags_List);
5025 -- Otherwise search for the tag component and secondary dispatch
5029 Comp_Elmt := First_Elmt (Comps_List);
5030 while Present (Comp_Elmt) loop
5031 Comp_Iface := Related_Type (Node (Comp_Elmt));
5033 if Comp_Iface = Iface
5034 or else Is_Ancestor (Iface, Comp_Iface, Use_Full_View => True)
5036 Append_Elmt (Node (Comp_Elmt), Components_List);
5037 Append_Elmt (Search_Tag (Comp_Iface), Tags_List);
5041 Next_Elmt (Comp_Elmt);
5043 pragma Assert (Present (Comp_Elmt));
5046 Next_Elmt (Iface_Elmt);
5048 end Collect_Interfaces_Info;
5050 ---------------------
5051 -- Collect_Parents --
5052 ---------------------
5054 procedure Collect_Parents
5056 List : out Elist_Id;
5057 Use_Full_View : Boolean := True)
5059 Current_Typ : Entity_Id := T;
5060 Parent_Typ : Entity_Id;
5063 List := New_Elmt_List;
5065 -- No action if the if the type has no parents
5067 if T = Etype (T) then
5072 Parent_Typ := Etype (Current_Typ);
5074 if Is_Private_Type (Parent_Typ)
5075 and then Present (Full_View (Parent_Typ))
5076 and then Use_Full_View
5078 Parent_Typ := Full_View (Base_Type (Parent_Typ));
5081 Append_Elmt (Parent_Typ, List);
5083 exit when Parent_Typ = Current_Typ;
5084 Current_Typ := Parent_Typ;
5086 end Collect_Parents;
5088 ----------------------------------
5089 -- Collect_Primitive_Operations --
5090 ----------------------------------
5092 function Collect_Primitive_Operations (T : Entity_Id) return Elist_Id is
5093 B_Type : constant Entity_Id := Base_Type (T);
5095 function Match (E : Entity_Id) return Boolean;
5096 -- True if E's base type is B_Type, or E is of an anonymous access type
5097 -- and the base type of its designated type is B_Type.
5103 function Match (E : Entity_Id) return Boolean is
5104 Etyp : Entity_Id := Etype (E);
5107 if Ekind (Etyp) = E_Anonymous_Access_Type then
5108 Etyp := Designated_Type (Etyp);
5111 -- In Ada 2012 a primitive operation may have a formal of an
5112 -- incomplete view of the parent type.
5114 return Base_Type (Etyp) = B_Type
5116 (Ada_Version >= Ada_2012
5117 and then Ekind (Etyp) = E_Incomplete_Type
5118 and then Full_View (Etyp) = B_Type);
5123 B_Decl : constant Node_Id := Original_Node (Parent (B_Type));
5124 B_Scope : Entity_Id := Scope (B_Type);
5126 Eq_Prims_List : Elist_Id := No_Elist;
5129 Is_Type_In_Pkg : Boolean;
5130 Formal_Derived : Boolean := False;
5133 -- Start of processing for Collect_Primitive_Operations
5136 -- For tagged types, the primitive operations are collected as they
5137 -- are declared, and held in an explicit list which is simply returned.
5139 if Is_Tagged_Type (B_Type) then
5140 return Primitive_Operations (B_Type);
5142 -- An untagged generic type that is a derived type inherits the
5143 -- primitive operations of its parent type. Other formal types only
5144 -- have predefined operators, which are not explicitly represented.
5146 elsif Is_Generic_Type (B_Type) then
5147 if Nkind (B_Decl) = N_Formal_Type_Declaration
5148 and then Nkind (Formal_Type_Definition (B_Decl)) =
5149 N_Formal_Derived_Type_Definition
5151 Formal_Derived := True;
5153 return New_Elmt_List;
5157 Op_List := New_Elmt_List;
5159 if B_Scope = Standard_Standard then
5160 if B_Type = Standard_String then
5161 Append_Elmt (Standard_Op_Concat, Op_List);
5163 elsif B_Type = Standard_Wide_String then
5164 Append_Elmt (Standard_Op_Concatw, Op_List);
5170 -- Locate the primitive subprograms of the type
5173 -- The primitive operations appear after the base type, except if the
5174 -- derivation happens within the private part of B_Scope and the type
5175 -- is a private type, in which case both the type and some primitive
5176 -- operations may appear before the base type, and the list of
5177 -- candidates starts after the type.
5179 if In_Open_Scopes (B_Scope)
5180 and then Scope (T) = B_Scope
5181 and then In_Private_Part (B_Scope)
5183 Id := Next_Entity (T);
5185 -- In Ada 2012, If the type has an incomplete partial view, there may
5186 -- be primitive operations declared before the full view, so we need
5187 -- to start scanning from the incomplete view, which is earlier on
5188 -- the entity chain.
5190 elsif Nkind (Parent (B_Type)) = N_Full_Type_Declaration
5191 and then Present (Incomplete_View (Parent (B_Type)))
5193 Id := Defining_Entity (Incomplete_View (Parent (B_Type)));
5195 -- If T is a derived from a type with an incomplete view declared
5196 -- elsewhere, that incomplete view is irrelevant, we want the
5197 -- operations in the scope of T.
5199 if Scope (Id) /= Scope (B_Type) then
5200 Id := Next_Entity (B_Type);
5204 Id := Next_Entity (B_Type);
5207 -- Set flag if this is a type in a package spec
5210 Is_Package_Or_Generic_Package (B_Scope)
5212 Nkind (Parent (Declaration_Node (First_Subtype (T)))) /=
5215 while Present (Id) loop
5217 -- Test whether the result type or any of the parameter types of
5218 -- each subprogram following the type match that type when the
5219 -- type is declared in a package spec, is a derived type, or the
5220 -- subprogram is marked as primitive. (The Is_Primitive test is
5221 -- needed to find primitives of nonderived types in declarative
5222 -- parts that happen to override the predefined "=" operator.)
5224 -- Note that generic formal subprograms are not considered to be
5225 -- primitive operations and thus are never inherited.
5227 if Is_Overloadable (Id)
5228 and then (Is_Type_In_Pkg
5229 or else Is_Derived_Type (B_Type)
5230 or else Is_Primitive (Id))
5231 and then Nkind (Parent (Parent (Id)))
5232 not in N_Formal_Subprogram_Declaration
5240 Formal := First_Formal (Id);
5241 while Present (Formal) loop
5242 if Match (Formal) then
5247 Next_Formal (Formal);
5251 -- For a formal derived type, the only primitives are the ones
5252 -- inherited from the parent type. Operations appearing in the
5253 -- package declaration are not primitive for it.
5256 and then (not Formal_Derived or else Present (Alias (Id)))
5258 -- In the special case of an equality operator aliased to
5259 -- an overriding dispatching equality belonging to the same
5260 -- type, we don't include it in the list of primitives.
5261 -- This avoids inheriting multiple equality operators when
5262 -- deriving from untagged private types whose full type is
5263 -- tagged, which can otherwise cause ambiguities. Note that
5264 -- this should only happen for this kind of untagged parent
5265 -- type, since normally dispatching operations are inherited
5266 -- using the type's Primitive_Operations list.
5268 if Chars (Id) = Name_Op_Eq
5269 and then Is_Dispatching_Operation (Id)
5270 and then Present (Alias (Id))
5271 and then Present (Overridden_Operation (Alias (Id)))
5272 and then Base_Type (Etype (First_Entity (Id))) =
5273 Base_Type (Etype (First_Entity (Alias (Id))))
5277 -- Include the subprogram in the list of primitives
5280 Append_Elmt (Id, Op_List);
5282 -- Save collected equality primitives for later filtering
5283 -- (if we are processing a private type for which we can
5284 -- collect several candidates).
5286 if Inherits_From_Tagged_Full_View (T)
5287 and then Chars (Id) = Name_Op_Eq
5288 and then Etype (First_Formal (Id)) =
5289 Etype (Next_Formal (First_Formal (Id)))
5291 if No (Eq_Prims_List) then
5292 Eq_Prims_List := New_Elmt_List;
5295 Append_Elmt (Id, Eq_Prims_List);
5303 -- For a type declared in System, some of its operations may
5304 -- appear in the target-specific extension to System.
5307 and then B_Scope = RTU_Entity (System)
5308 and then Present_System_Aux
5310 B_Scope := System_Aux_Id;
5311 Id := First_Entity (System_Aux_Id);
5315 -- Filter collected equality primitives
5317 if Inherits_From_Tagged_Full_View (T)
5318 and then Present (Eq_Prims_List)
5321 First : constant Elmt_Id := First_Elmt (Eq_Prims_List);
5325 pragma Assert (No (Next_Elmt (First))
5326 or else No (Next_Elmt (Next_Elmt (First))));
5328 -- No action needed if we have collected a single equality
5331 if Present (Next_Elmt (First)) then
5332 Second := Next_Elmt (First);
5334 if Is_Dispatching_Operation
5335 (Ultimate_Alias (Node (First)))
5337 Remove (Op_List, Node (First));
5339 elsif Is_Dispatching_Operation
5340 (Ultimate_Alias (Node (Second)))
5342 Remove (Op_List, Node (Second));
5345 pragma Assert (False);
5346 raise Program_Error;
5354 end Collect_Primitive_Operations;
5356 -----------------------------------
5357 -- Compile_Time_Constraint_Error --
5358 -----------------------------------
5360 function Compile_Time_Constraint_Error
5363 Ent : Entity_Id := Empty;
5364 Loc : Source_Ptr := No_Location;
5365 Warn : Boolean := False) return Node_Id
5367 Msgc : String (1 .. Msg'Length + 3);
5368 -- Copy of message, with room for possible ?? or << and ! at end
5374 -- Start of processing for Compile_Time_Constraint_Error
5377 -- If this is a warning, convert it into an error if we are in code
5378 -- subject to SPARK_Mode being set On, unless Warn is True to force a
5379 -- warning. The rationale is that a compile-time constraint error should
5380 -- lead to an error instead of a warning when SPARK_Mode is On, but in
5381 -- a few cases we prefer to issue a warning and generate both a suitable
5382 -- run-time error in GNAT and a suitable check message in GNATprove.
5383 -- Those cases are those that likely correspond to deactivated SPARK
5384 -- code, so that this kind of code can be compiled and analyzed instead
5385 -- of being rejected.
5387 Error_Msg_Warn := Warn or SPARK_Mode /= On;
5389 -- A static constraint error in an instance body is not a fatal error.
5390 -- we choose to inhibit the message altogether, because there is no
5391 -- obvious node (for now) on which to post it. On the other hand the
5392 -- offending node must be replaced with a constraint_error in any case.
5394 -- No messages are generated if we already posted an error on this node
5396 if not Error_Posted (N) then
5397 if Loc /= No_Location then
5403 -- Copy message to Msgc, converting any ? in the message into <
5404 -- instead, so that we have an error in GNATprove mode.
5408 for J in 1 .. Msgl loop
5409 if Msg (J) = '?' and then (J = 1 or else Msg (J - 1) /= ''') then
5412 Msgc (J) := Msg (J);
5416 -- Message is a warning, even in Ada 95 case
5418 if Msg (Msg'Last) = '?' or else Msg (Msg'Last) = '<' then
5421 -- In Ada 83, all messages are warnings. In the private part and the
5422 -- body of an instance, constraint_checks are only warnings. We also
5423 -- make this a warning if the Warn parameter is set.
5426 or else (Ada_Version = Ada_83 and then Comes_From_Source (N))
5427 or else In_Instance_Not_Visible
5435 -- Otherwise we have a real error message (Ada 95 static case) and we
5436 -- make this an unconditional message. Note that in the warning case
5437 -- we do not make the message unconditional, it seems reasonable to
5438 -- delete messages like this (about exceptions that will be raised)
5447 -- One more test, skip the warning if the related expression is
5448 -- statically unevaluated, since we don't want to warn about what
5449 -- will happen when something is evaluated if it never will be
5452 if not Is_Statically_Unevaluated (N) then
5453 if Present (Ent) then
5454 Error_Msg_NEL (Msgc (1 .. Msgl), N, Ent, Eloc);
5456 Error_Msg_NEL (Msgc (1 .. Msgl), N, Etype (N), Eloc);
5461 -- Check whether the context is an Init_Proc
5463 if Inside_Init_Proc then
5465 Conc_Typ : constant Entity_Id :=
5466 Corresponding_Concurrent_Type
5467 (Entity (Parameter_Type (First
5468 (Parameter_Specifications
5469 (Parent (Current_Scope))))));
5472 -- Don't complain if the corresponding concurrent type
5473 -- doesn't come from source (i.e. a single task/protected
5476 if Present (Conc_Typ)
5477 and then not Comes_From_Source (Conc_Typ)
5480 ("\& [<<", N, Standard_Constraint_Error, Eloc);
5483 if GNATprove_Mode then
5485 ("\& would have been raised for objects of this "
5486 & "type", N, Standard_Constraint_Error, Eloc);
5489 ("\& will be raised for objects of this type??",
5490 N, Standard_Constraint_Error, Eloc);
5496 Error_Msg_NEL ("\& [<<", N, Standard_Constraint_Error, Eloc);
5500 Error_Msg ("\static expression fails Constraint_Check", Eloc);
5501 Set_Error_Posted (N);
5507 end Compile_Time_Constraint_Error;
5509 -----------------------
5510 -- Conditional_Delay --
5511 -----------------------
5513 procedure Conditional_Delay (New_Ent, Old_Ent : Entity_Id) is
5515 if Has_Delayed_Freeze (Old_Ent) and then not Is_Frozen (Old_Ent) then
5516 Set_Has_Delayed_Freeze (New_Ent);
5518 end Conditional_Delay;
5520 -------------------------
5521 -- Copy_Component_List --
5522 -------------------------
5524 function Copy_Component_List
5526 Loc : Source_Ptr) return List_Id
5529 Comps : constant List_Id := New_List;
5532 Comp := First_Component (Underlying_Type (R_Typ));
5533 while Present (Comp) loop
5534 if Comes_From_Source (Comp) then
5536 Comp_Decl : constant Node_Id := Declaration_Node (Comp);
5539 Make_Component_Declaration (Loc,
5540 Defining_Identifier =>
5541 Make_Defining_Identifier (Loc, Chars (Comp)),
5542 Component_Definition =>
5544 (Component_Definition (Comp_Decl), New_Sloc => Loc)));
5548 Next_Component (Comp);
5552 end Copy_Component_List;
5554 -------------------------
5555 -- Copy_Parameter_List --
5556 -------------------------
5558 function Copy_Parameter_List (Subp_Id : Entity_Id) return List_Id is
5559 Loc : constant Source_Ptr := Sloc (Subp_Id);
5564 if No (First_Formal (Subp_Id)) then
5568 Formal := First_Formal (Subp_Id);
5569 while Present (Formal) loop
5571 Make_Parameter_Specification (Loc,
5572 Defining_Identifier =>
5573 Make_Defining_Identifier (Sloc (Formal), Chars (Formal)),
5574 In_Present => In_Present (Parent (Formal)),
5575 Out_Present => Out_Present (Parent (Formal)),
5577 New_Occurrence_Of (Etype (Formal), Loc),
5579 New_Copy_Tree (Expression (Parent (Formal)))));
5581 Next_Formal (Formal);
5586 end Copy_Parameter_List;
5588 ----------------------------
5589 -- Copy_SPARK_Mode_Aspect --
5590 ----------------------------
5592 procedure Copy_SPARK_Mode_Aspect (From : Node_Id; To : Node_Id) is
5593 pragma Assert (not Has_Aspects (To));
5597 if Has_Aspects (From) then
5598 Asp := Find_Aspect (Defining_Entity (From), Aspect_SPARK_Mode);
5600 if Present (Asp) then
5601 Set_Aspect_Specifications (To, New_List (New_Copy_Tree (Asp)));
5602 Set_Has_Aspects (To, True);
5605 end Copy_SPARK_Mode_Aspect;
5607 --------------------------
5608 -- Copy_Subprogram_Spec --
5609 --------------------------
5611 function Copy_Subprogram_Spec (Spec : Node_Id) return Node_Id is
5613 Formal_Spec : Node_Id;
5617 -- The structure of the original tree must be replicated without any
5618 -- alterations. Use New_Copy_Tree for this purpose.
5620 Result := New_Copy_Tree (Spec);
5622 -- However, the spec of a null procedure carries the corresponding null
5623 -- statement of the body (created by the parser), and this cannot be
5624 -- shared with the new subprogram spec.
5626 if Nkind (Result) = N_Procedure_Specification then
5627 Set_Null_Statement (Result, Empty);
5630 -- Create a new entity for the defining unit name
5632 Def_Id := Defining_Unit_Name (Result);
5633 Set_Defining_Unit_Name (Result,
5634 Make_Defining_Identifier (Sloc (Def_Id), Chars (Def_Id)));
5636 -- Create new entities for the formal parameters
5638 if Present (Parameter_Specifications (Result)) then
5639 Formal_Spec := First (Parameter_Specifications (Result));
5640 while Present (Formal_Spec) loop
5641 Def_Id := Defining_Identifier (Formal_Spec);
5642 Set_Defining_Identifier (Formal_Spec,
5643 Make_Defining_Identifier (Sloc (Def_Id), Chars (Def_Id)));
5650 end Copy_Subprogram_Spec;
5652 --------------------------------
5653 -- Corresponding_Generic_Type --
5654 --------------------------------
5656 function Corresponding_Generic_Type (T : Entity_Id) return Entity_Id is
5662 if not Is_Generic_Actual_Type (T) then
5665 -- If the actual is the actual of an enclosing instance, resolution
5666 -- was correct in the generic.
5668 elsif Nkind (Parent (T)) = N_Subtype_Declaration
5669 and then Is_Entity_Name (Subtype_Indication (Parent (T)))
5671 Is_Generic_Actual_Type (Entity (Subtype_Indication (Parent (T))))
5678 if Is_Wrapper_Package (Inst) then
5679 Inst := Related_Instance (Inst);
5684 (Specification (Unit_Declaration_Node (Inst)));
5686 -- Generic actual has the same name as the corresponding formal
5688 Typ := First_Entity (Gen);
5689 while Present (Typ) loop
5690 if Chars (Typ) = Chars (T) then
5699 end Corresponding_Generic_Type;
5701 --------------------
5702 -- Current_Entity --
5703 --------------------
5705 -- The currently visible definition for a given identifier is the
5706 -- one most chained at the start of the visibility chain, i.e. the
5707 -- one that is referenced by the Node_Id value of the name of the
5708 -- given identifier.
5710 function Current_Entity (N : Node_Id) return Entity_Id is
5712 return Get_Name_Entity_Id (Chars (N));
5715 -----------------------------
5716 -- Current_Entity_In_Scope --
5717 -----------------------------
5719 function Current_Entity_In_Scope (N : Node_Id) return Entity_Id is
5721 CS : constant Entity_Id := Current_Scope;
5723 Transient_Case : constant Boolean := Scope_Is_Transient;
5726 E := Get_Name_Entity_Id (Chars (N));
5728 and then Scope (E) /= CS
5729 and then (not Transient_Case or else Scope (E) /= Scope (CS))
5735 end Current_Entity_In_Scope;
5741 function Current_Scope return Entity_Id is
5743 if Scope_Stack.Last = -1 then
5744 return Standard_Standard;
5747 C : constant Entity_Id :=
5748 Scope_Stack.Table (Scope_Stack.Last).Entity;
5753 return Standard_Standard;
5759 ----------------------------
5760 -- Current_Scope_No_Loops --
5761 ----------------------------
5763 function Current_Scope_No_Loops return Entity_Id is
5767 -- Examine the scope stack starting from the current scope and skip any
5768 -- internally generated loops.
5771 while Present (S) and then S /= Standard_Standard loop
5772 if Ekind (S) = E_Loop and then not Comes_From_Source (S) then
5780 end Current_Scope_No_Loops;
5782 ------------------------
5783 -- Current_Subprogram --
5784 ------------------------
5786 function Current_Subprogram return Entity_Id is
5787 Scop : constant Entity_Id := Current_Scope;
5789 if Is_Subprogram_Or_Generic_Subprogram (Scop) then
5792 return Enclosing_Subprogram (Scop);
5794 end Current_Subprogram;
5796 ----------------------------------
5797 -- Deepest_Type_Access_Level --
5798 ----------------------------------
5800 function Deepest_Type_Access_Level (Typ : Entity_Id) return Uint is
5802 if Ekind (Typ) = E_Anonymous_Access_Type
5803 and then not Is_Local_Anonymous_Access (Typ)
5804 and then Nkind (Associated_Node_For_Itype (Typ)) = N_Object_Declaration
5806 -- Typ is the type of an Ada 2012 stand-alone object of an anonymous
5810 Scope_Depth (Enclosing_Dynamic_Scope
5811 (Defining_Identifier
5812 (Associated_Node_For_Itype (Typ))));
5814 -- For generic formal type, return Int'Last (infinite).
5815 -- See comment preceding Is_Generic_Type call in Type_Access_Level.
5817 elsif Is_Generic_Type (Root_Type (Typ)) then
5818 return UI_From_Int (Int'Last);
5821 return Type_Access_Level (Typ);
5823 end Deepest_Type_Access_Level;
5825 ---------------------
5826 -- Defining_Entity --
5827 ---------------------
5829 function Defining_Entity
5831 Empty_On_Errors : Boolean := False;
5832 Concurrent_Subunit : Boolean := False) return Entity_Id
5836 when N_Abstract_Subprogram_Declaration
5837 | N_Expression_Function
5838 | N_Formal_Subprogram_Declaration
5839 | N_Generic_Package_Declaration
5840 | N_Generic_Subprogram_Declaration
5841 | N_Package_Declaration
5843 | N_Subprogram_Body_Stub
5844 | N_Subprogram_Declaration
5845 | N_Subprogram_Renaming_Declaration
5847 return Defining_Entity (Specification (N));
5849 when N_Component_Declaration
5850 | N_Defining_Program_Unit_Name
5851 | N_Discriminant_Specification
5853 | N_Entry_Declaration
5854 | N_Entry_Index_Specification
5855 | N_Exception_Declaration
5856 | N_Exception_Renaming_Declaration
5857 | N_Formal_Object_Declaration
5858 | N_Formal_Package_Declaration
5859 | N_Formal_Type_Declaration
5860 | N_Full_Type_Declaration
5861 | N_Implicit_Label_Declaration
5862 | N_Incomplete_Type_Declaration
5863 | N_Iterator_Specification
5864 | N_Loop_Parameter_Specification
5865 | N_Number_Declaration
5866 | N_Object_Declaration
5867 | N_Object_Renaming_Declaration
5868 | N_Package_Body_Stub
5869 | N_Parameter_Specification
5870 | N_Private_Extension_Declaration
5871 | N_Private_Type_Declaration
5873 | N_Protected_Body_Stub
5874 | N_Protected_Type_Declaration
5875 | N_Single_Protected_Declaration
5876 | N_Single_Task_Declaration
5877 | N_Subtype_Declaration
5880 | N_Task_Type_Declaration
5882 return Defining_Identifier (N);
5886 Bod : constant Node_Id := Proper_Body (N);
5887 Orig_Bod : constant Node_Id := Original_Node (Bod);
5890 -- Retrieve the entity of the original protected or task body
5891 -- if requested by the caller.
5893 if Concurrent_Subunit
5894 and then Nkind (Bod) = N_Null_Statement
5895 and then Nkind_In (Orig_Bod, N_Protected_Body, N_Task_Body)
5897 return Defining_Entity (Orig_Bod);
5899 return Defining_Entity (Bod);
5903 when N_Function_Instantiation
5904 | N_Function_Specification
5905 | N_Generic_Function_Renaming_Declaration
5906 | N_Generic_Package_Renaming_Declaration
5907 | N_Generic_Procedure_Renaming_Declaration
5909 | N_Package_Instantiation
5910 | N_Package_Renaming_Declaration
5911 | N_Package_Specification
5912 | N_Procedure_Instantiation
5913 | N_Procedure_Specification
5916 Nam : constant Node_Id := Defining_Unit_Name (N);
5917 Err : Entity_Id := Empty;
5920 if Nkind (Nam) in N_Entity then
5923 -- For Error, make up a name and attach to declaration so we
5924 -- can continue semantic analysis.
5926 elsif Nam = Error then
5927 if Empty_On_Errors then
5930 Err := Make_Temporary (Sloc (N), 'T');
5931 Set_Defining_Unit_Name (N, Err);
5936 -- If not an entity, get defining identifier
5939 return Defining_Identifier (Nam);
5943 when N_Block_Statement
5946 return Entity (Identifier (N));
5949 if Empty_On_Errors then
5952 raise Program_Error;
5955 end Defining_Entity;
5957 --------------------------
5958 -- Denotes_Discriminant --
5959 --------------------------
5961 function Denotes_Discriminant
5963 Check_Concurrent : Boolean := False) return Boolean
5968 if not Is_Entity_Name (N) or else No (Entity (N)) then
5974 -- If we are checking for a protected type, the discriminant may have
5975 -- been rewritten as the corresponding discriminal of the original type
5976 -- or of the corresponding concurrent record, depending on whether we
5977 -- are in the spec or body of the protected type.
5979 return Ekind (E) = E_Discriminant
5982 and then Ekind (E) = E_In_Parameter
5983 and then Present (Discriminal_Link (E))
5985 (Is_Concurrent_Type (Scope (Discriminal_Link (E)))
5987 Is_Concurrent_Record_Type (Scope (Discriminal_Link (E)))));
5988 end Denotes_Discriminant;
5990 -------------------------
5991 -- Denotes_Same_Object --
5992 -------------------------
5994 function Denotes_Same_Object (A1, A2 : Node_Id) return Boolean is
5995 function Is_Renaming (N : Node_Id) return Boolean;
5996 -- Return true if N names a renaming entity
5998 function Is_Valid_Renaming (N : Node_Id) return Boolean;
5999 -- For renamings, return False if the prefix of any dereference within
6000 -- the renamed object_name is a variable, or any expression within the
6001 -- renamed object_name contains references to variables or calls on
6002 -- nonstatic functions; otherwise return True (RM 6.4.1(6.10/3))
6008 function Is_Renaming (N : Node_Id) return Boolean is
6011 Is_Entity_Name (N) and then Present (Renamed_Entity (Entity (N)));
6014 -----------------------
6015 -- Is_Valid_Renaming --
6016 -----------------------
6018 function Is_Valid_Renaming (N : Node_Id) return Boolean is
6019 function Check_Renaming (N : Node_Id) return Boolean;
6020 -- Recursive function used to traverse all the prefixes of N
6022 --------------------
6023 -- Check_Renaming --
6024 --------------------
6026 function Check_Renaming (N : Node_Id) return Boolean is
6029 and then not Check_Renaming (Renamed_Entity (Entity (N)))
6034 if Nkind (N) = N_Indexed_Component then
6039 Indx := First (Expressions (N));
6040 while Present (Indx) loop
6041 if not Is_OK_Static_Expression (Indx) then
6050 if Has_Prefix (N) then
6052 P : constant Node_Id := Prefix (N);
6055 if Nkind (N) = N_Explicit_Dereference
6056 and then Is_Variable (P)
6060 elsif Is_Entity_Name (P)
6061 and then Ekind (Entity (P)) = E_Function
6065 elsif Nkind (P) = N_Function_Call then
6069 -- Recursion to continue traversing the prefix of the
6070 -- renaming expression
6072 return Check_Renaming (P);
6079 -- Start of processing for Is_Valid_Renaming
6082 return Check_Renaming (N);
6083 end Is_Valid_Renaming;
6087 Obj1 : Node_Id := A1;
6088 Obj2 : Node_Id := A2;
6090 -- Start of processing for Denotes_Same_Object
6093 -- Both names statically denote the same stand-alone object or parameter
6094 -- (RM 6.4.1(6.5/3))
6096 if Is_Entity_Name (Obj1)
6097 and then Is_Entity_Name (Obj2)
6098 and then Entity (Obj1) = Entity (Obj2)
6103 -- For renamings, the prefix of any dereference within the renamed
6104 -- object_name is not a variable, and any expression within the
6105 -- renamed object_name contains no references to variables nor
6106 -- calls on nonstatic functions (RM 6.4.1(6.10/3)).
6108 if Is_Renaming (Obj1) then
6109 if Is_Valid_Renaming (Obj1) then
6110 Obj1 := Renamed_Entity (Entity (Obj1));
6116 if Is_Renaming (Obj2) then
6117 if Is_Valid_Renaming (Obj2) then
6118 Obj2 := Renamed_Entity (Entity (Obj2));
6124 -- No match if not same node kind (such cases are handled by
6125 -- Denotes_Same_Prefix)
6127 if Nkind (Obj1) /= Nkind (Obj2) then
6130 -- After handling valid renamings, one of the two names statically
6131 -- denoted a renaming declaration whose renamed object_name is known
6132 -- to denote the same object as the other (RM 6.4.1(6.10/3))
6134 elsif Is_Entity_Name (Obj1) then
6135 if Is_Entity_Name (Obj2) then
6136 return Entity (Obj1) = Entity (Obj2);
6141 -- Both names are selected_components, their prefixes are known to
6142 -- denote the same object, and their selector_names denote the same
6143 -- component (RM 6.4.1(6.6/3)).
6145 elsif Nkind (Obj1) = N_Selected_Component then
6146 return Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2))
6148 Entity (Selector_Name (Obj1)) = Entity (Selector_Name (Obj2));
6150 -- Both names are dereferences and the dereferenced names are known to
6151 -- denote the same object (RM 6.4.1(6.7/3))
6153 elsif Nkind (Obj1) = N_Explicit_Dereference then
6154 return Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2));
6156 -- Both names are indexed_components, their prefixes are known to denote
6157 -- the same object, and each of the pairs of corresponding index values
6158 -- are either both static expressions with the same static value or both
6159 -- names that are known to denote the same object (RM 6.4.1(6.8/3))
6161 elsif Nkind (Obj1) = N_Indexed_Component then
6162 if not Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2)) then
6170 Indx1 := First (Expressions (Obj1));
6171 Indx2 := First (Expressions (Obj2));
6172 while Present (Indx1) loop
6174 -- Indexes must denote the same static value or same object
6176 if Is_OK_Static_Expression (Indx1) then
6177 if not Is_OK_Static_Expression (Indx2) then
6180 elsif Expr_Value (Indx1) /= Expr_Value (Indx2) then
6184 elsif not Denotes_Same_Object (Indx1, Indx2) then
6196 -- Both names are slices, their prefixes are known to denote the same
6197 -- object, and the two slices have statically matching index constraints
6198 -- (RM 6.4.1(6.9/3))
6200 elsif Nkind (Obj1) = N_Slice
6201 and then Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2))
6204 Lo1, Lo2, Hi1, Hi2 : Node_Id;
6207 Get_Index_Bounds (Etype (Obj1), Lo1, Hi1);
6208 Get_Index_Bounds (Etype (Obj2), Lo2, Hi2);
6210 -- Check whether bounds are statically identical. There is no
6211 -- attempt to detect partial overlap of slices.
6213 return Denotes_Same_Object (Lo1, Lo2)
6215 Denotes_Same_Object (Hi1, Hi2);
6218 -- In the recursion, literals appear as indexes
6220 elsif Nkind (Obj1) = N_Integer_Literal
6222 Nkind (Obj2) = N_Integer_Literal
6224 return Intval (Obj1) = Intval (Obj2);
6229 end Denotes_Same_Object;
6231 -------------------------
6232 -- Denotes_Same_Prefix --
6233 -------------------------
6235 function Denotes_Same_Prefix (A1, A2 : Node_Id) return Boolean is
6237 if Is_Entity_Name (A1) then
6238 if Nkind_In (A2, N_Selected_Component, N_Indexed_Component)
6239 and then not Is_Access_Type (Etype (A1))
6241 return Denotes_Same_Object (A1, Prefix (A2))
6242 or else Denotes_Same_Prefix (A1, Prefix (A2));
6247 elsif Is_Entity_Name (A2) then
6248 return Denotes_Same_Prefix (A1 => A2, A2 => A1);
6250 elsif Nkind_In (A1, N_Selected_Component, N_Indexed_Component, N_Slice)
6252 Nkind_In (A2, N_Selected_Component, N_Indexed_Component, N_Slice)
6255 Root1, Root2 : Node_Id;
6256 Depth1, Depth2 : Nat := 0;
6259 Root1 := Prefix (A1);
6260 while not Is_Entity_Name (Root1) loop
6262 (Root1, N_Selected_Component, N_Indexed_Component)
6266 Root1 := Prefix (Root1);
6269 Depth1 := Depth1 + 1;
6272 Root2 := Prefix (A2);
6273 while not Is_Entity_Name (Root2) loop
6274 if not Nkind_In (Root2, N_Selected_Component,
6275 N_Indexed_Component)
6279 Root2 := Prefix (Root2);
6282 Depth2 := Depth2 + 1;
6285 -- If both have the same depth and they do not denote the same
6286 -- object, they are disjoint and no warning is needed.
6288 if Depth1 = Depth2 then
6291 elsif Depth1 > Depth2 then
6292 Root1 := Prefix (A1);
6293 for J in 1 .. Depth1 - Depth2 - 1 loop
6294 Root1 := Prefix (Root1);
6297 return Denotes_Same_Object (Root1, A2);
6300 Root2 := Prefix (A2);
6301 for J in 1 .. Depth2 - Depth1 - 1 loop
6302 Root2 := Prefix (Root2);
6305 return Denotes_Same_Object (A1, Root2);
6312 end Denotes_Same_Prefix;
6314 ----------------------
6315 -- Denotes_Variable --
6316 ----------------------
6318 function Denotes_Variable (N : Node_Id) return Boolean is
6320 return Is_Variable (N) and then Paren_Count (N) = 0;
6321 end Denotes_Variable;
6323 -----------------------------
6324 -- Depends_On_Discriminant --
6325 -----------------------------
6327 function Depends_On_Discriminant (N : Node_Id) return Boolean is
6332 Get_Index_Bounds (N, L, H);
6333 return Denotes_Discriminant (L) or else Denotes_Discriminant (H);
6334 end Depends_On_Discriminant;
6336 -------------------------
6337 -- Designate_Same_Unit --
6338 -------------------------
6340 function Designate_Same_Unit
6342 Name2 : Node_Id) return Boolean
6344 K1 : constant Node_Kind := Nkind (Name1);
6345 K2 : constant Node_Kind := Nkind (Name2);
6347 function Prefix_Node (N : Node_Id) return Node_Id;
6348 -- Returns the parent unit name node of a defining program unit name
6349 -- or the prefix if N is a selected component or an expanded name.
6351 function Select_Node (N : Node_Id) return Node_Id;
6352 -- Returns the defining identifier node of a defining program unit
6353 -- name or the selector node if N is a selected component or an
6360 function Prefix_Node (N : Node_Id) return Node_Id is
6362 if Nkind (N) = N_Defining_Program_Unit_Name then
6373 function Select_Node (N : Node_Id) return Node_Id is
6375 if Nkind (N) = N_Defining_Program_Unit_Name then
6376 return Defining_Identifier (N);
6378 return Selector_Name (N);
6382 -- Start of processing for Designate_Same_Unit
6385 if Nkind_In (K1, N_Identifier, N_Defining_Identifier)
6387 Nkind_In (K2, N_Identifier, N_Defining_Identifier)
6389 return Chars (Name1) = Chars (Name2);
6391 elsif Nkind_In (K1, N_Expanded_Name,
6392 N_Selected_Component,
6393 N_Defining_Program_Unit_Name)
6395 Nkind_In (K2, N_Expanded_Name,
6396 N_Selected_Component,
6397 N_Defining_Program_Unit_Name)
6400 (Chars (Select_Node (Name1)) = Chars (Select_Node (Name2)))
6402 Designate_Same_Unit (Prefix_Node (Name1), Prefix_Node (Name2));
6407 end Designate_Same_Unit;
6409 ---------------------------------------------
6410 -- Diagnose_Iterated_Component_Association --
6411 ---------------------------------------------
6413 procedure Diagnose_Iterated_Component_Association (N : Node_Id) is
6414 Def_Id : constant Entity_Id := Defining_Identifier (N);
6418 -- Determine whether the iterated component association appears within
6419 -- an aggregate. If this is the case, raise Program_Error because the
6420 -- iterated component association cannot be left in the tree as is and
6421 -- must always be processed by the related aggregate.
6424 while Present (Aggr) loop
6425 if Nkind (Aggr) = N_Aggregate then
6426 raise Program_Error;
6428 -- Prevent the search from going too far
6430 elsif Is_Body_Or_Package_Declaration (Aggr) then
6434 Aggr := Parent (Aggr);
6437 -- At this point it is known that the iterated component association is
6438 -- not within an aggregate. This is really a quantified expression with
6439 -- a missing "all" or "some" quantifier.
6441 Error_Msg_N ("missing quantifier", Def_Id);
6443 -- Rewrite the iterated component association as True to prevent any
6446 Rewrite (N, New_Occurrence_Of (Standard_True, Sloc (N)));
6448 end Diagnose_Iterated_Component_Association;
6450 ---------------------------------
6451 -- Dynamic_Accessibility_Level --
6452 ---------------------------------
6454 function Dynamic_Accessibility_Level (N : Node_Id) return Node_Id is
6455 Loc : constant Source_Ptr := Sloc (N);
6457 function Make_Level_Literal (Level : Uint) return Node_Id;
6458 -- Construct an integer literal representing an accessibility level
6459 -- with its type set to Natural.
6461 ------------------------
6462 -- Make_Level_Literal --
6463 ------------------------
6465 function Make_Level_Literal (Level : Uint) return Node_Id is
6466 Result : constant Node_Id := Make_Integer_Literal (Loc, Level);
6469 Set_Etype (Result, Standard_Natural);
6471 end Make_Level_Literal;
6475 Expr : constant Node_Id := Original_Node (N);
6476 -- Expr references the original node because at this stage N may be the
6477 -- reference to a variable internally created by the frontend to remove
6478 -- side effects of an expression.
6482 -- Start of processing for Dynamic_Accessibility_Level
6485 if Is_Entity_Name (Expr) then
6488 if Present (Renamed_Object (E)) then
6489 return Dynamic_Accessibility_Level (Renamed_Object (E));
6492 if Is_Formal (E) or else Ekind_In (E, E_Variable, E_Constant) then
6493 if Present (Extra_Accessibility (E)) then
6494 return New_Occurrence_Of (Extra_Accessibility (E), Loc);
6499 -- Unimplemented: Ptr.all'Access, where Ptr has Extra_Accessibility ???
6501 case Nkind (Expr) is
6503 -- For access discriminant, the level of the enclosing object
6505 when N_Selected_Component =>
6506 if Ekind (Entity (Selector_Name (Expr))) = E_Discriminant
6507 and then Ekind (Etype (Entity (Selector_Name (Expr)))) =
6508 E_Anonymous_Access_Type
6510 return Make_Level_Literal (Object_Access_Level (Expr));
6513 when N_Attribute_Reference =>
6514 case Get_Attribute_Id (Attribute_Name (Expr)) is
6516 -- For X'Access, the level of the prefix X
6518 when Attribute_Access =>
6519 return Make_Level_Literal
6520 (Object_Access_Level (Prefix (Expr)));
6522 -- Treat the unchecked attributes as library-level
6524 when Attribute_Unchecked_Access
6525 | Attribute_Unrestricted_Access
6527 return Make_Level_Literal (Scope_Depth (Standard_Standard));
6529 -- No other access-valued attributes
6532 raise Program_Error;
6537 -- This is not fully implemented since it depends on context (see
6538 -- 3.10.2(14/3-14.2/3). More work is needed in the following cases
6540 -- 1) For an anonymous allocator defining the value of an access
6541 -- parameter, the accessibility level is that of the innermost
6542 -- master of the call; however currently we pass the level of
6543 -- execution of the called subprogram, which is one greater
6544 -- than the current scope level (see Expand_Call_Helper).
6546 -- For example, a statement is a master and a declaration is
6547 -- not a master; so we should not pass in the same level for
6548 -- the following cases:
6550 -- function F (X : access Integer) return T is ... ;
6551 -- Decl : T := F (new Integer); -- level is off by one
6553 -- Decl := F (new Integer); -- we get this case right
6555 -- 2) For an anonymous allocator that defines the result of a
6556 -- function with an access result, the accessibility level is
6557 -- determined as though the allocator were in place of the call
6558 -- of the function. In the special case of a call that is the
6559 -- operand of a type conversion the level is that of the target
6560 -- access type of the conversion.
6562 -- 3) For an anonymous allocator defining an access discriminant
6563 -- the accessibility level is determined as follows:
6564 -- * for an allocator used to define the discriminant of an
6565 -- object, the level of the object
6566 -- * for an allocator used to define the constraint in a
6567 -- subtype_indication in any other context, the level of
6568 -- the master that elaborates the subtype_indication.
6570 case Nkind (Parent (N)) is
6571 when N_Object_Declaration =>
6573 -- For an anonymous allocator whose type is that of a
6574 -- stand-alone object of an anonymous access-to-object type,
6575 -- the accessibility level is that of the declaration of the
6576 -- stand-alone object.
6580 (Object_Access_Level
6581 (Defining_Identifier (Parent (N))));
6583 when N_Assignment_Statement =>
6586 (Object_Access_Level (Name (Parent (N))));
6590 S : constant String :=
6591 Node_Kind'Image (Nkind (Parent (N)));
6593 Error_Msg_Strlen := S'Length;
6594 Error_Msg_String (1 .. Error_Msg_Strlen) := S;
6596 ("unsupported context for anonymous allocator (~)",
6601 when N_Type_Conversion =>
6602 if not Is_Local_Anonymous_Access (Etype (Expr)) then
6604 -- Handle type conversions introduced for a rename of an
6605 -- Ada 2012 stand-alone object of an anonymous access type.
6607 return Dynamic_Accessibility_Level (Expression (Expr));
6614 return Make_Level_Literal (Type_Access_Level (Etype (Expr)));
6615 end Dynamic_Accessibility_Level;
6617 ------------------------
6618 -- Discriminated_Size --
6619 ------------------------
6621 function Discriminated_Size (Comp : Entity_Id) return Boolean is
6622 function Non_Static_Bound (Bound : Node_Id) return Boolean;
6623 -- Check whether the bound of an index is non-static and does denote
6624 -- a discriminant, in which case any object of the type (protected or
6625 -- otherwise) will have a non-static size.
6627 ----------------------
6628 -- Non_Static_Bound --
6629 ----------------------
6631 function Non_Static_Bound (Bound : Node_Id) return Boolean is
6633 if Is_OK_Static_Expression (Bound) then
6636 -- If the bound is given by a discriminant it is non-static
6637 -- (A static constraint replaces the reference with the value).
6638 -- In an protected object the discriminant has been replaced by
6639 -- the corresponding discriminal within the protected operation.
6641 elsif Is_Entity_Name (Bound)
6643 (Ekind (Entity (Bound)) = E_Discriminant
6644 or else Present (Discriminal_Link (Entity (Bound))))
6651 end Non_Static_Bound;
6655 Typ : constant Entity_Id := Etype (Comp);
6658 -- Start of processing for Discriminated_Size
6661 if not Is_Array_Type (Typ) then
6665 if Ekind (Typ) = E_Array_Subtype then
6666 Index := First_Index (Typ);
6667 while Present (Index) loop
6668 if Non_Static_Bound (Low_Bound (Index))
6669 or else Non_Static_Bound (High_Bound (Index))
6681 end Discriminated_Size;
6683 -----------------------------------
6684 -- Effective_Extra_Accessibility --
6685 -----------------------------------
6687 function Effective_Extra_Accessibility (Id : Entity_Id) return Entity_Id is
6689 if Present (Renamed_Object (Id))
6690 and then Is_Entity_Name (Renamed_Object (Id))
6692 return Effective_Extra_Accessibility (Entity (Renamed_Object (Id)));
6694 return Extra_Accessibility (Id);
6696 end Effective_Extra_Accessibility;
6698 -----------------------------
6699 -- Effective_Reads_Enabled --
6700 -----------------------------
6702 function Effective_Reads_Enabled (Id : Entity_Id) return Boolean is
6704 return Has_Enabled_Property (Id, Name_Effective_Reads);
6705 end Effective_Reads_Enabled;
6707 ------------------------------
6708 -- Effective_Writes_Enabled --
6709 ------------------------------
6711 function Effective_Writes_Enabled (Id : Entity_Id) return Boolean is
6713 return Has_Enabled_Property (Id, Name_Effective_Writes);
6714 end Effective_Writes_Enabled;
6716 ------------------------------
6717 -- Enclosing_Comp_Unit_Node --
6718 ------------------------------
6720 function Enclosing_Comp_Unit_Node (N : Node_Id) return Node_Id is
6721 Current_Node : Node_Id;
6725 while Present (Current_Node)
6726 and then Nkind (Current_Node) /= N_Compilation_Unit
6728 Current_Node := Parent (Current_Node);
6731 if Nkind (Current_Node) /= N_Compilation_Unit then
6734 return Current_Node;
6736 end Enclosing_Comp_Unit_Node;
6738 --------------------------
6739 -- Enclosing_CPP_Parent --
6740 --------------------------
6742 function Enclosing_CPP_Parent (Typ : Entity_Id) return Entity_Id is
6743 Parent_Typ : Entity_Id := Typ;
6746 while not Is_CPP_Class (Parent_Typ)
6747 and then Etype (Parent_Typ) /= Parent_Typ
6749 Parent_Typ := Etype (Parent_Typ);
6751 if Is_Private_Type (Parent_Typ) then
6752 Parent_Typ := Full_View (Base_Type (Parent_Typ));
6756 pragma Assert (Is_CPP_Class (Parent_Typ));
6758 end Enclosing_CPP_Parent;
6760 ---------------------------
6761 -- Enclosing_Declaration --
6762 ---------------------------
6764 function Enclosing_Declaration (N : Node_Id) return Node_Id is
6765 Decl : Node_Id := N;
6768 while Present (Decl)
6769 and then not (Nkind (Decl) in N_Declaration
6771 Nkind (Decl) in N_Later_Decl_Item
6773 Nkind (Decl) = N_Number_Declaration)
6775 Decl := Parent (Decl);
6779 end Enclosing_Declaration;
6781 ----------------------------
6782 -- Enclosing_Generic_Body --
6783 ----------------------------
6785 function Enclosing_Generic_Body (N : Node_Id) return Node_Id is
6787 Spec_Id : Entity_Id;
6791 while Present (Par) loop
6792 if Nkind_In (Par, N_Package_Body, N_Subprogram_Body) then
6793 Spec_Id := Corresponding_Spec (Par);
6795 if Present (Spec_Id)
6796 and then Nkind_In (Unit_Declaration_Node (Spec_Id),
6797 N_Generic_Package_Declaration,
6798 N_Generic_Subprogram_Declaration)
6804 Par := Parent (Par);
6808 end Enclosing_Generic_Body;
6810 ----------------------------
6811 -- Enclosing_Generic_Unit --
6812 ----------------------------
6814 function Enclosing_Generic_Unit (N : Node_Id) return Node_Id is
6816 Spec_Decl : Node_Id;
6817 Spec_Id : Entity_Id;
6821 while Present (Par) loop
6822 if Nkind_In (Par, N_Generic_Package_Declaration,
6823 N_Generic_Subprogram_Declaration)
6827 elsif Nkind_In (Par, N_Package_Body, N_Subprogram_Body) then
6828 Spec_Id := Corresponding_Spec (Par);
6830 if Present (Spec_Id) then
6831 Spec_Decl := Unit_Declaration_Node (Spec_Id);
6833 if Nkind_In (Spec_Decl, N_Generic_Package_Declaration,
6834 N_Generic_Subprogram_Declaration)
6841 Par := Parent (Par);
6845 end Enclosing_Generic_Unit;
6847 -------------------------------
6848 -- Enclosing_Lib_Unit_Entity --
6849 -------------------------------
6851 function Enclosing_Lib_Unit_Entity
6852 (E : Entity_Id := Current_Scope) return Entity_Id
6854 Unit_Entity : Entity_Id;
6857 -- Look for enclosing library unit entity by following scope links.
6858 -- Equivalent to, but faster than indexing through the scope stack.
6861 while (Present (Scope (Unit_Entity))
6862 and then Scope (Unit_Entity) /= Standard_Standard)
6863 and not Is_Child_Unit (Unit_Entity)
6865 Unit_Entity := Scope (Unit_Entity);
6869 end Enclosing_Lib_Unit_Entity;
6871 -----------------------------
6872 -- Enclosing_Lib_Unit_Node --
6873 -----------------------------
6875 function Enclosing_Lib_Unit_Node (N : Node_Id) return Node_Id is
6876 Encl_Unit : Node_Id;
6879 Encl_Unit := Enclosing_Comp_Unit_Node (N);
6880 while Present (Encl_Unit)
6881 and then Nkind (Unit (Encl_Unit)) = N_Subunit
6883 Encl_Unit := Library_Unit (Encl_Unit);
6886 pragma Assert (Nkind (Encl_Unit) = N_Compilation_Unit);
6888 end Enclosing_Lib_Unit_Node;
6890 -----------------------
6891 -- Enclosing_Package --
6892 -----------------------
6894 function Enclosing_Package (E : Entity_Id) return Entity_Id is
6895 Dynamic_Scope : constant Entity_Id := Enclosing_Dynamic_Scope (E);
6898 if Dynamic_Scope = Standard_Standard then
6899 return Standard_Standard;
6901 elsif Dynamic_Scope = Empty then
6904 elsif Ekind_In (Dynamic_Scope, E_Generic_Package,
6908 return Dynamic_Scope;
6911 return Enclosing_Package (Dynamic_Scope);
6913 end Enclosing_Package;
6915 -------------------------------------
6916 -- Enclosing_Package_Or_Subprogram --
6917 -------------------------------------
6919 function Enclosing_Package_Or_Subprogram (E : Entity_Id) return Entity_Id is
6924 while Present (S) loop
6925 if Is_Package_Or_Generic_Package (S)
6926 or else Is_Subprogram_Or_Generic_Subprogram (S)
6936 end Enclosing_Package_Or_Subprogram;
6938 --------------------------
6939 -- Enclosing_Subprogram --
6940 --------------------------
6942 function Enclosing_Subprogram (E : Entity_Id) return Entity_Id is
6943 Dyn_Scop : constant Entity_Id := Enclosing_Dynamic_Scope (E);
6946 if Dyn_Scop = Standard_Standard then
6949 elsif Dyn_Scop = Empty then
6952 elsif Ekind (Dyn_Scop) = E_Subprogram_Body then
6953 return Corresponding_Spec (Parent (Parent (Dyn_Scop)));
6955 elsif Ekind_In (Dyn_Scop, E_Block, E_Loop, E_Return_Statement) then
6956 return Enclosing_Subprogram (Dyn_Scop);
6958 elsif Ekind (Dyn_Scop) = E_Entry then
6960 -- For a task entry, return the enclosing subprogram of the
6963 if Ekind (Scope (Dyn_Scop)) = E_Task_Type then
6964 return Enclosing_Subprogram (Dyn_Scop);
6966 -- A protected entry is rewritten as a protected procedure which is
6967 -- the desired enclosing subprogram. This is relevant when unnesting
6968 -- a procedure local to an entry body.
6971 return Protected_Body_Subprogram (Dyn_Scop);
6974 elsif Ekind (Dyn_Scop) = E_Task_Type then
6975 return Get_Task_Body_Procedure (Dyn_Scop);
6977 -- The scope may appear as a private type or as a private extension
6978 -- whose completion is a task or protected type.
6980 elsif Ekind_In (Dyn_Scop, E_Limited_Private_Type,
6981 E_Record_Type_With_Private)
6982 and then Present (Full_View (Dyn_Scop))
6983 and then Ekind_In (Full_View (Dyn_Scop), E_Task_Type, E_Protected_Type)
6985 return Get_Task_Body_Procedure (Full_View (Dyn_Scop));
6987 -- No body is generated if the protected operation is eliminated
6989 elsif Convention (Dyn_Scop) = Convention_Protected
6990 and then not Is_Eliminated (Dyn_Scop)
6991 and then Present (Protected_Body_Subprogram (Dyn_Scop))
6993 return Protected_Body_Subprogram (Dyn_Scop);
6998 end Enclosing_Subprogram;
7000 --------------------------
7001 -- End_Keyword_Location --
7002 --------------------------
7004 function End_Keyword_Location (N : Node_Id) return Source_Ptr is
7005 function End_Label_Loc (Nod : Node_Id) return Source_Ptr;
7006 -- Return the source location of Nod's end label according to the
7007 -- following precedence rules:
7009 -- 1) If the end label exists, return its location
7010 -- 2) If Nod exists, return its location
7011 -- 3) Return the location of N
7017 function End_Label_Loc (Nod : Node_Id) return Source_Ptr is
7021 if Present (Nod) then
7022 Label := End_Label (Nod);
7024 if Present (Label) then
7025 return Sloc (Label);
7039 -- Start of processing for End_Keyword_Location
7042 if Nkind_In (N, N_Block_Statement,
7048 Owner := Handled_Statement_Sequence (N);
7050 elsif Nkind (N) = N_Package_Declaration then
7051 Owner := Specification (N);
7053 elsif Nkind (N) = N_Protected_Body then
7056 elsif Nkind_In (N, N_Protected_Type_Declaration,
7057 N_Single_Protected_Declaration)
7059 Owner := Protected_Definition (N);
7061 elsif Nkind_In (N, N_Single_Task_Declaration,
7062 N_Task_Type_Declaration)
7064 Owner := Task_Definition (N);
7066 -- This routine should not be called with other contexts
7069 pragma Assert (False);
7073 return End_Label_Loc (Owner);
7074 end End_Keyword_Location;
7076 ------------------------
7077 -- Ensure_Freeze_Node --
7078 ------------------------
7080 procedure Ensure_Freeze_Node (E : Entity_Id) is
7083 if No (Freeze_Node (E)) then
7084 FN := Make_Freeze_Entity (Sloc (E));
7085 Set_Has_Delayed_Freeze (E);
7086 Set_Freeze_Node (E, FN);
7087 Set_Access_Types_To_Process (FN, No_Elist);
7088 Set_TSS_Elist (FN, No_Elist);
7091 end Ensure_Freeze_Node;
7097 procedure Enter_Name (Def_Id : Entity_Id) is
7098 C : constant Entity_Id := Current_Entity (Def_Id);
7099 E : constant Entity_Id := Current_Entity_In_Scope (Def_Id);
7100 S : constant Entity_Id := Current_Scope;
7103 Generate_Definition (Def_Id);
7105 -- Add new name to current scope declarations. Check for duplicate
7106 -- declaration, which may or may not be a genuine error.
7110 -- Case of previous entity entered because of a missing declaration
7111 -- or else a bad subtype indication. Best is to use the new entity,
7112 -- and make the previous one invisible.
7114 if Etype (E) = Any_Type then
7115 Set_Is_Immediately_Visible (E, False);
7117 -- Case of renaming declaration constructed for package instances.
7118 -- if there is an explicit declaration with the same identifier,
7119 -- the renaming is not immediately visible any longer, but remains
7120 -- visible through selected component notation.
7122 elsif Nkind (Parent (E)) = N_Package_Renaming_Declaration
7123 and then not Comes_From_Source (E)
7125 Set_Is_Immediately_Visible (E, False);
7127 -- The new entity may be the package renaming, which has the same
7128 -- same name as a generic formal which has been seen already.
7130 elsif Nkind (Parent (Def_Id)) = N_Package_Renaming_Declaration
7131 and then not Comes_From_Source (Def_Id)
7133 Set_Is_Immediately_Visible (E, False);
7135 -- For a fat pointer corresponding to a remote access to subprogram,
7136 -- we use the same identifier as the RAS type, so that the proper
7137 -- name appears in the stub. This type is only retrieved through
7138 -- the RAS type and never by visibility, and is not added to the
7139 -- visibility list (see below).
7141 elsif Nkind (Parent (Def_Id)) = N_Full_Type_Declaration
7142 and then Ekind (Def_Id) = E_Record_Type
7143 and then Present (Corresponding_Remote_Type (Def_Id))
7147 -- Case of an implicit operation or derived literal. The new entity
7148 -- hides the implicit one, which is removed from all visibility,
7149 -- i.e. the entity list of its scope, and homonym chain of its name.
7151 elsif (Is_Overloadable (E) and then Is_Inherited_Operation (E))
7152 or else Is_Internal (E)
7155 Decl : constant Node_Id := Parent (E);
7157 Prev_Vis : Entity_Id;
7160 -- If E is an implicit declaration, it cannot be the first
7161 -- entity in the scope.
7163 Prev := First_Entity (Current_Scope);
7164 while Present (Prev) and then Next_Entity (Prev) /= E loop
7170 -- If E is not on the entity chain of the current scope,
7171 -- it is an implicit declaration in the generic formal
7172 -- part of a generic subprogram. When analyzing the body,
7173 -- the generic formals are visible but not on the entity
7174 -- chain of the subprogram. The new entity will become
7175 -- the visible one in the body.
7178 (Nkind (Parent (Decl)) = N_Generic_Subprogram_Declaration);
7182 Link_Entities (Prev, Next_Entity (E));
7184 if No (Next_Entity (Prev)) then
7185 Set_Last_Entity (Current_Scope, Prev);
7188 if E = Current_Entity (E) then
7192 Prev_Vis := Current_Entity (E);
7193 while Homonym (Prev_Vis) /= E loop
7194 Prev_Vis := Homonym (Prev_Vis);
7198 if Present (Prev_Vis) then
7200 -- Skip E in the visibility chain
7202 Set_Homonym (Prev_Vis, Homonym (E));
7205 Set_Name_Entity_Id (Chars (E), Homonym (E));
7210 -- This section of code could use a comment ???
7212 elsif Present (Etype (E))
7213 and then Is_Concurrent_Type (Etype (E))
7218 -- If the homograph is a protected component renaming, it should not
7219 -- be hiding the current entity. Such renamings are treated as weak
7222 elsif Is_Prival (E) then
7223 Set_Is_Immediately_Visible (E, False);
7225 -- In this case the current entity is a protected component renaming.
7226 -- Perform minimal decoration by setting the scope and return since
7227 -- the prival should not be hiding other visible entities.
7229 elsif Is_Prival (Def_Id) then
7230 Set_Scope (Def_Id, Current_Scope);
7233 -- Analogous to privals, the discriminal generated for an entry index
7234 -- parameter acts as a weak declaration. Perform minimal decoration
7235 -- to avoid bogus errors.
7237 elsif Is_Discriminal (Def_Id)
7238 and then Ekind (Discriminal_Link (Def_Id)) = E_Entry_Index_Parameter
7240 Set_Scope (Def_Id, Current_Scope);
7243 -- In the body or private part of an instance, a type extension may
7244 -- introduce a component with the same name as that of an actual. The
7245 -- legality rule is not enforced, but the semantics of the full type
7246 -- with two components of same name are not clear at this point???
7248 elsif In_Instance_Not_Visible then
7251 -- When compiling a package body, some child units may have become
7252 -- visible. They cannot conflict with local entities that hide them.
7254 elsif Is_Child_Unit (E)
7255 and then In_Open_Scopes (Scope (E))
7256 and then not Is_Immediately_Visible (E)
7260 -- Conversely, with front-end inlining we may compile the parent body
7261 -- first, and a child unit subsequently. The context is now the
7262 -- parent spec, and body entities are not visible.
7264 elsif Is_Child_Unit (Def_Id)
7265 and then Is_Package_Body_Entity (E)
7266 and then not In_Package_Body (Current_Scope)
7270 -- Case of genuine duplicate declaration
7273 Error_Msg_Sloc := Sloc (E);
7275 -- If the previous declaration is an incomplete type declaration
7276 -- this may be an attempt to complete it with a private type. The
7277 -- following avoids confusing cascaded errors.
7279 if Nkind (Parent (E)) = N_Incomplete_Type_Declaration
7280 and then Nkind (Parent (Def_Id)) = N_Private_Type_Declaration
7283 ("incomplete type cannot be completed with a private " &
7284 "declaration", Parent (Def_Id));
7285 Set_Is_Immediately_Visible (E, False);
7286 Set_Full_View (E, Def_Id);
7288 -- An inherited component of a record conflicts with a new
7289 -- discriminant. The discriminant is inserted first in the scope,
7290 -- but the error should be posted on it, not on the component.
7292 elsif Ekind (E) = E_Discriminant
7293 and then Present (Scope (Def_Id))
7294 and then Scope (Def_Id) /= Current_Scope
7296 Error_Msg_Sloc := Sloc (Def_Id);
7297 Error_Msg_N ("& conflicts with declaration#", E);
7300 -- If the name of the unit appears in its own context clause, a
7301 -- dummy package with the name has already been created, and the
7302 -- error emitted. Try to continue quietly.
7304 elsif Error_Posted (E)
7305 and then Sloc (E) = No_Location
7306 and then Nkind (Parent (E)) = N_Package_Specification
7307 and then Current_Scope = Standard_Standard
7309 Set_Scope (Def_Id, Current_Scope);
7313 Error_Msg_N ("& conflicts with declaration#", Def_Id);
7315 -- Avoid cascaded messages with duplicate components in
7318 if Ekind_In (E, E_Component, E_Discriminant) then
7323 if Nkind (Parent (Parent (Def_Id))) =
7324 N_Generic_Subprogram_Declaration
7326 Defining_Entity (Specification (Parent (Parent (Def_Id))))
7328 Error_Msg_N ("\generic units cannot be overloaded", Def_Id);
7331 -- If entity is in standard, then we are in trouble, because it
7332 -- means that we have a library package with a duplicated name.
7333 -- That's hard to recover from, so abort.
7335 if S = Standard_Standard then
7336 raise Unrecoverable_Error;
7338 -- Otherwise we continue with the declaration. Having two
7339 -- identical declarations should not cause us too much trouble.
7347 -- If we fall through, declaration is OK, at least OK enough to continue
7349 -- If Def_Id is a discriminant or a record component we are in the midst
7350 -- of inheriting components in a derived record definition. Preserve
7351 -- their Ekind and Etype.
7353 if Ekind_In (Def_Id, E_Discriminant, E_Component) then
7356 -- If a type is already set, leave it alone (happens when a type
7357 -- declaration is reanalyzed following a call to the optimizer).
7359 elsif Present (Etype (Def_Id)) then
7362 -- Otherwise, the kind E_Void insures that premature uses of the entity
7363 -- will be detected. Any_Type insures that no cascaded errors will occur
7366 Set_Ekind (Def_Id, E_Void);
7367 Set_Etype (Def_Id, Any_Type);
7370 -- Inherited discriminants and components in derived record types are
7371 -- immediately visible. Itypes are not.
7373 -- Unless the Itype is for a record type with a corresponding remote
7374 -- type (what is that about, it was not commented ???)
7376 if Ekind_In (Def_Id, E_Discriminant, E_Component)
7378 ((not Is_Record_Type (Def_Id)
7379 or else No (Corresponding_Remote_Type (Def_Id)))
7380 and then not Is_Itype (Def_Id))
7382 Set_Is_Immediately_Visible (Def_Id);
7383 Set_Current_Entity (Def_Id);
7386 Set_Homonym (Def_Id, C);
7387 Append_Entity (Def_Id, S);
7388 Set_Public_Status (Def_Id);
7390 -- Declaring a homonym is not allowed in SPARK ...
7392 if Present (C) and then Restriction_Check_Required (SPARK_05) then
7394 Enclosing_Subp : constant Node_Id := Enclosing_Subprogram (Def_Id);
7395 Enclosing_Pack : constant Node_Id := Enclosing_Package (Def_Id);
7396 Other_Scope : constant Node_Id := Enclosing_Dynamic_Scope (C);
7399 -- ... unless the new declaration is in a subprogram, and the
7400 -- visible declaration is a variable declaration or a parameter
7401 -- specification outside that subprogram.
7403 if Present (Enclosing_Subp)
7404 and then Nkind_In (Parent (C), N_Object_Declaration,
7405 N_Parameter_Specification)
7406 and then not Scope_Within_Or_Same (Other_Scope, Enclosing_Subp)
7410 -- ... or the new declaration is in a package, and the visible
7411 -- declaration occurs outside that package.
7413 elsif Present (Enclosing_Pack)
7414 and then not Scope_Within_Or_Same (Other_Scope, Enclosing_Pack)
7418 -- ... or the new declaration is a component declaration in a
7419 -- record type definition.
7421 elsif Nkind (Parent (Def_Id)) = N_Component_Declaration then
7424 -- Don't issue error for non-source entities
7426 elsif Comes_From_Source (Def_Id)
7427 and then Comes_From_Source (C)
7429 Error_Msg_Sloc := Sloc (C);
7430 Check_SPARK_05_Restriction
7431 ("redeclaration of identifier &#", Def_Id);
7436 -- Warn if new entity hides an old one
7438 if Warn_On_Hiding and then Present (C)
7440 -- Don't warn for record components since they always have a well
7441 -- defined scope which does not confuse other uses. Note that in
7442 -- some cases, Ekind has not been set yet.
7444 and then Ekind (C) /= E_Component
7445 and then Ekind (C) /= E_Discriminant
7446 and then Nkind (Parent (C)) /= N_Component_Declaration
7447 and then Ekind (Def_Id) /= E_Component
7448 and then Ekind (Def_Id) /= E_Discriminant
7449 and then Nkind (Parent (Def_Id)) /= N_Component_Declaration
7451 -- Don't warn for one character variables. It is too common to use
7452 -- such variables as locals and will just cause too many false hits.
7454 and then Length_Of_Name (Chars (C)) /= 1
7456 -- Don't warn for non-source entities
7458 and then Comes_From_Source (C)
7459 and then Comes_From_Source (Def_Id)
7461 -- Don't warn unless entity in question is in extended main source
7463 and then In_Extended_Main_Source_Unit (Def_Id)
7465 -- Finally, the hidden entity must be either immediately visible or
7466 -- use visible (i.e. from a used package).
7469 (Is_Immediately_Visible (C)
7471 Is_Potentially_Use_Visible (C))
7473 Error_Msg_Sloc := Sloc (C);
7474 Error_Msg_N ("declaration hides &#?h?", Def_Id);
7482 function Entity_Of (N : Node_Id) return Entity_Id is
7487 -- Assume that the arbitrary node does not have an entity
7491 if Is_Entity_Name (N) then
7494 -- Follow a possible chain of renamings to reach the earliest renamed
7498 and then Is_Object (Id)
7499 and then Present (Renamed_Object (Id))
7501 Ren := Renamed_Object (Id);
7503 -- The reference renames an abstract state or a whole object
7506 -- Ren : ... renames Obj;
7508 if Is_Entity_Name (Ren) then
7510 -- Do not follow a renaming that goes through a generic formal,
7511 -- because these entities are hidden and must not be referenced
7512 -- from outside the generic.
7514 if Is_Hidden (Entity (Ren)) then
7521 -- The reference renames a function result. Check the original
7522 -- node in case expansion relocates the function call.
7524 -- Ren : ... renames Func_Call;
7526 elsif Nkind (Original_Node (Ren)) = N_Function_Call then
7529 -- Otherwise the reference renames something which does not yield
7530 -- an abstract state or a whole object. Treat the reference as not
7531 -- having a proper entity for SPARK legality purposes.
7543 --------------------------
7544 -- Examine_Array_Bounds --
7545 --------------------------
7547 procedure Examine_Array_Bounds
7549 All_Static : out Boolean;
7550 Has_Empty : out Boolean)
7552 function Is_OK_Static_Bound (Bound : Node_Id) return Boolean;
7553 -- Determine whether bound Bound is a suitable static bound
7555 ------------------------
7556 -- Is_OK_Static_Bound --
7557 ------------------------
7559 function Is_OK_Static_Bound (Bound : Node_Id) return Boolean is
7562 not Error_Posted (Bound)
7563 and then Is_OK_Static_Expression (Bound);
7564 end Is_OK_Static_Bound;
7572 -- Start of processing for Examine_Array_Bounds
7575 -- An unconstrained array type does not have static bounds, and it is
7576 -- not known whether they are empty or not.
7578 if not Is_Constrained (Typ) then
7579 All_Static := False;
7582 -- A string literal has static bounds, and is not empty as long as it
7583 -- contains at least one character.
7585 elsif Ekind (Typ) = E_String_Literal_Subtype then
7587 Has_Empty := String_Literal_Length (Typ) > 0;
7590 -- Assume that all bounds are static and not empty
7595 -- Examine each index
7597 Index := First_Index (Typ);
7598 while Present (Index) loop
7599 if Is_Discrete_Type (Etype (Index)) then
7600 Get_Index_Bounds (Index, Lo_Bound, Hi_Bound);
7602 if Is_OK_Static_Bound (Lo_Bound)
7604 Is_OK_Static_Bound (Hi_Bound)
7606 -- The static bounds produce an empty range
7608 if Is_Null_Range (Lo_Bound, Hi_Bound) then
7612 -- Otherwise at least one of the bounds is not static
7615 All_Static := False;
7618 -- Otherwise the index is non-discrete, therefore not static
7621 All_Static := False;
7626 end Examine_Array_Bounds;
7632 function Exceptions_OK return Boolean is
7635 not (Restriction_Active (No_Exception_Handlers) or else
7636 Restriction_Active (No_Exception_Propagation) or else
7637 Restriction_Active (No_Exceptions));
7640 --------------------------
7641 -- Explain_Limited_Type --
7642 --------------------------
7644 procedure Explain_Limited_Type (T : Entity_Id; N : Node_Id) is
7648 -- For array, component type must be limited
7650 if Is_Array_Type (T) then
7651 Error_Msg_Node_2 := T;
7653 ("\component type& of type& is limited", N, Component_Type (T));
7654 Explain_Limited_Type (Component_Type (T), N);
7656 elsif Is_Record_Type (T) then
7658 -- No need for extra messages if explicit limited record
7660 if Is_Limited_Record (Base_Type (T)) then
7664 -- Otherwise find a limited component. Check only components that
7665 -- come from source, or inherited components that appear in the
7666 -- source of the ancestor.
7668 C := First_Component (T);
7669 while Present (C) loop
7670 if Is_Limited_Type (Etype (C))
7672 (Comes_From_Source (C)
7674 (Present (Original_Record_Component (C))
7676 Comes_From_Source (Original_Record_Component (C))))
7678 Error_Msg_Node_2 := T;
7679 Error_Msg_NE ("\component& of type& has limited type", N, C);
7680 Explain_Limited_Type (Etype (C), N);
7687 -- The type may be declared explicitly limited, even if no component
7688 -- of it is limited, in which case we fall out of the loop.
7691 end Explain_Limited_Type;
7693 ---------------------------------------
7694 -- Expression_Of_Expression_Function --
7695 ---------------------------------------
7697 function Expression_Of_Expression_Function
7698 (Subp : Entity_Id) return Node_Id
7700 Expr_Func : Node_Id;
7703 pragma Assert (Is_Expression_Function_Or_Completion (Subp));
7705 if Nkind (Original_Node (Subprogram_Spec (Subp))) =
7706 N_Expression_Function
7708 Expr_Func := Original_Node (Subprogram_Spec (Subp));
7710 elsif Nkind (Original_Node (Subprogram_Body (Subp))) =
7711 N_Expression_Function
7713 Expr_Func := Original_Node (Subprogram_Body (Subp));
7716 pragma Assert (False);
7720 return Original_Node (Expression (Expr_Func));
7721 end Expression_Of_Expression_Function;
7723 -------------------------------
7724 -- Extensions_Visible_Status --
7725 -------------------------------
7727 function Extensions_Visible_Status
7728 (Id : Entity_Id) return Extensions_Visible_Mode
7737 -- When a formal parameter is subject to Extensions_Visible, the pragma
7738 -- is stored in the contract of related subprogram.
7740 if Is_Formal (Id) then
7743 elsif Is_Subprogram_Or_Generic_Subprogram (Id) then
7746 -- No other construct carries this pragma
7749 return Extensions_Visible_None;
7752 Prag := Get_Pragma (Subp, Pragma_Extensions_Visible);
7754 -- In certain cases analysis may request the Extensions_Visible status
7755 -- of an expression function before the pragma has been analyzed yet.
7756 -- Inspect the declarative items after the expression function looking
7757 -- for the pragma (if any).
7759 if No (Prag) and then Is_Expression_Function (Subp) then
7760 Decl := Next (Unit_Declaration_Node (Subp));
7761 while Present (Decl) loop
7762 if Nkind (Decl) = N_Pragma
7763 and then Pragma_Name (Decl) = Name_Extensions_Visible
7768 -- A source construct ends the region where Extensions_Visible may
7769 -- appear, stop the traversal. An expanded expression function is
7770 -- no longer a source construct, but it must still be recognized.
7772 elsif Comes_From_Source (Decl)
7774 (Nkind_In (Decl, N_Subprogram_Body,
7775 N_Subprogram_Declaration)
7776 and then Is_Expression_Function (Defining_Entity (Decl)))
7785 -- Extract the value from the Boolean expression (if any)
7787 if Present (Prag) then
7788 Arg := First (Pragma_Argument_Associations (Prag));
7790 if Present (Arg) then
7791 Expr := Get_Pragma_Arg (Arg);
7793 -- When the associated subprogram is an expression function, the
7794 -- argument of the pragma may not have been analyzed.
7796 if not Analyzed (Expr) then
7797 Preanalyze_And_Resolve (Expr, Standard_Boolean);
7800 -- Guard against cascading errors when the argument of pragma
7801 -- Extensions_Visible is not a valid static Boolean expression.
7803 if Error_Posted (Expr) then
7804 return Extensions_Visible_None;
7806 elsif Is_True (Expr_Value (Expr)) then
7807 return Extensions_Visible_True;
7810 return Extensions_Visible_False;
7813 -- Otherwise the aspect or pragma defaults to True
7816 return Extensions_Visible_True;
7819 -- Otherwise aspect or pragma Extensions_Visible is not inherited or
7820 -- directly specified. In SPARK code, its value defaults to "False".
7822 elsif SPARK_Mode = On then
7823 return Extensions_Visible_False;
7825 -- In non-SPARK code, aspect or pragma Extensions_Visible defaults to
7829 return Extensions_Visible_True;
7831 end Extensions_Visible_Status;
7837 procedure Find_Actual
7839 Formal : out Entity_Id;
7842 Context : constant Node_Id := Parent (N);
7847 if Nkind_In (Context, N_Indexed_Component, N_Selected_Component)
7848 and then N = Prefix (Context)
7850 Find_Actual (Context, Formal, Call);
7853 elsif Nkind (Context) = N_Parameter_Association
7854 and then N = Explicit_Actual_Parameter (Context)
7856 Call := Parent (Context);
7858 elsif Nkind_In (Context, N_Entry_Call_Statement,
7860 N_Procedure_Call_Statement)
7870 -- If we have a call to a subprogram look for the parameter. Note that
7871 -- we exclude overloaded calls, since we don't know enough to be sure
7872 -- of giving the right answer in this case.
7874 if Nkind_In (Call, N_Entry_Call_Statement,
7876 N_Procedure_Call_Statement)
7878 Call_Nam := Name (Call);
7880 -- A call to a protected or task entry appears as a selected
7881 -- component rather than an expanded name.
7883 if Nkind (Call_Nam) = N_Selected_Component then
7884 Call_Nam := Selector_Name (Call_Nam);
7887 if Is_Entity_Name (Call_Nam)
7888 and then Present (Entity (Call_Nam))
7889 and then Is_Overloadable (Entity (Call_Nam))
7890 and then not Is_Overloaded (Call_Nam)
7892 -- If node is name in call it is not an actual
7894 if N = Call_Nam then
7900 -- Fall here if we are definitely a parameter
7902 Actual := First_Actual (Call);
7903 Formal := First_Formal (Entity (Call_Nam));
7904 while Present (Formal) and then Present (Actual) loop
7908 -- An actual that is the prefix in a prefixed call may have
7909 -- been rewritten in the call, after the deferred reference
7910 -- was collected. Check if sloc and kinds and names match.
7912 elsif Sloc (Actual) = Sloc (N)
7913 and then Nkind (Actual) = N_Identifier
7914 and then Nkind (Actual) = Nkind (N)
7915 and then Chars (Actual) = Chars (N)
7920 Actual := Next_Actual (Actual);
7921 Formal := Next_Formal (Formal);
7927 -- Fall through here if we did not find matching actual
7933 ---------------------------
7934 -- Find_Body_Discriminal --
7935 ---------------------------
7937 function Find_Body_Discriminal
7938 (Spec_Discriminant : Entity_Id) return Entity_Id
7944 -- If expansion is suppressed, then the scope can be the concurrent type
7945 -- itself rather than a corresponding concurrent record type.
7947 if Is_Concurrent_Type (Scope (Spec_Discriminant)) then
7948 Tsk := Scope (Spec_Discriminant);
7951 pragma Assert (Is_Concurrent_Record_Type (Scope (Spec_Discriminant)));
7953 Tsk := Corresponding_Concurrent_Type (Scope (Spec_Discriminant));
7956 -- Find discriminant of original concurrent type, and use its current
7957 -- discriminal, which is the renaming within the task/protected body.
7959 Disc := First_Discriminant (Tsk);
7960 while Present (Disc) loop
7961 if Chars (Disc) = Chars (Spec_Discriminant) then
7962 return Discriminal (Disc);
7965 Next_Discriminant (Disc);
7968 -- That loop should always succeed in finding a matching entry and
7969 -- returning. Fatal error if not.
7971 raise Program_Error;
7972 end Find_Body_Discriminal;
7974 -------------------------------------
7975 -- Find_Corresponding_Discriminant --
7976 -------------------------------------
7978 function Find_Corresponding_Discriminant
7980 Typ : Entity_Id) return Entity_Id
7982 Par_Disc : Entity_Id;
7983 Old_Disc : Entity_Id;
7984 New_Disc : Entity_Id;
7987 Par_Disc := Original_Record_Component (Original_Discriminant (Id));
7989 -- The original type may currently be private, and the discriminant
7990 -- only appear on its full view.
7992 if Is_Private_Type (Scope (Par_Disc))
7993 and then not Has_Discriminants (Scope (Par_Disc))
7994 and then Present (Full_View (Scope (Par_Disc)))
7996 Old_Disc := First_Discriminant (Full_View (Scope (Par_Disc)));
7998 Old_Disc := First_Discriminant (Scope (Par_Disc));
8001 if Is_Class_Wide_Type (Typ) then
8002 New_Disc := First_Discriminant (Root_Type (Typ));
8004 New_Disc := First_Discriminant (Typ);
8007 while Present (Old_Disc) and then Present (New_Disc) loop
8008 if Old_Disc = Par_Disc then
8012 Next_Discriminant (Old_Disc);
8013 Next_Discriminant (New_Disc);
8016 -- Should always find it
8018 raise Program_Error;
8019 end Find_Corresponding_Discriminant;
8025 function Find_DIC_Type (Typ : Entity_Id) return Entity_Id is
8026 Curr_Typ : Entity_Id;
8027 -- The current type being examined in the parent hierarchy traversal
8029 DIC_Typ : Entity_Id;
8030 -- The type which carries the DIC pragma. This variable denotes the
8031 -- partial view when private types are involved.
8033 Par_Typ : Entity_Id;
8034 -- The parent type of the current type. This variable denotes the full
8035 -- view when private types are involved.
8038 -- The input type defines its own DIC pragma, therefore it is the owner
8040 if Has_Own_DIC (Typ) then
8043 -- Otherwise the DIC pragma is inherited from a parent type
8046 pragma Assert (Has_Inherited_DIC (Typ));
8048 -- Climb the parent chain
8052 -- Inspect the parent type. Do not consider subtypes as they
8053 -- inherit the DIC attributes from their base types.
8055 DIC_Typ := Base_Type (Etype (Curr_Typ));
8057 -- Look at the full view of a private type because the type may
8058 -- have a hidden parent introduced in the full view.
8062 if Is_Private_Type (Par_Typ)
8063 and then Present (Full_View (Par_Typ))
8065 Par_Typ := Full_View (Par_Typ);
8068 -- Stop the climb once the nearest parent type which defines a DIC
8069 -- pragma of its own is encountered or when the root of the parent
8070 -- chain is reached.
8072 exit when Has_Own_DIC (DIC_Typ) or else Curr_Typ = Par_Typ;
8074 Curr_Typ := Par_Typ;
8081 ----------------------------------
8082 -- Find_Enclosing_Iterator_Loop --
8083 ----------------------------------
8085 function Find_Enclosing_Iterator_Loop (Id : Entity_Id) return Entity_Id is
8090 -- Traverse the scope chain looking for an iterator loop. Such loops are
8091 -- usually transformed into blocks, hence the use of Original_Node.
8094 while Present (S) and then S /= Standard_Standard loop
8095 if Ekind (S) = E_Loop
8096 and then Nkind (Parent (S)) = N_Implicit_Label_Declaration
8098 Constr := Original_Node (Label_Construct (Parent (S)));
8100 if Nkind (Constr) = N_Loop_Statement
8101 and then Present (Iteration_Scheme (Constr))
8102 and then Nkind (Iterator_Specification
8103 (Iteration_Scheme (Constr))) =
8104 N_Iterator_Specification
8114 end Find_Enclosing_Iterator_Loop;
8116 --------------------------
8117 -- Find_Enclosing_Scope --
8118 --------------------------
8120 function Find_Enclosing_Scope (N : Node_Id) return Entity_Id is
8124 -- Examine the parent chain looking for a construct which defines a
8128 while Present (Par) loop
8131 -- The construct denotes a declaration, the proper scope is its
8134 when N_Entry_Declaration
8135 | N_Expression_Function
8136 | N_Full_Type_Declaration
8137 | N_Generic_Package_Declaration
8138 | N_Generic_Subprogram_Declaration
8139 | N_Package_Declaration
8140 | N_Private_Extension_Declaration
8141 | N_Protected_Type_Declaration
8142 | N_Single_Protected_Declaration
8143 | N_Single_Task_Declaration
8144 | N_Subprogram_Declaration
8145 | N_Task_Type_Declaration
8147 return Defining_Entity (Par);
8149 -- The construct denotes a body, the proper scope is the entity of
8150 -- the corresponding spec or that of the body if the body does not
8151 -- complete a previous declaration.
8159 return Unique_Defining_Entity (Par);
8163 -- Blocks carry either a source or an internally-generated scope,
8164 -- unless the block is a byproduct of exception handling.
8166 when N_Block_Statement =>
8167 if not Exception_Junk (Par) then
8168 return Entity (Identifier (Par));
8171 -- Loops carry an internally-generated scope
8173 when N_Loop_Statement =>
8174 return Entity (Identifier (Par));
8176 -- Extended return statements carry an internally-generated scope
8178 when N_Extended_Return_Statement =>
8179 return Return_Statement_Entity (Par);
8181 -- A traversal from a subunit continues via the corresponding stub
8184 Par := Corresponding_Stub (Par);
8190 Par := Parent (Par);
8193 return Standard_Standard;
8194 end Find_Enclosing_Scope;
8196 ------------------------------------
8197 -- Find_Loop_In_Conditional_Block --
8198 ------------------------------------
8200 function Find_Loop_In_Conditional_Block (N : Node_Id) return Node_Id is
8206 if Nkind (Stmt) = N_If_Statement then
8207 Stmt := First (Then_Statements (Stmt));
8210 pragma Assert (Nkind (Stmt) = N_Block_Statement);
8212 -- Inspect the statements of the conditional block. In general the loop
8213 -- should be the first statement in the statement sequence of the block,
8214 -- but the finalization machinery may have introduced extra object
8217 Stmt := First (Statements (Handled_Statement_Sequence (Stmt)));
8218 while Present (Stmt) loop
8219 if Nkind (Stmt) = N_Loop_Statement then
8226 -- The expansion of attribute 'Loop_Entry produced a malformed block
8228 raise Program_Error;
8229 end Find_Loop_In_Conditional_Block;
8231 --------------------------
8232 -- Find_Overlaid_Entity --
8233 --------------------------
8235 procedure Find_Overlaid_Entity
8237 Ent : out Entity_Id;
8243 -- We are looking for one of the two following forms:
8245 -- for X'Address use Y'Address
8249 -- Const : constant Address := expr;
8251 -- for X'Address use Const;
8253 -- In the second case, the expr is either Y'Address, or recursively a
8254 -- constant that eventually references Y'Address.
8259 if Nkind (N) = N_Attribute_Definition_Clause
8260 and then Chars (N) = Name_Address
8262 Expr := Expression (N);
8264 -- This loop checks the form of the expression for Y'Address,
8265 -- using recursion to deal with intermediate constants.
8268 -- Check for Y'Address
8270 if Nkind (Expr) = N_Attribute_Reference
8271 and then Attribute_Name (Expr) = Name_Address
8273 Expr := Prefix (Expr);
8276 -- Check for Const where Const is a constant entity
8278 elsif Is_Entity_Name (Expr)
8279 and then Ekind (Entity (Expr)) = E_Constant
8281 Expr := Constant_Value (Entity (Expr));
8283 -- Anything else does not need checking
8290 -- This loop checks the form of the prefix for an entity, using
8291 -- recursion to deal with intermediate components.
8294 -- Check for Y where Y is an entity
8296 if Is_Entity_Name (Expr) then
8297 Ent := Entity (Expr);
8300 -- Check for components
8303 Nkind_In (Expr, N_Selected_Component, N_Indexed_Component)
8305 Expr := Prefix (Expr);
8308 -- Anything else does not need checking
8315 end Find_Overlaid_Entity;
8317 -------------------------
8318 -- Find_Parameter_Type --
8319 -------------------------
8321 function Find_Parameter_Type (Param : Node_Id) return Entity_Id is
8323 if Nkind (Param) /= N_Parameter_Specification then
8326 -- For an access parameter, obtain the type from the formal entity
8327 -- itself, because access to subprogram nodes do not carry a type.
8328 -- Shouldn't we always use the formal entity ???
8330 elsif Nkind (Parameter_Type (Param)) = N_Access_Definition then
8331 return Etype (Defining_Identifier (Param));
8334 return Etype (Parameter_Type (Param));
8336 end Find_Parameter_Type;
8338 -----------------------------------
8339 -- Find_Placement_In_State_Space --
8340 -----------------------------------
8342 procedure Find_Placement_In_State_Space
8343 (Item_Id : Entity_Id;
8344 Placement : out State_Space_Kind;
8345 Pack_Id : out Entity_Id)
8347 Context : Entity_Id;
8350 -- Assume that the item does not appear in the state space of a package
8352 Placement := Not_In_Package;
8355 -- Climb the scope stack and examine the enclosing context
8357 Context := Scope (Item_Id);
8358 while Present (Context) and then Context /= Standard_Standard loop
8359 if Is_Package_Or_Generic_Package (Context) then
8362 -- A package body is a cut off point for the traversal as the item
8363 -- cannot be visible to the outside from this point on. Note that
8364 -- this test must be done first as a body is also classified as a
8367 if In_Package_Body (Context) then
8368 Placement := Body_State_Space;
8371 -- The private part of a package is a cut off point for the
8372 -- traversal as the item cannot be visible to the outside from
8375 elsif In_Private_Part (Context) then
8376 Placement := Private_State_Space;
8379 -- When the item appears in the visible state space of a package,
8380 -- continue to climb the scope stack as this may not be the final
8384 Placement := Visible_State_Space;
8386 -- The visible state space of a child unit acts as the proper
8387 -- placement of an item.
8389 if Is_Child_Unit (Context) then
8394 -- The item or its enclosing package appear in a construct that has
8398 Placement := Not_In_Package;
8402 Context := Scope (Context);
8404 end Find_Placement_In_State_Space;
8406 -----------------------
8407 -- Find_Primitive_Eq --
8408 -----------------------
8410 function Find_Primitive_Eq (Typ : Entity_Id) return Entity_Id is
8411 function Find_Eq_Prim (Prims_List : Elist_Id) return Entity_Id;
8412 -- Search for the equality primitive; return Empty if the primitive is
8419 function Find_Eq_Prim (Prims_List : Elist_Id) return Entity_Id is
8421 Prim_Elmt : Elmt_Id;
8424 Prim_Elmt := First_Elmt (Prims_List);
8425 while Present (Prim_Elmt) loop
8426 Prim := Node (Prim_Elmt);
8428 -- Locate primitive equality with the right signature
8430 if Chars (Prim) = Name_Op_Eq
8431 and then Etype (First_Formal (Prim)) =
8432 Etype (Next_Formal (First_Formal (Prim)))
8433 and then Base_Type (Etype (Prim)) = Standard_Boolean
8438 Next_Elmt (Prim_Elmt);
8446 Eq_Prim : Entity_Id;
8447 Full_Type : Entity_Id;
8449 -- Start of processing for Find_Primitive_Eq
8452 if Is_Private_Type (Typ) then
8453 Full_Type := Underlying_Type (Typ);
8458 if No (Full_Type) then
8462 Full_Type := Base_Type (Full_Type);
8464 -- When the base type itself is private, use the full view
8466 if Is_Private_Type (Full_Type) then
8467 Full_Type := Underlying_Type (Full_Type);
8470 if Is_Class_Wide_Type (Full_Type) then
8471 Full_Type := Root_Type (Full_Type);
8474 if not Is_Tagged_Type (Full_Type) then
8475 Eq_Prim := Find_Eq_Prim (Collect_Primitive_Operations (Typ));
8477 -- If this is an untagged private type completed with a derivation of
8478 -- an untagged private type whose full view is a tagged type, we use
8479 -- the primitive operations of the private parent type (since it does
8480 -- not have a full view, and also because its equality primitive may
8481 -- have been overridden in its untagged full view). If no equality was
8482 -- defined for it then take its dispatching equality primitive.
8484 elsif Inherits_From_Tagged_Full_View (Typ) then
8485 Eq_Prim := Find_Eq_Prim (Collect_Primitive_Operations (Typ));
8487 if No (Eq_Prim) then
8488 Eq_Prim := Find_Eq_Prim (Primitive_Operations (Full_Type));
8492 Eq_Prim := Find_Eq_Prim (Primitive_Operations (Full_Type));
8496 end Find_Primitive_Eq;
8498 ------------------------
8499 -- Find_Specific_Type --
8500 ------------------------
8502 function Find_Specific_Type (CW : Entity_Id) return Entity_Id is
8503 Typ : Entity_Id := Root_Type (CW);
8506 if Ekind (Typ) = E_Incomplete_Type then
8507 if From_Limited_With (Typ) then
8508 Typ := Non_Limited_View (Typ);
8510 Typ := Full_View (Typ);
8514 if Is_Private_Type (Typ)
8515 and then not Is_Tagged_Type (Typ)
8516 and then Present (Full_View (Typ))
8518 return Full_View (Typ);
8522 end Find_Specific_Type;
8524 -----------------------------
8525 -- Find_Static_Alternative --
8526 -----------------------------
8528 function Find_Static_Alternative (N : Node_Id) return Node_Id is
8529 Expr : constant Node_Id := Expression (N);
8530 Val : constant Uint := Expr_Value (Expr);
8535 Alt := First (Alternatives (N));
8538 if Nkind (Alt) /= N_Pragma then
8539 Choice := First (Discrete_Choices (Alt));
8540 while Present (Choice) loop
8542 -- Others choice, always matches
8544 if Nkind (Choice) = N_Others_Choice then
8547 -- Range, check if value is in the range
8549 elsif Nkind (Choice) = N_Range then
8551 Val >= Expr_Value (Low_Bound (Choice))
8553 Val <= Expr_Value (High_Bound (Choice));
8555 -- Choice is a subtype name. Note that we know it must
8556 -- be a static subtype, since otherwise it would have
8557 -- been diagnosed as illegal.
8559 elsif Is_Entity_Name (Choice)
8560 and then Is_Type (Entity (Choice))
8562 exit Search when Is_In_Range (Expr, Etype (Choice),
8563 Assume_Valid => False);
8565 -- Choice is a subtype indication
8567 elsif Nkind (Choice) = N_Subtype_Indication then
8569 C : constant Node_Id := Constraint (Choice);
8570 R : constant Node_Id := Range_Expression (C);
8574 Val >= Expr_Value (Low_Bound (R))
8576 Val <= Expr_Value (High_Bound (R));
8579 -- Choice is a simple expression
8582 exit Search when Val = Expr_Value (Choice);
8590 pragma Assert (Present (Alt));
8593 -- The above loop *must* terminate by finding a match, since we know the
8594 -- case statement is valid, and the value of the expression is known at
8595 -- compile time. When we fall out of the loop, Alt points to the
8596 -- alternative that we know will be selected at run time.
8599 end Find_Static_Alternative;
8605 function First_Actual (Node : Node_Id) return Node_Id is
8609 if No (Parameter_Associations (Node)) then
8613 N := First (Parameter_Associations (Node));
8615 if Nkind (N) = N_Parameter_Association then
8616 return First_Named_Actual (Node);
8626 function First_Global
8628 Global_Mode : Name_Id;
8629 Refined : Boolean := False) return Node_Id
8631 function First_From_Global_List
8633 Global_Mode : Name_Id := Name_Input) return Entity_Id;
8634 -- Get the first item with suitable mode from List
8636 ----------------------------
8637 -- First_From_Global_List --
8638 ----------------------------
8640 function First_From_Global_List
8642 Global_Mode : Name_Id := Name_Input) return Entity_Id
8647 -- Empty list (no global items)
8649 if Nkind (List) = N_Null then
8652 -- Single global item declaration (only input items)
8654 elsif Nkind_In (List, N_Expanded_Name, N_Identifier) then
8655 if Global_Mode = Name_Input then
8661 -- Simple global list (only input items) or moded global list
8664 elsif Nkind (List) = N_Aggregate then
8665 if Present (Expressions (List)) then
8666 if Global_Mode = Name_Input then
8667 return First (Expressions (List));
8673 Assoc := First (Component_Associations (List));
8674 while Present (Assoc) loop
8676 -- When we find the desired mode in an association, call
8677 -- recursively First_From_Global_List as if the mode was
8678 -- Name_Input, in order to reuse the existing machinery
8679 -- for the other cases.
8681 if Chars (First (Choices (Assoc))) = Global_Mode then
8682 return First_From_Global_List (Expression (Assoc));
8691 -- To accommodate partial decoration of disabled SPARK features,
8692 -- this routine may be called with illegal input. If this is the
8693 -- case, do not raise Program_Error.
8698 end First_From_Global_List;
8702 Global : Node_Id := Empty;
8703 Body_Id : Entity_Id;
8705 -- Start of processing for First_Global
8708 pragma Assert (Nam_In (Global_Mode, Name_In_Out,
8713 -- Retrieve the suitable pragma Global or Refined_Global. In the second
8714 -- case, it can only be located on the body entity.
8717 if Is_Subprogram_Or_Generic_Subprogram (Subp) then
8718 Body_Id := Subprogram_Body_Entity (Subp);
8720 elsif Is_Entry (Subp) or else Is_Task_Type (Subp) then
8721 Body_Id := Corresponding_Body (Parent (Subp));
8723 -- ??? It should be possible to retrieve the Refined_Global on the
8724 -- task body associated to the task object. This is not yet possible.
8726 elsif Is_Single_Task_Object (Subp) then
8733 if Present (Body_Id) then
8734 Global := Get_Pragma (Body_Id, Pragma_Refined_Global);
8737 Global := Get_Pragma (Subp, Pragma_Global);
8740 -- No corresponding global if pragma is not present
8745 -- Otherwise retrieve the corresponding list of items depending on the
8749 return First_From_Global_List
8750 (Expression (Get_Argument (Global, Subp)), Global_Mode);
8758 function Fix_Msg (Id : Entity_Id; Msg : String) return String is
8759 Is_Task : constant Boolean :=
8760 Ekind_In (Id, E_Task_Body, E_Task_Type)
8761 or else Is_Single_Task_Object (Id);
8762 Msg_Last : constant Natural := Msg'Last;
8763 Msg_Index : Natural;
8764 Res : String (Msg'Range) := (others => ' ');
8765 Res_Index : Natural;
8768 -- Copy all characters from the input message Msg to result Res with
8769 -- suitable replacements.
8771 Msg_Index := Msg'First;
8772 Res_Index := Res'First;
8773 while Msg_Index <= Msg_Last loop
8775 -- Replace "subprogram" with a different word
8777 if Msg_Index <= Msg_Last - 10
8778 and then Msg (Msg_Index .. Msg_Index + 9) = "subprogram"
8780 if Ekind_In (Id, E_Entry, E_Entry_Family) then
8781 Res (Res_Index .. Res_Index + 4) := "entry";
8782 Res_Index := Res_Index + 5;
8785 Res (Res_Index .. Res_Index + 8) := "task type";
8786 Res_Index := Res_Index + 9;
8789 Res (Res_Index .. Res_Index + 9) := "subprogram";
8790 Res_Index := Res_Index + 10;
8793 Msg_Index := Msg_Index + 10;
8795 -- Replace "protected" with a different word
8797 elsif Msg_Index <= Msg_Last - 9
8798 and then Msg (Msg_Index .. Msg_Index + 8) = "protected"
8801 Res (Res_Index .. Res_Index + 3) := "task";
8802 Res_Index := Res_Index + 4;
8803 Msg_Index := Msg_Index + 9;
8805 -- Otherwise copy the character
8808 Res (Res_Index) := Msg (Msg_Index);
8809 Msg_Index := Msg_Index + 1;
8810 Res_Index := Res_Index + 1;
8814 return Res (Res'First .. Res_Index - 1);
8817 -------------------------
8818 -- From_Nested_Package --
8819 -------------------------
8821 function From_Nested_Package (T : Entity_Id) return Boolean is
8822 Pack : constant Entity_Id := Scope (T);
8826 Ekind (Pack) = E_Package
8827 and then not Is_Frozen (Pack)
8828 and then not Scope_Within_Or_Same (Current_Scope, Pack)
8829 and then In_Open_Scopes (Scope (Pack));
8830 end From_Nested_Package;
8832 -----------------------
8833 -- Gather_Components --
8834 -----------------------
8836 procedure Gather_Components
8838 Comp_List : Node_Id;
8839 Governed_By : List_Id;
8841 Report_Errors : out Boolean)
8845 Discrete_Choice : Node_Id;
8846 Comp_Item : Node_Id;
8848 Discrim : Entity_Id;
8849 Discrim_Name : Node_Id;
8850 Discrim_Value : Node_Id;
8853 Report_Errors := False;
8855 if No (Comp_List) or else Null_Present (Comp_List) then
8858 elsif Present (Component_Items (Comp_List)) then
8859 Comp_Item := First (Component_Items (Comp_List));
8865 while Present (Comp_Item) loop
8867 -- Skip the tag of a tagged record, the interface tags, as well
8868 -- as all items that are not user components (anonymous types,
8869 -- rep clauses, Parent field, controller field).
8871 if Nkind (Comp_Item) = N_Component_Declaration then
8873 Comp : constant Entity_Id := Defining_Identifier (Comp_Item);
8875 if not Is_Tag (Comp) and then Chars (Comp) /= Name_uParent then
8876 Append_Elmt (Comp, Into);
8884 if No (Variant_Part (Comp_List)) then
8887 Discrim_Name := Name (Variant_Part (Comp_List));
8888 Variant := First_Non_Pragma (Variants (Variant_Part (Comp_List)));
8891 -- Look for the discriminant that governs this variant part.
8892 -- The discriminant *must* be in the Governed_By List
8894 Assoc := First (Governed_By);
8895 Find_Constraint : loop
8896 Discrim := First (Choices (Assoc));
8897 exit Find_Constraint when
8898 Chars (Discrim_Name) = Chars (Discrim)
8900 (Present (Corresponding_Discriminant (Entity (Discrim)))
8901 and then Chars (Corresponding_Discriminant
8902 (Entity (Discrim))) = Chars (Discrim_Name))
8904 Chars (Original_Record_Component (Entity (Discrim))) =
8905 Chars (Discrim_Name);
8907 if No (Next (Assoc)) then
8908 if not Is_Constrained (Typ) and then Is_Derived_Type (Typ) then
8910 -- If the type is a tagged type with inherited discriminants,
8911 -- use the stored constraint on the parent in order to find
8912 -- the values of discriminants that are otherwise hidden by an
8913 -- explicit constraint. Renamed discriminants are handled in
8916 -- If several parent discriminants are renamed by a single
8917 -- discriminant of the derived type, the call to obtain the
8918 -- Corresponding_Discriminant field only retrieves the last
8919 -- of them. We recover the constraint on the others from the
8920 -- Stored_Constraint as well.
8922 -- An inherited discriminant may have been constrained in a
8923 -- later ancestor (not the immediate parent) so we must examine
8924 -- the stored constraint of all of them to locate the inherited
8930 T : Entity_Id := Typ;
8933 while Is_Derived_Type (T) loop
8934 if Present (Stored_Constraint (T)) then
8935 D := First_Discriminant (Etype (T));
8936 C := First_Elmt (Stored_Constraint (T));
8937 while Present (D) and then Present (C) loop
8938 if Chars (Discrim_Name) = Chars (D) then
8939 if Is_Entity_Name (Node (C))
8940 and then Entity (Node (C)) = Entity (Discrim)
8942 -- D is renamed by Discrim, whose value is
8949 Make_Component_Association (Sloc (Typ),
8951 (New_Occurrence_Of (D, Sloc (Typ))),
8952 Duplicate_Subexpr_No_Checks (Node (C)));
8955 exit Find_Constraint;
8958 Next_Discriminant (D);
8963 -- Discriminant may be inherited from ancestor
8971 if No (Next (Assoc)) then
8973 (" missing value for discriminant&",
8974 First (Governed_By), Discrim_Name);
8976 Report_Errors := True;
8981 end loop Find_Constraint;
8983 Discrim_Value := Expression (Assoc);
8985 if not Is_OK_Static_Expression (Discrim_Value) then
8987 -- If the variant part is governed by a discriminant of the type
8988 -- this is an error. If the variant part and the discriminant are
8989 -- inherited from an ancestor this is legal (AI05-120) unless the
8990 -- components are being gathered for an aggregate, in which case
8991 -- the caller must check Report_Errors.
8993 if Scope (Original_Record_Component
8994 ((Entity (First (Choices (Assoc)))))) = Typ
8997 ("value for discriminant & must be static!",
8998 Discrim_Value, Discrim);
8999 Why_Not_Static (Discrim_Value);
9002 Report_Errors := True;
9006 Search_For_Discriminant_Value : declare
9012 UI_Discrim_Value : constant Uint := Expr_Value (Discrim_Value);
9015 Find_Discrete_Value : while Present (Variant) loop
9017 -- If a choice is a subtype with a static predicate, it must
9018 -- be rewritten as an explicit list of non-predicated choices.
9020 Expand_Static_Predicates_In_Choices (Variant);
9022 Discrete_Choice := First (Discrete_Choices (Variant));
9023 while Present (Discrete_Choice) loop
9024 exit Find_Discrete_Value when
9025 Nkind (Discrete_Choice) = N_Others_Choice;
9027 Get_Index_Bounds (Discrete_Choice, Low, High);
9029 UI_Low := Expr_Value (Low);
9030 UI_High := Expr_Value (High);
9032 exit Find_Discrete_Value when
9033 UI_Low <= UI_Discrim_Value
9035 UI_High >= UI_Discrim_Value;
9037 Next (Discrete_Choice);
9040 Next_Non_Pragma (Variant);
9041 end loop Find_Discrete_Value;
9042 end Search_For_Discriminant_Value;
9044 -- The case statement must include a variant that corresponds to the
9045 -- value of the discriminant, unless the discriminant type has a
9046 -- static predicate. In that case the absence of an others_choice that
9047 -- would cover this value becomes a run-time error (3.8,1 (21.1/2)).
9050 and then not Has_Static_Predicate (Etype (Discrim_Name))
9053 ("value of discriminant & is out of range", Discrim_Value, Discrim);
9054 Report_Errors := True;
9058 -- If we have found the corresponding choice, recursively add its
9059 -- components to the Into list. The nested components are part of
9060 -- the same record type.
9062 if Present (Variant) then
9064 (Typ, Component_List (Variant), Governed_By, Into, Report_Errors);
9066 end Gather_Components;
9068 ------------------------
9069 -- Get_Actual_Subtype --
9070 ------------------------
9072 function Get_Actual_Subtype (N : Node_Id) return Entity_Id is
9073 Typ : constant Entity_Id := Etype (N);
9074 Utyp : Entity_Id := Underlying_Type (Typ);
9083 -- If what we have is an identifier that references a subprogram
9084 -- formal, or a variable or constant object, then we get the actual
9085 -- subtype from the referenced entity if one has been built.
9087 if Nkind (N) = N_Identifier
9089 (Is_Formal (Entity (N))
9090 or else Ekind (Entity (N)) = E_Constant
9091 or else Ekind (Entity (N)) = E_Variable)
9092 and then Present (Actual_Subtype (Entity (N)))
9094 return Actual_Subtype (Entity (N));
9096 -- Actual subtype of unchecked union is always itself. We never need
9097 -- the "real" actual subtype. If we did, we couldn't get it anyway
9098 -- because the discriminant is not available. The restrictions on
9099 -- Unchecked_Union are designed to make sure that this is OK.
9101 elsif Is_Unchecked_Union (Base_Type (Utyp)) then
9104 -- Here for the unconstrained case, we must find actual subtype
9105 -- No actual subtype is available, so we must build it on the fly.
9107 -- Checking the type, not the underlying type, for constrainedness
9108 -- seems to be necessary. Maybe all the tests should be on the type???
9110 elsif (not Is_Constrained (Typ))
9111 and then (Is_Array_Type (Utyp)
9112 or else (Is_Record_Type (Utyp)
9113 and then Has_Discriminants (Utyp)))
9114 and then not Has_Unknown_Discriminants (Utyp)
9115 and then not (Ekind (Utyp) = E_String_Literal_Subtype)
9117 -- Nothing to do if in spec expression (why not???)
9119 if In_Spec_Expression then
9122 elsif Is_Private_Type (Typ) and then not Has_Discriminants (Typ) then
9124 -- If the type has no discriminants, there is no subtype to
9125 -- build, even if the underlying type is discriminated.
9129 -- Else build the actual subtype
9132 Decl := Build_Actual_Subtype (Typ, N);
9134 -- The call may yield a declaration, or just return the entity
9140 Atyp := Defining_Identifier (Decl);
9142 -- If Build_Actual_Subtype generated a new declaration then use it
9146 -- The actual subtype is an Itype, so analyze the declaration,
9147 -- but do not attach it to the tree, to get the type defined.
9149 Set_Parent (Decl, N);
9150 Set_Is_Itype (Atyp);
9151 Analyze (Decl, Suppress => All_Checks);
9152 Set_Associated_Node_For_Itype (Atyp, N);
9153 Set_Has_Delayed_Freeze (Atyp, False);
9155 -- We need to freeze the actual subtype immediately. This is
9156 -- needed, because otherwise this Itype will not get frozen
9157 -- at all, and it is always safe to freeze on creation because
9158 -- any associated types must be frozen at this point.
9160 Freeze_Itype (Atyp, N);
9163 -- Otherwise we did not build a declaration, so return original
9170 -- For all remaining cases, the actual subtype is the same as
9171 -- the nominal type.
9176 end Get_Actual_Subtype;
9178 -------------------------------------
9179 -- Get_Actual_Subtype_If_Available --
9180 -------------------------------------
9182 function Get_Actual_Subtype_If_Available (N : Node_Id) return Entity_Id is
9183 Typ : constant Entity_Id := Etype (N);
9186 -- If what we have is an identifier that references a subprogram
9187 -- formal, or a variable or constant object, then we get the actual
9188 -- subtype from the referenced entity if one has been built.
9190 if Nkind (N) = N_Identifier
9192 (Is_Formal (Entity (N))
9193 or else Ekind (Entity (N)) = E_Constant
9194 or else Ekind (Entity (N)) = E_Variable)
9195 and then Present (Actual_Subtype (Entity (N)))
9197 return Actual_Subtype (Entity (N));
9199 -- Otherwise the Etype of N is returned unchanged
9204 end Get_Actual_Subtype_If_Available;
9206 ------------------------
9207 -- Get_Body_From_Stub --
9208 ------------------------
9210 function Get_Body_From_Stub (N : Node_Id) return Node_Id is
9212 return Proper_Body (Unit (Library_Unit (N)));
9213 end Get_Body_From_Stub;
9215 ---------------------
9216 -- Get_Cursor_Type --
9217 ---------------------
9219 function Get_Cursor_Type
9221 Typ : Entity_Id) return Entity_Id
9225 First_Op : Entity_Id;
9229 -- If error already detected, return
9231 if Error_Posted (Aspect) then
9235 -- The cursor type for an Iterable aspect is the return type of a
9236 -- non-overloaded First primitive operation. Locate association for
9239 Assoc := First (Component_Associations (Expression (Aspect)));
9241 while Present (Assoc) loop
9242 if Chars (First (Choices (Assoc))) = Name_First then
9243 First_Op := Expression (Assoc);
9250 if First_Op = Any_Id then
9251 Error_Msg_N ("aspect Iterable must specify First operation", Aspect);
9254 elsif not Analyzed (First_Op) then
9260 -- Locate function with desired name and profile in scope of type
9261 -- In the rare case where the type is an integer type, a base type
9262 -- is created for it, check that the base type of the first formal
9263 -- of First matches the base type of the domain.
9265 Func := First_Entity (Scope (Typ));
9266 while Present (Func) loop
9267 if Chars (Func) = Chars (First_Op)
9268 and then Ekind (Func) = E_Function
9269 and then Present (First_Formal (Func))
9270 and then Base_Type (Etype (First_Formal (Func))) = Base_Type (Typ)
9271 and then No (Next_Formal (First_Formal (Func)))
9273 if Cursor /= Any_Type then
9275 ("Operation First for iterable type must be unique", Aspect);
9278 Cursor := Etype (Func);
9285 -- If not found, no way to resolve remaining primitives
9287 if Cursor = Any_Type then
9289 ("primitive operation for Iterable type must appear in the same "
9290 & "list of declarations as the type", Aspect);
9294 end Get_Cursor_Type;
9296 function Get_Cursor_Type (Typ : Entity_Id) return Entity_Id is
9298 return Etype (Get_Iterable_Type_Primitive (Typ, Name_First));
9299 end Get_Cursor_Type;
9301 -------------------------------
9302 -- Get_Default_External_Name --
9303 -------------------------------
9305 function Get_Default_External_Name (E : Node_Or_Entity_Id) return Node_Id is
9307 Get_Decoded_Name_String (Chars (E));
9309 if Opt.External_Name_Imp_Casing = Uppercase then
9310 Set_Casing (All_Upper_Case);
9312 Set_Casing (All_Lower_Case);
9316 Make_String_Literal (Sloc (E),
9317 Strval => String_From_Name_Buffer);
9318 end Get_Default_External_Name;
9320 --------------------------
9321 -- Get_Enclosing_Object --
9322 --------------------------
9324 function Get_Enclosing_Object (N : Node_Id) return Entity_Id is
9326 if Is_Entity_Name (N) then
9330 when N_Indexed_Component
9331 | N_Selected_Component
9334 -- If not generating code, a dereference may be left implicit.
9335 -- In thoses cases, return Empty.
9337 if Is_Access_Type (Etype (Prefix (N))) then
9340 return Get_Enclosing_Object (Prefix (N));
9343 when N_Type_Conversion =>
9344 return Get_Enclosing_Object (Expression (N));
9350 end Get_Enclosing_Object;
9352 ---------------------------
9353 -- Get_Enum_Lit_From_Pos --
9354 ---------------------------
9356 function Get_Enum_Lit_From_Pos
9359 Loc : Source_Ptr) return Node_Id
9361 Btyp : Entity_Id := Base_Type (T);
9366 -- In the case where the literal is of type Character, Wide_Character
9367 -- or Wide_Wide_Character or of a type derived from them, there needs
9368 -- to be some special handling since there is no explicit chain of
9369 -- literals to search. Instead, an N_Character_Literal node is created
9370 -- with the appropriate Char_Code and Chars fields.
9372 if Is_Standard_Character_Type (T) then
9373 Set_Character_Literal_Name (UI_To_CC (Pos));
9376 Make_Character_Literal (Loc,
9378 Char_Literal_Value => Pos);
9380 -- For all other cases, we have a complete table of literals, and
9381 -- we simply iterate through the chain of literal until the one
9382 -- with the desired position value is found.
9385 if Is_Private_Type (Btyp) and then Present (Full_View (Btyp)) then
9386 Btyp := Full_View (Btyp);
9389 Lit := First_Literal (Btyp);
9391 -- Position in the enumeration type starts at 0
9393 if UI_To_Int (Pos) < 0 then
9394 raise Constraint_Error;
9397 for J in 1 .. UI_To_Int (Pos) loop
9400 -- If Lit is Empty, Pos is not in range, so raise Constraint_Error
9401 -- inside the loop to avoid calling Next_Literal on Empty.
9404 raise Constraint_Error;
9408 -- Create a new node from Lit, with source location provided by Loc
9409 -- if not equal to No_Location, or by copying the source location of
9414 if LLoc = No_Location then
9418 return New_Occurrence_Of (Lit, LLoc);
9420 end Get_Enum_Lit_From_Pos;
9422 ------------------------
9423 -- Get_Generic_Entity --
9424 ------------------------
9426 function Get_Generic_Entity (N : Node_Id) return Entity_Id is
9427 Ent : constant Entity_Id := Entity (Name (N));
9429 if Present (Renamed_Object (Ent)) then
9430 return Renamed_Object (Ent);
9434 end Get_Generic_Entity;
9436 -------------------------------------
9437 -- Get_Incomplete_View_Of_Ancestor --
9438 -------------------------------------
9440 function Get_Incomplete_View_Of_Ancestor (E : Entity_Id) return Entity_Id is
9441 Cur_Unit : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
9442 Par_Scope : Entity_Id;
9443 Par_Type : Entity_Id;
9446 -- The incomplete view of an ancestor is only relevant for private
9447 -- derived types in child units.
9449 if not Is_Derived_Type (E)
9450 or else not Is_Child_Unit (Cur_Unit)
9455 Par_Scope := Scope (Cur_Unit);
9456 if No (Par_Scope) then
9460 Par_Type := Etype (Base_Type (E));
9462 -- Traverse list of ancestor types until we find one declared in
9463 -- a parent or grandparent unit (two levels seem sufficient).
9465 while Present (Par_Type) loop
9466 if Scope (Par_Type) = Par_Scope
9467 or else Scope (Par_Type) = Scope (Par_Scope)
9471 elsif not Is_Derived_Type (Par_Type) then
9475 Par_Type := Etype (Base_Type (Par_Type));
9479 -- If none found, there is no relevant ancestor type.
9483 end Get_Incomplete_View_Of_Ancestor;
9485 ----------------------
9486 -- Get_Index_Bounds --
9487 ----------------------
9489 procedure Get_Index_Bounds
9493 Use_Full_View : Boolean := False)
9495 function Scalar_Range_Of_Type (Typ : Entity_Id) return Node_Id;
9496 -- Obtain the scalar range of type Typ. If flag Use_Full_View is set and
9497 -- Typ qualifies, the scalar range is obtained from the full view of the
9500 --------------------------
9501 -- Scalar_Range_Of_Type --
9502 --------------------------
9504 function Scalar_Range_Of_Type (Typ : Entity_Id) return Node_Id is
9505 T : Entity_Id := Typ;
9508 if Use_Full_View and then Present (Full_View (T)) then
9512 return Scalar_Range (T);
9513 end Scalar_Range_Of_Type;
9517 Kind : constant Node_Kind := Nkind (N);
9520 -- Start of processing for Get_Index_Bounds
9523 if Kind = N_Range then
9525 H := High_Bound (N);
9527 elsif Kind = N_Subtype_Indication then
9528 Rng := Range_Expression (Constraint (N));
9536 L := Low_Bound (Range_Expression (Constraint (N)));
9537 H := High_Bound (Range_Expression (Constraint (N)));
9540 elsif Is_Entity_Name (N) and then Is_Type (Entity (N)) then
9541 Rng := Scalar_Range_Of_Type (Entity (N));
9543 if Error_Posted (Rng) then
9547 elsif Nkind (Rng) = N_Subtype_Indication then
9548 Get_Index_Bounds (Rng, L, H);
9551 L := Low_Bound (Rng);
9552 H := High_Bound (Rng);
9556 -- N is an expression, indicating a range with one value
9561 end Get_Index_Bounds;
9563 -----------------------------
9564 -- Get_Interfacing_Aspects --
9565 -----------------------------
9567 procedure Get_Interfacing_Aspects
9568 (Iface_Asp : Node_Id;
9569 Conv_Asp : out Node_Id;
9570 EN_Asp : out Node_Id;
9571 Expo_Asp : out Node_Id;
9572 Imp_Asp : out Node_Id;
9573 LN_Asp : out Node_Id;
9574 Do_Checks : Boolean := False)
9576 procedure Save_Or_Duplication_Error
9578 To : in out Node_Id);
9579 -- Save the value of aspect Asp in node To. If To already has a value,
9580 -- then this is considered a duplicate use of aspect. Emit an error if
9581 -- flag Do_Checks is set.
9583 -------------------------------
9584 -- Save_Or_Duplication_Error --
9585 -------------------------------
9587 procedure Save_Or_Duplication_Error
9589 To : in out Node_Id)
9592 -- Detect an extra aspect and issue an error
9594 if Present (To) then
9596 Error_Msg_Name_1 := Chars (Identifier (Asp));
9597 Error_Msg_Sloc := Sloc (To);
9598 Error_Msg_N ("aspect % previously given #", Asp);
9601 -- Otherwise capture the aspect
9606 end Save_Or_Duplication_Error;
9613 -- The following variables capture each individual aspect
9615 Conv : Node_Id := Empty;
9616 EN : Node_Id := Empty;
9617 Expo : Node_Id := Empty;
9618 Imp : Node_Id := Empty;
9619 LN : Node_Id := Empty;
9621 -- Start of processing for Get_Interfacing_Aspects
9624 -- The input interfacing aspect should reside in an aspect specification
9627 pragma Assert (Is_List_Member (Iface_Asp));
9629 -- Examine the aspect specifications of the related entity. Find and
9630 -- capture all interfacing aspects. Detect duplicates and emit errors
9633 Asp := First (List_Containing (Iface_Asp));
9634 while Present (Asp) loop
9635 Asp_Id := Get_Aspect_Id (Asp);
9637 if Asp_Id = Aspect_Convention then
9638 Save_Or_Duplication_Error (Asp, Conv);
9640 elsif Asp_Id = Aspect_External_Name then
9641 Save_Or_Duplication_Error (Asp, EN);
9643 elsif Asp_Id = Aspect_Export then
9644 Save_Or_Duplication_Error (Asp, Expo);
9646 elsif Asp_Id = Aspect_Import then
9647 Save_Or_Duplication_Error (Asp, Imp);
9649 elsif Asp_Id = Aspect_Link_Name then
9650 Save_Or_Duplication_Error (Asp, LN);
9661 end Get_Interfacing_Aspects;
9663 ---------------------------------
9664 -- Get_Iterable_Type_Primitive --
9665 ---------------------------------
9667 function Get_Iterable_Type_Primitive
9669 Nam : Name_Id) return Entity_Id
9671 Funcs : constant Node_Id := Find_Value_Of_Aspect (Typ, Aspect_Iterable);
9679 Assoc := First (Component_Associations (Funcs));
9680 while Present (Assoc) loop
9681 if Chars (First (Choices (Assoc))) = Nam then
9682 return Entity (Expression (Assoc));
9685 Assoc := Next (Assoc);
9690 end Get_Iterable_Type_Primitive;
9692 ----------------------------------
9693 -- Get_Library_Unit_Name_String --
9694 ----------------------------------
9696 procedure Get_Library_Unit_Name_String (Decl_Node : Node_Id) is
9697 Unit_Name_Id : constant Unit_Name_Type := Get_Unit_Name (Decl_Node);
9700 Get_Unit_Name_String (Unit_Name_Id);
9702 -- Remove seven last character (" (spec)" or " (body)")
9704 Name_Len := Name_Len - 7;
9705 pragma Assert (Name_Buffer (Name_Len + 1) = ' ');
9706 end Get_Library_Unit_Name_String;
9708 --------------------------
9709 -- Get_Max_Queue_Length --
9710 --------------------------
9712 function Get_Max_Queue_Length (Id : Entity_Id) return Uint is
9713 pragma Assert (Is_Entry (Id));
9714 Prag : constant Entity_Id := Get_Pragma (Id, Pragma_Max_Queue_Length);
9717 -- A value of 0 represents no maximum specified, and entries and entry
9718 -- families with no Max_Queue_Length aspect or pragma default to it.
9720 if not Present (Prag) then
9724 return Intval (Expression (First (Pragma_Argument_Associations (Prag))));
9725 end Get_Max_Queue_Length;
9727 ------------------------
9728 -- Get_Name_Entity_Id --
9729 ------------------------
9731 function Get_Name_Entity_Id (Id : Name_Id) return Entity_Id is
9733 return Entity_Id (Get_Name_Table_Int (Id));
9734 end Get_Name_Entity_Id;
9736 ------------------------------
9737 -- Get_Name_From_CTC_Pragma --
9738 ------------------------------
9740 function Get_Name_From_CTC_Pragma (N : Node_Id) return String_Id is
9741 Arg : constant Node_Id :=
9742 Get_Pragma_Arg (First (Pragma_Argument_Associations (N)));
9744 return Strval (Expr_Value_S (Arg));
9745 end Get_Name_From_CTC_Pragma;
9747 -----------------------
9748 -- Get_Parent_Entity --
9749 -----------------------
9751 function Get_Parent_Entity (Unit : Node_Id) return Entity_Id is
9753 if Nkind (Unit) = N_Package_Body
9754 and then Nkind (Original_Node (Unit)) = N_Package_Instantiation
9756 return Defining_Entity
9757 (Specification (Instance_Spec (Original_Node (Unit))));
9758 elsif Nkind (Unit) = N_Package_Instantiation then
9759 return Defining_Entity (Specification (Instance_Spec (Unit)));
9761 return Defining_Entity (Unit);
9763 end Get_Parent_Entity;
9769 function Get_Pragma_Id (N : Node_Id) return Pragma_Id is
9771 return Get_Pragma_Id (Pragma_Name_Unmapped (N));
9774 ------------------------
9775 -- Get_Qualified_Name --
9776 ------------------------
9778 function Get_Qualified_Name
9780 Suffix : Entity_Id := Empty) return Name_Id
9782 Suffix_Nam : Name_Id := No_Name;
9785 if Present (Suffix) then
9786 Suffix_Nam := Chars (Suffix);
9789 return Get_Qualified_Name (Chars (Id), Suffix_Nam, Scope (Id));
9790 end Get_Qualified_Name;
9792 function Get_Qualified_Name
9794 Suffix : Name_Id := No_Name;
9795 Scop : Entity_Id := Current_Scope) return Name_Id
9797 procedure Add_Scope (S : Entity_Id);
9798 -- Add the fully qualified form of scope S to the name buffer. The
9806 procedure Add_Scope (S : Entity_Id) is
9811 elsif S = Standard_Standard then
9815 Add_Scope (Scope (S));
9816 Get_Name_String_And_Append (Chars (S));
9817 Add_Str_To_Name_Buffer ("__");
9821 -- Start of processing for Get_Qualified_Name
9827 -- Append the base name after all scopes have been chained
9829 Get_Name_String_And_Append (Nam);
9831 -- Append the suffix (if present)
9833 if Suffix /= No_Name then
9834 Add_Str_To_Name_Buffer ("__");
9835 Get_Name_String_And_Append (Suffix);
9839 end Get_Qualified_Name;
9841 -----------------------
9842 -- Get_Reason_String --
9843 -----------------------
9845 procedure Get_Reason_String (N : Node_Id) is
9847 if Nkind (N) = N_String_Literal then
9848 Store_String_Chars (Strval (N));
9850 elsif Nkind (N) = N_Op_Concat then
9851 Get_Reason_String (Left_Opnd (N));
9852 Get_Reason_String (Right_Opnd (N));
9854 -- If not of required form, error
9858 ("Reason for pragma Warnings has wrong form", N);
9860 ("\must be string literal or concatenation of string literals", N);
9863 end Get_Reason_String;
9865 --------------------------------
9866 -- Get_Reference_Discriminant --
9867 --------------------------------
9869 function Get_Reference_Discriminant (Typ : Entity_Id) return Entity_Id is
9873 D := First_Discriminant (Typ);
9874 while Present (D) loop
9875 if Has_Implicit_Dereference (D) then
9878 Next_Discriminant (D);
9882 end Get_Reference_Discriminant;
9884 ---------------------------
9885 -- Get_Referenced_Object --
9886 ---------------------------
9888 function Get_Referenced_Object (N : Node_Id) return Node_Id is
9893 while Is_Entity_Name (R)
9894 and then Present (Renamed_Object (Entity (R)))
9896 R := Renamed_Object (Entity (R));
9900 end Get_Referenced_Object;
9902 ------------------------
9903 -- Get_Renamed_Entity --
9904 ------------------------
9906 function Get_Renamed_Entity (E : Entity_Id) return Entity_Id is
9911 while Present (Renamed_Entity (R)) loop
9912 R := Renamed_Entity (R);
9916 end Get_Renamed_Entity;
9918 -----------------------
9919 -- Get_Return_Object --
9920 -----------------------
9922 function Get_Return_Object (N : Node_Id) return Entity_Id is
9926 Decl := First (Return_Object_Declarations (N));
9927 while Present (Decl) loop
9928 exit when Nkind (Decl) = N_Object_Declaration
9929 and then Is_Return_Object (Defining_Identifier (Decl));
9933 pragma Assert (Present (Decl));
9934 return Defining_Identifier (Decl);
9935 end Get_Return_Object;
9937 ---------------------------
9938 -- Get_Subprogram_Entity --
9939 ---------------------------
9941 function Get_Subprogram_Entity (Nod : Node_Id) return Entity_Id is
9943 Subp_Id : Entity_Id;
9946 if Nkind (Nod) = N_Accept_Statement then
9947 Subp := Entry_Direct_Name (Nod);
9949 elsif Nkind (Nod) = N_Slice then
9950 Subp := Prefix (Nod);
9956 -- Strip the subprogram call
9959 if Nkind_In (Subp, N_Explicit_Dereference,
9960 N_Indexed_Component,
9961 N_Selected_Component)
9963 Subp := Prefix (Subp);
9965 elsif Nkind_In (Subp, N_Type_Conversion,
9966 N_Unchecked_Type_Conversion)
9968 Subp := Expression (Subp);
9975 -- Extract the entity of the subprogram call
9977 if Is_Entity_Name (Subp) then
9978 Subp_Id := Entity (Subp);
9980 if Ekind (Subp_Id) = E_Access_Subprogram_Type then
9981 Subp_Id := Directly_Designated_Type (Subp_Id);
9984 if Is_Subprogram (Subp_Id) then
9990 -- The search did not find a construct that denotes a subprogram
9995 end Get_Subprogram_Entity;
9997 -----------------------------
9998 -- Get_Task_Body_Procedure --
9999 -----------------------------
10001 function Get_Task_Body_Procedure (E : Entity_Id) return Entity_Id is
10003 -- Note: A task type may be the completion of a private type with
10004 -- discriminants. When performing elaboration checks on a task
10005 -- declaration, the current view of the type may be the private one,
10006 -- and the procedure that holds the body of the task is held in its
10007 -- underlying type.
10009 -- This is an odd function, why not have Task_Body_Procedure do
10010 -- the following digging???
10012 return Task_Body_Procedure (Underlying_Type (Root_Type (E)));
10013 end Get_Task_Body_Procedure;
10015 -------------------------
10016 -- Get_User_Defined_Eq --
10017 -------------------------
10019 function Get_User_Defined_Eq (E : Entity_Id) return Entity_Id is
10024 Prim := First_Elmt (Collect_Primitive_Operations (E));
10025 while Present (Prim) loop
10028 if Chars (Op) = Name_Op_Eq
10029 and then Etype (Op) = Standard_Boolean
10030 and then Etype (First_Formal (Op)) = E
10031 and then Etype (Next_Formal (First_Formal (Op))) = E
10040 end Get_User_Defined_Eq;
10046 procedure Get_Views
10048 Priv_Typ : out Entity_Id;
10049 Full_Typ : out Entity_Id;
10050 Full_Base : out Entity_Id;
10051 CRec_Typ : out Entity_Id)
10053 IP_View : Entity_Id;
10056 -- Assume that none of the views can be recovered
10060 Full_Base := Empty;
10063 -- The input type is the corresponding record type of a protected or a
10066 if Ekind (Typ) = E_Record_Type
10067 and then Is_Concurrent_Record_Type (Typ)
10070 Full_Typ := Corresponding_Concurrent_Type (CRec_Typ);
10071 Full_Base := Base_Type (Full_Typ);
10072 Priv_Typ := Incomplete_Or_Partial_View (Full_Typ);
10074 -- Otherwise the input type denotes an arbitrary type
10077 IP_View := Incomplete_Or_Partial_View (Typ);
10079 -- The input type denotes the full view of a private type
10081 if Present (IP_View) then
10082 Priv_Typ := IP_View;
10085 -- The input type is a private type
10087 elsif Is_Private_Type (Typ) then
10089 Full_Typ := Full_View (Priv_Typ);
10091 -- Otherwise the input type does not have any views
10097 if Present (Full_Typ) then
10098 Full_Base := Base_Type (Full_Typ);
10100 if Ekind_In (Full_Typ, E_Protected_Type, E_Task_Type) then
10101 CRec_Typ := Corresponding_Record_Type (Full_Typ);
10107 -----------------------
10108 -- Has_Access_Values --
10109 -----------------------
10111 function Has_Access_Values (T : Entity_Id) return Boolean is
10112 Typ : constant Entity_Id := Underlying_Type (T);
10115 -- Case of a private type which is not completed yet. This can only
10116 -- happen in the case of a generic format type appearing directly, or
10117 -- as a component of the type to which this function is being applied
10118 -- at the top level. Return False in this case, since we certainly do
10119 -- not know that the type contains access types.
10124 elsif Is_Access_Type (Typ) then
10127 elsif Is_Array_Type (Typ) then
10128 return Has_Access_Values (Component_Type (Typ));
10130 elsif Is_Record_Type (Typ) then
10135 -- Loop to Check components
10137 Comp := First_Component_Or_Discriminant (Typ);
10138 while Present (Comp) loop
10140 -- Check for access component, tag field does not count, even
10141 -- though it is implemented internally using an access type.
10143 if Has_Access_Values (Etype (Comp))
10144 and then Chars (Comp) /= Name_uTag
10149 Next_Component_Or_Discriminant (Comp);
10158 end Has_Access_Values;
10160 ------------------------------
10161 -- Has_Compatible_Alignment --
10162 ------------------------------
10164 function Has_Compatible_Alignment
10167 Layout_Done : Boolean) return Alignment_Result
10169 function Has_Compatible_Alignment_Internal
10172 Layout_Done : Boolean;
10173 Default : Alignment_Result) return Alignment_Result;
10174 -- This is the internal recursive function that actually does the work.
10175 -- There is one additional parameter, which says what the result should
10176 -- be if no alignment information is found, and there is no definite
10177 -- indication of compatible alignments. At the outer level, this is set
10178 -- to Unknown, but for internal recursive calls in the case where types
10179 -- are known to be correct, it is set to Known_Compatible.
10181 ---------------------------------------
10182 -- Has_Compatible_Alignment_Internal --
10183 ---------------------------------------
10185 function Has_Compatible_Alignment_Internal
10188 Layout_Done : Boolean;
10189 Default : Alignment_Result) return Alignment_Result
10191 Result : Alignment_Result := Known_Compatible;
10192 -- Holds the current status of the result. Note that once a value of
10193 -- Known_Incompatible is set, it is sticky and does not get changed
10194 -- to Unknown (the value in Result only gets worse as we go along,
10197 Offs : Uint := No_Uint;
10198 -- Set to a factor of the offset from the base object when Expr is a
10199 -- selected or indexed component, based on Component_Bit_Offset and
10200 -- Component_Size respectively. A negative value is used to represent
10201 -- a value which is not known at compile time.
10203 procedure Check_Prefix;
10204 -- Checks the prefix recursively in the case where the expression
10205 -- is an indexed or selected component.
10207 procedure Set_Result (R : Alignment_Result);
10208 -- If R represents a worse outcome (unknown instead of known
10209 -- compatible, or known incompatible), then set Result to R.
10215 procedure Check_Prefix is
10217 -- The subtlety here is that in doing a recursive call to check
10218 -- the prefix, we have to decide what to do in the case where we
10219 -- don't find any specific indication of an alignment problem.
10221 -- At the outer level, we normally set Unknown as the result in
10222 -- this case, since we can only set Known_Compatible if we really
10223 -- know that the alignment value is OK, but for the recursive
10224 -- call, in the case where the types match, and we have not
10225 -- specified a peculiar alignment for the object, we are only
10226 -- concerned about suspicious rep clauses, the default case does
10227 -- not affect us, since the compiler will, in the absence of such
10228 -- rep clauses, ensure that the alignment is correct.
10230 if Default = Known_Compatible
10232 (Etype (Obj) = Etype (Expr)
10233 and then (Unknown_Alignment (Obj)
10235 Alignment (Obj) = Alignment (Etype (Obj))))
10238 (Has_Compatible_Alignment_Internal
10239 (Obj, Prefix (Expr), Layout_Done, Known_Compatible));
10241 -- In all other cases, we need a full check on the prefix
10245 (Has_Compatible_Alignment_Internal
10246 (Obj, Prefix (Expr), Layout_Done, Unknown));
10254 procedure Set_Result (R : Alignment_Result) is
10261 -- Start of processing for Has_Compatible_Alignment_Internal
10264 -- If Expr is a selected component, we must make sure there is no
10265 -- potentially troublesome component clause and that the record is
10266 -- not packed if the layout is not done.
10268 if Nkind (Expr) = N_Selected_Component then
10270 -- Packing generates unknown alignment if layout is not done
10272 if Is_Packed (Etype (Prefix (Expr))) and then not Layout_Done then
10273 Set_Result (Unknown);
10276 -- Check prefix and component offset
10279 Offs := Component_Bit_Offset (Entity (Selector_Name (Expr)));
10281 -- If Expr is an indexed component, we must make sure there is no
10282 -- potentially troublesome Component_Size clause and that the array
10283 -- is not bit-packed if the layout is not done.
10285 elsif Nkind (Expr) = N_Indexed_Component then
10287 Typ : constant Entity_Id := Etype (Prefix (Expr));
10290 -- Packing generates unknown alignment if layout is not done
10292 if Is_Bit_Packed_Array (Typ) and then not Layout_Done then
10293 Set_Result (Unknown);
10296 -- Check prefix and component offset (or at least size)
10299 Offs := Indexed_Component_Bit_Offset (Expr);
10300 if Offs = No_Uint then
10301 Offs := Component_Size (Typ);
10306 -- If we have a null offset, the result is entirely determined by
10307 -- the base object and has already been computed recursively.
10309 if Offs = Uint_0 then
10312 -- Case where we know the alignment of the object
10314 elsif Known_Alignment (Obj) then
10316 ObjA : constant Uint := Alignment (Obj);
10317 ExpA : Uint := No_Uint;
10318 SizA : Uint := No_Uint;
10321 -- If alignment of Obj is 1, then we are always OK
10324 Set_Result (Known_Compatible);
10326 -- Alignment of Obj is greater than 1, so we need to check
10329 -- If we have an offset, see if it is compatible
10331 if Offs /= No_Uint and Offs > Uint_0 then
10332 if Offs mod (System_Storage_Unit * ObjA) /= 0 then
10333 Set_Result (Known_Incompatible);
10336 -- See if Expr is an object with known alignment
10338 elsif Is_Entity_Name (Expr)
10339 and then Known_Alignment (Entity (Expr))
10341 ExpA := Alignment (Entity (Expr));
10343 -- Otherwise, we can use the alignment of the type of
10344 -- Expr given that we already checked for
10345 -- discombobulating rep clauses for the cases of indexed
10346 -- and selected components above.
10348 elsif Known_Alignment (Etype (Expr)) then
10349 ExpA := Alignment (Etype (Expr));
10351 -- Otherwise the alignment is unknown
10354 Set_Result (Default);
10357 -- If we got an alignment, see if it is acceptable
10359 if ExpA /= No_Uint and then ExpA < ObjA then
10360 Set_Result (Known_Incompatible);
10363 -- If Expr is not a piece of a larger object, see if size
10364 -- is given. If so, check that it is not too small for the
10365 -- required alignment.
10367 if Offs /= No_Uint then
10370 -- See if Expr is an object with known size
10372 elsif Is_Entity_Name (Expr)
10373 and then Known_Static_Esize (Entity (Expr))
10375 SizA := Esize (Entity (Expr));
10377 -- Otherwise, we check the object size of the Expr type
10379 elsif Known_Static_Esize (Etype (Expr)) then
10380 SizA := Esize (Etype (Expr));
10383 -- If we got a size, see if it is a multiple of the Obj
10384 -- alignment, if not, then the alignment cannot be
10385 -- acceptable, since the size is always a multiple of the
10388 if SizA /= No_Uint then
10389 if SizA mod (ObjA * Ttypes.System_Storage_Unit) /= 0 then
10390 Set_Result (Known_Incompatible);
10396 -- If we do not know required alignment, any non-zero offset is a
10397 -- potential problem (but certainly may be OK, so result is unknown).
10399 elsif Offs /= No_Uint then
10400 Set_Result (Unknown);
10402 -- If we can't find the result by direct comparison of alignment
10403 -- values, then there is still one case that we can determine known
10404 -- result, and that is when we can determine that the types are the
10405 -- same, and no alignments are specified. Then we known that the
10406 -- alignments are compatible, even if we don't know the alignment
10407 -- value in the front end.
10409 elsif Etype (Obj) = Etype (Expr) then
10411 -- Types are the same, but we have to check for possible size
10412 -- and alignments on the Expr object that may make the alignment
10413 -- different, even though the types are the same.
10415 if Is_Entity_Name (Expr) then
10417 -- First check alignment of the Expr object. Any alignment less
10418 -- than Maximum_Alignment is worrisome since this is the case
10419 -- where we do not know the alignment of Obj.
10421 if Known_Alignment (Entity (Expr))
10422 and then UI_To_Int (Alignment (Entity (Expr))) <
10423 Ttypes.Maximum_Alignment
10425 Set_Result (Unknown);
10427 -- Now check size of Expr object. Any size that is not an
10428 -- even multiple of Maximum_Alignment is also worrisome
10429 -- since it may cause the alignment of the object to be less
10430 -- than the alignment of the type.
10432 elsif Known_Static_Esize (Entity (Expr))
10434 (UI_To_Int (Esize (Entity (Expr))) mod
10435 (Ttypes.Maximum_Alignment * Ttypes.System_Storage_Unit))
10438 Set_Result (Unknown);
10440 -- Otherwise same type is decisive
10443 Set_Result (Known_Compatible);
10447 -- Another case to deal with is when there is an explicit size or
10448 -- alignment clause when the types are not the same. If so, then the
10449 -- result is Unknown. We don't need to do this test if the Default is
10450 -- Unknown, since that result will be set in any case.
10452 elsif Default /= Unknown
10453 and then (Has_Size_Clause (Etype (Expr))
10455 Has_Alignment_Clause (Etype (Expr)))
10457 Set_Result (Unknown);
10459 -- If no indication found, set default
10462 Set_Result (Default);
10465 -- Return worst result found
10468 end Has_Compatible_Alignment_Internal;
10470 -- Start of processing for Has_Compatible_Alignment
10473 -- If Obj has no specified alignment, then set alignment from the type
10474 -- alignment. Perhaps we should always do this, but for sure we should
10475 -- do it when there is an address clause since we can do more if the
10476 -- alignment is known.
10478 if Unknown_Alignment (Obj) then
10479 Set_Alignment (Obj, Alignment (Etype (Obj)));
10482 -- Now do the internal call that does all the work
10485 Has_Compatible_Alignment_Internal (Obj, Expr, Layout_Done, Unknown);
10486 end Has_Compatible_Alignment;
10488 ----------------------
10489 -- Has_Declarations --
10490 ----------------------
10492 function Has_Declarations (N : Node_Id) return Boolean is
10494 return Nkind_In (Nkind (N), N_Accept_Statement,
10496 N_Compilation_Unit_Aux,
10502 N_Package_Specification);
10503 end Has_Declarations;
10505 ---------------------------------
10506 -- Has_Defaulted_Discriminants --
10507 ---------------------------------
10509 function Has_Defaulted_Discriminants (Typ : Entity_Id) return Boolean is
10511 return Has_Discriminants (Typ)
10512 and then Present (First_Discriminant (Typ))
10513 and then Present (Discriminant_Default_Value
10514 (First_Discriminant (Typ)));
10515 end Has_Defaulted_Discriminants;
10517 -------------------
10518 -- Has_Denormals --
10519 -------------------
10521 function Has_Denormals (E : Entity_Id) return Boolean is
10523 return Is_Floating_Point_Type (E) and then Denorm_On_Target;
10526 -------------------------------------------
10527 -- Has_Discriminant_Dependent_Constraint --
10528 -------------------------------------------
10530 function Has_Discriminant_Dependent_Constraint
10531 (Comp : Entity_Id) return Boolean
10533 Comp_Decl : constant Node_Id := Parent (Comp);
10534 Subt_Indic : Node_Id;
10539 -- Discriminants can't depend on discriminants
10541 if Ekind (Comp) = E_Discriminant then
10545 Subt_Indic := Subtype_Indication (Component_Definition (Comp_Decl));
10547 if Nkind (Subt_Indic) = N_Subtype_Indication then
10548 Constr := Constraint (Subt_Indic);
10550 if Nkind (Constr) = N_Index_Or_Discriminant_Constraint then
10551 Assn := First (Constraints (Constr));
10552 while Present (Assn) loop
10553 case Nkind (Assn) is
10556 | N_Subtype_Indication
10558 if Depends_On_Discriminant (Assn) then
10562 when N_Discriminant_Association =>
10563 if Depends_On_Discriminant (Expression (Assn)) then
10578 end Has_Discriminant_Dependent_Constraint;
10580 --------------------------------------
10581 -- Has_Effectively_Volatile_Profile --
10582 --------------------------------------
10584 function Has_Effectively_Volatile_Profile
10585 (Subp_Id : Entity_Id) return Boolean
10587 Formal : Entity_Id;
10590 -- Inspect the formal parameters looking for an effectively volatile
10593 Formal := First_Formal (Subp_Id);
10594 while Present (Formal) loop
10595 if Is_Effectively_Volatile (Etype (Formal)) then
10599 Next_Formal (Formal);
10602 -- Inspect the return type of functions
10604 if Ekind_In (Subp_Id, E_Function, E_Generic_Function)
10605 and then Is_Effectively_Volatile (Etype (Subp_Id))
10611 end Has_Effectively_Volatile_Profile;
10613 --------------------------
10614 -- Has_Enabled_Property --
10615 --------------------------
10617 function Has_Enabled_Property
10618 (Item_Id : Entity_Id;
10619 Property : Name_Id) return Boolean
10621 function Protected_Object_Has_Enabled_Property return Boolean;
10622 -- Determine whether a protected object denoted by Item_Id has the
10623 -- property enabled.
10625 function State_Has_Enabled_Property return Boolean;
10626 -- Determine whether a state denoted by Item_Id has the property enabled
10628 function Variable_Has_Enabled_Property return Boolean;
10629 -- Determine whether a variable denoted by Item_Id has the property
10632 -------------------------------------------
10633 -- Protected_Object_Has_Enabled_Property --
10634 -------------------------------------------
10636 function Protected_Object_Has_Enabled_Property return Boolean is
10637 Constits : constant Elist_Id := Part_Of_Constituents (Item_Id);
10638 Constit_Elmt : Elmt_Id;
10639 Constit_Id : Entity_Id;
10642 -- Protected objects always have the properties Async_Readers and
10643 -- Async_Writers (SPARK RM 7.1.2(16)).
10645 if Property = Name_Async_Readers
10646 or else Property = Name_Async_Writers
10650 -- Protected objects that have Part_Of components also inherit their
10651 -- properties Effective_Reads and Effective_Writes
10652 -- (SPARK RM 7.1.2(16)).
10654 elsif Present (Constits) then
10655 Constit_Elmt := First_Elmt (Constits);
10656 while Present (Constit_Elmt) loop
10657 Constit_Id := Node (Constit_Elmt);
10659 if Has_Enabled_Property (Constit_Id, Property) then
10663 Next_Elmt (Constit_Elmt);
10668 end Protected_Object_Has_Enabled_Property;
10670 --------------------------------
10671 -- State_Has_Enabled_Property --
10672 --------------------------------
10674 function State_Has_Enabled_Property return Boolean is
10675 Decl : constant Node_Id := Parent (Item_Id);
10677 procedure Find_Simple_Properties
10678 (Has_External : out Boolean;
10679 Has_Synchronous : out Boolean);
10680 -- Extract the simple properties associated with declaration Decl
10682 function Is_Enabled_External_Property return Boolean;
10683 -- Determine whether property Property appears within the external
10684 -- property list of declaration Decl, and return its status.
10686 ----------------------------
10687 -- Find_Simple_Properties --
10688 ----------------------------
10690 procedure Find_Simple_Properties
10691 (Has_External : out Boolean;
10692 Has_Synchronous : out Boolean)
10697 -- Assume that none of the properties are available
10699 Has_External := False;
10700 Has_Synchronous := False;
10702 Opt := First (Expressions (Decl));
10703 while Present (Opt) loop
10704 if Nkind (Opt) = N_Identifier then
10705 if Chars (Opt) = Name_External then
10706 Has_External := True;
10708 elsif Chars (Opt) = Name_Synchronous then
10709 Has_Synchronous := True;
10715 end Find_Simple_Properties;
10717 ----------------------------------
10718 -- Is_Enabled_External_Property --
10719 ----------------------------------
10721 function Is_Enabled_External_Property return Boolean is
10725 Prop_Nam : Node_Id;
10729 Opt := First (Component_Associations (Decl));
10730 while Present (Opt) loop
10731 Opt_Nam := First (Choices (Opt));
10733 if Nkind (Opt_Nam) = N_Identifier
10734 and then Chars (Opt_Nam) = Name_External
10736 Props := Expression (Opt);
10738 -- Multiple properties appear as an aggregate
10740 if Nkind (Props) = N_Aggregate then
10742 -- Simple property form
10744 Prop := First (Expressions (Props));
10745 while Present (Prop) loop
10746 if Chars (Prop) = Property then
10753 -- Property with expression form
10755 Prop := First (Component_Associations (Props));
10756 while Present (Prop) loop
10757 Prop_Nam := First (Choices (Prop));
10759 -- The property can be represented in two ways:
10760 -- others => <value>
10761 -- <property> => <value>
10763 if Nkind (Prop_Nam) = N_Others_Choice
10764 or else (Nkind (Prop_Nam) = N_Identifier
10765 and then Chars (Prop_Nam) = Property)
10767 return Is_True (Expr_Value (Expression (Prop)));
10776 return Chars (Props) = Property;
10784 end Is_Enabled_External_Property;
10788 Has_External : Boolean;
10789 Has_Synchronous : Boolean;
10791 -- Start of processing for State_Has_Enabled_Property
10794 -- The declaration of an external abstract state appears as an
10795 -- extension aggregate. If this is not the case, properties can
10798 if Nkind (Decl) /= N_Extension_Aggregate then
10802 Find_Simple_Properties (Has_External, Has_Synchronous);
10804 -- Simple option External enables all properties (SPARK RM 7.1.2(2))
10806 if Has_External then
10809 -- Option External may enable or disable specific properties
10811 elsif Is_Enabled_External_Property then
10814 -- Simple option Synchronous
10816 -- enables disables
10817 -- Async_Readers Effective_Reads
10818 -- Async_Writers Effective_Writes
10820 -- Note that both forms of External have higher precedence than
10821 -- Synchronous (SPARK RM 7.1.4(9)).
10823 elsif Has_Synchronous then
10824 return Nam_In (Property, Name_Async_Readers, Name_Async_Writers);
10828 end State_Has_Enabled_Property;
10830 -----------------------------------
10831 -- Variable_Has_Enabled_Property --
10832 -----------------------------------
10834 function Variable_Has_Enabled_Property return Boolean is
10835 function Is_Enabled (Prag : Node_Id) return Boolean;
10836 -- Determine whether property pragma Prag (if present) denotes an
10837 -- enabled property.
10843 function Is_Enabled (Prag : Node_Id) return Boolean is
10847 if Present (Prag) then
10848 Arg1 := First (Pragma_Argument_Associations (Prag));
10850 -- The pragma has an optional Boolean expression, the related
10851 -- property is enabled only when the expression evaluates to
10854 if Present (Arg1) then
10855 return Is_True (Expr_Value (Get_Pragma_Arg (Arg1)));
10857 -- Otherwise the lack of expression enables the property by
10864 -- The property was never set in the first place
10873 AR : constant Node_Id :=
10874 Get_Pragma (Item_Id, Pragma_Async_Readers);
10875 AW : constant Node_Id :=
10876 Get_Pragma (Item_Id, Pragma_Async_Writers);
10877 ER : constant Node_Id :=
10878 Get_Pragma (Item_Id, Pragma_Effective_Reads);
10879 EW : constant Node_Id :=
10880 Get_Pragma (Item_Id, Pragma_Effective_Writes);
10882 -- Start of processing for Variable_Has_Enabled_Property
10885 -- A non-effectively volatile object can never possess external
10888 if not Is_Effectively_Volatile (Item_Id) then
10891 -- External properties related to variables come in two flavors -
10892 -- explicit and implicit. The explicit case is characterized by the
10893 -- presence of a property pragma with an optional Boolean flag. The
10894 -- property is enabled when the flag evaluates to True or the flag is
10895 -- missing altogether.
10897 elsif Property = Name_Async_Readers and then Is_Enabled (AR) then
10900 elsif Property = Name_Async_Writers and then Is_Enabled (AW) then
10903 elsif Property = Name_Effective_Reads and then Is_Enabled (ER) then
10906 elsif Property = Name_Effective_Writes and then Is_Enabled (EW) then
10909 -- The implicit case lacks all property pragmas
10911 elsif No (AR) and then No (AW) and then No (ER) and then No (EW) then
10912 if Is_Protected_Type (Etype (Item_Id)) then
10913 return Protected_Object_Has_Enabled_Property;
10921 end Variable_Has_Enabled_Property;
10923 -- Start of processing for Has_Enabled_Property
10926 -- Abstract states and variables have a flexible scheme of specifying
10927 -- external properties.
10929 if Ekind (Item_Id) = E_Abstract_State then
10930 return State_Has_Enabled_Property;
10932 elsif Ekind (Item_Id) = E_Variable then
10933 return Variable_Has_Enabled_Property;
10935 -- By default, protected objects only have the properties Async_Readers
10936 -- and Async_Writers. If they have Part_Of components, they also inherit
10937 -- their properties Effective_Reads and Effective_Writes
10938 -- (SPARK RM 7.1.2(16)).
10940 elsif Ekind (Item_Id) = E_Protected_Object then
10941 return Protected_Object_Has_Enabled_Property;
10943 -- Otherwise a property is enabled when the related item is effectively
10947 return Is_Effectively_Volatile (Item_Id);
10949 end Has_Enabled_Property;
10951 -------------------------------------
10952 -- Has_Full_Default_Initialization --
10953 -------------------------------------
10955 function Has_Full_Default_Initialization (Typ : Entity_Id) return Boolean is
10959 -- A type subject to pragma Default_Initial_Condition may be fully
10960 -- default initialized depending on inheritance and the argument of
10961 -- the pragma. Since any type may act as the full view of a private
10962 -- type, this check must be performed prior to the specialized tests
10965 if Has_Fully_Default_Initializing_DIC_Pragma (Typ) then
10969 -- A scalar type is fully default initialized if it is subject to aspect
10972 if Is_Scalar_Type (Typ) then
10973 return Has_Default_Aspect (Typ);
10975 -- An access type is fully default initialized by default
10977 elsif Is_Access_Type (Typ) then
10980 -- An array type is fully default initialized if its element type is
10981 -- scalar and the array type carries aspect Default_Component_Value or
10982 -- the element type is fully default initialized.
10984 elsif Is_Array_Type (Typ) then
10986 Has_Default_Aspect (Typ)
10987 or else Has_Full_Default_Initialization (Component_Type (Typ));
10989 -- A protected type, record type, or type extension is fully default
10990 -- initialized if all its components either carry an initialization
10991 -- expression or have a type that is fully default initialized. The
10992 -- parent type of a type extension must be fully default initialized.
10994 elsif Is_Record_Type (Typ) or else Is_Protected_Type (Typ) then
10996 -- Inspect all entities defined in the scope of the type, looking for
10997 -- uninitialized components.
10999 Comp := First_Entity (Typ);
11000 while Present (Comp) loop
11001 if Ekind (Comp) = E_Component
11002 and then Comes_From_Source (Comp)
11003 and then No (Expression (Parent (Comp)))
11004 and then not Has_Full_Default_Initialization (Etype (Comp))
11009 Next_Entity (Comp);
11012 -- Ensure that the parent type of a type extension is fully default
11015 if Etype (Typ) /= Typ
11016 and then not Has_Full_Default_Initialization (Etype (Typ))
11021 -- If we get here, then all components and parent portion are fully
11022 -- default initialized.
11026 -- A task type is fully default initialized by default
11028 elsif Is_Task_Type (Typ) then
11031 -- Otherwise the type is not fully default initialized
11036 end Has_Full_Default_Initialization;
11038 -----------------------------------------------
11039 -- Has_Fully_Default_Initializing_DIC_Pragma --
11040 -----------------------------------------------
11042 function Has_Fully_Default_Initializing_DIC_Pragma
11043 (Typ : Entity_Id) return Boolean
11049 -- A type that inherits pragma Default_Initial_Condition from a parent
11050 -- type is automatically fully default initialized.
11052 if Has_Inherited_DIC (Typ) then
11055 -- Otherwise the type is fully default initialized only when the pragma
11056 -- appears without an argument, or the argument is non-null.
11058 elsif Has_Own_DIC (Typ) then
11059 Prag := Get_Pragma (Typ, Pragma_Default_Initial_Condition);
11060 pragma Assert (Present (Prag));
11061 Args := Pragma_Argument_Associations (Prag);
11063 -- The pragma appears without an argument in which case it defaults
11069 -- The pragma appears with a non-null expression
11071 elsif Nkind (Get_Pragma_Arg (First (Args))) /= N_Null then
11077 end Has_Fully_Default_Initializing_DIC_Pragma;
11079 --------------------
11080 -- Has_Infinities --
11081 --------------------
11083 function Has_Infinities (E : Entity_Id) return Boolean is
11086 Is_Floating_Point_Type (E)
11087 and then Nkind (Scalar_Range (E)) = N_Range
11088 and then Includes_Infinities (Scalar_Range (E));
11089 end Has_Infinities;
11091 --------------------
11092 -- Has_Interfaces --
11093 --------------------
11095 function Has_Interfaces
11097 Use_Full_View : Boolean := True) return Boolean
11099 Typ : Entity_Id := Base_Type (T);
11102 -- Handle concurrent types
11104 if Is_Concurrent_Type (Typ) then
11105 Typ := Corresponding_Record_Type (Typ);
11108 if not Present (Typ)
11109 or else not Is_Record_Type (Typ)
11110 or else not Is_Tagged_Type (Typ)
11115 -- Handle private types
11117 if Use_Full_View and then Present (Full_View (Typ)) then
11118 Typ := Full_View (Typ);
11121 -- Handle concurrent record types
11123 if Is_Concurrent_Record_Type (Typ)
11124 and then Is_Non_Empty_List (Abstract_Interface_List (Typ))
11130 if Is_Interface (Typ)
11132 (Is_Record_Type (Typ)
11133 and then Present (Interfaces (Typ))
11134 and then not Is_Empty_Elmt_List (Interfaces (Typ)))
11139 exit when Etype (Typ) = Typ
11141 -- Handle private types
11143 or else (Present (Full_View (Etype (Typ)))
11144 and then Full_View (Etype (Typ)) = Typ)
11146 -- Protect frontend against wrong sources with cyclic derivations
11148 or else Etype (Typ) = T;
11150 -- Climb to the ancestor type handling private types
11152 if Present (Full_View (Etype (Typ))) then
11153 Typ := Full_View (Etype (Typ));
11155 Typ := Etype (Typ);
11160 end Has_Interfaces;
11162 --------------------------
11163 -- Has_Max_Queue_Length --
11164 --------------------------
11166 function Has_Max_Queue_Length (Id : Entity_Id) return Boolean is
11169 Ekind (Id) = E_Entry
11170 and then Present (Get_Pragma (Id, Pragma_Max_Queue_Length));
11171 end Has_Max_Queue_Length;
11173 ---------------------------------
11174 -- Has_No_Obvious_Side_Effects --
11175 ---------------------------------
11177 function Has_No_Obvious_Side_Effects (N : Node_Id) return Boolean is
11179 -- For now handle literals, constants, and non-volatile variables and
11180 -- expressions combining these with operators or short circuit forms.
11182 if Nkind (N) in N_Numeric_Or_String_Literal then
11185 elsif Nkind (N) = N_Character_Literal then
11188 elsif Nkind (N) in N_Unary_Op then
11189 return Has_No_Obvious_Side_Effects (Right_Opnd (N));
11191 elsif Nkind (N) in N_Binary_Op or else Nkind (N) in N_Short_Circuit then
11192 return Has_No_Obvious_Side_Effects (Left_Opnd (N))
11194 Has_No_Obvious_Side_Effects (Right_Opnd (N));
11196 elsif Nkind (N) = N_Expression_With_Actions
11197 and then Is_Empty_List (Actions (N))
11199 return Has_No_Obvious_Side_Effects (Expression (N));
11201 elsif Nkind (N) in N_Has_Entity then
11202 return Present (Entity (N))
11203 and then Ekind_In (Entity (N), E_Variable,
11205 E_Enumeration_Literal,
11208 E_In_Out_Parameter)
11209 and then not Is_Volatile (Entity (N));
11214 end Has_No_Obvious_Side_Effects;
11216 -----------------------------
11217 -- Has_Non_Null_Refinement --
11218 -----------------------------
11220 function Has_Non_Null_Refinement (Id : Entity_Id) return Boolean is
11221 Constits : Elist_Id;
11224 pragma Assert (Ekind (Id) = E_Abstract_State);
11225 Constits := Refinement_Constituents (Id);
11227 -- For a refinement to be non-null, the first constituent must be
11228 -- anything other than null.
11232 and then Nkind (Node (First_Elmt (Constits))) /= N_Null;
11233 end Has_Non_Null_Refinement;
11235 -----------------------------
11236 -- Has_Non_Null_Statements --
11237 -----------------------------
11239 function Has_Non_Null_Statements (L : List_Id) return Boolean is
11243 if Is_Non_Empty_List (L) then
11247 if Nkind (Node) /= N_Null_Statement then
11252 exit when Node = Empty;
11257 end Has_Non_Null_Statements;
11259 ----------------------------------
11260 -- Has_Non_Trivial_Precondition --
11261 ----------------------------------
11263 function Has_Non_Trivial_Precondition (Subp : Entity_Id) return Boolean is
11264 Pre : constant Node_Id := Find_Aspect (Subp, Aspect_Pre);
11269 and then Class_Present (Pre)
11270 and then not Is_Entity_Name (Expression (Pre));
11271 end Has_Non_Trivial_Precondition;
11273 -------------------
11274 -- Has_Null_Body --
11275 -------------------
11277 function Has_Null_Body (Proc_Id : Entity_Id) return Boolean is
11278 Body_Id : Entity_Id;
11285 Spec := Parent (Proc_Id);
11286 Decl := Parent (Spec);
11288 -- Retrieve the entity of the procedure body (e.g. invariant proc).
11290 if Nkind (Spec) = N_Procedure_Specification
11291 and then Nkind (Decl) = N_Subprogram_Declaration
11293 Body_Id := Corresponding_Body (Decl);
11295 -- The body acts as a spec
11298 Body_Id := Proc_Id;
11301 -- The body will be generated later
11303 if No (Body_Id) then
11307 Spec := Parent (Body_Id);
11308 Decl := Parent (Spec);
11311 (Nkind (Spec) = N_Procedure_Specification
11312 and then Nkind (Decl) = N_Subprogram_Body);
11314 Stmt1 := First (Statements (Handled_Statement_Sequence (Decl)));
11316 -- Look for a null statement followed by an optional return
11319 if Nkind (Stmt1) = N_Null_Statement then
11320 Stmt2 := Next (Stmt1);
11322 if Present (Stmt2) then
11323 return Nkind (Stmt2) = N_Simple_Return_Statement;
11332 ------------------------
11333 -- Has_Null_Exclusion --
11334 ------------------------
11336 function Has_Null_Exclusion (N : Node_Id) return Boolean is
11339 when N_Access_Definition
11340 | N_Access_Function_Definition
11341 | N_Access_Procedure_Definition
11342 | N_Access_To_Object_Definition
11344 | N_Derived_Type_Definition
11345 | N_Function_Specification
11346 | N_Subtype_Declaration
11348 return Null_Exclusion_Present (N);
11350 when N_Component_Definition
11351 | N_Formal_Object_Declaration
11352 | N_Object_Renaming_Declaration
11354 if Present (Subtype_Mark (N)) then
11355 return Null_Exclusion_Present (N);
11356 else pragma Assert (Present (Access_Definition (N)));
11357 return Null_Exclusion_Present (Access_Definition (N));
11360 when N_Discriminant_Specification =>
11361 if Nkind (Discriminant_Type (N)) = N_Access_Definition then
11362 return Null_Exclusion_Present (Discriminant_Type (N));
11364 return Null_Exclusion_Present (N);
11367 when N_Object_Declaration =>
11368 if Nkind (Object_Definition (N)) = N_Access_Definition then
11369 return Null_Exclusion_Present (Object_Definition (N));
11371 return Null_Exclusion_Present (N);
11374 when N_Parameter_Specification =>
11375 if Nkind (Parameter_Type (N)) = N_Access_Definition then
11376 return Null_Exclusion_Present (Parameter_Type (N));
11378 return Null_Exclusion_Present (N);
11384 end Has_Null_Exclusion;
11386 ------------------------
11387 -- Has_Null_Extension --
11388 ------------------------
11390 function Has_Null_Extension (T : Entity_Id) return Boolean is
11391 B : constant Entity_Id := Base_Type (T);
11396 if Nkind (Parent (B)) = N_Full_Type_Declaration
11397 and then Present (Record_Extension_Part (Type_Definition (Parent (B))))
11399 Ext := Record_Extension_Part (Type_Definition (Parent (B)));
11401 if Present (Ext) then
11402 if Null_Present (Ext) then
11405 Comps := Component_List (Ext);
11407 -- The null component list is rewritten during analysis to
11408 -- include the parent component. Any other component indicates
11409 -- that the extension was not originally null.
11411 return Null_Present (Comps)
11412 or else No (Next (First (Component_Items (Comps))));
11421 end Has_Null_Extension;
11423 -------------------------
11424 -- Has_Null_Refinement --
11425 -------------------------
11427 function Has_Null_Refinement (Id : Entity_Id) return Boolean is
11428 Constits : Elist_Id;
11431 pragma Assert (Ekind (Id) = E_Abstract_State);
11432 Constits := Refinement_Constituents (Id);
11434 -- For a refinement to be null, the state's sole constituent must be a
11439 and then Nkind (Node (First_Elmt (Constits))) = N_Null;
11440 end Has_Null_Refinement;
11442 -------------------------------
11443 -- Has_Overriding_Initialize --
11444 -------------------------------
11446 function Has_Overriding_Initialize (T : Entity_Id) return Boolean is
11447 BT : constant Entity_Id := Base_Type (T);
11451 if Is_Controlled (BT) then
11452 if Is_RTU (Scope (BT), Ada_Finalization) then
11455 elsif Present (Primitive_Operations (BT)) then
11456 P := First_Elmt (Primitive_Operations (BT));
11457 while Present (P) loop
11459 Init : constant Entity_Id := Node (P);
11460 Formal : constant Entity_Id := First_Formal (Init);
11462 if Ekind (Init) = E_Procedure
11463 and then Chars (Init) = Name_Initialize
11464 and then Comes_From_Source (Init)
11465 and then Present (Formal)
11466 and then Etype (Formal) = BT
11467 and then No (Next_Formal (Formal))
11468 and then (Ada_Version < Ada_2012
11469 or else not Null_Present (Parent (Init)))
11479 -- Here if type itself does not have a non-null Initialize operation:
11480 -- check immediate ancestor.
11482 if Is_Derived_Type (BT)
11483 and then Has_Overriding_Initialize (Etype (BT))
11490 end Has_Overriding_Initialize;
11492 --------------------------------------
11493 -- Has_Preelaborable_Initialization --
11494 --------------------------------------
11496 function Has_Preelaborable_Initialization (E : Entity_Id) return Boolean is
11499 procedure Check_Components (E : Entity_Id);
11500 -- Check component/discriminant chain, sets Has_PE False if a component
11501 -- or discriminant does not meet the preelaborable initialization rules.
11503 ----------------------
11504 -- Check_Components --
11505 ----------------------
11507 procedure Check_Components (E : Entity_Id) is
11512 -- Loop through entities of record or protected type
11515 while Present (Ent) loop
11517 -- We are interested only in components and discriminants
11521 case Ekind (Ent) is
11522 when E_Component =>
11524 -- Get default expression if any. If there is no declaration
11525 -- node, it means we have an internal entity. The parent and
11526 -- tag fields are examples of such entities. For such cases,
11527 -- we just test the type of the entity.
11529 if Present (Declaration_Node (Ent)) then
11530 Exp := Expression (Declaration_Node (Ent));
11533 when E_Discriminant =>
11535 -- Note: for a renamed discriminant, the Declaration_Node
11536 -- may point to the one from the ancestor, and have a
11537 -- different expression, so use the proper attribute to
11538 -- retrieve the expression from the derived constraint.
11540 Exp := Discriminant_Default_Value (Ent);
11543 goto Check_Next_Entity;
11546 -- A component has PI if it has no default expression and the
11547 -- component type has PI.
11550 if not Has_Preelaborable_Initialization (Etype (Ent)) then
11555 -- Require the default expression to be preelaborable
11557 elsif not Is_Preelaborable_Construct (Exp) then
11562 <<Check_Next_Entity>>
11565 end Check_Components;
11567 -- Start of processing for Has_Preelaborable_Initialization
11570 -- Immediate return if already marked as known preelaborable init. This
11571 -- covers types for which this function has already been called once
11572 -- and returned True (in which case the result is cached), and also
11573 -- types to which a pragma Preelaborable_Initialization applies.
11575 if Known_To_Have_Preelab_Init (E) then
11579 -- If the type is a subtype representing a generic actual type, then
11580 -- test whether its base type has preelaborable initialization since
11581 -- the subtype representing the actual does not inherit this attribute
11582 -- from the actual or formal. (but maybe it should???)
11584 if Is_Generic_Actual_Type (E) then
11585 return Has_Preelaborable_Initialization (Base_Type (E));
11588 -- All elementary types have preelaborable initialization
11590 if Is_Elementary_Type (E) then
11593 -- Array types have PI if the component type has PI
11595 elsif Is_Array_Type (E) then
11596 Has_PE := Has_Preelaborable_Initialization (Component_Type (E));
11598 -- A derived type has preelaborable initialization if its parent type
11599 -- has preelaborable initialization and (in the case of a derived record
11600 -- extension) if the non-inherited components all have preelaborable
11601 -- initialization. However, a user-defined controlled type with an
11602 -- overriding Initialize procedure does not have preelaborable
11605 elsif Is_Derived_Type (E) then
11607 -- If the derived type is a private extension then it doesn't have
11608 -- preelaborable initialization.
11610 if Ekind (Base_Type (E)) = E_Record_Type_With_Private then
11614 -- First check whether ancestor type has preelaborable initialization
11616 Has_PE := Has_Preelaborable_Initialization (Etype (Base_Type (E)));
11618 -- If OK, check extension components (if any)
11620 if Has_PE and then Is_Record_Type (E) then
11621 Check_Components (First_Entity (E));
11624 -- Check specifically for 10.2.1(11.4/2) exception: a controlled type
11625 -- with a user defined Initialize procedure does not have PI. If
11626 -- the type is untagged, the control primitives come from a component
11627 -- that has already been checked.
11630 and then Is_Controlled (E)
11631 and then Is_Tagged_Type (E)
11632 and then Has_Overriding_Initialize (E)
11637 -- Private types not derived from a type having preelaborable init and
11638 -- that are not marked with pragma Preelaborable_Initialization do not
11639 -- have preelaborable initialization.
11641 elsif Is_Private_Type (E) then
11644 -- Record type has PI if it is non private and all components have PI
11646 elsif Is_Record_Type (E) then
11648 Check_Components (First_Entity (E));
11650 -- Protected types must not have entries, and components must meet
11651 -- same set of rules as for record components.
11653 elsif Is_Protected_Type (E) then
11654 if Has_Entries (E) then
11658 Check_Components (First_Entity (E));
11659 Check_Components (First_Private_Entity (E));
11662 -- Type System.Address always has preelaborable initialization
11664 elsif Is_RTE (E, RE_Address) then
11667 -- In all other cases, type does not have preelaborable initialization
11673 -- If type has preelaborable initialization, cache result
11676 Set_Known_To_Have_Preelab_Init (E);
11680 end Has_Preelaborable_Initialization;
11686 function Has_Prefix (N : Node_Id) return Boolean is
11689 Nkind_In (N, N_Attribute_Reference,
11691 N_Explicit_Dereference,
11692 N_Indexed_Component,
11694 N_Selected_Component,
11698 ---------------------------
11699 -- Has_Private_Component --
11700 ---------------------------
11702 function Has_Private_Component (Type_Id : Entity_Id) return Boolean is
11703 Btype : Entity_Id := Base_Type (Type_Id);
11704 Component : Entity_Id;
11707 if Error_Posted (Type_Id)
11708 or else Error_Posted (Btype)
11713 if Is_Class_Wide_Type (Btype) then
11714 Btype := Root_Type (Btype);
11717 if Is_Private_Type (Btype) then
11719 UT : constant Entity_Id := Underlying_Type (Btype);
11722 if No (Full_View (Btype)) then
11723 return not Is_Generic_Type (Btype)
11725 not Is_Generic_Type (Root_Type (Btype));
11727 return not Is_Generic_Type (Root_Type (Full_View (Btype)));
11730 return not Is_Frozen (UT) and then Has_Private_Component (UT);
11734 elsif Is_Array_Type (Btype) then
11735 return Has_Private_Component (Component_Type (Btype));
11737 elsif Is_Record_Type (Btype) then
11738 Component := First_Component (Btype);
11739 while Present (Component) loop
11740 if Has_Private_Component (Etype (Component)) then
11744 Next_Component (Component);
11749 elsif Is_Protected_Type (Btype)
11750 and then Present (Corresponding_Record_Type (Btype))
11752 return Has_Private_Component (Corresponding_Record_Type (Btype));
11757 end Has_Private_Component;
11759 ----------------------
11760 -- Has_Signed_Zeros --
11761 ----------------------
11763 function Has_Signed_Zeros (E : Entity_Id) return Boolean is
11765 return Is_Floating_Point_Type (E) and then Signed_Zeros_On_Target;
11766 end Has_Signed_Zeros;
11768 ------------------------------
11769 -- Has_Significant_Contract --
11770 ------------------------------
11772 function Has_Significant_Contract (Subp_Id : Entity_Id) return Boolean is
11773 Subp_Nam : constant Name_Id := Chars (Subp_Id);
11776 -- _Finalizer procedure
11778 if Subp_Nam = Name_uFinalizer then
11781 -- _Postconditions procedure
11783 elsif Subp_Nam = Name_uPostconditions then
11786 -- Predicate function
11788 elsif Ekind (Subp_Id) = E_Function
11789 and then Is_Predicate_Function (Subp_Id)
11795 elsif Get_TSS_Name (Subp_Id) /= TSS_Null then
11801 end Has_Significant_Contract;
11803 -----------------------------
11804 -- Has_Static_Array_Bounds --
11805 -----------------------------
11807 function Has_Static_Array_Bounds (Typ : Node_Id) return Boolean is
11808 All_Static : Boolean;
11812 Examine_Array_Bounds (Typ, All_Static, Dummy);
11815 end Has_Static_Array_Bounds;
11817 ---------------------------------------
11818 -- Has_Static_Non_Empty_Array_Bounds --
11819 ---------------------------------------
11821 function Has_Static_Non_Empty_Array_Bounds (Typ : Node_Id) return Boolean is
11822 All_Static : Boolean;
11823 Has_Empty : Boolean;
11826 Examine_Array_Bounds (Typ, All_Static, Has_Empty);
11828 return All_Static and not Has_Empty;
11829 end Has_Static_Non_Empty_Array_Bounds;
11835 function Has_Stream (T : Entity_Id) return Boolean is
11842 elsif Is_RTE (Root_Type (T), RE_Root_Stream_Type) then
11845 elsif Is_Array_Type (T) then
11846 return Has_Stream (Component_Type (T));
11848 elsif Is_Record_Type (T) then
11849 E := First_Component (T);
11850 while Present (E) loop
11851 if Has_Stream (Etype (E)) then
11854 Next_Component (E);
11860 elsif Is_Private_Type (T) then
11861 return Has_Stream (Underlying_Type (T));
11872 function Has_Suffix (E : Entity_Id; Suffix : Character) return Boolean is
11874 Get_Name_String (Chars (E));
11875 return Name_Buffer (Name_Len) = Suffix;
11882 function Add_Suffix (E : Entity_Id; Suffix : Character) return Name_Id is
11884 Get_Name_String (Chars (E));
11885 Add_Char_To_Name_Buffer (Suffix);
11889 -------------------
11890 -- Remove_Suffix --
11891 -------------------
11893 function Remove_Suffix (E : Entity_Id; Suffix : Character) return Name_Id is
11895 pragma Assert (Has_Suffix (E, Suffix));
11896 Get_Name_String (Chars (E));
11897 Name_Len := Name_Len - 1;
11901 ----------------------------------
11902 -- Replace_Null_By_Null_Address --
11903 ----------------------------------
11905 procedure Replace_Null_By_Null_Address (N : Node_Id) is
11906 procedure Replace_Null_Operand (Op : Node_Id; Other_Op : Node_Id);
11907 -- Replace operand Op with a reference to Null_Address when the operand
11908 -- denotes a null Address. Other_Op denotes the other operand.
11910 --------------------------
11911 -- Replace_Null_Operand --
11912 --------------------------
11914 procedure Replace_Null_Operand (Op : Node_Id; Other_Op : Node_Id) is
11916 -- Check the type of the complementary operand since the N_Null node
11917 -- has not been decorated yet.
11919 if Nkind (Op) = N_Null
11920 and then Is_Descendant_Of_Address (Etype (Other_Op))
11922 Rewrite (Op, New_Occurrence_Of (RTE (RE_Null_Address), Sloc (Op)));
11924 end Replace_Null_Operand;
11926 -- Start of processing for Replace_Null_By_Null_Address
11929 pragma Assert (Relaxed_RM_Semantics);
11930 pragma Assert (Nkind_In (N, N_Null,
11938 if Nkind (N) = N_Null then
11939 Rewrite (N, New_Occurrence_Of (RTE (RE_Null_Address), Sloc (N)));
11943 L : constant Node_Id := Left_Opnd (N);
11944 R : constant Node_Id := Right_Opnd (N);
11947 Replace_Null_Operand (L, Other_Op => R);
11948 Replace_Null_Operand (R, Other_Op => L);
11951 end Replace_Null_By_Null_Address;
11953 --------------------------
11954 -- Has_Tagged_Component --
11955 --------------------------
11957 function Has_Tagged_Component (Typ : Entity_Id) return Boolean is
11961 if Is_Private_Type (Typ) and then Present (Underlying_Type (Typ)) then
11962 return Has_Tagged_Component (Underlying_Type (Typ));
11964 elsif Is_Array_Type (Typ) then
11965 return Has_Tagged_Component (Component_Type (Typ));
11967 elsif Is_Tagged_Type (Typ) then
11970 elsif Is_Record_Type (Typ) then
11971 Comp := First_Component (Typ);
11972 while Present (Comp) loop
11973 if Has_Tagged_Component (Etype (Comp)) then
11977 Next_Component (Comp);
11985 end Has_Tagged_Component;
11987 -----------------------------
11988 -- Has_Undefined_Reference --
11989 -----------------------------
11991 function Has_Undefined_Reference (Expr : Node_Id) return Boolean is
11992 Has_Undef_Ref : Boolean := False;
11993 -- Flag set when expression Expr contains at least one undefined
11996 function Is_Undefined_Reference (N : Node_Id) return Traverse_Result;
11997 -- Determine whether N denotes a reference and if it does, whether it is
12000 ----------------------------
12001 -- Is_Undefined_Reference --
12002 ----------------------------
12004 function Is_Undefined_Reference (N : Node_Id) return Traverse_Result is
12006 if Is_Entity_Name (N)
12007 and then Present (Entity (N))
12008 and then Entity (N) = Any_Id
12010 Has_Undef_Ref := True;
12015 end Is_Undefined_Reference;
12017 procedure Find_Undefined_References is
12018 new Traverse_Proc (Is_Undefined_Reference);
12020 -- Start of processing for Has_Undefined_Reference
12023 Find_Undefined_References (Expr);
12025 return Has_Undef_Ref;
12026 end Has_Undefined_Reference;
12028 ----------------------------
12029 -- Has_Volatile_Component --
12030 ----------------------------
12032 function Has_Volatile_Component (Typ : Entity_Id) return Boolean is
12036 if Has_Volatile_Components (Typ) then
12039 elsif Is_Array_Type (Typ) then
12040 return Is_Volatile (Component_Type (Typ));
12042 elsif Is_Record_Type (Typ) then
12043 Comp := First_Component (Typ);
12044 while Present (Comp) loop
12045 if Is_Volatile_Object (Comp) then
12049 Comp := Next_Component (Comp);
12054 end Has_Volatile_Component;
12056 -------------------------
12057 -- Implementation_Kind --
12058 -------------------------
12060 function Implementation_Kind (Subp : Entity_Id) return Name_Id is
12061 Impl_Prag : constant Node_Id := Get_Rep_Pragma (Subp, Name_Implemented);
12064 pragma Assert (Present (Impl_Prag));
12065 Arg := Last (Pragma_Argument_Associations (Impl_Prag));
12066 return Chars (Get_Pragma_Arg (Arg));
12067 end Implementation_Kind;
12069 --------------------------
12070 -- Implements_Interface --
12071 --------------------------
12073 function Implements_Interface
12074 (Typ_Ent : Entity_Id;
12075 Iface_Ent : Entity_Id;
12076 Exclude_Parents : Boolean := False) return Boolean
12078 Ifaces_List : Elist_Id;
12080 Iface : Entity_Id := Base_Type (Iface_Ent);
12081 Typ : Entity_Id := Base_Type (Typ_Ent);
12084 if Is_Class_Wide_Type (Typ) then
12085 Typ := Root_Type (Typ);
12088 if not Has_Interfaces (Typ) then
12092 if Is_Class_Wide_Type (Iface) then
12093 Iface := Root_Type (Iface);
12096 Collect_Interfaces (Typ, Ifaces_List);
12098 Elmt := First_Elmt (Ifaces_List);
12099 while Present (Elmt) loop
12100 if Is_Ancestor (Node (Elmt), Typ, Use_Full_View => True)
12101 and then Exclude_Parents
12105 elsif Node (Elmt) = Iface then
12113 end Implements_Interface;
12115 ------------------------------------
12116 -- In_Assertion_Expression_Pragma --
12117 ------------------------------------
12119 function In_Assertion_Expression_Pragma (N : Node_Id) return Boolean is
12121 Prag : Node_Id := Empty;
12124 -- Climb the parent chain looking for an enclosing pragma
12127 while Present (Par) loop
12128 if Nkind (Par) = N_Pragma then
12132 -- Precondition-like pragmas are expanded into if statements, check
12133 -- the original node instead.
12135 elsif Nkind (Original_Node (Par)) = N_Pragma then
12136 Prag := Original_Node (Par);
12139 -- The expansion of attribute 'Old generates a constant to capture
12140 -- the result of the prefix. If the parent traversal reaches
12141 -- one of these constants, then the node technically came from a
12142 -- postcondition-like pragma. Note that the Ekind is not tested here
12143 -- because N may be the expression of an object declaration which is
12144 -- currently being analyzed. Such objects carry Ekind of E_Void.
12146 elsif Nkind (Par) = N_Object_Declaration
12147 and then Constant_Present (Par)
12148 and then Stores_Attribute_Old_Prefix (Defining_Entity (Par))
12152 -- Prevent the search from going too far
12154 elsif Is_Body_Or_Package_Declaration (Par) then
12158 Par := Parent (Par);
12163 and then Assertion_Expression_Pragma (Get_Pragma_Id (Prag));
12164 end In_Assertion_Expression_Pragma;
12166 ----------------------
12167 -- In_Generic_Scope --
12168 ----------------------
12170 function In_Generic_Scope (E : Entity_Id) return Boolean is
12175 while Present (S) and then S /= Standard_Standard loop
12176 if Is_Generic_Unit (S) then
12184 end In_Generic_Scope;
12190 function In_Instance return Boolean is
12191 Curr_Unit : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
12195 S := Current_Scope;
12196 while Present (S) and then S /= Standard_Standard loop
12197 if Is_Generic_Instance (S) then
12199 -- A child instance is always compiled in the context of a parent
12200 -- instance. Nevertheless, the actuals are not analyzed in an
12201 -- instance context. We detect this case by examining the current
12202 -- compilation unit, which must be a child instance, and checking
12203 -- that it is not currently on the scope stack.
12205 if Is_Child_Unit (Curr_Unit)
12206 and then Nkind (Unit (Cunit (Current_Sem_Unit))) =
12207 N_Package_Instantiation
12208 and then not In_Open_Scopes (Curr_Unit)
12222 ----------------------
12223 -- In_Instance_Body --
12224 ----------------------
12226 function In_Instance_Body return Boolean is
12230 S := Current_Scope;
12231 while Present (S) and then S /= Standard_Standard loop
12232 if Ekind_In (S, E_Function, E_Procedure)
12233 and then Is_Generic_Instance (S)
12237 elsif Ekind (S) = E_Package
12238 and then In_Package_Body (S)
12239 and then Is_Generic_Instance (S)
12248 end In_Instance_Body;
12250 -----------------------------
12251 -- In_Instance_Not_Visible --
12252 -----------------------------
12254 function In_Instance_Not_Visible return Boolean is
12258 S := Current_Scope;
12259 while Present (S) and then S /= Standard_Standard loop
12260 if Ekind_In (S, E_Function, E_Procedure)
12261 and then Is_Generic_Instance (S)
12265 elsif Ekind (S) = E_Package
12266 and then (In_Package_Body (S) or else In_Private_Part (S))
12267 and then Is_Generic_Instance (S)
12276 end In_Instance_Not_Visible;
12278 ------------------------------
12279 -- In_Instance_Visible_Part --
12280 ------------------------------
12282 function In_Instance_Visible_Part
12283 (Id : Entity_Id := Current_Scope) return Boolean
12289 while Present (Inst) and then Inst /= Standard_Standard loop
12290 if Ekind (Inst) = E_Package
12291 and then Is_Generic_Instance (Inst)
12292 and then not In_Package_Body (Inst)
12293 and then not In_Private_Part (Inst)
12298 Inst := Scope (Inst);
12302 end In_Instance_Visible_Part;
12304 ---------------------
12305 -- In_Package_Body --
12306 ---------------------
12308 function In_Package_Body return Boolean is
12312 S := Current_Scope;
12313 while Present (S) and then S /= Standard_Standard loop
12314 if Ekind (S) = E_Package and then In_Package_Body (S) then
12322 end In_Package_Body;
12324 --------------------------
12325 -- In_Pragma_Expression --
12326 --------------------------
12328 function In_Pragma_Expression (N : Node_Id; Nam : Name_Id) return Boolean is
12335 elsif Nkind (P) = N_Pragma and then Pragma_Name (P) = Nam then
12341 end In_Pragma_Expression;
12343 ---------------------------
12344 -- In_Pre_Post_Condition --
12345 ---------------------------
12347 function In_Pre_Post_Condition (N : Node_Id) return Boolean is
12349 Prag : Node_Id := Empty;
12350 Prag_Id : Pragma_Id;
12353 -- Climb the parent chain looking for an enclosing pragma
12356 while Present (Par) loop
12357 if Nkind (Par) = N_Pragma then
12361 -- Prevent the search from going too far
12363 elsif Is_Body_Or_Package_Declaration (Par) then
12367 Par := Parent (Par);
12370 if Present (Prag) then
12371 Prag_Id := Get_Pragma_Id (Prag);
12374 Prag_Id = Pragma_Post
12375 or else Prag_Id = Pragma_Post_Class
12376 or else Prag_Id = Pragma_Postcondition
12377 or else Prag_Id = Pragma_Pre
12378 or else Prag_Id = Pragma_Pre_Class
12379 or else Prag_Id = Pragma_Precondition;
12381 -- Otherwise the node is not enclosed by a pre/postcondition pragma
12386 end In_Pre_Post_Condition;
12388 ------------------------------
12389 -- In_Quantified_Expression --
12390 ------------------------------
12392 function In_Quantified_Expression (N : Node_Id) return Boolean is
12399 elsif Nkind (P) = N_Quantified_Expression then
12405 end In_Quantified_Expression;
12407 -------------------------------------
12408 -- In_Reverse_Storage_Order_Object --
12409 -------------------------------------
12411 function In_Reverse_Storage_Order_Object (N : Node_Id) return Boolean is
12413 Btyp : Entity_Id := Empty;
12416 -- Climb up indexed components
12420 case Nkind (Pref) is
12421 when N_Selected_Component =>
12422 Pref := Prefix (Pref);
12425 when N_Indexed_Component =>
12426 Pref := Prefix (Pref);
12434 if Present (Pref) then
12435 Btyp := Base_Type (Etype (Pref));
12438 return Present (Btyp)
12439 and then (Is_Record_Type (Btyp) or else Is_Array_Type (Btyp))
12440 and then Reverse_Storage_Order (Btyp);
12441 end In_Reverse_Storage_Order_Object;
12443 ------------------------------
12444 -- In_Same_Declarative_Part --
12445 ------------------------------
12447 function In_Same_Declarative_Part
12448 (Context : Node_Id;
12449 N : Node_Id) return Boolean
12451 Cont : Node_Id := Context;
12455 if Nkind (Cont) = N_Compilation_Unit_Aux then
12456 Cont := Parent (Cont);
12460 while Present (Nod) loop
12464 elsif Nkind_In (Nod, N_Accept_Statement,
12466 N_Compilation_Unit,
12469 N_Package_Declaration,
12476 elsif Nkind (Nod) = N_Subunit then
12477 Nod := Corresponding_Stub (Nod);
12480 Nod := Parent (Nod);
12485 end In_Same_Declarative_Part;
12487 --------------------------------------
12488 -- In_Subprogram_Or_Concurrent_Unit --
12489 --------------------------------------
12491 function In_Subprogram_Or_Concurrent_Unit return Boolean is
12496 -- Use scope chain to check successively outer scopes
12498 E := Current_Scope;
12502 if K in Subprogram_Kind
12503 or else K in Concurrent_Kind
12504 or else K in Generic_Subprogram_Kind
12508 elsif E = Standard_Standard then
12514 end In_Subprogram_Or_Concurrent_Unit;
12520 function In_Subtree (N : Node_Id; Root : Node_Id) return Boolean is
12525 while Present (Curr) loop
12526 if Curr = Root then
12530 Curr := Parent (Curr);
12540 function In_Subtree
12543 Root2 : Node_Id) return Boolean
12549 while Present (Curr) loop
12550 if Curr = Root1 or else Curr = Root2 then
12554 Curr := Parent (Curr);
12560 ---------------------
12561 -- In_Visible_Part --
12562 ---------------------
12564 function In_Visible_Part (Scope_Id : Entity_Id) return Boolean is
12566 return Is_Package_Or_Generic_Package (Scope_Id)
12567 and then In_Open_Scopes (Scope_Id)
12568 and then not In_Package_Body (Scope_Id)
12569 and then not In_Private_Part (Scope_Id);
12570 end In_Visible_Part;
12572 --------------------------------
12573 -- Incomplete_Or_Partial_View --
12574 --------------------------------
12576 function Incomplete_Or_Partial_View (Id : Entity_Id) return Entity_Id is
12577 function Inspect_Decls
12579 Taft : Boolean := False) return Entity_Id;
12580 -- Check whether a declarative region contains the incomplete or partial
12583 -------------------
12584 -- Inspect_Decls --
12585 -------------------
12587 function Inspect_Decls
12589 Taft : Boolean := False) return Entity_Id
12595 Decl := First (Decls);
12596 while Present (Decl) loop
12599 -- The partial view of a Taft-amendment type is an incomplete
12603 if Nkind (Decl) = N_Incomplete_Type_Declaration then
12604 Match := Defining_Identifier (Decl);
12607 -- Otherwise look for a private type whose full view matches the
12608 -- input type. Note that this checks full_type_declaration nodes
12609 -- to account for derivations from a private type where the type
12610 -- declaration hold the partial view and the full view is an
12613 elsif Nkind_In (Decl, N_Full_Type_Declaration,
12614 N_Private_Extension_Declaration,
12615 N_Private_Type_Declaration)
12617 Match := Defining_Identifier (Decl);
12620 -- Guard against unanalyzed entities
12623 and then Is_Type (Match)
12624 and then Present (Full_View (Match))
12625 and then Full_View (Match) = Id
12640 -- Start of processing for Incomplete_Or_Partial_View
12643 -- Deferred constant or incomplete type case
12645 Prev := Current_Entity_In_Scope (Id);
12648 and then (Is_Incomplete_Type (Prev) or else Ekind (Prev) = E_Constant)
12649 and then Present (Full_View (Prev))
12650 and then Full_View (Prev) = Id
12655 -- Private or Taft amendment type case
12658 Pkg : constant Entity_Id := Scope (Id);
12659 Pkg_Decl : Node_Id := Pkg;
12663 and then Ekind_In (Pkg, E_Generic_Package, E_Package)
12665 while Nkind (Pkg_Decl) /= N_Package_Specification loop
12666 Pkg_Decl := Parent (Pkg_Decl);
12669 -- It is knows that Typ has a private view, look for it in the
12670 -- visible declarations of the enclosing scope. A special case
12671 -- of this is when the two views have been exchanged - the full
12672 -- appears earlier than the private.
12674 if Has_Private_Declaration (Id) then
12675 Prev := Inspect_Decls (Visible_Declarations (Pkg_Decl));
12677 -- Exchanged view case, look in the private declarations
12680 Prev := Inspect_Decls (Private_Declarations (Pkg_Decl));
12685 -- Otherwise if this is the package body, then Typ is a potential
12686 -- Taft amendment type. The incomplete view should be located in
12687 -- the private declarations of the enclosing scope.
12689 elsif In_Package_Body (Pkg) then
12690 return Inspect_Decls (Private_Declarations (Pkg_Decl), True);
12695 -- The type has no incomplete or private view
12698 end Incomplete_Or_Partial_View;
12700 ---------------------------------------
12701 -- Incomplete_View_From_Limited_With --
12702 ---------------------------------------
12704 function Incomplete_View_From_Limited_With
12705 (Typ : Entity_Id) return Entity_Id
12708 -- It might make sense to make this an attribute in Einfo, and set it
12709 -- in Sem_Ch10 in Build_Shadow_Entity. However, we're running short on
12710 -- slots for new attributes, and it seems a bit simpler to just search
12711 -- the Limited_View (if it exists) for an incomplete type whose
12712 -- Non_Limited_View is Typ.
12714 if Ekind (Scope (Typ)) = E_Package
12715 and then Present (Limited_View (Scope (Typ)))
12718 Ent : Entity_Id := First_Entity (Limited_View (Scope (Typ)));
12720 while Present (Ent) loop
12721 if Ekind (Ent) in Incomplete_Kind
12722 and then Non_Limited_View (Ent) = Typ
12727 Ent := Next_Entity (Ent);
12733 end Incomplete_View_From_Limited_With;
12735 ----------------------------------
12736 -- Indexed_Component_Bit_Offset --
12737 ----------------------------------
12739 function Indexed_Component_Bit_Offset (N : Node_Id) return Uint is
12740 Exp : constant Node_Id := First (Expressions (N));
12741 Typ : constant Entity_Id := Etype (Prefix (N));
12742 Off : constant Uint := Component_Size (Typ);
12746 -- Return early if the component size is not known or variable
12748 if Off = No_Uint or else Off < Uint_0 then
12752 -- Deal with the degenerate case of an empty component
12754 if Off = Uint_0 then
12758 -- Check that both the index value and the low bound are known
12760 if not Compile_Time_Known_Value (Exp) then
12764 Ind := First_Index (Typ);
12769 if Nkind (Ind) = N_Subtype_Indication then
12770 Ind := Constraint (Ind);
12772 if Nkind (Ind) = N_Range_Constraint then
12773 Ind := Range_Expression (Ind);
12777 if Nkind (Ind) /= N_Range
12778 or else not Compile_Time_Known_Value (Low_Bound (Ind))
12783 -- Return the scaled offset
12785 return Off * (Expr_Value (Exp) - Expr_Value (Low_Bound ((Ind))));
12786 end Indexed_Component_Bit_Offset;
12788 ----------------------------
12789 -- Inherit_Rep_Item_Chain --
12790 ----------------------------
12792 procedure Inherit_Rep_Item_Chain (Typ : Entity_Id; From_Typ : Entity_Id) is
12794 Next_Item : Node_Id;
12797 -- There are several inheritance scenarios to consider depending on
12798 -- whether both types have rep item chains and whether the destination
12799 -- type already inherits part of the source type's rep item chain.
12801 -- 1) The source type lacks a rep item chain
12802 -- From_Typ ---> Empty
12804 -- Typ --------> Item (or Empty)
12806 -- In this case inheritance cannot take place because there are no items
12809 -- 2) The destination type lacks a rep item chain
12810 -- From_Typ ---> Item ---> ...
12812 -- Typ --------> Empty
12814 -- Inheritance takes place by setting the First_Rep_Item of the
12815 -- destination type to the First_Rep_Item of the source type.
12816 -- From_Typ ---> Item ---> ...
12818 -- Typ -----------+
12820 -- 3.1) Both source and destination types have at least one rep item.
12821 -- The destination type does NOT inherit a rep item from the source
12823 -- From_Typ ---> Item ---> Item
12825 -- Typ --------> Item ---> Item
12827 -- Inheritance takes place by setting the Next_Rep_Item of the last item
12828 -- of the destination type to the First_Rep_Item of the source type.
12829 -- From_Typ -------------------> Item ---> Item
12831 -- Typ --------> Item ---> Item --+
12833 -- 3.2) Both source and destination types have at least one rep item.
12834 -- The destination type DOES inherit part of the rep item chain of the
12836 -- From_Typ ---> Item ---> Item ---> Item
12838 -- Typ --------> Item ------+
12840 -- This rare case arises when the full view of a private extension must
12841 -- inherit the rep item chain from the full view of its parent type and
12842 -- the full view of the parent type contains extra rep items. Currently
12843 -- only invariants may lead to such form of inheritance.
12845 -- type From_Typ is tagged private
12846 -- with Type_Invariant'Class => Item_2;
12848 -- type Typ is new From_Typ with private
12849 -- with Type_Invariant => Item_4;
12851 -- At this point the rep item chains contain the following items
12853 -- From_Typ -----------> Item_2 ---> Item_3
12855 -- Typ --------> Item_4 --+
12857 -- The full views of both types may introduce extra invariants
12859 -- type From_Typ is tagged null record
12860 -- with Type_Invariant => Item_1;
12862 -- type Typ is new From_Typ with null record;
12864 -- The full view of Typ would have to inherit any new rep items added to
12865 -- the full view of From_Typ.
12867 -- From_Typ -----------> Item_1 ---> Item_2 ---> Item_3
12869 -- Typ --------> Item_4 --+
12871 -- To achieve this form of inheritance, the destination type must first
12872 -- sever the link between its own rep chain and that of the source type,
12873 -- then inheritance 3.1 takes place.
12875 -- Case 1: The source type lacks a rep item chain
12877 if No (First_Rep_Item (From_Typ)) then
12880 -- Case 2: The destination type lacks a rep item chain
12882 elsif No (First_Rep_Item (Typ)) then
12883 Set_First_Rep_Item (Typ, First_Rep_Item (From_Typ));
12885 -- Case 3: Both the source and destination types have at least one rep
12886 -- item. Traverse the rep item chain of the destination type to find the
12891 Next_Item := First_Rep_Item (Typ);
12892 while Present (Next_Item) loop
12894 -- Detect a link between the destination type's rep chain and that
12895 -- of the source type. There are two possibilities:
12900 -- From_Typ ---> Item_1 --->
12902 -- Typ -----------+
12909 -- From_Typ ---> Item_1 ---> Item_2 --->
12911 -- Typ --------> Item_3 ------+
12915 if Has_Rep_Item (From_Typ, Next_Item) then
12920 Next_Item := Next_Rep_Item (Next_Item);
12923 -- Inherit the source type's rep item chain
12925 if Present (Item) then
12926 Set_Next_Rep_Item (Item, First_Rep_Item (From_Typ));
12928 Set_First_Rep_Item (Typ, First_Rep_Item (From_Typ));
12931 end Inherit_Rep_Item_Chain;
12933 ------------------------------------
12934 -- Inherits_From_Tagged_Full_View --
12935 ------------------------------------
12937 function Inherits_From_Tagged_Full_View (Typ : Entity_Id) return Boolean is
12939 return Is_Private_Type (Typ)
12940 and then Present (Full_View (Typ))
12941 and then Is_Private_Type (Full_View (Typ))
12942 and then not Is_Tagged_Type (Full_View (Typ))
12943 and then Present (Underlying_Type (Full_View (Typ)))
12944 and then Is_Tagged_Type (Underlying_Type (Full_View (Typ)));
12945 end Inherits_From_Tagged_Full_View;
12947 ---------------------------------
12948 -- Insert_Explicit_Dereference --
12949 ---------------------------------
12951 procedure Insert_Explicit_Dereference (N : Node_Id) is
12952 New_Prefix : constant Node_Id := Relocate_Node (N);
12953 Ent : Entity_Id := Empty;
12960 Save_Interps (N, New_Prefix);
12963 Make_Explicit_Dereference (Sloc (Parent (N)),
12964 Prefix => New_Prefix));
12966 Set_Etype (N, Designated_Type (Etype (New_Prefix)));
12968 if Is_Overloaded (New_Prefix) then
12970 -- The dereference is also overloaded, and its interpretations are
12971 -- the designated types of the interpretations of the original node.
12973 Set_Etype (N, Any_Type);
12975 Get_First_Interp (New_Prefix, I, It);
12976 while Present (It.Nam) loop
12979 if Is_Access_Type (T) then
12980 Add_One_Interp (N, Designated_Type (T), Designated_Type (T));
12983 Get_Next_Interp (I, It);
12989 -- Prefix is unambiguous: mark the original prefix (which might
12990 -- Come_From_Source) as a reference, since the new (relocated) one
12991 -- won't be taken into account.
12993 if Is_Entity_Name (New_Prefix) then
12994 Ent := Entity (New_Prefix);
12995 Pref := New_Prefix;
12997 -- For a retrieval of a subcomponent of some composite object,
12998 -- retrieve the ultimate entity if there is one.
13000 elsif Nkind_In (New_Prefix, N_Selected_Component,
13001 N_Indexed_Component)
13003 Pref := Prefix (New_Prefix);
13004 while Present (Pref)
13005 and then Nkind_In (Pref, N_Selected_Component,
13006 N_Indexed_Component)
13008 Pref := Prefix (Pref);
13011 if Present (Pref) and then Is_Entity_Name (Pref) then
13012 Ent := Entity (Pref);
13016 -- Place the reference on the entity node
13018 if Present (Ent) then
13019 Generate_Reference (Ent, Pref);
13022 end Insert_Explicit_Dereference;
13024 ------------------------------------------
13025 -- Inspect_Deferred_Constant_Completion --
13026 ------------------------------------------
13028 procedure Inspect_Deferred_Constant_Completion (Decls : List_Id) is
13032 Decl := First (Decls);
13033 while Present (Decl) loop
13035 -- Deferred constant signature
13037 if Nkind (Decl) = N_Object_Declaration
13038 and then Constant_Present (Decl)
13039 and then No (Expression (Decl))
13041 -- No need to check internally generated constants
13043 and then Comes_From_Source (Decl)
13045 -- The constant is not completed. A full object declaration or a
13046 -- pragma Import complete a deferred constant.
13048 and then not Has_Completion (Defining_Identifier (Decl))
13051 ("constant declaration requires initialization expression",
13052 Defining_Identifier (Decl));
13055 Decl := Next (Decl);
13057 end Inspect_Deferred_Constant_Completion;
13059 -------------------------------
13060 -- Install_Elaboration_Model --
13061 -------------------------------
13063 procedure Install_Elaboration_Model (Unit_Id : Entity_Id) is
13064 function Find_Elaboration_Checks_Pragma (L : List_Id) return Node_Id;
13065 -- Try to find pragma Elaboration_Checks in arbitrary list L. Return
13066 -- Empty if there is no such pragma.
13068 ------------------------------------
13069 -- Find_Elaboration_Checks_Pragma --
13070 ------------------------------------
13072 function Find_Elaboration_Checks_Pragma (L : List_Id) return Node_Id is
13077 while Present (Item) loop
13078 if Nkind (Item) = N_Pragma
13079 and then Pragma_Name (Item) = Name_Elaboration_Checks
13088 end Find_Elaboration_Checks_Pragma;
13097 -- Start of processing for Install_Elaboration_Model
13100 -- Nothing to do when the unit does not exist
13102 if No (Unit_Id) then
13106 Unit := Parent (Unit_Declaration_Node (Unit_Id));
13108 -- Nothing to do when the unit is not a library unit
13110 if Nkind (Unit) /= N_Compilation_Unit then
13114 Prag := Find_Elaboration_Checks_Pragma (Context_Items (Unit));
13116 -- The compilation unit is subject to pragma Elaboration_Checks. Set the
13117 -- elaboration model as specified by the pragma.
13119 if Present (Prag) then
13120 Args := Pragma_Argument_Associations (Prag);
13122 -- Guard against an illegal pragma. The sole argument must be an
13123 -- identifier which specifies either Dynamic or Static model.
13125 if Present (Args) then
13126 Model := Get_Pragma_Arg (First (Args));
13128 if Nkind (Model) = N_Identifier then
13129 Dynamic_Elaboration_Checks := Chars (Model) = Name_Dynamic;
13133 end Install_Elaboration_Model;
13135 -----------------------------
13136 -- Install_Generic_Formals --
13137 -----------------------------
13139 procedure Install_Generic_Formals (Subp_Id : Entity_Id) is
13143 pragma Assert (Is_Generic_Subprogram (Subp_Id));
13145 E := First_Entity (Subp_Id);
13146 while Present (E) loop
13147 Install_Entity (E);
13150 end Install_Generic_Formals;
13152 ------------------------
13153 -- Install_SPARK_Mode --
13154 ------------------------
13156 procedure Install_SPARK_Mode (Mode : SPARK_Mode_Type; Prag : Node_Id) is
13158 SPARK_Mode := Mode;
13159 SPARK_Mode_Pragma := Prag;
13160 end Install_SPARK_Mode;
13162 --------------------------
13163 -- Invalid_Scalar_Value --
13164 --------------------------
13166 function Invalid_Scalar_Value
13168 Scal_Typ : Scalar_Id) return Node_Id
13170 function Invalid_Binder_Value return Node_Id;
13171 -- Return a reference to the corresponding invalid value for type
13172 -- Scal_Typ as defined in unit System.Scalar_Values.
13174 function Invalid_Float_Value return Node_Id;
13175 -- Return the invalid value of float type Scal_Typ
13177 function Invalid_Integer_Value return Node_Id;
13178 -- Return the invalid value of integer type Scal_Typ
13180 procedure Set_Invalid_Binder_Values;
13181 -- Set the contents of collection Invalid_Binder_Values
13183 --------------------------
13184 -- Invalid_Binder_Value --
13185 --------------------------
13187 function Invalid_Binder_Value return Node_Id is
13188 Val_Id : Entity_Id;
13191 -- Initialize the collection of invalid binder values the first time
13194 Set_Invalid_Binder_Values;
13196 -- Obtain the corresponding variable from System.Scalar_Values which
13197 -- holds the invalid value for this type.
13199 Val_Id := Invalid_Binder_Values (Scal_Typ);
13200 pragma Assert (Present (Val_Id));
13202 return New_Occurrence_Of (Val_Id, Loc);
13203 end Invalid_Binder_Value;
13205 -------------------------
13206 -- Invalid_Float_Value --
13207 -------------------------
13209 function Invalid_Float_Value return Node_Id is
13210 Value : constant Ureal := Invalid_Floats (Scal_Typ);
13213 -- Pragma Invalid_Scalars did not specify an invalid value for this
13214 -- type. Fall back to the value provided by the binder.
13216 if Value = No_Ureal then
13217 return Invalid_Binder_Value;
13219 return Make_Real_Literal (Loc, Realval => Value);
13221 end Invalid_Float_Value;
13223 ---------------------------
13224 -- Invalid_Integer_Value --
13225 ---------------------------
13227 function Invalid_Integer_Value return Node_Id is
13228 Value : constant Uint := Invalid_Integers (Scal_Typ);
13231 -- Pragma Invalid_Scalars did not specify an invalid value for this
13232 -- type. Fall back to the value provided by the binder.
13234 if Value = No_Uint then
13235 return Invalid_Binder_Value;
13237 return Make_Integer_Literal (Loc, Intval => Value);
13239 end Invalid_Integer_Value;
13241 -------------------------------
13242 -- Set_Invalid_Binder_Values --
13243 -------------------------------
13245 procedure Set_Invalid_Binder_Values is
13247 if not Invalid_Binder_Values_Set then
13248 Invalid_Binder_Values_Set := True;
13250 -- Initialize the contents of the collection once since RTE calls
13253 Invalid_Binder_Values :=
13254 (Name_Short_Float => RTE (RE_IS_Isf),
13255 Name_Float => RTE (RE_IS_Ifl),
13256 Name_Long_Float => RTE (RE_IS_Ilf),
13257 Name_Long_Long_Float => RTE (RE_IS_Ill),
13258 Name_Signed_8 => RTE (RE_IS_Is1),
13259 Name_Signed_16 => RTE (RE_IS_Is2),
13260 Name_Signed_32 => RTE (RE_IS_Is4),
13261 Name_Signed_64 => RTE (RE_IS_Is8),
13262 Name_Unsigned_8 => RTE (RE_IS_Iu1),
13263 Name_Unsigned_16 => RTE (RE_IS_Iu2),
13264 Name_Unsigned_32 => RTE (RE_IS_Iu4),
13265 Name_Unsigned_64 => RTE (RE_IS_Iu8));
13267 end Set_Invalid_Binder_Values;
13269 -- Start of processing for Invalid_Scalar_Value
13272 if Scal_Typ in Float_Scalar_Id then
13273 return Invalid_Float_Value;
13275 else pragma Assert (Scal_Typ in Integer_Scalar_Id);
13276 return Invalid_Integer_Value;
13278 end Invalid_Scalar_Value;
13280 -----------------------------
13281 -- Is_Actual_Out_Parameter --
13282 -----------------------------
13284 function Is_Actual_Out_Parameter (N : Node_Id) return Boolean is
13285 Formal : Entity_Id;
13288 Find_Actual (N, Formal, Call);
13289 return Present (Formal) and then Ekind (Formal) = E_Out_Parameter;
13290 end Is_Actual_Out_Parameter;
13292 -------------------------
13293 -- Is_Actual_Parameter --
13294 -------------------------
13296 function Is_Actual_Parameter (N : Node_Id) return Boolean is
13297 PK : constant Node_Kind := Nkind (Parent (N));
13301 when N_Parameter_Association =>
13302 return N = Explicit_Actual_Parameter (Parent (N));
13304 when N_Subprogram_Call =>
13305 return Is_List_Member (N)
13307 List_Containing (N) = Parameter_Associations (Parent (N));
13312 end Is_Actual_Parameter;
13314 --------------------------------
13315 -- Is_Actual_Tagged_Parameter --
13316 --------------------------------
13318 function Is_Actual_Tagged_Parameter (N : Node_Id) return Boolean is
13319 Formal : Entity_Id;
13322 Find_Actual (N, Formal, Call);
13323 return Present (Formal) and then Is_Tagged_Type (Etype (Formal));
13324 end Is_Actual_Tagged_Parameter;
13326 ---------------------
13327 -- Is_Aliased_View --
13328 ---------------------
13330 function Is_Aliased_View (Obj : Node_Id) return Boolean is
13334 if Is_Entity_Name (Obj) then
13341 or else (Present (Renamed_Object (E))
13342 and then Is_Aliased_View (Renamed_Object (E)))))
13344 or else ((Is_Formal (E) or else Is_Formal_Object (E))
13345 and then Is_Tagged_Type (Etype (E)))
13347 or else (Is_Concurrent_Type (E) and then In_Open_Scopes (E))
13349 -- Current instance of type, either directly or as rewritten
13350 -- reference to the current object.
13352 or else (Is_Entity_Name (Original_Node (Obj))
13353 and then Present (Entity (Original_Node (Obj)))
13354 and then Is_Type (Entity (Original_Node (Obj))))
13356 or else (Is_Type (E) and then E = Current_Scope)
13358 or else (Is_Incomplete_Or_Private_Type (E)
13359 and then Full_View (E) = Current_Scope)
13361 -- Ada 2012 AI05-0053: the return object of an extended return
13362 -- statement is aliased if its type is immutably limited.
13364 or else (Is_Return_Object (E)
13365 and then Is_Limited_View (Etype (E)));
13367 elsif Nkind (Obj) = N_Selected_Component then
13368 return Is_Aliased (Entity (Selector_Name (Obj)));
13370 elsif Nkind (Obj) = N_Indexed_Component then
13371 return Has_Aliased_Components (Etype (Prefix (Obj)))
13373 (Is_Access_Type (Etype (Prefix (Obj)))
13374 and then Has_Aliased_Components
13375 (Designated_Type (Etype (Prefix (Obj)))));
13377 elsif Nkind_In (Obj, N_Unchecked_Type_Conversion, N_Type_Conversion) then
13378 return Is_Tagged_Type (Etype (Obj))
13379 and then Is_Aliased_View (Expression (Obj));
13381 elsif Nkind (Obj) = N_Explicit_Dereference then
13382 return Nkind (Original_Node (Obj)) /= N_Function_Call;
13387 end Is_Aliased_View;
13389 -------------------------
13390 -- Is_Ancestor_Package --
13391 -------------------------
13393 function Is_Ancestor_Package
13395 E2 : Entity_Id) return Boolean
13401 while Present (Par) and then Par /= Standard_Standard loop
13406 Par := Scope (Par);
13410 end Is_Ancestor_Package;
13412 ----------------------
13413 -- Is_Atomic_Object --
13414 ----------------------
13416 function Is_Atomic_Object (N : Node_Id) return Boolean is
13417 function Is_Atomic_Entity (Id : Entity_Id) return Boolean;
13418 pragma Inline (Is_Atomic_Entity);
13419 -- Determine whether arbitrary entity Id is either atomic or has atomic
13422 function Is_Atomic_Prefix (Pref : Node_Id) return Boolean;
13423 -- Determine whether prefix Pref of an indexed or selected component is
13424 -- an atomic object.
13426 ----------------------
13427 -- Is_Atomic_Entity --
13428 ----------------------
13430 function Is_Atomic_Entity (Id : Entity_Id) return Boolean is
13432 return Is_Atomic (Id) or else Has_Atomic_Components (Id);
13433 end Is_Atomic_Entity;
13435 ----------------------
13436 -- Is_Atomic_Prefix --
13437 ----------------------
13439 function Is_Atomic_Prefix (Pref : Node_Id) return Boolean is
13440 Typ : constant Entity_Id := Etype (Pref);
13443 if Is_Access_Type (Typ) then
13444 return Has_Atomic_Components (Designated_Type (Typ));
13446 elsif Is_Atomic_Entity (Typ) then
13449 elsif Is_Entity_Name (Pref)
13450 and then Is_Atomic_Entity (Entity (Pref))
13454 elsif Nkind (Pref) = N_Indexed_Component then
13455 return Is_Atomic_Prefix (Prefix (Pref));
13457 elsif Nkind (Pref) = N_Selected_Component then
13459 Is_Atomic_Prefix (Prefix (Pref))
13460 or else Is_Atomic (Entity (Selector_Name (Pref)));
13464 end Is_Atomic_Prefix;
13466 -- Start of processing for Is_Atomic_Object
13469 if Is_Entity_Name (N) then
13470 return Is_Atomic_Object_Entity (Entity (N));
13472 elsif Nkind (N) = N_Indexed_Component then
13473 return Is_Atomic (Etype (N)) or else Is_Atomic_Prefix (Prefix (N));
13475 elsif Nkind (N) = N_Selected_Component then
13477 Is_Atomic (Etype (N))
13478 or else Is_Atomic_Prefix (Prefix (N))
13479 or else Is_Atomic (Entity (Selector_Name (N)));
13483 end Is_Atomic_Object;
13485 -----------------------------
13486 -- Is_Atomic_Object_Entity --
13487 -----------------------------
13489 function Is_Atomic_Object_Entity (Id : Entity_Id) return Boolean is
13493 and then (Is_Atomic (Id) or else Is_Atomic (Etype (Id)));
13494 end Is_Atomic_Object_Entity;
13496 -----------------------------
13497 -- Is_Atomic_Or_VFA_Object --
13498 -----------------------------
13500 function Is_Atomic_Or_VFA_Object (N : Node_Id) return Boolean is
13502 return Is_Atomic_Object (N)
13503 or else (Is_Object_Reference (N)
13504 and then Is_Entity_Name (N)
13505 and then (Is_Volatile_Full_Access (Entity (N))
13507 Is_Volatile_Full_Access (Etype (Entity (N)))));
13508 end Is_Atomic_Or_VFA_Object;
13510 -------------------------
13511 -- Is_Attribute_Result --
13512 -------------------------
13514 function Is_Attribute_Result (N : Node_Id) return Boolean is
13516 return Nkind (N) = N_Attribute_Reference
13517 and then Attribute_Name (N) = Name_Result;
13518 end Is_Attribute_Result;
13520 -------------------------
13521 -- Is_Attribute_Update --
13522 -------------------------
13524 function Is_Attribute_Update (N : Node_Id) return Boolean is
13526 return Nkind (N) = N_Attribute_Reference
13527 and then Attribute_Name (N) = Name_Update;
13528 end Is_Attribute_Update;
13530 ------------------------------------
13531 -- Is_Body_Or_Package_Declaration --
13532 ------------------------------------
13534 function Is_Body_Or_Package_Declaration (N : Node_Id) return Boolean is
13536 return Is_Body (N) or else Nkind (N) = N_Package_Declaration;
13537 end Is_Body_Or_Package_Declaration;
13539 -----------------------
13540 -- Is_Bounded_String --
13541 -----------------------
13543 function Is_Bounded_String (T : Entity_Id) return Boolean is
13544 Under : constant Entity_Id := Underlying_Type (Root_Type (T));
13547 -- Check whether T is ultimately derived from Ada.Strings.Superbounded.
13548 -- Super_String, or one of the [Wide_]Wide_ versions. This will
13549 -- be True for all the Bounded_String types in instances of the
13550 -- Generic_Bounded_Length generics, and for types derived from those.
13552 return Present (Under)
13553 and then (Is_RTE (Root_Type (Under), RO_SU_Super_String) or else
13554 Is_RTE (Root_Type (Under), RO_WI_Super_String) or else
13555 Is_RTE (Root_Type (Under), RO_WW_Super_String));
13556 end Is_Bounded_String;
13558 ---------------------
13559 -- Is_CCT_Instance --
13560 ---------------------
13562 function Is_CCT_Instance
13563 (Ref_Id : Entity_Id;
13564 Context_Id : Entity_Id) return Boolean
13567 pragma Assert (Ekind_In (Ref_Id, E_Protected_Type, E_Task_Type));
13569 if Is_Single_Task_Object (Context_Id) then
13570 return Scope_Within_Or_Same (Etype (Context_Id), Ref_Id);
13573 pragma Assert (Ekind_In (Context_Id, E_Entry,
13581 Is_Record_Type (Context_Id));
13582 return Scope_Within_Or_Same (Context_Id, Ref_Id);
13584 end Is_CCT_Instance;
13586 -------------------------
13587 -- Is_Child_Or_Sibling --
13588 -------------------------
13590 function Is_Child_Or_Sibling
13591 (Pack_1 : Entity_Id;
13592 Pack_2 : Entity_Id) return Boolean
13594 function Distance_From_Standard (Pack : Entity_Id) return Nat;
13595 -- Given an arbitrary package, return the number of "climbs" necessary
13596 -- to reach scope Standard_Standard.
13598 procedure Equalize_Depths
13599 (Pack : in out Entity_Id;
13600 Depth : in out Nat;
13601 Depth_To_Reach : Nat);
13602 -- Given an arbitrary package, its depth and a target depth to reach,
13603 -- climb the scope chain until the said depth is reached. The pointer
13604 -- to the package and its depth a modified during the climb.
13606 ----------------------------
13607 -- Distance_From_Standard --
13608 ----------------------------
13610 function Distance_From_Standard (Pack : Entity_Id) return Nat is
13617 while Present (Scop) and then Scop /= Standard_Standard loop
13619 Scop := Scope (Scop);
13623 end Distance_From_Standard;
13625 ---------------------
13626 -- Equalize_Depths --
13627 ---------------------
13629 procedure Equalize_Depths
13630 (Pack : in out Entity_Id;
13631 Depth : in out Nat;
13632 Depth_To_Reach : Nat)
13635 -- The package must be at a greater or equal depth
13637 if Depth < Depth_To_Reach then
13638 raise Program_Error;
13641 -- Climb the scope chain until the desired depth is reached
13643 while Present (Pack) and then Depth /= Depth_To_Reach loop
13644 Pack := Scope (Pack);
13645 Depth := Depth - 1;
13647 end Equalize_Depths;
13651 P_1 : Entity_Id := Pack_1;
13652 P_1_Child : Boolean := False;
13653 P_1_Depth : Nat := Distance_From_Standard (P_1);
13654 P_2 : Entity_Id := Pack_2;
13655 P_2_Child : Boolean := False;
13656 P_2_Depth : Nat := Distance_From_Standard (P_2);
13658 -- Start of processing for Is_Child_Or_Sibling
13662 (Ekind (Pack_1) = E_Package and then Ekind (Pack_2) = E_Package);
13664 -- Both packages denote the same entity, therefore they cannot be
13665 -- children or siblings.
13670 -- One of the packages is at a deeper level than the other. Note that
13671 -- both may still come from different hierarchies.
13679 elsif P_1_Depth > P_2_Depth then
13682 Depth => P_1_Depth,
13683 Depth_To_Reach => P_2_Depth);
13692 elsif P_2_Depth > P_1_Depth then
13695 Depth => P_2_Depth,
13696 Depth_To_Reach => P_1_Depth);
13700 -- At this stage the package pointers have been elevated to the same
13701 -- depth. If the related entities are the same, then one package is a
13702 -- potential child of the other:
13706 -- X became P_1 P_2 or vice versa
13712 return Is_Child_Unit (Pack_1);
13714 else pragma Assert (P_2_Child);
13715 return Is_Child_Unit (Pack_2);
13718 -- The packages may come from the same package chain or from entirely
13719 -- different hierarcies. To determine this, climb the scope stack until
13720 -- a common root is found.
13722 -- (root) (root 1) (root 2)
13727 while Present (P_1) and then Present (P_2) loop
13729 -- The two packages may be siblings
13732 return Is_Child_Unit (Pack_1) and then Is_Child_Unit (Pack_2);
13735 P_1 := Scope (P_1);
13736 P_2 := Scope (P_2);
13741 end Is_Child_Or_Sibling;
13743 -----------------------------
13744 -- Is_Concurrent_Interface --
13745 -----------------------------
13747 function Is_Concurrent_Interface (T : Entity_Id) return Boolean is
13749 return Is_Interface (T)
13751 (Is_Protected_Interface (T)
13752 or else Is_Synchronized_Interface (T)
13753 or else Is_Task_Interface (T));
13754 end Is_Concurrent_Interface;
13756 -----------------------
13757 -- Is_Constant_Bound --
13758 -----------------------
13760 function Is_Constant_Bound (Exp : Node_Id) return Boolean is
13762 if Compile_Time_Known_Value (Exp) then
13765 elsif Is_Entity_Name (Exp) and then Present (Entity (Exp)) then
13766 return Is_Constant_Object (Entity (Exp))
13767 or else Ekind (Entity (Exp)) = E_Enumeration_Literal;
13769 elsif Nkind (Exp) in N_Binary_Op then
13770 return Is_Constant_Bound (Left_Opnd (Exp))
13771 and then Is_Constant_Bound (Right_Opnd (Exp))
13772 and then Scope (Entity (Exp)) = Standard_Standard;
13777 end Is_Constant_Bound;
13779 ---------------------------
13780 -- Is_Container_Element --
13781 ---------------------------
13783 function Is_Container_Element (Exp : Node_Id) return Boolean is
13784 Loc : constant Source_Ptr := Sloc (Exp);
13785 Pref : constant Node_Id := Prefix (Exp);
13788 -- Call to an indexing aspect
13790 Cont_Typ : Entity_Id;
13791 -- The type of the container being accessed
13793 Elem_Typ : Entity_Id;
13794 -- Its element type
13796 Indexing : Entity_Id;
13797 Is_Const : Boolean;
13798 -- Indicates that constant indexing is used, and the element is thus
13801 Ref_Typ : Entity_Id;
13802 -- The reference type returned by the indexing operation
13805 -- If C is a container, in a context that imposes the element type of
13806 -- that container, the indexing notation C (X) is rewritten as:
13808 -- Indexing (C, X).Discr.all
13810 -- where Indexing is one of the indexing aspects of the container.
13811 -- If the context does not require a reference, the construct can be
13816 -- First, verify that the construct has the proper form
13818 if not Expander_Active then
13821 elsif Nkind (Pref) /= N_Selected_Component then
13824 elsif Nkind (Prefix (Pref)) /= N_Function_Call then
13828 Call := Prefix (Pref);
13829 Ref_Typ := Etype (Call);
13832 if not Has_Implicit_Dereference (Ref_Typ)
13833 or else No (First (Parameter_Associations (Call)))
13834 or else not Is_Entity_Name (Name (Call))
13839 -- Retrieve type of container object, and its iterator aspects
13841 Cont_Typ := Etype (First (Parameter_Associations (Call)));
13842 Indexing := Find_Value_Of_Aspect (Cont_Typ, Aspect_Constant_Indexing);
13845 if No (Indexing) then
13847 -- Container should have at least one indexing operation
13851 elsif Entity (Name (Call)) /= Entity (Indexing) then
13853 -- This may be a variable indexing operation
13855 Indexing := Find_Value_Of_Aspect (Cont_Typ, Aspect_Variable_Indexing);
13858 or else Entity (Name (Call)) /= Entity (Indexing)
13867 Elem_Typ := Find_Value_Of_Aspect (Cont_Typ, Aspect_Iterator_Element);
13869 if No (Elem_Typ) or else Entity (Elem_Typ) /= Etype (Exp) then
13873 -- Check that the expression is not the target of an assignment, in
13874 -- which case the rewriting is not possible.
13876 if not Is_Const then
13882 while Present (Par)
13884 if Nkind (Parent (Par)) = N_Assignment_Statement
13885 and then Par = Name (Parent (Par))
13889 -- A renaming produces a reference, and the transformation
13892 elsif Nkind (Parent (Par)) = N_Object_Renaming_Declaration then
13896 (Nkind (Parent (Par)), N_Function_Call,
13897 N_Procedure_Call_Statement,
13898 N_Entry_Call_Statement)
13900 -- Check that the element is not part of an actual for an
13901 -- in-out parameter.
13908 F := First_Formal (Entity (Name (Parent (Par))));
13909 A := First (Parameter_Associations (Parent (Par)));
13910 while Present (F) loop
13911 if A = Par and then Ekind (F) /= E_In_Parameter then
13920 -- E_In_Parameter in a call: element is not modified.
13925 Par := Parent (Par);
13930 -- The expression has the proper form and the context requires the
13931 -- element type. Retrieve the Element function of the container and
13932 -- rewrite the construct as a call to it.
13938 Op := First_Elmt (Primitive_Operations (Cont_Typ));
13939 while Present (Op) loop
13940 exit when Chars (Node (Op)) = Name_Element;
13949 Make_Function_Call (Loc,
13950 Name => New_Occurrence_Of (Node (Op), Loc),
13951 Parameter_Associations => Parameter_Associations (Call)));
13952 Analyze_And_Resolve (Exp, Entity (Elem_Typ));
13956 end Is_Container_Element;
13958 ----------------------------
13959 -- Is_Contract_Annotation --
13960 ----------------------------
13962 function Is_Contract_Annotation (Item : Node_Id) return Boolean is
13964 return Is_Package_Contract_Annotation (Item)
13966 Is_Subprogram_Contract_Annotation (Item);
13967 end Is_Contract_Annotation;
13969 --------------------------------------
13970 -- Is_Controlling_Limited_Procedure --
13971 --------------------------------------
13973 function Is_Controlling_Limited_Procedure
13974 (Proc_Nam : Entity_Id) return Boolean
13977 Param_Typ : Entity_Id := Empty;
13980 if Ekind (Proc_Nam) = E_Procedure
13981 and then Present (Parameter_Specifications (Parent (Proc_Nam)))
13985 (First (Parameter_Specifications (Parent (Proc_Nam))));
13987 -- The formal may be an anonymous access type
13989 if Nkind (Param) = N_Access_Definition then
13990 Param_Typ := Entity (Subtype_Mark (Param));
13992 Param_Typ := Etype (Param);
13995 -- In the case where an Itype was created for a dispatchin call, the
13996 -- procedure call has been rewritten. The actual may be an access to
13997 -- interface type in which case it is the designated type that is the
13998 -- controlling type.
14000 elsif Present (Associated_Node_For_Itype (Proc_Nam))
14001 and then Present (Original_Node (Associated_Node_For_Itype (Proc_Nam)))
14003 Present (Parameter_Associations
14004 (Associated_Node_For_Itype (Proc_Nam)))
14007 Etype (First (Parameter_Associations
14008 (Associated_Node_For_Itype (Proc_Nam))));
14010 if Ekind (Param_Typ) = E_Anonymous_Access_Type then
14011 Param_Typ := Directly_Designated_Type (Param_Typ);
14015 if Present (Param_Typ) then
14017 Is_Interface (Param_Typ)
14018 and then Is_Limited_Record (Param_Typ);
14022 end Is_Controlling_Limited_Procedure;
14024 -----------------------------
14025 -- Is_CPP_Constructor_Call --
14026 -----------------------------
14028 function Is_CPP_Constructor_Call (N : Node_Id) return Boolean is
14030 return Nkind (N) = N_Function_Call
14031 and then Is_CPP_Class (Etype (Etype (N)))
14032 and then Is_Constructor (Entity (Name (N)))
14033 and then Is_Imported (Entity (Name (N)));
14034 end Is_CPP_Constructor_Call;
14036 -------------------------
14037 -- Is_Current_Instance --
14038 -------------------------
14040 function Is_Current_Instance (N : Node_Id) return Boolean is
14041 Typ : constant Entity_Id := Entity (N);
14045 -- Simplest case: entity is a concurrent type and we are currently
14046 -- inside the body. This will eventually be expanded into a call to
14047 -- Self (for tasks) or _object (for protected objects).
14049 if Is_Concurrent_Type (Typ) and then In_Open_Scopes (Typ) then
14053 -- Check whether the context is a (sub)type declaration for the
14057 while Present (P) loop
14058 if Nkind_In (P, N_Full_Type_Declaration,
14059 N_Private_Type_Declaration,
14060 N_Subtype_Declaration)
14061 and then Comes_From_Source (P)
14062 and then Defining_Entity (P) = Typ
14066 -- A subtype name may appear in an aspect specification for a
14067 -- Predicate_Failure aspect, for which we do not construct a
14068 -- wrapper procedure. The subtype will be replaced by the
14069 -- expression being tested when the corresponding predicate
14070 -- check is expanded.
14072 elsif Nkind (P) = N_Aspect_Specification
14073 and then Nkind (Parent (P)) = N_Subtype_Declaration
14077 elsif Nkind (P) = N_Pragma
14078 and then Get_Pragma_Id (P) = Pragma_Predicate_Failure
14087 -- In any other context this is not a current occurrence
14090 end Is_Current_Instance;
14092 --------------------
14093 -- Is_Declaration --
14094 --------------------
14096 function Is_Declaration
14098 Body_OK : Boolean := True;
14099 Concurrent_OK : Boolean := True;
14100 Formal_OK : Boolean := True;
14101 Generic_OK : Boolean := True;
14102 Instantiation_OK : Boolean := True;
14103 Renaming_OK : Boolean := True;
14104 Stub_OK : Boolean := True;
14105 Subprogram_OK : Boolean := True;
14106 Type_OK : Boolean := True) return Boolean
14111 -- Body declarations
14113 when N_Proper_Body =>
14116 -- Concurrent type declarations
14118 when N_Protected_Type_Declaration
14119 | N_Single_Protected_Declaration
14120 | N_Single_Task_Declaration
14121 | N_Task_Type_Declaration
14123 return Concurrent_OK or Type_OK;
14125 -- Formal declarations
14127 when N_Formal_Abstract_Subprogram_Declaration
14128 | N_Formal_Concrete_Subprogram_Declaration
14129 | N_Formal_Object_Declaration
14130 | N_Formal_Package_Declaration
14131 | N_Formal_Type_Declaration
14135 -- Generic declarations
14137 when N_Generic_Package_Declaration
14138 | N_Generic_Subprogram_Declaration
14142 -- Generic instantiations
14144 when N_Function_Instantiation
14145 | N_Package_Instantiation
14146 | N_Procedure_Instantiation
14148 return Instantiation_OK;
14150 -- Generic renaming declarations
14152 when N_Generic_Renaming_Declaration =>
14153 return Generic_OK or Renaming_OK;
14155 -- Renaming declarations
14157 when N_Exception_Renaming_Declaration
14158 | N_Object_Renaming_Declaration
14159 | N_Package_Renaming_Declaration
14160 | N_Subprogram_Renaming_Declaration
14162 return Renaming_OK;
14164 -- Stub declarations
14166 when N_Body_Stub =>
14169 -- Subprogram declarations
14171 when N_Abstract_Subprogram_Declaration
14172 | N_Entry_Declaration
14173 | N_Expression_Function
14174 | N_Subprogram_Declaration
14176 return Subprogram_OK;
14178 -- Type declarations
14180 when N_Full_Type_Declaration
14181 | N_Incomplete_Type_Declaration
14182 | N_Private_Extension_Declaration
14183 | N_Private_Type_Declaration
14184 | N_Subtype_Declaration
14190 when N_Component_Declaration
14191 | N_Exception_Declaration
14192 | N_Implicit_Label_Declaration
14193 | N_Number_Declaration
14194 | N_Object_Declaration
14195 | N_Package_Declaration
14202 end Is_Declaration;
14204 --------------------------------
14205 -- Is_Declared_Within_Variant --
14206 --------------------------------
14208 function Is_Declared_Within_Variant (Comp : Entity_Id) return Boolean is
14209 Comp_Decl : constant Node_Id := Parent (Comp);
14210 Comp_List : constant Node_Id := Parent (Comp_Decl);
14212 return Nkind (Parent (Comp_List)) = N_Variant;
14213 end Is_Declared_Within_Variant;
14215 ----------------------------------------------
14216 -- Is_Dependent_Component_Of_Mutable_Object --
14217 ----------------------------------------------
14219 function Is_Dependent_Component_Of_Mutable_Object
14220 (Object : Node_Id) return Boolean
14223 Prefix_Type : Entity_Id;
14224 P_Aliased : Boolean := False;
14227 Deref : Node_Id := Object;
14228 -- Dereference node, in something like X.all.Y(2)
14230 -- Start of processing for Is_Dependent_Component_Of_Mutable_Object
14233 -- Find the dereference node if any
14235 while Nkind_In (Deref, N_Indexed_Component,
14236 N_Selected_Component,
14239 Deref := Prefix (Deref);
14242 -- If the prefix is a qualified expression of a variable, then function
14243 -- Is_Variable will return False for that because a qualified expression
14244 -- denotes a constant view, so we need to get the name being qualified
14245 -- so we can test below whether that's a variable (or a dereference).
14247 if Nkind (Deref) = N_Qualified_Expression then
14248 Deref := Expression (Deref);
14251 -- Ada 2005: If we have a component or slice of a dereference, something
14252 -- like X.all.Y (2) and the type of X is access-to-constant, Is_Variable
14253 -- will return False, because it is indeed a constant view. But it might
14254 -- be a view of a variable object, so we want the following condition to
14255 -- be True in that case.
14257 if Is_Variable (Object)
14258 or else Is_Variable (Deref)
14259 or else (Ada_Version >= Ada_2005
14260 and then (Nkind (Deref) = N_Explicit_Dereference
14261 or else Is_Access_Type (Etype (Deref))))
14263 if Nkind (Object) = N_Selected_Component then
14265 -- If the selector is not a component, then we definitely return
14266 -- False (it could be a function selector in a prefix form call
14267 -- occurring in an iterator specification).
14269 if not Ekind_In (Entity (Selector_Name (Object)), E_Component,
14275 -- Get the original node of the prefix in case it has been
14276 -- rewritten, which can occur, for example, in qualified
14277 -- expression cases. Also, a discriminant check on a selected
14278 -- component may be expanded into a dereference when removing
14279 -- side effects, and the subtype of the original node may be
14282 P := Original_Node (Prefix (Object));
14283 Prefix_Type := Etype (P);
14285 -- If the prefix is a qualified expression, we want to look at its
14288 if Nkind (P) = N_Qualified_Expression then
14289 P := Expression (P);
14290 Prefix_Type := Etype (P);
14293 if Is_Entity_Name (P) then
14294 if Ekind (Entity (P)) = E_Generic_In_Out_Parameter then
14295 Prefix_Type := Base_Type (Prefix_Type);
14298 if Is_Aliased (Entity (P)) then
14302 -- For explicit dereferences we get the access prefix so we can
14303 -- treat this similarly to implicit dereferences and examine the
14304 -- kind of the access type and its designated subtype further
14307 elsif Nkind (P) = N_Explicit_Dereference then
14309 Prefix_Type := Etype (P);
14312 -- Check for prefix being an aliased component???
14317 -- A heap object is constrained by its initial value
14319 -- Ada 2005 (AI-363): Always assume the object could be mutable in
14320 -- the dereferenced case, since the access value might denote an
14321 -- unconstrained aliased object, whereas in Ada 95 the designated
14322 -- object is guaranteed to be constrained. A worst-case assumption
14323 -- has to apply in Ada 2005 because we can't tell at compile
14324 -- time whether the object is "constrained by its initial value",
14325 -- despite the fact that 3.10.2(26/2) and 8.5.1(5/2) are semantic
14326 -- rules (these rules are acknowledged to need fixing). We don't
14327 -- impose this more stringent checking for earlier Ada versions or
14328 -- when Relaxed_RM_Semantics applies (the latter for CodePeer's
14329 -- benefit, though it's unclear on why using -gnat95 would not be
14332 if Ada_Version < Ada_2005 or else Relaxed_RM_Semantics then
14333 if Is_Access_Type (Prefix_Type)
14334 or else Nkind (P) = N_Explicit_Dereference
14339 else pragma Assert (Ada_Version >= Ada_2005);
14340 if Is_Access_Type (Prefix_Type) then
14341 -- We need to make sure we have the base subtype, in case
14342 -- this is actually an access subtype (whose Ekind will be
14343 -- E_Access_Subtype).
14345 Prefix_Type := Etype (Prefix_Type);
14347 -- If the access type is pool-specific, and there is no
14348 -- constrained partial view of the designated type, then the
14349 -- designated object is known to be constrained. If it's a
14350 -- formal access type and the renaming is in the generic
14351 -- spec, we also treat it as pool-specific (known to be
14352 -- constrained), but assume the worst if in the generic body
14353 -- (see RM 3.3(23.3/3)).
14355 if Ekind (Prefix_Type) = E_Access_Type
14356 and then (not Is_Generic_Type (Prefix_Type)
14357 or else not In_Generic_Body (Current_Scope))
14358 and then not Object_Type_Has_Constrained_Partial_View
14359 (Typ => Designated_Type (Prefix_Type),
14360 Scop => Current_Scope)
14364 -- Otherwise (general access type, or there is a constrained
14365 -- partial view of the designated type), we need to check
14366 -- based on the designated type.
14369 Prefix_Type := Designated_Type (Prefix_Type);
14375 Original_Record_Component (Entity (Selector_Name (Object)));
14377 -- As per AI-0017, the renaming is illegal in a generic body, even
14378 -- if the subtype is indefinite (only applies to prefixes of an
14379 -- untagged formal type, see RM 3.3 (23.11/3)).
14381 -- Ada 2005 (AI-363): In Ada 2005 an aliased object can be mutable
14383 if not Is_Constrained (Prefix_Type)
14384 and then (Is_Definite_Subtype (Prefix_Type)
14386 (not Is_Tagged_Type (Prefix_Type)
14387 and then Is_Generic_Type (Prefix_Type)
14388 and then In_Generic_Body (Current_Scope)))
14390 and then (Is_Declared_Within_Variant (Comp)
14391 or else Has_Discriminant_Dependent_Constraint (Comp))
14392 and then (not P_Aliased or else Ada_Version >= Ada_2005)
14396 -- If the prefix is of an access type at this point, then we want
14397 -- to return False, rather than calling this function recursively
14398 -- on the access object (which itself might be a discriminant-
14399 -- dependent component of some other object, but that isn't
14400 -- relevant to checking the object passed to us). This avoids
14401 -- issuing wrong errors when compiling with -gnatc, where there
14402 -- can be implicit dereferences that have not been expanded.
14404 elsif Is_Access_Type (Etype (Prefix (Object))) then
14409 Is_Dependent_Component_Of_Mutable_Object (Prefix (Object));
14412 elsif Nkind (Object) = N_Indexed_Component
14413 or else Nkind (Object) = N_Slice
14415 return Is_Dependent_Component_Of_Mutable_Object (Prefix (Object));
14417 -- A type conversion that Is_Variable is a view conversion:
14418 -- go back to the denoted object.
14420 elsif Nkind (Object) = N_Type_Conversion then
14422 Is_Dependent_Component_Of_Mutable_Object (Expression (Object));
14427 end Is_Dependent_Component_Of_Mutable_Object;
14429 ---------------------
14430 -- Is_Dereferenced --
14431 ---------------------
14433 function Is_Dereferenced (N : Node_Id) return Boolean is
14434 P : constant Node_Id := Parent (N);
14436 return Nkind_In (P, N_Selected_Component,
14437 N_Explicit_Dereference,
14438 N_Indexed_Component,
14440 and then Prefix (P) = N;
14441 end Is_Dereferenced;
14443 ----------------------
14444 -- Is_Descendant_Of --
14445 ----------------------
14447 function Is_Descendant_Of (T1 : Entity_Id; T2 : Entity_Id) return Boolean is
14452 pragma Assert (Nkind (T1) in N_Entity);
14453 pragma Assert (Nkind (T2) in N_Entity);
14455 T := Base_Type (T1);
14457 -- Immediate return if the types match
14462 -- Comment needed here ???
14464 elsif Ekind (T) = E_Class_Wide_Type then
14465 return Etype (T) = T2;
14473 -- Done if we found the type we are looking for
14478 -- Done if no more derivations to check
14485 -- Following test catches error cases resulting from prev errors
14487 elsif No (Etyp) then
14490 elsif Is_Private_Type (T) and then Etyp = Full_View (T) then
14493 elsif Is_Private_Type (Etyp) and then Full_View (Etyp) = T then
14497 T := Base_Type (Etyp);
14500 end Is_Descendant_Of;
14502 ----------------------------------------
14503 -- Is_Descendant_Of_Suspension_Object --
14504 ----------------------------------------
14506 function Is_Descendant_Of_Suspension_Object
14507 (Typ : Entity_Id) return Boolean
14509 Cur_Typ : Entity_Id;
14510 Par_Typ : Entity_Id;
14513 -- Climb the type derivation chain checking each parent type against
14514 -- Suspension_Object.
14516 Cur_Typ := Base_Type (Typ);
14517 while Present (Cur_Typ) loop
14518 Par_Typ := Etype (Cur_Typ);
14520 -- The current type is a match
14522 if Is_Suspension_Object (Cur_Typ) then
14525 -- Stop the traversal once the root of the derivation chain has been
14526 -- reached. In that case the current type is its own base type.
14528 elsif Cur_Typ = Par_Typ then
14532 Cur_Typ := Base_Type (Par_Typ);
14536 end Is_Descendant_Of_Suspension_Object;
14538 ---------------------------------------------
14539 -- Is_Double_Precision_Floating_Point_Type --
14540 ---------------------------------------------
14542 function Is_Double_Precision_Floating_Point_Type
14543 (E : Entity_Id) return Boolean is
14545 return Is_Floating_Point_Type (E)
14546 and then Machine_Radix_Value (E) = Uint_2
14547 and then Machine_Mantissa_Value (E) = UI_From_Int (53)
14548 and then Machine_Emax_Value (E) = Uint_2 ** Uint_10
14549 and then Machine_Emin_Value (E) = Uint_3 - (Uint_2 ** Uint_10);
14550 end Is_Double_Precision_Floating_Point_Type;
14552 -----------------------------
14553 -- Is_Effectively_Volatile --
14554 -----------------------------
14556 function Is_Effectively_Volatile (Id : Entity_Id) return Boolean is
14558 if Is_Type (Id) then
14560 -- An arbitrary type is effectively volatile when it is subject to
14561 -- pragma Atomic or Volatile.
14563 if Is_Volatile (Id) then
14566 -- An array type is effectively volatile when it is subject to pragma
14567 -- Atomic_Components or Volatile_Components or its component type is
14568 -- effectively volatile.
14570 elsif Is_Array_Type (Id) then
14572 Anc : Entity_Id := Base_Type (Id);
14574 if Is_Private_Type (Anc) then
14575 Anc := Full_View (Anc);
14578 -- Test for presence of ancestor, as the full view of a private
14579 -- type may be missing in case of error.
14582 Has_Volatile_Components (Id)
14585 and then Is_Effectively_Volatile (Component_Type (Anc)));
14588 -- A protected type is always volatile
14590 elsif Is_Protected_Type (Id) then
14593 -- A descendant of Ada.Synchronous_Task_Control.Suspension_Object is
14594 -- automatically volatile.
14596 elsif Is_Descendant_Of_Suspension_Object (Id) then
14599 -- Otherwise the type is not effectively volatile
14605 -- Otherwise Id denotes an object
14608 -- A volatile object for which No_Caching is enabled is not
14609 -- effectively volatile.
14612 (Is_Volatile (Id) and then not No_Caching_Enabled (Id))
14613 or else Has_Volatile_Components (Id)
14614 or else Is_Effectively_Volatile (Etype (Id));
14616 end Is_Effectively_Volatile;
14618 ------------------------------------
14619 -- Is_Effectively_Volatile_Object --
14620 ------------------------------------
14622 function Is_Effectively_Volatile_Object (N : Node_Id) return Boolean is
14624 if Is_Entity_Name (N) then
14625 return Is_Effectively_Volatile (Entity (N));
14627 elsif Nkind (N) = N_Indexed_Component then
14628 return Is_Effectively_Volatile_Object (Prefix (N));
14630 elsif Nkind (N) = N_Selected_Component then
14632 Is_Effectively_Volatile_Object (Prefix (N))
14634 Is_Effectively_Volatile_Object (Selector_Name (N));
14639 end Is_Effectively_Volatile_Object;
14641 -------------------
14642 -- Is_Entry_Body --
14643 -------------------
14645 function Is_Entry_Body (Id : Entity_Id) return Boolean is
14648 Ekind_In (Id, E_Entry, E_Entry_Family)
14649 and then Nkind (Unit_Declaration_Node (Id)) = N_Entry_Body;
14652 --------------------------
14653 -- Is_Entry_Declaration --
14654 --------------------------
14656 function Is_Entry_Declaration (Id : Entity_Id) return Boolean is
14659 Ekind_In (Id, E_Entry, E_Entry_Family)
14660 and then Nkind (Unit_Declaration_Node (Id)) = N_Entry_Declaration;
14661 end Is_Entry_Declaration;
14663 ------------------------------------
14664 -- Is_Expanded_Priority_Attribute --
14665 ------------------------------------
14667 function Is_Expanded_Priority_Attribute (E : Entity_Id) return Boolean is
14670 Nkind (E) = N_Function_Call
14671 and then not Configurable_Run_Time_Mode
14672 and then Nkind (Original_Node (E)) = N_Attribute_Reference
14673 and then (Entity (Name (E)) = RTE (RE_Get_Ceiling)
14674 or else Entity (Name (E)) = RTE (RO_PE_Get_Ceiling));
14675 end Is_Expanded_Priority_Attribute;
14677 ----------------------------
14678 -- Is_Expression_Function --
14679 ----------------------------
14681 function Is_Expression_Function (Subp : Entity_Id) return Boolean is
14683 if Ekind_In (Subp, E_Function, E_Subprogram_Body) then
14685 Nkind (Original_Node (Unit_Declaration_Node (Subp))) =
14686 N_Expression_Function;
14690 end Is_Expression_Function;
14692 ------------------------------------------
14693 -- Is_Expression_Function_Or_Completion --
14694 ------------------------------------------
14696 function Is_Expression_Function_Or_Completion
14697 (Subp : Entity_Id) return Boolean
14699 Subp_Decl : Node_Id;
14702 if Ekind (Subp) = E_Function then
14703 Subp_Decl := Unit_Declaration_Node (Subp);
14705 -- The function declaration is either an expression function or is
14706 -- completed by an expression function body.
14709 Is_Expression_Function (Subp)
14710 or else (Nkind (Subp_Decl) = N_Subprogram_Declaration
14711 and then Present (Corresponding_Body (Subp_Decl))
14712 and then Is_Expression_Function
14713 (Corresponding_Body (Subp_Decl)));
14715 elsif Ekind (Subp) = E_Subprogram_Body then
14716 return Is_Expression_Function (Subp);
14721 end Is_Expression_Function_Or_Completion;
14723 -----------------------
14724 -- Is_EVF_Expression --
14725 -----------------------
14727 function Is_EVF_Expression (N : Node_Id) return Boolean is
14728 Orig_N : constant Node_Id := Original_Node (N);
14734 -- Detect a reference to a formal parameter of a specific tagged type
14735 -- whose related subprogram is subject to pragma Expresions_Visible with
14738 if Is_Entity_Name (N) and then Present (Entity (N)) then
14743 and then Is_Specific_Tagged_Type (Etype (Id))
14744 and then Extensions_Visible_Status (Id) =
14745 Extensions_Visible_False;
14747 -- A case expression is an EVF expression when it contains at least one
14748 -- EVF dependent_expression. Note that a case expression may have been
14749 -- expanded, hence the use of Original_Node.
14751 elsif Nkind (Orig_N) = N_Case_Expression then
14752 Alt := First (Alternatives (Orig_N));
14753 while Present (Alt) loop
14754 if Is_EVF_Expression (Expression (Alt)) then
14761 -- An if expression is an EVF expression when it contains at least one
14762 -- EVF dependent_expression. Note that an if expression may have been
14763 -- expanded, hence the use of Original_Node.
14765 elsif Nkind (Orig_N) = N_If_Expression then
14766 Expr := Next (First (Expressions (Orig_N)));
14767 while Present (Expr) loop
14768 if Is_EVF_Expression (Expr) then
14775 -- A qualified expression or a type conversion is an EVF expression when
14776 -- its operand is an EVF expression.
14778 elsif Nkind_In (N, N_Qualified_Expression,
14779 N_Unchecked_Type_Conversion,
14782 return Is_EVF_Expression (Expression (N));
14784 -- Attributes 'Loop_Entry, 'Old, and 'Update are EVF expressions when
14785 -- their prefix denotes an EVF expression.
14787 elsif Nkind (N) = N_Attribute_Reference
14788 and then Nam_In (Attribute_Name (N), Name_Loop_Entry,
14792 return Is_EVF_Expression (Prefix (N));
14796 end Is_EVF_Expression;
14802 function Is_False (U : Uint) return Boolean is
14807 ---------------------------
14808 -- Is_Fixed_Model_Number --
14809 ---------------------------
14811 function Is_Fixed_Model_Number (U : Ureal; T : Entity_Id) return Boolean is
14812 S : constant Ureal := Small_Value (T);
14813 M : Urealp.Save_Mark;
14818 R := (U = UR_Trunc (U / S) * S);
14819 Urealp.Release (M);
14821 end Is_Fixed_Model_Number;
14823 -------------------------------
14824 -- Is_Fully_Initialized_Type --
14825 -------------------------------
14827 function Is_Fully_Initialized_Type (Typ : Entity_Id) return Boolean is
14831 if Is_Scalar_Type (Typ) then
14833 -- A scalar type with an aspect Default_Value is fully initialized
14835 -- Note: Iniitalize/Normalize_Scalars also ensure full initialization
14836 -- of a scalar type, but we don't take that into account here, since
14837 -- we don't want these to affect warnings.
14839 return Has_Default_Aspect (Typ);
14841 elsif Is_Access_Type (Typ) then
14844 elsif Is_Array_Type (Typ) then
14845 if Is_Fully_Initialized_Type (Component_Type (Typ))
14846 or else (Ada_Version >= Ada_2012 and then Has_Default_Aspect (Typ))
14851 -- An interesting case, if we have a constrained type one of whose
14852 -- bounds is known to be null, then there are no elements to be
14853 -- initialized, so all the elements are initialized.
14855 if Is_Constrained (Typ) then
14858 Indx_Typ : Entity_Id;
14859 Lbd, Hbd : Node_Id;
14862 Indx := First_Index (Typ);
14863 while Present (Indx) loop
14864 if Etype (Indx) = Any_Type then
14867 -- If index is a range, use directly
14869 elsif Nkind (Indx) = N_Range then
14870 Lbd := Low_Bound (Indx);
14871 Hbd := High_Bound (Indx);
14874 Indx_Typ := Etype (Indx);
14876 if Is_Private_Type (Indx_Typ) then
14877 Indx_Typ := Full_View (Indx_Typ);
14880 if No (Indx_Typ) or else Etype (Indx_Typ) = Any_Type then
14883 Lbd := Type_Low_Bound (Indx_Typ);
14884 Hbd := Type_High_Bound (Indx_Typ);
14888 if Compile_Time_Known_Value (Lbd)
14890 Compile_Time_Known_Value (Hbd)
14892 if Expr_Value (Hbd) < Expr_Value (Lbd) then
14902 -- If no null indexes, then type is not fully initialized
14908 elsif Is_Record_Type (Typ) then
14909 if Has_Discriminants (Typ)
14911 Present (Discriminant_Default_Value (First_Discriminant (Typ)))
14912 and then Is_Fully_Initialized_Variant (Typ)
14917 -- We consider bounded string types to be fully initialized, because
14918 -- otherwise we get false alarms when the Data component is not
14919 -- default-initialized.
14921 if Is_Bounded_String (Typ) then
14925 -- Controlled records are considered to be fully initialized if
14926 -- there is a user defined Initialize routine. This may not be
14927 -- entirely correct, but as the spec notes, we are guessing here
14928 -- what is best from the point of view of issuing warnings.
14930 if Is_Controlled (Typ) then
14932 Utyp : constant Entity_Id := Underlying_Type (Typ);
14935 if Present (Utyp) then
14937 Init : constant Entity_Id :=
14938 (Find_Optional_Prim_Op
14939 (Underlying_Type (Typ), Name_Initialize));
14943 and then Comes_From_Source (Init)
14944 and then not In_Predefined_Unit (Init)
14948 elsif Has_Null_Extension (Typ)
14950 Is_Fully_Initialized_Type
14951 (Etype (Base_Type (Typ)))
14960 -- Otherwise see if all record components are initialized
14966 Ent := First_Entity (Typ);
14967 while Present (Ent) loop
14968 if Ekind (Ent) = E_Component
14969 and then (No (Parent (Ent))
14970 or else No (Expression (Parent (Ent))))
14971 and then not Is_Fully_Initialized_Type (Etype (Ent))
14973 -- Special VM case for tag components, which need to be
14974 -- defined in this case, but are never initialized as VMs
14975 -- are using other dispatching mechanisms. Ignore this
14976 -- uninitialized case. Note that this applies both to the
14977 -- uTag entry and the main vtable pointer (CPP_Class case).
14979 and then (Tagged_Type_Expansion or else not Is_Tag (Ent))
14988 -- No uninitialized components, so type is fully initialized.
14989 -- Note that this catches the case of no components as well.
14993 elsif Is_Concurrent_Type (Typ) then
14996 elsif Is_Private_Type (Typ) then
14998 U : constant Entity_Id := Underlying_Type (Typ);
15004 return Is_Fully_Initialized_Type (U);
15011 end Is_Fully_Initialized_Type;
15013 ----------------------------------
15014 -- Is_Fully_Initialized_Variant --
15015 ----------------------------------
15017 function Is_Fully_Initialized_Variant (Typ : Entity_Id) return Boolean is
15018 Loc : constant Source_Ptr := Sloc (Typ);
15019 Constraints : constant List_Id := New_List;
15020 Components : constant Elist_Id := New_Elmt_List;
15021 Comp_Elmt : Elmt_Id;
15023 Comp_List : Node_Id;
15025 Discr_Val : Node_Id;
15027 Report_Errors : Boolean;
15028 pragma Warnings (Off, Report_Errors);
15031 if Serious_Errors_Detected > 0 then
15035 if Is_Record_Type (Typ)
15036 and then Nkind (Parent (Typ)) = N_Full_Type_Declaration
15037 and then Nkind (Type_Definition (Parent (Typ))) = N_Record_Definition
15039 Comp_List := Component_List (Type_Definition (Parent (Typ)));
15041 Discr := First_Discriminant (Typ);
15042 while Present (Discr) loop
15043 if Nkind (Parent (Discr)) = N_Discriminant_Specification then
15044 Discr_Val := Expression (Parent (Discr));
15046 if Present (Discr_Val)
15047 and then Is_OK_Static_Expression (Discr_Val)
15049 Append_To (Constraints,
15050 Make_Component_Association (Loc,
15051 Choices => New_List (New_Occurrence_Of (Discr, Loc)),
15052 Expression => New_Copy (Discr_Val)));
15060 Next_Discriminant (Discr);
15065 Comp_List => Comp_List,
15066 Governed_By => Constraints,
15067 Into => Components,
15068 Report_Errors => Report_Errors);
15070 -- Check that each component present is fully initialized
15072 Comp_Elmt := First_Elmt (Components);
15073 while Present (Comp_Elmt) loop
15074 Comp_Id := Node (Comp_Elmt);
15076 if Ekind (Comp_Id) = E_Component
15077 and then (No (Parent (Comp_Id))
15078 or else No (Expression (Parent (Comp_Id))))
15079 and then not Is_Fully_Initialized_Type (Etype (Comp_Id))
15084 Next_Elmt (Comp_Elmt);
15089 elsif Is_Private_Type (Typ) then
15091 U : constant Entity_Id := Underlying_Type (Typ);
15097 return Is_Fully_Initialized_Variant (U);
15104 end Is_Fully_Initialized_Variant;
15106 ------------------------------------
15107 -- Is_Generic_Declaration_Or_Body --
15108 ------------------------------------
15110 function Is_Generic_Declaration_Or_Body (Decl : Node_Id) return Boolean is
15111 Spec_Decl : Node_Id;
15114 -- Package/subprogram body
15116 if Nkind_In (Decl, N_Package_Body, N_Subprogram_Body)
15117 and then Present (Corresponding_Spec (Decl))
15119 Spec_Decl := Unit_Declaration_Node (Corresponding_Spec (Decl));
15121 -- Package/subprogram body stub
15123 elsif Nkind_In (Decl, N_Package_Body_Stub, N_Subprogram_Body_Stub)
15124 and then Present (Corresponding_Spec_Of_Stub (Decl))
15127 Unit_Declaration_Node (Corresponding_Spec_Of_Stub (Decl));
15135 -- Rather than inspecting the defining entity of the spec declaration,
15136 -- look at its Nkind. This takes care of the case where the analysis of
15137 -- a generic body modifies the Ekind of its spec to allow for recursive
15141 Nkind_In (Spec_Decl, N_Generic_Package_Declaration,
15142 N_Generic_Subprogram_Declaration);
15143 end Is_Generic_Declaration_Or_Body;
15145 ----------------------------
15146 -- Is_Inherited_Operation --
15147 ----------------------------
15149 function Is_Inherited_Operation (E : Entity_Id) return Boolean is
15150 pragma Assert (Is_Overloadable (E));
15151 Kind : constant Node_Kind := Nkind (Parent (E));
15153 return Kind = N_Full_Type_Declaration
15154 or else Kind = N_Private_Extension_Declaration
15155 or else Kind = N_Subtype_Declaration
15156 or else (Ekind (E) = E_Enumeration_Literal
15157 and then Is_Derived_Type (Etype (E)));
15158 end Is_Inherited_Operation;
15160 -------------------------------------
15161 -- Is_Inherited_Operation_For_Type --
15162 -------------------------------------
15164 function Is_Inherited_Operation_For_Type
15166 Typ : Entity_Id) return Boolean
15169 -- Check that the operation has been created by the type declaration
15171 return Is_Inherited_Operation (E)
15172 and then Defining_Identifier (Parent (E)) = Typ;
15173 end Is_Inherited_Operation_For_Type;
15175 --------------------------------------
15176 -- Is_Inlinable_Expression_Function --
15177 --------------------------------------
15179 function Is_Inlinable_Expression_Function
15180 (Subp : Entity_Id) return Boolean
15182 Return_Expr : Node_Id;
15185 if Is_Expression_Function_Or_Completion (Subp)
15186 and then Has_Pragma_Inline_Always (Subp)
15187 and then Needs_No_Actuals (Subp)
15188 and then No (Contract (Subp))
15189 and then not Is_Dispatching_Operation (Subp)
15190 and then Needs_Finalization (Etype (Subp))
15191 and then not Is_Class_Wide_Type (Etype (Subp))
15192 and then not (Has_Invariants (Etype (Subp)))
15193 and then Present (Subprogram_Body (Subp))
15194 and then Was_Expression_Function (Subprogram_Body (Subp))
15196 Return_Expr := Expression_Of_Expression_Function (Subp);
15198 -- The returned object must not have a qualified expression and its
15199 -- nominal subtype must be statically compatible with the result
15200 -- subtype of the expression function.
15203 Nkind (Return_Expr) = N_Identifier
15204 and then Etype (Return_Expr) = Etype (Subp);
15208 end Is_Inlinable_Expression_Function;
15214 function Is_Iterator (Typ : Entity_Id) return Boolean is
15215 function Denotes_Iterator (Iter_Typ : Entity_Id) return Boolean;
15216 -- Determine whether type Iter_Typ is a predefined forward or reversible
15219 ----------------------
15220 -- Denotes_Iterator --
15221 ----------------------
15223 function Denotes_Iterator (Iter_Typ : Entity_Id) return Boolean is
15225 -- Check that the name matches, and that the ultimate ancestor is in
15226 -- a predefined unit, i.e the one that declares iterator interfaces.
15229 Nam_In (Chars (Iter_Typ), Name_Forward_Iterator,
15230 Name_Reversible_Iterator)
15231 and then In_Predefined_Unit (Root_Type (Iter_Typ));
15232 end Denotes_Iterator;
15236 Iface_Elmt : Elmt_Id;
15239 -- Start of processing for Is_Iterator
15242 -- The type may be a subtype of a descendant of the proper instance of
15243 -- the predefined interface type, so we must use the root type of the
15244 -- given type. The same is done for Is_Reversible_Iterator.
15246 if Is_Class_Wide_Type (Typ)
15247 and then Denotes_Iterator (Root_Type (Typ))
15251 elsif not Is_Tagged_Type (Typ) or else not Is_Derived_Type (Typ) then
15254 elsif Present (Find_Value_Of_Aspect (Typ, Aspect_Iterable)) then
15258 Collect_Interfaces (Typ, Ifaces);
15260 Iface_Elmt := First_Elmt (Ifaces);
15261 while Present (Iface_Elmt) loop
15262 if Denotes_Iterator (Node (Iface_Elmt)) then
15266 Next_Elmt (Iface_Elmt);
15273 ----------------------------
15274 -- Is_Iterator_Over_Array --
15275 ----------------------------
15277 function Is_Iterator_Over_Array (N : Node_Id) return Boolean is
15278 Container : constant Node_Id := Name (N);
15279 Container_Typ : constant Entity_Id := Base_Type (Etype (Container));
15281 return Is_Array_Type (Container_Typ);
15282 end Is_Iterator_Over_Array;
15288 -- We seem to have a lot of overlapping functions that do similar things
15289 -- (testing for left hand sides or lvalues???).
15291 function Is_LHS (N : Node_Id) return Is_LHS_Result is
15292 P : constant Node_Id := Parent (N);
15295 -- Return True if we are the left hand side of an assignment statement
15297 if Nkind (P) = N_Assignment_Statement then
15298 if Name (P) = N then
15304 -- Case of prefix of indexed or selected component or slice
15306 elsif Nkind_In (P, N_Indexed_Component, N_Selected_Component, N_Slice)
15307 and then N = Prefix (P)
15309 -- Here we have the case where the parent P is N.Q or N(Q .. R).
15310 -- If P is an LHS, then N is also effectively an LHS, but there
15311 -- is an important exception. If N is of an access type, then
15312 -- what we really have is N.all.Q (or N.all(Q .. R)). In either
15313 -- case this makes N.all a left hand side but not N itself.
15315 -- If we don't know the type yet, this is the case where we return
15316 -- Unknown, since the answer depends on the type which is unknown.
15318 if No (Etype (N)) then
15321 -- We have an Etype set, so we can check it
15323 elsif Is_Access_Type (Etype (N)) then
15326 -- OK, not access type case, so just test whole expression
15332 -- All other cases are not left hand sides
15339 -----------------------------
15340 -- Is_Library_Level_Entity --
15341 -----------------------------
15343 function Is_Library_Level_Entity (E : Entity_Id) return Boolean is
15345 -- The following is a small optimization, and it also properly handles
15346 -- discriminals, which in task bodies might appear in expressions before
15347 -- the corresponding procedure has been created, and which therefore do
15348 -- not have an assigned scope.
15350 if Is_Formal (E) then
15354 -- Normal test is simply that the enclosing dynamic scope is Standard
15356 return Enclosing_Dynamic_Scope (E) = Standard_Standard;
15357 end Is_Library_Level_Entity;
15359 --------------------------------
15360 -- Is_Limited_Class_Wide_Type --
15361 --------------------------------
15363 function Is_Limited_Class_Wide_Type (Typ : Entity_Id) return Boolean is
15366 Is_Class_Wide_Type (Typ)
15367 and then (Is_Limited_Type (Typ) or else From_Limited_With (Typ));
15368 end Is_Limited_Class_Wide_Type;
15370 ---------------------------------
15371 -- Is_Local_Variable_Reference --
15372 ---------------------------------
15374 function Is_Local_Variable_Reference (Expr : Node_Id) return Boolean is
15376 if not Is_Entity_Name (Expr) then
15381 Ent : constant Entity_Id := Entity (Expr);
15382 Sub : constant Entity_Id := Enclosing_Subprogram (Ent);
15384 if not Ekind_In (Ent, E_Variable, E_In_Out_Parameter) then
15387 return Present (Sub) and then Sub = Current_Subprogram;
15391 end Is_Local_Variable_Reference;
15393 -----------------------
15394 -- Is_Name_Reference --
15395 -----------------------
15397 function Is_Name_Reference (N : Node_Id) return Boolean is
15399 if Is_Entity_Name (N) then
15400 return Present (Entity (N)) and then Is_Object (Entity (N));
15404 when N_Indexed_Component
15408 Is_Name_Reference (Prefix (N))
15409 or else Is_Access_Type (Etype (Prefix (N)));
15411 -- Attributes 'Input, 'Old and 'Result produce objects
15413 when N_Attribute_Reference =>
15415 Nam_In (Attribute_Name (N), Name_Input, Name_Old, Name_Result);
15417 when N_Selected_Component =>
15419 Is_Name_Reference (Selector_Name (N))
15421 (Is_Name_Reference (Prefix (N))
15422 or else Is_Access_Type (Etype (Prefix (N))));
15424 when N_Explicit_Dereference =>
15427 -- A view conversion of a tagged name is a name reference
15429 when N_Type_Conversion =>
15431 Is_Tagged_Type (Etype (Subtype_Mark (N)))
15432 and then Is_Tagged_Type (Etype (Expression (N)))
15433 and then Is_Name_Reference (Expression (N));
15435 -- An unchecked type conversion is considered to be a name if the
15436 -- operand is a name (this construction arises only as a result of
15437 -- expansion activities).
15439 when N_Unchecked_Type_Conversion =>
15440 return Is_Name_Reference (Expression (N));
15445 end Is_Name_Reference;
15447 ------------------------------------
15448 -- Is_Non_Preelaborable_Construct --
15449 ------------------------------------
15451 function Is_Non_Preelaborable_Construct (N : Node_Id) return Boolean is
15453 -- NOTE: the routines within Is_Non_Preelaborable_Construct are
15454 -- intentionally unnested to avoid deep indentation of code.
15456 Non_Preelaborable : exception;
15457 -- This exception is raised when the construct violates preelaborability
15458 -- to terminate the recursion.
15460 procedure Visit (Nod : Node_Id);
15461 -- Semantically inspect construct Nod to determine whether it violates
15462 -- preelaborability. This routine raises Non_Preelaborable.
15464 procedure Visit_List (List : List_Id);
15465 pragma Inline (Visit_List);
15466 -- Invoke Visit on each element of list List. This routine raises
15467 -- Non_Preelaborable.
15469 procedure Visit_Pragma (Prag : Node_Id);
15470 pragma Inline (Visit_Pragma);
15471 -- Semantically inspect pragma Prag to determine whether it violates
15472 -- preelaborability. This routine raises Non_Preelaborable.
15474 procedure Visit_Subexpression (Expr : Node_Id);
15475 pragma Inline (Visit_Subexpression);
15476 -- Semantically inspect expression Expr to determine whether it violates
15477 -- preelaborability. This routine raises Non_Preelaborable.
15483 procedure Visit (Nod : Node_Id) is
15485 case Nkind (Nod) is
15489 when N_Component_Declaration =>
15491 -- Defining_Identifier is left out because it is not relevant
15492 -- for preelaborability.
15494 Visit (Component_Definition (Nod));
15495 Visit (Expression (Nod));
15497 when N_Derived_Type_Definition =>
15499 -- Interface_List is left out because it is not relevant for
15500 -- preelaborability.
15502 Visit (Record_Extension_Part (Nod));
15503 Visit (Subtype_Indication (Nod));
15505 when N_Entry_Declaration =>
15507 -- A protected type with at leat one entry is not preelaborable
15508 -- while task types are never preelaborable. This renders entry
15509 -- declarations non-preelaborable.
15511 raise Non_Preelaborable;
15513 when N_Full_Type_Declaration =>
15515 -- Defining_Identifier and Discriminant_Specifications are left
15516 -- out because they are not relevant for preelaborability.
15518 Visit (Type_Definition (Nod));
15520 when N_Function_Instantiation
15521 | N_Package_Instantiation
15522 | N_Procedure_Instantiation
15524 -- Defining_Unit_Name and Name are left out because they are
15525 -- not relevant for preelaborability.
15527 Visit_List (Generic_Associations (Nod));
15529 when N_Object_Declaration =>
15531 -- Defining_Identifier is left out because it is not relevant
15532 -- for preelaborability.
15534 Visit (Object_Definition (Nod));
15536 if Has_Init_Expression (Nod) then
15537 Visit (Expression (Nod));
15539 elsif not Has_Preelaborable_Initialization
15540 (Etype (Defining_Entity (Nod)))
15542 raise Non_Preelaborable;
15545 when N_Private_Extension_Declaration
15546 | N_Subtype_Declaration
15548 -- Defining_Identifier, Discriminant_Specifications, and
15549 -- Interface_List are left out because they are not relevant
15550 -- for preelaborability.
15552 Visit (Subtype_Indication (Nod));
15554 when N_Protected_Type_Declaration
15555 | N_Single_Protected_Declaration
15557 -- Defining_Identifier, Discriminant_Specifications, and
15558 -- Interface_List are left out because they are not relevant
15559 -- for preelaborability.
15561 Visit (Protected_Definition (Nod));
15563 -- A [single] task type is never preelaborable
15565 when N_Single_Task_Declaration
15566 | N_Task_Type_Declaration
15568 raise Non_Preelaborable;
15573 Visit_Pragma (Nod);
15577 when N_Statement_Other_Than_Procedure_Call =>
15578 if Nkind (Nod) /= N_Null_Statement then
15579 raise Non_Preelaborable;
15585 Visit_Subexpression (Nod);
15589 when N_Access_To_Object_Definition =>
15590 Visit (Subtype_Indication (Nod));
15592 when N_Case_Expression_Alternative =>
15593 Visit (Expression (Nod));
15594 Visit_List (Discrete_Choices (Nod));
15596 when N_Component_Definition =>
15597 Visit (Access_Definition (Nod));
15598 Visit (Subtype_Indication (Nod));
15600 when N_Component_List =>
15601 Visit_List (Component_Items (Nod));
15602 Visit (Variant_Part (Nod));
15604 when N_Constrained_Array_Definition =>
15605 Visit_List (Discrete_Subtype_Definitions (Nod));
15606 Visit (Component_Definition (Nod));
15608 when N_Delta_Constraint
15609 | N_Digits_Constraint
15611 -- Delta_Expression and Digits_Expression are left out because
15612 -- they are not relevant for preelaborability.
15614 Visit (Range_Constraint (Nod));
15616 when N_Discriminant_Specification =>
15618 -- Defining_Identifier and Expression are left out because they
15619 -- are not relevant for preelaborability.
15621 Visit (Discriminant_Type (Nod));
15623 when N_Generic_Association =>
15625 -- Selector_Name is left out because it is not relevant for
15626 -- preelaborability.
15628 Visit (Explicit_Generic_Actual_Parameter (Nod));
15630 when N_Index_Or_Discriminant_Constraint =>
15631 Visit_List (Constraints (Nod));
15633 when N_Iterator_Specification =>
15635 -- Defining_Identifier is left out because it is not relevant
15636 -- for preelaborability.
15638 Visit (Name (Nod));
15639 Visit (Subtype_Indication (Nod));
15641 when N_Loop_Parameter_Specification =>
15643 -- Defining_Identifier is left out because it is not relevant
15644 -- for preelaborability.
15646 Visit (Discrete_Subtype_Definition (Nod));
15648 when N_Protected_Definition =>
15650 -- End_Label is left out because it is not relevant for
15651 -- preelaborability.
15653 Visit_List (Private_Declarations (Nod));
15654 Visit_List (Visible_Declarations (Nod));
15656 when N_Range_Constraint =>
15657 Visit (Range_Expression (Nod));
15659 when N_Record_Definition
15662 -- End_Label, Discrete_Choices, and Interface_List are left out
15663 -- because they are not relevant for preelaborability.
15665 Visit (Component_List (Nod));
15667 when N_Subtype_Indication =>
15669 -- Subtype_Mark is left out because it is not relevant for
15670 -- preelaborability.
15672 Visit (Constraint (Nod));
15674 when N_Unconstrained_Array_Definition =>
15676 -- Subtype_Marks is left out because it is not relevant for
15677 -- preelaborability.
15679 Visit (Component_Definition (Nod));
15681 when N_Variant_Part =>
15683 -- Name is left out because it is not relevant for
15684 -- preelaborability.
15686 Visit_List (Variants (Nod));
15699 procedure Visit_List (List : List_Id) is
15703 if Present (List) then
15704 Nod := First (List);
15705 while Present (Nod) loop
15716 procedure Visit_Pragma (Prag : Node_Id) is
15718 case Get_Pragma_Id (Prag) is
15720 | Pragma_Assert_And_Cut
15722 | Pragma_Async_Readers
15723 | Pragma_Async_Writers
15724 | Pragma_Attribute_Definition
15726 | Pragma_Constant_After_Elaboration
15728 | Pragma_Deadline_Floor
15729 | Pragma_Dispatching_Domain
15730 | Pragma_Effective_Reads
15731 | Pragma_Effective_Writes
15732 | Pragma_Extensions_Visible
15734 | Pragma_Secondary_Stack_Size
15736 | Pragma_Volatile_Function
15738 Visit_List (Pragma_Argument_Associations (Prag));
15747 -------------------------
15748 -- Visit_Subexpression --
15749 -------------------------
15751 procedure Visit_Subexpression (Expr : Node_Id) is
15752 procedure Visit_Aggregate (Aggr : Node_Id);
15753 pragma Inline (Visit_Aggregate);
15754 -- Semantically inspect aggregate Aggr to determine whether it
15755 -- violates preelaborability.
15757 ---------------------
15758 -- Visit_Aggregate --
15759 ---------------------
15761 procedure Visit_Aggregate (Aggr : Node_Id) is
15763 if not Is_Preelaborable_Aggregate (Aggr) then
15764 raise Non_Preelaborable;
15766 end Visit_Aggregate;
15768 -- Start of processing for Visit_Subexpression
15771 case Nkind (Expr) is
15773 | N_Qualified_Expression
15774 | N_Type_Conversion
15775 | N_Unchecked_Expression
15776 | N_Unchecked_Type_Conversion
15778 -- Subpool_Handle_Name and Subtype_Mark are left out because
15779 -- they are not relevant for preelaborability.
15781 Visit (Expression (Expr));
15784 | N_Extension_Aggregate
15786 Visit_Aggregate (Expr);
15788 when N_Attribute_Reference
15789 | N_Explicit_Dereference
15792 -- Attribute_Name and Expressions are left out because they are
15793 -- not relevant for preelaborability.
15795 Visit (Prefix (Expr));
15797 when N_Case_Expression =>
15799 -- End_Span is left out because it is not relevant for
15800 -- preelaborability.
15802 Visit_List (Alternatives (Expr));
15803 Visit (Expression (Expr));
15805 when N_Delta_Aggregate =>
15806 Visit_Aggregate (Expr);
15807 Visit (Expression (Expr));
15809 when N_Expression_With_Actions =>
15810 Visit_List (Actions (Expr));
15811 Visit (Expression (Expr));
15813 when N_If_Expression =>
15814 Visit_List (Expressions (Expr));
15816 when N_Quantified_Expression =>
15817 Visit (Condition (Expr));
15818 Visit (Iterator_Specification (Expr));
15819 Visit (Loop_Parameter_Specification (Expr));
15822 Visit (High_Bound (Expr));
15823 Visit (Low_Bound (Expr));
15826 Visit (Discrete_Range (Expr));
15827 Visit (Prefix (Expr));
15833 -- The evaluation of an object name is not preelaborable,
15834 -- unless the name is a static expression (checked further
15835 -- below), or statically denotes a discriminant.
15837 if Is_Entity_Name (Expr) then
15838 Object_Name : declare
15839 Id : constant Entity_Id := Entity (Expr);
15842 if Is_Object (Id) then
15843 if Ekind (Id) = E_Discriminant then
15846 elsif Ekind_In (Id, E_Constant, E_In_Parameter)
15847 and then Present (Discriminal_Link (Id))
15852 raise Non_Preelaborable;
15857 -- A non-static expression is not preelaborable
15859 elsif not Is_OK_Static_Expression (Expr) then
15860 raise Non_Preelaborable;
15863 end Visit_Subexpression;
15865 -- Start of processing for Is_Non_Preelaborable_Construct
15870 -- At this point it is known that the construct is preelaborable
15876 -- The elaboration of the construct performs an action which violates
15877 -- preelaborability.
15879 when Non_Preelaborable =>
15881 end Is_Non_Preelaborable_Construct;
15883 ---------------------------------
15884 -- Is_Nontrivial_DIC_Procedure --
15885 ---------------------------------
15887 function Is_Nontrivial_DIC_Procedure (Id : Entity_Id) return Boolean is
15888 Body_Decl : Node_Id;
15892 if Ekind (Id) = E_Procedure and then Is_DIC_Procedure (Id) then
15894 Unit_Declaration_Node
15895 (Corresponding_Body (Unit_Declaration_Node (Id)));
15897 -- The body of the Default_Initial_Condition procedure must contain
15898 -- at least one statement, otherwise the generation of the subprogram
15901 pragma Assert (Present (Handled_Statement_Sequence (Body_Decl)));
15903 -- To qualify as nontrivial, the first statement of the procedure
15904 -- must be a check in the form of an if statement. If the original
15905 -- Default_Initial_Condition expression was folded, then the first
15906 -- statement is not a check.
15908 Stmt := First (Statements (Handled_Statement_Sequence (Body_Decl)));
15911 Nkind (Stmt) = N_If_Statement
15912 and then Nkind (Original_Node (Stmt)) = N_Pragma;
15916 end Is_Nontrivial_DIC_Procedure;
15918 -------------------------
15919 -- Is_Null_Record_Type --
15920 -------------------------
15922 function Is_Null_Record_Type (T : Entity_Id) return Boolean is
15923 Decl : constant Node_Id := Parent (T);
15925 return Nkind (Decl) = N_Full_Type_Declaration
15926 and then Nkind (Type_Definition (Decl)) = N_Record_Definition
15928 (No (Component_List (Type_Definition (Decl)))
15929 or else Null_Present (Component_List (Type_Definition (Decl))));
15930 end Is_Null_Record_Type;
15932 ---------------------
15933 -- Is_Object_Image --
15934 ---------------------
15936 function Is_Object_Image (Prefix : Node_Id) return Boolean is
15938 -- When the type of the prefix is not scalar, then the prefix is not
15939 -- valid in any scenario.
15941 if not Is_Scalar_Type (Etype (Prefix)) then
15945 -- Here we test for the case that the prefix is not a type and assume
15946 -- if it is not then it must be a named value or an object reference.
15947 -- This is because the parser always checks that prefixes of attributes
15950 return not (Is_Entity_Name (Prefix) and then Is_Type (Entity (Prefix)));
15951 end Is_Object_Image;
15953 -------------------------
15954 -- Is_Object_Reference --
15955 -------------------------
15957 function Is_Object_Reference (N : Node_Id) return Boolean is
15958 function Is_Internally_Generated_Renaming (N : Node_Id) return Boolean;
15959 -- Determine whether N is the name of an internally-generated renaming
15961 --------------------------------------
15962 -- Is_Internally_Generated_Renaming --
15963 --------------------------------------
15965 function Is_Internally_Generated_Renaming (N : Node_Id) return Boolean is
15970 while Present (P) loop
15971 if Nkind (P) = N_Object_Renaming_Declaration then
15972 return not Comes_From_Source (P);
15973 elsif Is_List_Member (P) then
15981 end Is_Internally_Generated_Renaming;
15983 -- Start of processing for Is_Object_Reference
15986 if Is_Entity_Name (N) then
15987 return Present (Entity (N)) and then Is_Object (Entity (N));
15991 when N_Indexed_Component
15995 Is_Object_Reference (Prefix (N))
15996 or else Is_Access_Type (Etype (Prefix (N)));
15998 -- In Ada 95, a function call is a constant object; a procedure
16001 -- Note that predefined operators are functions as well, and so
16002 -- are attributes that are (can be renamed as) functions.
16008 return Etype (N) /= Standard_Void_Type;
16010 -- Attributes references 'Loop_Entry, 'Old, and 'Result yield
16011 -- objects, even though they are not functions.
16013 when N_Attribute_Reference =>
16015 Nam_In (Attribute_Name (N), Name_Loop_Entry,
16018 or else Is_Function_Attribute_Name (Attribute_Name (N));
16020 when N_Selected_Component =>
16022 Is_Object_Reference (Selector_Name (N))
16024 (Is_Object_Reference (Prefix (N))
16025 or else Is_Access_Type (Etype (Prefix (N))));
16027 -- An explicit dereference denotes an object, except that a
16028 -- conditional expression gets turned into an explicit dereference
16029 -- in some cases, and conditional expressions are not object
16032 when N_Explicit_Dereference =>
16033 return not Nkind_In (Original_Node (N), N_Case_Expression,
16036 -- A view conversion of a tagged object is an object reference
16038 when N_Type_Conversion =>
16039 return Is_Tagged_Type (Etype (Subtype_Mark (N)))
16040 and then Is_Tagged_Type (Etype (Expression (N)))
16041 and then Is_Object_Reference (Expression (N));
16043 -- An unchecked type conversion is considered to be an object if
16044 -- the operand is an object (this construction arises only as a
16045 -- result of expansion activities).
16047 when N_Unchecked_Type_Conversion =>
16050 -- Allow string literals to act as objects as long as they appear
16051 -- in internally-generated renamings. The expansion of iterators
16052 -- may generate such renamings when the range involves a string
16055 when N_String_Literal =>
16056 return Is_Internally_Generated_Renaming (Parent (N));
16058 -- AI05-0003: In Ada 2012 a qualified expression is a name.
16059 -- This allows disambiguation of function calls and the use
16060 -- of aggregates in more contexts.
16062 when N_Qualified_Expression =>
16063 if Ada_Version < Ada_2012 then
16066 return Is_Object_Reference (Expression (N))
16067 or else Nkind (Expression (N)) = N_Aggregate;
16074 end Is_Object_Reference;
16076 -----------------------------------
16077 -- Is_OK_Variable_For_Out_Formal --
16078 -----------------------------------
16080 function Is_OK_Variable_For_Out_Formal (AV : Node_Id) return Boolean is
16082 Note_Possible_Modification (AV, Sure => True);
16084 -- We must reject parenthesized variable names. Comes_From_Source is
16085 -- checked because there are currently cases where the compiler violates
16086 -- this rule (e.g. passing a task object to its controlled Initialize
16087 -- routine). This should be properly documented in sinfo???
16089 if Paren_Count (AV) > 0 and then Comes_From_Source (AV) then
16092 -- A variable is always allowed
16094 elsif Is_Variable (AV) then
16097 -- Generalized indexing operations are rewritten as explicit
16098 -- dereferences, and it is only during resolution that we can
16099 -- check whether the context requires an access_to_variable type.
16101 elsif Nkind (AV) = N_Explicit_Dereference
16102 and then Ada_Version >= Ada_2012
16103 and then Nkind (Original_Node (AV)) = N_Indexed_Component
16104 and then Present (Etype (Original_Node (AV)))
16105 and then Has_Implicit_Dereference (Etype (Original_Node (AV)))
16107 return not Is_Access_Constant (Etype (Prefix (AV)));
16109 -- Unchecked conversions are allowed only if they come from the
16110 -- generated code, which sometimes uses unchecked conversions for out
16111 -- parameters in cases where code generation is unaffected. We tell
16112 -- source unchecked conversions by seeing if they are rewrites of
16113 -- an original Unchecked_Conversion function call, or of an explicit
16114 -- conversion of a function call or an aggregate (as may happen in the
16115 -- expansion of a packed array aggregate).
16117 elsif Nkind (AV) = N_Unchecked_Type_Conversion then
16118 if Nkind_In (Original_Node (AV), N_Function_Call, N_Aggregate) then
16121 elsif Comes_From_Source (AV)
16122 and then Nkind (Original_Node (Expression (AV))) = N_Function_Call
16126 elsif Nkind (Original_Node (AV)) = N_Type_Conversion then
16127 return Is_OK_Variable_For_Out_Formal (Expression (AV));
16133 -- Normal type conversions are allowed if argument is a variable
16135 elsif Nkind (AV) = N_Type_Conversion then
16136 if Is_Variable (Expression (AV))
16137 and then Paren_Count (Expression (AV)) = 0
16139 Note_Possible_Modification (Expression (AV), Sure => True);
16142 -- We also allow a non-parenthesized expression that raises
16143 -- constraint error if it rewrites what used to be a variable
16145 elsif Raises_Constraint_Error (Expression (AV))
16146 and then Paren_Count (Expression (AV)) = 0
16147 and then Is_Variable (Original_Node (Expression (AV)))
16151 -- Type conversion of something other than a variable
16157 -- If this node is rewritten, then test the original form, if that is
16158 -- OK, then we consider the rewritten node OK (for example, if the
16159 -- original node is a conversion, then Is_Variable will not be true
16160 -- but we still want to allow the conversion if it converts a variable).
16162 elsif Is_Rewrite_Substitution (AV) then
16164 -- In Ada 2012, the explicit dereference may be a rewritten call to a
16165 -- Reference function.
16167 if Ada_Version >= Ada_2012
16168 and then Nkind (Original_Node (AV)) = N_Function_Call
16170 Has_Implicit_Dereference (Etype (Name (Original_Node (AV))))
16173 -- Check that this is not a constant reference.
16175 return not Is_Access_Constant (Etype (Prefix (AV)));
16177 elsif Has_Implicit_Dereference (Etype (Original_Node (AV))) then
16179 not Is_Access_Constant (Etype
16180 (Get_Reference_Discriminant (Etype (Original_Node (AV)))));
16183 return Is_OK_Variable_For_Out_Formal (Original_Node (AV));
16186 -- All other non-variables are rejected
16191 end Is_OK_Variable_For_Out_Formal;
16193 ----------------------------
16194 -- Is_OK_Volatile_Context --
16195 ----------------------------
16197 function Is_OK_Volatile_Context
16198 (Context : Node_Id;
16199 Obj_Ref : Node_Id) return Boolean
16201 function Is_Protected_Operation_Call (Nod : Node_Id) return Boolean;
16202 -- Determine whether an arbitrary node denotes a call to a protected
16203 -- entry, function, or procedure in prefixed form where the prefix is
16206 function Within_Check (Nod : Node_Id) return Boolean;
16207 -- Determine whether an arbitrary node appears in a check node
16209 function Within_Volatile_Function (Id : Entity_Id) return Boolean;
16210 -- Determine whether an arbitrary entity appears in a volatile function
16212 ---------------------------------
16213 -- Is_Protected_Operation_Call --
16214 ---------------------------------
16216 function Is_Protected_Operation_Call (Nod : Node_Id) return Boolean is
16221 -- A call to a protected operations retains its selected component
16222 -- form as opposed to other prefixed calls that are transformed in
16225 if Nkind (Nod) = N_Selected_Component then
16226 Pref := Prefix (Nod);
16227 Subp := Selector_Name (Nod);
16231 and then Present (Etype (Pref))
16232 and then Is_Protected_Type (Etype (Pref))
16233 and then Is_Entity_Name (Subp)
16234 and then Present (Entity (Subp))
16235 and then Ekind_In (Entity (Subp), E_Entry,
16242 end Is_Protected_Operation_Call;
16248 function Within_Check (Nod : Node_Id) return Boolean is
16252 -- Climb the parent chain looking for a check node
16255 while Present (Par) loop
16256 if Nkind (Par) in N_Raise_xxx_Error then
16259 -- Prevent the search from going too far
16261 elsif Is_Body_Or_Package_Declaration (Par) then
16265 Par := Parent (Par);
16271 ------------------------------
16272 -- Within_Volatile_Function --
16273 ------------------------------
16275 function Within_Volatile_Function (Id : Entity_Id) return Boolean is
16276 Func_Id : Entity_Id;
16279 -- Traverse the scope stack looking for a [generic] function
16282 while Present (Func_Id) and then Func_Id /= Standard_Standard loop
16283 if Ekind_In (Func_Id, E_Function, E_Generic_Function) then
16284 return Is_Volatile_Function (Func_Id);
16287 Func_Id := Scope (Func_Id);
16291 end Within_Volatile_Function;
16295 Obj_Id : Entity_Id;
16297 -- Start of processing for Is_OK_Volatile_Context
16300 -- The volatile object appears on either side of an assignment
16302 if Nkind (Context) = N_Assignment_Statement then
16305 -- The volatile object is part of the initialization expression of
16308 elsif Nkind (Context) = N_Object_Declaration
16309 and then Present (Expression (Context))
16310 and then Expression (Context) = Obj_Ref
16312 Obj_Id := Defining_Entity (Context);
16314 -- The volatile object acts as the initialization expression of an
16315 -- extended return statement. This is valid context as long as the
16316 -- function is volatile.
16318 if Is_Return_Object (Obj_Id) then
16319 return Within_Volatile_Function (Obj_Id);
16321 -- Otherwise this is a normal object initialization
16327 -- The volatile object acts as the name of a renaming declaration
16329 elsif Nkind (Context) = N_Object_Renaming_Declaration
16330 and then Name (Context) = Obj_Ref
16334 -- The volatile object appears as an actual parameter in a call to an
16335 -- instance of Unchecked_Conversion whose result is renamed.
16337 elsif Nkind (Context) = N_Function_Call
16338 and then Is_Entity_Name (Name (Context))
16339 and then Is_Unchecked_Conversion_Instance (Entity (Name (Context)))
16340 and then Nkind (Parent (Context)) = N_Object_Renaming_Declaration
16344 -- The volatile object is actually the prefix in a protected entry,
16345 -- function, or procedure call.
16347 elsif Is_Protected_Operation_Call (Context) then
16350 -- The volatile object appears as the expression of a simple return
16351 -- statement that applies to a volatile function.
16353 elsif Nkind (Context) = N_Simple_Return_Statement
16354 and then Expression (Context) = Obj_Ref
16357 Within_Volatile_Function (Return_Statement_Entity (Context));
16359 -- The volatile object appears as the prefix of a name occurring in a
16360 -- non-interfering context.
16362 elsif Nkind_In (Context, N_Attribute_Reference,
16363 N_Explicit_Dereference,
16364 N_Indexed_Component,
16365 N_Selected_Component,
16367 and then Prefix (Context) = Obj_Ref
16368 and then Is_OK_Volatile_Context
16369 (Context => Parent (Context),
16370 Obj_Ref => Context)
16374 -- The volatile object appears as the prefix of attributes Address,
16375 -- Alignment, Component_Size, First, First_Bit, Last, Last_Bit, Length,
16376 -- Position, Size, Storage_Size.
16378 elsif Nkind (Context) = N_Attribute_Reference
16379 and then Prefix (Context) = Obj_Ref
16380 and then Nam_In (Attribute_Name (Context), Name_Address,
16382 Name_Component_Size,
16394 -- The volatile object appears as the expression of a type conversion
16395 -- occurring in a non-interfering context.
16397 elsif Nkind_In (Context, N_Type_Conversion,
16398 N_Unchecked_Type_Conversion)
16399 and then Expression (Context) = Obj_Ref
16400 and then Is_OK_Volatile_Context
16401 (Context => Parent (Context),
16402 Obj_Ref => Context)
16406 -- The volatile object appears as the expression in a delay statement
16408 elsif Nkind (Context) in N_Delay_Statement then
16411 -- Allow references to volatile objects in various checks. This is not a
16412 -- direct SPARK 2014 requirement.
16414 elsif Within_Check (Context) then
16417 -- Assume that references to effectively volatile objects that appear
16418 -- as actual parameters in a subprogram call are always legal. A full
16419 -- legality check is done when the actuals are resolved (see routine
16420 -- Resolve_Actuals).
16422 elsif Within_Subprogram_Call (Context) then
16425 -- Otherwise the context is not suitable for an effectively volatile
16431 end Is_OK_Volatile_Context;
16433 ------------------------------------
16434 -- Is_Package_Contract_Annotation --
16435 ------------------------------------
16437 function Is_Package_Contract_Annotation (Item : Node_Id) return Boolean is
16441 if Nkind (Item) = N_Aspect_Specification then
16442 Nam := Chars (Identifier (Item));
16444 else pragma Assert (Nkind (Item) = N_Pragma);
16445 Nam := Pragma_Name (Item);
16448 return Nam = Name_Abstract_State
16449 or else Nam = Name_Initial_Condition
16450 or else Nam = Name_Initializes
16451 or else Nam = Name_Refined_State;
16452 end Is_Package_Contract_Annotation;
16454 -----------------------------------
16455 -- Is_Partially_Initialized_Type --
16456 -----------------------------------
16458 function Is_Partially_Initialized_Type
16460 Include_Implicit : Boolean := True) return Boolean
16463 if Is_Scalar_Type (Typ) then
16466 elsif Is_Access_Type (Typ) then
16467 return Include_Implicit;
16469 elsif Is_Array_Type (Typ) then
16471 -- If component type is partially initialized, so is array type
16473 if Is_Partially_Initialized_Type
16474 (Component_Type (Typ), Include_Implicit)
16478 -- Otherwise we are only partially initialized if we are fully
16479 -- initialized (this is the empty array case, no point in us
16480 -- duplicating that code here).
16483 return Is_Fully_Initialized_Type (Typ);
16486 elsif Is_Record_Type (Typ) then
16488 -- A discriminated type is always partially initialized if in
16491 if Has_Discriminants (Typ) and then Include_Implicit then
16494 -- A tagged type is always partially initialized
16496 elsif Is_Tagged_Type (Typ) then
16499 -- Case of non-discriminated record
16505 Component_Present : Boolean := False;
16506 -- Set True if at least one component is present. If no
16507 -- components are present, then record type is fully
16508 -- initialized (another odd case, like the null array).
16511 -- Loop through components
16513 Ent := First_Entity (Typ);
16514 while Present (Ent) loop
16515 if Ekind (Ent) = E_Component then
16516 Component_Present := True;
16518 -- If a component has an initialization expression then
16519 -- the enclosing record type is partially initialized
16521 if Present (Parent (Ent))
16522 and then Present (Expression (Parent (Ent)))
16526 -- If a component is of a type which is itself partially
16527 -- initialized, then the enclosing record type is also.
16529 elsif Is_Partially_Initialized_Type
16530 (Etype (Ent), Include_Implicit)
16539 -- No initialized components found. If we found any components
16540 -- they were all uninitialized so the result is false.
16542 if Component_Present then
16545 -- But if we found no components, then all the components are
16546 -- initialized so we consider the type to be initialized.
16554 -- Concurrent types are always fully initialized
16556 elsif Is_Concurrent_Type (Typ) then
16559 -- For a private type, go to underlying type. If there is no underlying
16560 -- type then just assume this partially initialized. Not clear if this
16561 -- can happen in a non-error case, but no harm in testing for this.
16563 elsif Is_Private_Type (Typ) then
16565 U : constant Entity_Id := Underlying_Type (Typ);
16570 return Is_Partially_Initialized_Type (U, Include_Implicit);
16574 -- For any other type (are there any?) assume partially initialized
16579 end Is_Partially_Initialized_Type;
16581 ------------------------------------
16582 -- Is_Potentially_Persistent_Type --
16583 ------------------------------------
16585 function Is_Potentially_Persistent_Type (T : Entity_Id) return Boolean is
16590 -- For private type, test corresponding full type
16592 if Is_Private_Type (T) then
16593 return Is_Potentially_Persistent_Type (Full_View (T));
16595 -- Scalar types are potentially persistent
16597 elsif Is_Scalar_Type (T) then
16600 -- Record type is potentially persistent if not tagged and the types of
16601 -- all it components are potentially persistent, and no component has
16602 -- an initialization expression.
16604 elsif Is_Record_Type (T)
16605 and then not Is_Tagged_Type (T)
16606 and then not Is_Partially_Initialized_Type (T)
16608 Comp := First_Component (T);
16609 while Present (Comp) loop
16610 if not Is_Potentially_Persistent_Type (Etype (Comp)) then
16613 Next_Entity (Comp);
16619 -- Array type is potentially persistent if its component type is
16620 -- potentially persistent and if all its constraints are static.
16622 elsif Is_Array_Type (T) then
16623 if not Is_Potentially_Persistent_Type (Component_Type (T)) then
16627 Indx := First_Index (T);
16628 while Present (Indx) loop
16629 if not Is_OK_Static_Subtype (Etype (Indx)) then
16638 -- All other types are not potentially persistent
16643 end Is_Potentially_Persistent_Type;
16645 --------------------------------
16646 -- Is_Potentially_Unevaluated --
16647 --------------------------------
16649 function Is_Potentially_Unevaluated (N : Node_Id) return Boolean is
16657 -- A postcondition whose expression is a short-circuit is broken down
16658 -- into individual aspects for better exception reporting. The original
16659 -- short-circuit expression is rewritten as the second operand, and an
16660 -- occurrence of 'Old in that operand is potentially unevaluated.
16661 -- See sem_ch13.adb for details of this transformation. The reference
16662 -- to 'Old may appear within an expression, so we must look for the
16663 -- enclosing pragma argument in the tree that contains the reference.
16665 while Present (Par)
16666 and then Nkind (Par) /= N_Pragma_Argument_Association
16668 if Is_Rewrite_Substitution (Par)
16669 and then Nkind (Original_Node (Par)) = N_And_Then
16674 Par := Parent (Par);
16677 -- Other cases; 'Old appears within other expression (not the top-level
16678 -- conjunct in a postcondition) with a potentially unevaluated operand.
16680 Par := Parent (Expr);
16681 while not Nkind_In (Par, N_And_Then,
16687 N_Quantified_Expression)
16690 Par := Parent (Par);
16692 -- If the context is not an expression, or if is the result of
16693 -- expansion of an enclosing construct (such as another attribute)
16694 -- the predicate does not apply.
16696 if Nkind (Par) = N_Case_Expression_Alternative then
16699 elsif Nkind (Par) not in N_Subexpr
16700 or else not Comes_From_Source (Par)
16706 if Nkind (Par) = N_If_Expression then
16707 return Is_Elsif (Par) or else Expr /= First (Expressions (Par));
16709 elsif Nkind (Par) = N_Case_Expression then
16710 return Expr /= Expression (Par);
16712 elsif Nkind_In (Par, N_And_Then, N_Or_Else) then
16713 return Expr = Right_Opnd (Par);
16715 elsif Nkind_In (Par, N_In, N_Not_In) then
16717 -- If the membership includes several alternatives, only the first is
16718 -- definitely evaluated.
16720 if Present (Alternatives (Par)) then
16721 return Expr /= First (Alternatives (Par));
16723 -- If this is a range membership both bounds are evaluated
16729 elsif Nkind (Par) = N_Quantified_Expression then
16730 return Expr = Condition (Par);
16735 end Is_Potentially_Unevaluated;
16737 -----------------------------------------
16738 -- Is_Predefined_Dispatching_Operation --
16739 -----------------------------------------
16741 function Is_Predefined_Dispatching_Operation
16742 (E : Entity_Id) return Boolean
16744 TSS_Name : TSS_Name_Type;
16747 if not Is_Dispatching_Operation (E) then
16751 Get_Name_String (Chars (E));
16753 -- Most predefined primitives have internally generated names. Equality
16754 -- must be treated differently; the predefined operation is recognized
16755 -- as a homogeneous binary operator that returns Boolean.
16757 if Name_Len > TSS_Name_Type'Last then
16760 (Name_Buffer (Name_Len - TSS_Name'Length + 1 .. Name_Len));
16762 if Nam_In (Chars (E), Name_uAssign, Name_uSize)
16764 (Chars (E) = Name_Op_Eq
16765 and then Etype (First_Formal (E)) = Etype (Last_Formal (E)))
16766 or else TSS_Name = TSS_Deep_Adjust
16767 or else TSS_Name = TSS_Deep_Finalize
16768 or else TSS_Name = TSS_Stream_Input
16769 or else TSS_Name = TSS_Stream_Output
16770 or else TSS_Name = TSS_Stream_Read
16771 or else TSS_Name = TSS_Stream_Write
16772 or else Is_Predefined_Interface_Primitive (E)
16779 end Is_Predefined_Dispatching_Operation;
16781 ---------------------------------------
16782 -- Is_Predefined_Interface_Primitive --
16783 ---------------------------------------
16785 function Is_Predefined_Interface_Primitive (E : Entity_Id) return Boolean is
16787 -- In VM targets we don't restrict the functionality of this test to
16788 -- compiling in Ada 2005 mode since in VM targets any tagged type has
16789 -- these primitives.
16791 return (Ada_Version >= Ada_2005 or else not Tagged_Type_Expansion)
16792 and then Nam_In (Chars (E), Name_uDisp_Asynchronous_Select,
16793 Name_uDisp_Conditional_Select,
16794 Name_uDisp_Get_Prim_Op_Kind,
16795 Name_uDisp_Get_Task_Id,
16796 Name_uDisp_Requeue,
16797 Name_uDisp_Timed_Select);
16798 end Is_Predefined_Interface_Primitive;
16800 ---------------------------------------
16801 -- Is_Predefined_Internal_Operation --
16802 ---------------------------------------
16804 function Is_Predefined_Internal_Operation
16805 (E : Entity_Id) return Boolean
16807 TSS_Name : TSS_Name_Type;
16810 if not Is_Dispatching_Operation (E) then
16814 Get_Name_String (Chars (E));
16816 -- Most predefined primitives have internally generated names. Equality
16817 -- must be treated differently; the predefined operation is recognized
16818 -- as a homogeneous binary operator that returns Boolean.
16820 if Name_Len > TSS_Name_Type'Last then
16823 (Name_Buffer (Name_Len - TSS_Name'Length + 1 .. Name_Len));
16825 if Nam_In (Chars (E), Name_uSize, Name_uAssign)
16827 (Chars (E) = Name_Op_Eq
16828 and then Etype (First_Formal (E)) = Etype (Last_Formal (E)))
16829 or else TSS_Name = TSS_Deep_Adjust
16830 or else TSS_Name = TSS_Deep_Finalize
16831 or else Is_Predefined_Interface_Primitive (E)
16838 end Is_Predefined_Internal_Operation;
16840 --------------------------------
16841 -- Is_Preelaborable_Aggregate --
16842 --------------------------------
16844 function Is_Preelaborable_Aggregate (Aggr : Node_Id) return Boolean is
16845 Aggr_Typ : constant Entity_Id := Etype (Aggr);
16846 Array_Aggr : constant Boolean := Is_Array_Type (Aggr_Typ);
16848 Anc_Part : Node_Id;
16851 Comp_Typ : Entity_Id := Empty; -- init to avoid warning
16856 Comp_Typ := Component_Type (Aggr_Typ);
16859 -- Inspect the ancestor part
16861 if Nkind (Aggr) = N_Extension_Aggregate then
16862 Anc_Part := Ancestor_Part (Aggr);
16864 -- The ancestor denotes a subtype mark
16866 if Is_Entity_Name (Anc_Part)
16867 and then Is_Type (Entity (Anc_Part))
16869 if not Has_Preelaborable_Initialization (Entity (Anc_Part)) then
16873 -- Otherwise the ancestor denotes an expression
16875 elsif not Is_Preelaborable_Construct (Anc_Part) then
16880 -- Inspect the positional associations
16882 Expr := First (Expressions (Aggr));
16883 while Present (Expr) loop
16884 if not Is_Preelaborable_Construct (Expr) then
16891 -- Inspect the named associations
16893 Assoc := First (Component_Associations (Aggr));
16894 while Present (Assoc) loop
16896 -- Inspect the choices of the current named association
16898 Choice := First (Choices (Assoc));
16899 while Present (Choice) loop
16902 -- For a choice to be preelaborable, it must denote either a
16903 -- static range or a static expression.
16905 if Nkind (Choice) = N_Others_Choice then
16908 elsif Nkind (Choice) = N_Range then
16909 if not Is_OK_Static_Range (Choice) then
16913 elsif not Is_OK_Static_Expression (Choice) then
16918 Comp_Typ := Etype (Choice);
16924 -- The type of the choice must have preelaborable initialization if
16925 -- the association carries a <>.
16927 pragma Assert (Present (Comp_Typ));
16928 if Box_Present (Assoc) then
16929 if not Has_Preelaborable_Initialization (Comp_Typ) then
16933 -- The type of the expression must have preelaborable initialization
16935 elsif not Is_Preelaborable_Construct (Expression (Assoc)) then
16942 -- At this point the aggregate is preelaborable
16945 end Is_Preelaborable_Aggregate;
16947 --------------------------------
16948 -- Is_Preelaborable_Construct --
16949 --------------------------------
16951 function Is_Preelaborable_Construct (N : Node_Id) return Boolean is
16955 if Nkind_In (N, N_Aggregate, N_Extension_Aggregate) then
16956 return Is_Preelaborable_Aggregate (N);
16958 -- Attributes are allowed in general, even if their prefix is a formal
16959 -- type. It seems that certain attributes known not to be static might
16960 -- not be allowed, but there are no rules to prevent them.
16962 elsif Nkind (N) = N_Attribute_Reference then
16967 elsif Nkind (N) in N_Subexpr and then Is_OK_Static_Expression (N) then
16970 elsif Nkind (N) = N_Qualified_Expression then
16971 return Is_Preelaborable_Construct (Expression (N));
16973 -- Names are preelaborable when they denote a discriminant of an
16974 -- enclosing type. Discriminals are also considered for this check.
16976 elsif Is_Entity_Name (N)
16977 and then Present (Entity (N))
16979 (Ekind (Entity (N)) = E_Discriminant
16980 or else (Ekind_In (Entity (N), E_Constant, E_In_Parameter)
16981 and then Present (Discriminal_Link (Entity (N)))))
16987 elsif Nkind (N) = N_Null then
16990 -- Otherwise the construct is not preelaborable
16995 end Is_Preelaborable_Construct;
16997 ---------------------------------
16998 -- Is_Protected_Self_Reference --
16999 ---------------------------------
17001 function Is_Protected_Self_Reference (N : Node_Id) return Boolean is
17003 function In_Access_Definition (N : Node_Id) return Boolean;
17004 -- Returns true if N belongs to an access definition
17006 --------------------------
17007 -- In_Access_Definition --
17008 --------------------------
17010 function In_Access_Definition (N : Node_Id) return Boolean is
17015 while Present (P) loop
17016 if Nkind (P) = N_Access_Definition then
17024 end In_Access_Definition;
17026 -- Start of processing for Is_Protected_Self_Reference
17029 -- Verify that prefix is analyzed and has the proper form. Note that
17030 -- the attributes Elab_Spec, Elab_Body, and Elab_Subp_Body, which also
17031 -- produce the address of an entity, do not analyze their prefix
17032 -- because they denote entities that are not necessarily visible.
17033 -- Neither of them can apply to a protected type.
17035 return Ada_Version >= Ada_2005
17036 and then Is_Entity_Name (N)
17037 and then Present (Entity (N))
17038 and then Is_Protected_Type (Entity (N))
17039 and then In_Open_Scopes (Entity (N))
17040 and then not In_Access_Definition (N);
17041 end Is_Protected_Self_Reference;
17043 -----------------------------
17044 -- Is_RCI_Pkg_Spec_Or_Body --
17045 -----------------------------
17047 function Is_RCI_Pkg_Spec_Or_Body (Cunit : Node_Id) return Boolean is
17049 function Is_RCI_Pkg_Decl_Cunit (Cunit : Node_Id) return Boolean;
17050 -- Return True if the unit of Cunit is an RCI package declaration
17052 ---------------------------
17053 -- Is_RCI_Pkg_Decl_Cunit --
17054 ---------------------------
17056 function Is_RCI_Pkg_Decl_Cunit (Cunit : Node_Id) return Boolean is
17057 The_Unit : constant Node_Id := Unit (Cunit);
17060 if Nkind (The_Unit) /= N_Package_Declaration then
17064 return Is_Remote_Call_Interface (Defining_Entity (The_Unit));
17065 end Is_RCI_Pkg_Decl_Cunit;
17067 -- Start of processing for Is_RCI_Pkg_Spec_Or_Body
17070 return Is_RCI_Pkg_Decl_Cunit (Cunit)
17072 (Nkind (Unit (Cunit)) = N_Package_Body
17073 and then Is_RCI_Pkg_Decl_Cunit (Library_Unit (Cunit)));
17074 end Is_RCI_Pkg_Spec_Or_Body;
17076 -----------------------------------------
17077 -- Is_Remote_Access_To_Class_Wide_Type --
17078 -----------------------------------------
17080 function Is_Remote_Access_To_Class_Wide_Type
17081 (E : Entity_Id) return Boolean
17084 -- A remote access to class-wide type is a general access to object type
17085 -- declared in the visible part of a Remote_Types or Remote_Call_
17088 return Ekind (E) = E_General_Access_Type
17089 and then (Is_Remote_Call_Interface (E) or else Is_Remote_Types (E));
17090 end Is_Remote_Access_To_Class_Wide_Type;
17092 -----------------------------------------
17093 -- Is_Remote_Access_To_Subprogram_Type --
17094 -----------------------------------------
17096 function Is_Remote_Access_To_Subprogram_Type
17097 (E : Entity_Id) return Boolean
17100 return (Ekind (E) = E_Access_Subprogram_Type
17101 or else (Ekind (E) = E_Record_Type
17102 and then Present (Corresponding_Remote_Type (E))))
17103 and then (Is_Remote_Call_Interface (E) or else Is_Remote_Types (E));
17104 end Is_Remote_Access_To_Subprogram_Type;
17106 --------------------
17107 -- Is_Remote_Call --
17108 --------------------
17110 function Is_Remote_Call (N : Node_Id) return Boolean is
17112 if Nkind (N) not in N_Subprogram_Call then
17114 -- An entry call cannot be remote
17118 elsif Nkind (Name (N)) in N_Has_Entity
17119 and then Is_Remote_Call_Interface (Entity (Name (N)))
17121 -- A subprogram declared in the spec of a RCI package is remote
17125 elsif Nkind (Name (N)) = N_Explicit_Dereference
17126 and then Is_Remote_Access_To_Subprogram_Type
17127 (Etype (Prefix (Name (N))))
17129 -- The dereference of a RAS is a remote call
17133 elsif Present (Controlling_Argument (N))
17134 and then Is_Remote_Access_To_Class_Wide_Type
17135 (Etype (Controlling_Argument (N)))
17137 -- Any primitive operation call with a controlling argument of
17138 -- a RACW type is a remote call.
17143 -- All other calls are local calls
17146 end Is_Remote_Call;
17148 ----------------------
17149 -- Is_Renamed_Entry --
17150 ----------------------
17152 function Is_Renamed_Entry (Proc_Nam : Entity_Id) return Boolean is
17153 Orig_Node : Node_Id := Empty;
17154 Subp_Decl : Node_Id := Parent (Parent (Proc_Nam));
17156 function Is_Entry (Nam : Node_Id) return Boolean;
17157 -- Determine whether Nam is an entry. Traverse selectors if there are
17158 -- nested selected components.
17164 function Is_Entry (Nam : Node_Id) return Boolean is
17166 if Nkind (Nam) = N_Selected_Component then
17167 return Is_Entry (Selector_Name (Nam));
17170 return Ekind (Entity (Nam)) = E_Entry;
17173 -- Start of processing for Is_Renamed_Entry
17176 if Present (Alias (Proc_Nam)) then
17177 Subp_Decl := Parent (Parent (Alias (Proc_Nam)));
17180 -- Look for a rewritten subprogram renaming declaration
17182 if Nkind (Subp_Decl) = N_Subprogram_Declaration
17183 and then Present (Original_Node (Subp_Decl))
17185 Orig_Node := Original_Node (Subp_Decl);
17188 -- The rewritten subprogram is actually an entry
17190 if Present (Orig_Node)
17191 and then Nkind (Orig_Node) = N_Subprogram_Renaming_Declaration
17192 and then Is_Entry (Name (Orig_Node))
17198 end Is_Renamed_Entry;
17200 -----------------------------
17201 -- Is_Renaming_Declaration --
17202 -----------------------------
17204 function Is_Renaming_Declaration (N : Node_Id) return Boolean is
17207 when N_Exception_Renaming_Declaration
17208 | N_Generic_Function_Renaming_Declaration
17209 | N_Generic_Package_Renaming_Declaration
17210 | N_Generic_Procedure_Renaming_Declaration
17211 | N_Object_Renaming_Declaration
17212 | N_Package_Renaming_Declaration
17213 | N_Subprogram_Renaming_Declaration
17220 end Is_Renaming_Declaration;
17222 ----------------------------
17223 -- Is_Reversible_Iterator --
17224 ----------------------------
17226 function Is_Reversible_Iterator (Typ : Entity_Id) return Boolean is
17227 Ifaces_List : Elist_Id;
17228 Iface_Elmt : Elmt_Id;
17232 if Is_Class_Wide_Type (Typ)
17233 and then Chars (Root_Type (Typ)) = Name_Reversible_Iterator
17234 and then In_Predefined_Unit (Root_Type (Typ))
17238 elsif not Is_Tagged_Type (Typ) or else not Is_Derived_Type (Typ) then
17242 Collect_Interfaces (Typ, Ifaces_List);
17244 Iface_Elmt := First_Elmt (Ifaces_List);
17245 while Present (Iface_Elmt) loop
17246 Iface := Node (Iface_Elmt);
17247 if Chars (Iface) = Name_Reversible_Iterator
17248 and then In_Predefined_Unit (Iface)
17253 Next_Elmt (Iface_Elmt);
17258 end Is_Reversible_Iterator;
17260 ----------------------
17261 -- Is_Selector_Name --
17262 ----------------------
17264 function Is_Selector_Name (N : Node_Id) return Boolean is
17266 if not Is_List_Member (N) then
17268 P : constant Node_Id := Parent (N);
17270 return Nkind_In (P, N_Expanded_Name,
17271 N_Generic_Association,
17272 N_Parameter_Association,
17273 N_Selected_Component)
17274 and then Selector_Name (P) = N;
17279 L : constant List_Id := List_Containing (N);
17280 P : constant Node_Id := Parent (L);
17282 return (Nkind (P) = N_Discriminant_Association
17283 and then Selector_Names (P) = L)
17285 (Nkind (P) = N_Component_Association
17286 and then Choices (P) = L);
17289 end Is_Selector_Name;
17291 ---------------------------------
17292 -- Is_Single_Concurrent_Object --
17293 ---------------------------------
17295 function Is_Single_Concurrent_Object (Id : Entity_Id) return Boolean is
17298 Is_Single_Protected_Object (Id) or else Is_Single_Task_Object (Id);
17299 end Is_Single_Concurrent_Object;
17301 -------------------------------
17302 -- Is_Single_Concurrent_Type --
17303 -------------------------------
17305 function Is_Single_Concurrent_Type (Id : Entity_Id) return Boolean is
17308 Ekind_In (Id, E_Protected_Type, E_Task_Type)
17309 and then Is_Single_Concurrent_Type_Declaration
17310 (Declaration_Node (Id));
17311 end Is_Single_Concurrent_Type;
17313 -------------------------------------------
17314 -- Is_Single_Concurrent_Type_Declaration --
17315 -------------------------------------------
17317 function Is_Single_Concurrent_Type_Declaration
17318 (N : Node_Id) return Boolean
17321 return Nkind_In (Original_Node (N), N_Single_Protected_Declaration,
17322 N_Single_Task_Declaration);
17323 end Is_Single_Concurrent_Type_Declaration;
17325 ---------------------------------------------
17326 -- Is_Single_Precision_Floating_Point_Type --
17327 ---------------------------------------------
17329 function Is_Single_Precision_Floating_Point_Type
17330 (E : Entity_Id) return Boolean is
17332 return Is_Floating_Point_Type (E)
17333 and then Machine_Radix_Value (E) = Uint_2
17334 and then Machine_Mantissa_Value (E) = Uint_24
17335 and then Machine_Emax_Value (E) = Uint_2 ** Uint_7
17336 and then Machine_Emin_Value (E) = Uint_3 - (Uint_2 ** Uint_7);
17337 end Is_Single_Precision_Floating_Point_Type;
17339 --------------------------------
17340 -- Is_Single_Protected_Object --
17341 --------------------------------
17343 function Is_Single_Protected_Object (Id : Entity_Id) return Boolean is
17346 Ekind (Id) = E_Variable
17347 and then Ekind (Etype (Id)) = E_Protected_Type
17348 and then Is_Single_Concurrent_Type (Etype (Id));
17349 end Is_Single_Protected_Object;
17351 ---------------------------
17352 -- Is_Single_Task_Object --
17353 ---------------------------
17355 function Is_Single_Task_Object (Id : Entity_Id) return Boolean is
17358 Ekind (Id) = E_Variable
17359 and then Ekind (Etype (Id)) = E_Task_Type
17360 and then Is_Single_Concurrent_Type (Etype (Id));
17361 end Is_Single_Task_Object;
17363 -------------------------------------
17364 -- Is_SPARK_05_Initialization_Expr --
17365 -------------------------------------
17367 function Is_SPARK_05_Initialization_Expr (N : Node_Id) return Boolean is
17370 Comp_Assn : Node_Id;
17371 Orig_N : constant Node_Id := Original_Node (N);
17376 if not Comes_From_Source (Orig_N) then
17380 pragma Assert (Nkind (Orig_N) in N_Subexpr);
17382 case Nkind (Orig_N) is
17383 when N_Character_Literal
17384 | N_Integer_Literal
17390 when N_Expanded_Name
17393 if Is_Entity_Name (Orig_N)
17394 and then Present (Entity (Orig_N)) -- needed in some cases
17396 case Ekind (Entity (Orig_N)) is
17398 | E_Enumeration_Literal
17405 if Is_Type (Entity (Orig_N)) then
17413 when N_Qualified_Expression
17414 | N_Type_Conversion
17416 Is_Ok := Is_SPARK_05_Initialization_Expr (Expression (Orig_N));
17419 Is_Ok := Is_SPARK_05_Initialization_Expr (Right_Opnd (Orig_N));
17422 | N_Membership_Test
17425 Is_Ok := Is_SPARK_05_Initialization_Expr (Left_Opnd (Orig_N))
17427 Is_SPARK_05_Initialization_Expr (Right_Opnd (Orig_N));
17430 | N_Extension_Aggregate
17432 if Nkind (Orig_N) = N_Extension_Aggregate then
17434 Is_SPARK_05_Initialization_Expr (Ancestor_Part (Orig_N));
17437 Expr := First (Expressions (Orig_N));
17438 while Present (Expr) loop
17439 if not Is_SPARK_05_Initialization_Expr (Expr) then
17447 Comp_Assn := First (Component_Associations (Orig_N));
17448 while Present (Comp_Assn) loop
17449 Expr := Expression (Comp_Assn);
17451 -- Note: test for Present here needed for box assocation
17454 and then not Is_SPARK_05_Initialization_Expr (Expr)
17463 when N_Attribute_Reference =>
17464 if Nkind (Prefix (Orig_N)) in N_Subexpr then
17465 Is_Ok := Is_SPARK_05_Initialization_Expr (Prefix (Orig_N));
17468 Expr := First (Expressions (Orig_N));
17469 while Present (Expr) loop
17470 if not Is_SPARK_05_Initialization_Expr (Expr) then
17478 -- Selected components might be expanded named not yet resolved, so
17479 -- default on the safe side. (Eg on sparklex.ads)
17481 when N_Selected_Component =>
17490 end Is_SPARK_05_Initialization_Expr;
17492 ----------------------------------
17493 -- Is_SPARK_05_Object_Reference --
17494 ----------------------------------
17496 function Is_SPARK_05_Object_Reference (N : Node_Id) return Boolean is
17498 if Is_Entity_Name (N) then
17499 return Present (Entity (N))
17501 (Ekind_In (Entity (N), E_Constant, E_Variable)
17502 or else Ekind (Entity (N)) in Formal_Kind);
17506 when N_Selected_Component =>
17507 return Is_SPARK_05_Object_Reference (Prefix (N));
17513 end Is_SPARK_05_Object_Reference;
17515 -----------------------------
17516 -- Is_Specific_Tagged_Type --
17517 -----------------------------
17519 function Is_Specific_Tagged_Type (Typ : Entity_Id) return Boolean is
17520 Full_Typ : Entity_Id;
17523 -- Handle private types
17525 if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then
17526 Full_Typ := Full_View (Typ);
17531 -- A specific tagged type is a non-class-wide tagged type
17533 return Is_Tagged_Type (Full_Typ) and not Is_Class_Wide_Type (Full_Typ);
17534 end Is_Specific_Tagged_Type;
17540 function Is_Statement (N : Node_Id) return Boolean is
17543 Nkind (N) in N_Statement_Other_Than_Procedure_Call
17544 or else Nkind (N) = N_Procedure_Call_Statement;
17547 ---------------------------------------
17548 -- Is_Subprogram_Contract_Annotation --
17549 ---------------------------------------
17551 function Is_Subprogram_Contract_Annotation
17552 (Item : Node_Id) return Boolean
17557 if Nkind (Item) = N_Aspect_Specification then
17558 Nam := Chars (Identifier (Item));
17560 else pragma Assert (Nkind (Item) = N_Pragma);
17561 Nam := Pragma_Name (Item);
17564 return Nam = Name_Contract_Cases
17565 or else Nam = Name_Depends
17566 or else Nam = Name_Extensions_Visible
17567 or else Nam = Name_Global
17568 or else Nam = Name_Post
17569 or else Nam = Name_Post_Class
17570 or else Nam = Name_Postcondition
17571 or else Nam = Name_Pre
17572 or else Nam = Name_Pre_Class
17573 or else Nam = Name_Precondition
17574 or else Nam = Name_Refined_Depends
17575 or else Nam = Name_Refined_Global
17576 or else Nam = Name_Refined_Post
17577 or else Nam = Name_Test_Case;
17578 end Is_Subprogram_Contract_Annotation;
17580 --------------------------------------------------
17581 -- Is_Subprogram_Stub_Without_Prior_Declaration --
17582 --------------------------------------------------
17584 function Is_Subprogram_Stub_Without_Prior_Declaration
17585 (N : Node_Id) return Boolean
17588 pragma Assert (Nkind (N) = N_Subprogram_Body_Stub);
17590 case Ekind (Defining_Entity (N)) is
17592 -- A subprogram stub without prior declaration serves as declaration
17593 -- for the actual subprogram body. As such, it has an attached
17594 -- defining entity of E_Function or E_Procedure.
17601 -- Otherwise, it is completes a [generic] subprogram declaration
17603 when E_Generic_Function
17604 | E_Generic_Procedure
17605 | E_Subprogram_Body
17610 raise Program_Error;
17612 end Is_Subprogram_Stub_Without_Prior_Declaration;
17614 ---------------------------
17615 -- Is_Suitable_Primitive --
17616 ---------------------------
17618 function Is_Suitable_Primitive (Subp_Id : Entity_Id) return Boolean is
17620 -- The Default_Initial_Condition and invariant procedures must not be
17621 -- treated as primitive operations even when they apply to a tagged
17622 -- type. These routines must not act as targets of dispatching calls
17623 -- because they already utilize class-wide-precondition semantics to
17624 -- handle inheritance and overriding.
17626 if Ekind (Subp_Id) = E_Procedure
17627 and then (Is_DIC_Procedure (Subp_Id)
17629 Is_Invariant_Procedure (Subp_Id))
17635 end Is_Suitable_Primitive;
17637 --------------------------
17638 -- Is_Suspension_Object --
17639 --------------------------
17641 function Is_Suspension_Object (Id : Entity_Id) return Boolean is
17643 -- This approach does an exact name match rather than to rely on
17644 -- RTSfind. Routine Is_Effectively_Volatile is used by clients of the
17645 -- front end at point where all auxiliary tables are locked and any
17646 -- modifications to them are treated as violations. Do not tamper with
17647 -- the tables, instead examine the Chars fields of all the scopes of Id.
17650 Chars (Id) = Name_Suspension_Object
17651 and then Present (Scope (Id))
17652 and then Chars (Scope (Id)) = Name_Synchronous_Task_Control
17653 and then Present (Scope (Scope (Id)))
17654 and then Chars (Scope (Scope (Id))) = Name_Ada
17655 and then Present (Scope (Scope (Scope (Id))))
17656 and then Scope (Scope (Scope (Id))) = Standard_Standard;
17657 end Is_Suspension_Object;
17659 ----------------------------
17660 -- Is_Synchronized_Object --
17661 ----------------------------
17663 function Is_Synchronized_Object (Id : Entity_Id) return Boolean is
17667 if Is_Object (Id) then
17669 -- The object is synchronized if it is of a type that yields a
17670 -- synchronized object.
17672 if Yields_Synchronized_Object (Etype (Id)) then
17675 -- The object is synchronized if it is atomic and Async_Writers is
17678 elsif Is_Atomic_Object_Entity (Id)
17679 and then Async_Writers_Enabled (Id)
17683 -- A constant is a synchronized object by default
17685 elsif Ekind (Id) = E_Constant then
17688 -- A variable is a synchronized object if it is subject to pragma
17689 -- Constant_After_Elaboration.
17691 elsif Ekind (Id) = E_Variable then
17692 Prag := Get_Pragma (Id, Pragma_Constant_After_Elaboration);
17694 return Present (Prag) and then Is_Enabled_Pragma (Prag);
17698 -- Otherwise the input is not an object or it does not qualify as a
17699 -- synchronized object.
17702 end Is_Synchronized_Object;
17704 ---------------------------------
17705 -- Is_Synchronized_Tagged_Type --
17706 ---------------------------------
17708 function Is_Synchronized_Tagged_Type (E : Entity_Id) return Boolean is
17709 Kind : constant Entity_Kind := Ekind (Base_Type (E));
17712 -- A task or protected type derived from an interface is a tagged type.
17713 -- Such a tagged type is called a synchronized tagged type, as are
17714 -- synchronized interfaces and private extensions whose declaration
17715 -- includes the reserved word synchronized.
17717 return (Is_Tagged_Type (E)
17718 and then (Kind = E_Task_Type
17720 Kind = E_Protected_Type))
17723 and then Is_Synchronized_Interface (E))
17725 (Ekind (E) = E_Record_Type_With_Private
17726 and then Nkind (Parent (E)) = N_Private_Extension_Declaration
17727 and then (Synchronized_Present (Parent (E))
17728 or else Is_Synchronized_Interface (Etype (E))));
17729 end Is_Synchronized_Tagged_Type;
17735 function Is_Transfer (N : Node_Id) return Boolean is
17736 Kind : constant Node_Kind := Nkind (N);
17739 if Kind = N_Simple_Return_Statement
17741 Kind = N_Extended_Return_Statement
17743 Kind = N_Goto_Statement
17745 Kind = N_Raise_Statement
17747 Kind = N_Requeue_Statement
17751 elsif (Kind = N_Exit_Statement or else Kind in N_Raise_xxx_Error)
17752 and then No (Condition (N))
17756 elsif Kind = N_Procedure_Call_Statement
17757 and then Is_Entity_Name (Name (N))
17758 and then Present (Entity (Name (N)))
17759 and then No_Return (Entity (Name (N)))
17763 elsif Nkind (Original_Node (N)) = N_Raise_Statement then
17775 function Is_True (U : Uint) return Boolean is
17780 --------------------------------------
17781 -- Is_Unchecked_Conversion_Instance --
17782 --------------------------------------
17784 function Is_Unchecked_Conversion_Instance (Id : Entity_Id) return Boolean is
17788 -- Look for a function whose generic parent is the predefined intrinsic
17789 -- function Unchecked_Conversion, or for one that renames such an
17792 if Ekind (Id) = E_Function then
17793 Par := Parent (Id);
17795 if Nkind (Par) = N_Function_Specification then
17796 Par := Generic_Parent (Par);
17798 if Present (Par) then
17800 Chars (Par) = Name_Unchecked_Conversion
17801 and then Is_Intrinsic_Subprogram (Par)
17802 and then In_Predefined_Unit (Par);
17805 Present (Alias (Id))
17806 and then Is_Unchecked_Conversion_Instance (Alias (Id));
17812 end Is_Unchecked_Conversion_Instance;
17814 -------------------------------
17815 -- Is_Universal_Numeric_Type --
17816 -------------------------------
17818 function Is_Universal_Numeric_Type (T : Entity_Id) return Boolean is
17820 return T = Universal_Integer or else T = Universal_Real;
17821 end Is_Universal_Numeric_Type;
17823 ------------------------------
17824 -- Is_User_Defined_Equality --
17825 ------------------------------
17827 function Is_User_Defined_Equality (Id : Entity_Id) return Boolean is
17829 return Ekind (Id) = E_Function
17830 and then Chars (Id) = Name_Op_Eq
17831 and then Comes_From_Source (Id)
17833 -- Internally generated equalities have a full type declaration
17834 -- as their parent.
17836 and then Nkind (Parent (Id)) = N_Function_Specification;
17837 end Is_User_Defined_Equality;
17839 --------------------------------------
17840 -- Is_Validation_Variable_Reference --
17841 --------------------------------------
17843 function Is_Validation_Variable_Reference (N : Node_Id) return Boolean is
17844 Var : constant Node_Id := Unqual_Conv (N);
17845 Var_Id : Entity_Id;
17850 if Is_Entity_Name (Var) then
17851 Var_Id := Entity (Var);
17856 and then Ekind (Var_Id) = E_Variable
17857 and then Present (Validated_Object (Var_Id));
17858 end Is_Validation_Variable_Reference;
17860 ----------------------------
17861 -- Is_Variable_Size_Array --
17862 ----------------------------
17864 function Is_Variable_Size_Array (E : Entity_Id) return Boolean is
17868 pragma Assert (Is_Array_Type (E));
17870 -- Check if some index is initialized with a non-constant value
17872 Idx := First_Index (E);
17873 while Present (Idx) loop
17874 if Nkind (Idx) = N_Range then
17875 if not Is_Constant_Bound (Low_Bound (Idx))
17876 or else not Is_Constant_Bound (High_Bound (Idx))
17882 Idx := Next_Index (Idx);
17886 end Is_Variable_Size_Array;
17888 -----------------------------
17889 -- Is_Variable_Size_Record --
17890 -----------------------------
17892 function Is_Variable_Size_Record (E : Entity_Id) return Boolean is
17894 Comp_Typ : Entity_Id;
17897 pragma Assert (Is_Record_Type (E));
17899 Comp := First_Component (E);
17900 while Present (Comp) loop
17901 Comp_Typ := Underlying_Type (Etype (Comp));
17903 -- Recursive call if the record type has discriminants
17905 if Is_Record_Type (Comp_Typ)
17906 and then Has_Discriminants (Comp_Typ)
17907 and then Is_Variable_Size_Record (Comp_Typ)
17911 elsif Is_Array_Type (Comp_Typ)
17912 and then Is_Variable_Size_Array (Comp_Typ)
17917 Next_Component (Comp);
17921 end Is_Variable_Size_Record;
17927 function Is_Variable
17929 Use_Original_Node : Boolean := True) return Boolean
17931 Orig_Node : Node_Id;
17933 function In_Protected_Function (E : Entity_Id) return Boolean;
17934 -- Within a protected function, the private components of the enclosing
17935 -- protected type are constants. A function nested within a (protected)
17936 -- procedure is not itself protected. Within the body of a protected
17937 -- function the current instance of the protected type is a constant.
17939 function Is_Variable_Prefix (P : Node_Id) return Boolean;
17940 -- Prefixes can involve implicit dereferences, in which case we must
17941 -- test for the case of a reference of a constant access type, which can
17942 -- can never be a variable.
17944 ---------------------------
17945 -- In_Protected_Function --
17946 ---------------------------
17948 function In_Protected_Function (E : Entity_Id) return Boolean is
17953 -- E is the current instance of a type
17955 if Is_Type (E) then
17964 if not Is_Protected_Type (Prot) then
17968 S := Current_Scope;
17969 while Present (S) and then S /= Prot loop
17970 if Ekind (S) = E_Function and then Scope (S) = Prot then
17979 end In_Protected_Function;
17981 ------------------------
17982 -- Is_Variable_Prefix --
17983 ------------------------
17985 function Is_Variable_Prefix (P : Node_Id) return Boolean is
17987 if Is_Access_Type (Etype (P)) then
17988 return not Is_Access_Constant (Root_Type (Etype (P)));
17990 -- For the case of an indexed component whose prefix has a packed
17991 -- array type, the prefix has been rewritten into a type conversion.
17992 -- Determine variable-ness from the converted expression.
17994 elsif Nkind (P) = N_Type_Conversion
17995 and then not Comes_From_Source (P)
17996 and then Is_Array_Type (Etype (P))
17997 and then Is_Packed (Etype (P))
17999 return Is_Variable (Expression (P));
18002 return Is_Variable (P);
18004 end Is_Variable_Prefix;
18006 -- Start of processing for Is_Variable
18009 -- Special check, allow x'Deref(expr) as a variable
18011 if Nkind (N) = N_Attribute_Reference
18012 and then Attribute_Name (N) = Name_Deref
18017 -- Check if we perform the test on the original node since this may be a
18018 -- test of syntactic categories which must not be disturbed by whatever
18019 -- rewriting might have occurred. For example, an aggregate, which is
18020 -- certainly NOT a variable, could be turned into a variable by
18023 if Use_Original_Node then
18024 Orig_Node := Original_Node (N);
18029 -- Definitely OK if Assignment_OK is set. Since this is something that
18030 -- only gets set for expanded nodes, the test is on N, not Orig_Node.
18032 if Nkind (N) in N_Subexpr and then Assignment_OK (N) then
18035 -- Normally we go to the original node, but there is one exception where
18036 -- we use the rewritten node, namely when it is an explicit dereference.
18037 -- The generated code may rewrite a prefix which is an access type with
18038 -- an explicit dereference. The dereference is a variable, even though
18039 -- the original node may not be (since it could be a constant of the
18042 -- In Ada 2005 we have a further case to consider: the prefix may be a
18043 -- function call given in prefix notation. The original node appears to
18044 -- be a selected component, but we need to examine the call.
18046 elsif Nkind (N) = N_Explicit_Dereference
18047 and then Nkind (Orig_Node) /= N_Explicit_Dereference
18048 and then Present (Etype (Orig_Node))
18049 and then Is_Access_Type (Etype (Orig_Node))
18051 -- Note that if the prefix is an explicit dereference that does not
18052 -- come from source, we must check for a rewritten function call in
18053 -- prefixed notation before other forms of rewriting, to prevent a
18057 (Nkind (Orig_Node) = N_Function_Call
18058 and then not Is_Access_Constant (Etype (Prefix (N))))
18060 Is_Variable_Prefix (Original_Node (Prefix (N)));
18062 -- in Ada 2012, the dereference may have been added for a type with
18063 -- a declared implicit dereference aspect. Check that it is not an
18064 -- access to constant.
18066 elsif Nkind (N) = N_Explicit_Dereference
18067 and then Present (Etype (Orig_Node))
18068 and then Ada_Version >= Ada_2012
18069 and then Has_Implicit_Dereference (Etype (Orig_Node))
18071 return not Is_Access_Constant (Etype (Prefix (N)));
18073 -- A function call is never a variable
18075 elsif Nkind (N) = N_Function_Call then
18078 -- All remaining checks use the original node
18080 elsif Is_Entity_Name (Orig_Node)
18081 and then Present (Entity (Orig_Node))
18084 E : constant Entity_Id := Entity (Orig_Node);
18085 K : constant Entity_Kind := Ekind (E);
18088 if Is_Loop_Parameter (E) then
18092 return (K = E_Variable
18093 and then Nkind (Parent (E)) /= N_Exception_Handler)
18094 or else (K = E_Component
18095 and then not In_Protected_Function (E))
18096 or else K = E_Out_Parameter
18097 or else K = E_In_Out_Parameter
18098 or else K = E_Generic_In_Out_Parameter
18100 -- Current instance of type. If this is a protected type, check
18101 -- we are not within the body of one of its protected functions.
18103 or else (Is_Type (E)
18104 and then In_Open_Scopes (E)
18105 and then not In_Protected_Function (E))
18107 or else (Is_Incomplete_Or_Private_Type (E)
18108 and then In_Open_Scopes (Full_View (E)));
18112 case Nkind (Orig_Node) is
18113 when N_Indexed_Component
18116 return Is_Variable_Prefix (Prefix (Orig_Node));
18118 when N_Selected_Component =>
18119 return (Is_Variable (Selector_Name (Orig_Node))
18120 and then Is_Variable_Prefix (Prefix (Orig_Node)))
18122 (Nkind (N) = N_Expanded_Name
18123 and then Scope (Entity (N)) = Entity (Prefix (N)));
18125 -- For an explicit dereference, the type of the prefix cannot
18126 -- be an access to constant or an access to subprogram.
18128 when N_Explicit_Dereference =>
18130 Typ : constant Entity_Id := Etype (Prefix (Orig_Node));
18132 return Is_Access_Type (Typ)
18133 and then not Is_Access_Constant (Root_Type (Typ))
18134 and then Ekind (Typ) /= E_Access_Subprogram_Type;
18137 -- The type conversion is the case where we do not deal with the
18138 -- context dependent special case of an actual parameter. Thus
18139 -- the type conversion is only considered a variable for the
18140 -- purposes of this routine if the target type is tagged. However,
18141 -- a type conversion is considered to be a variable if it does not
18142 -- come from source (this deals for example with the conversions
18143 -- of expressions to their actual subtypes).
18145 when N_Type_Conversion =>
18146 return Is_Variable (Expression (Orig_Node))
18148 (not Comes_From_Source (Orig_Node)
18150 (Is_Tagged_Type (Etype (Subtype_Mark (Orig_Node)))
18152 Is_Tagged_Type (Etype (Expression (Orig_Node)))));
18154 -- GNAT allows an unchecked type conversion as a variable. This
18155 -- only affects the generation of internal expanded code, since
18156 -- calls to instantiations of Unchecked_Conversion are never
18157 -- considered variables (since they are function calls).
18159 when N_Unchecked_Type_Conversion =>
18160 return Is_Variable (Expression (Orig_Node));
18168 ---------------------------
18169 -- Is_Visibly_Controlled --
18170 ---------------------------
18172 function Is_Visibly_Controlled (T : Entity_Id) return Boolean is
18173 Root : constant Entity_Id := Root_Type (T);
18175 return Chars (Scope (Root)) = Name_Finalization
18176 and then Chars (Scope (Scope (Root))) = Name_Ada
18177 and then Scope (Scope (Scope (Root))) = Standard_Standard;
18178 end Is_Visibly_Controlled;
18180 --------------------------
18181 -- Is_Volatile_Function --
18182 --------------------------
18184 function Is_Volatile_Function (Func_Id : Entity_Id) return Boolean is
18186 pragma Assert (Ekind_In (Func_Id, E_Function, E_Generic_Function));
18188 -- A function declared within a protected type is volatile
18190 if Is_Protected_Type (Scope (Func_Id)) then
18193 -- An instance of Ada.Unchecked_Conversion is a volatile function if
18194 -- either the source or the target are effectively volatile.
18196 elsif Is_Unchecked_Conversion_Instance (Func_Id)
18197 and then Has_Effectively_Volatile_Profile (Func_Id)
18201 -- Otherwise the function is treated as volatile if it is subject to
18202 -- enabled pragma Volatile_Function.
18206 Is_Enabled_Pragma (Get_Pragma (Func_Id, Pragma_Volatile_Function));
18208 end Is_Volatile_Function;
18210 ------------------------
18211 -- Is_Volatile_Object --
18212 ------------------------
18214 function Is_Volatile_Object (N : Node_Id) return Boolean is
18215 function Is_Volatile_Prefix (N : Node_Id) return Boolean;
18216 -- If prefix is an implicit dereference, examine designated type
18218 function Object_Has_Volatile_Components (N : Node_Id) return Boolean;
18219 -- Determines if given object has volatile components
18221 ------------------------
18222 -- Is_Volatile_Prefix --
18223 ------------------------
18225 function Is_Volatile_Prefix (N : Node_Id) return Boolean is
18226 Typ : constant Entity_Id := Etype (N);
18229 if Is_Access_Type (Typ) then
18231 Dtyp : constant Entity_Id := Designated_Type (Typ);
18234 return Is_Volatile (Dtyp)
18235 or else Has_Volatile_Components (Dtyp);
18239 return Object_Has_Volatile_Components (N);
18241 end Is_Volatile_Prefix;
18243 ------------------------------------
18244 -- Object_Has_Volatile_Components --
18245 ------------------------------------
18247 function Object_Has_Volatile_Components (N : Node_Id) return Boolean is
18248 Typ : constant Entity_Id := Etype (N);
18251 if Is_Volatile (Typ)
18252 or else Has_Volatile_Components (Typ)
18256 elsif Is_Entity_Name (N)
18257 and then (Has_Volatile_Components (Entity (N))
18258 or else Is_Volatile (Entity (N)))
18262 elsif Nkind (N) = N_Indexed_Component
18263 or else Nkind (N) = N_Selected_Component
18265 return Is_Volatile_Prefix (Prefix (N));
18270 end Object_Has_Volatile_Components;
18272 -- Start of processing for Is_Volatile_Object
18275 if Nkind (N) = N_Defining_Identifier then
18276 return Is_Volatile (N) or else Is_Volatile (Etype (N));
18278 elsif Nkind (N) = N_Expanded_Name then
18279 return Is_Volatile_Object (Entity (N));
18281 elsif Is_Volatile (Etype (N))
18282 or else (Is_Entity_Name (N) and then Is_Volatile (Entity (N)))
18286 elsif Nkind_In (N, N_Indexed_Component, N_Selected_Component)
18287 and then Is_Volatile_Prefix (Prefix (N))
18291 elsif Nkind (N) = N_Selected_Component
18292 and then Is_Volatile (Entity (Selector_Name (N)))
18299 end Is_Volatile_Object;
18301 -----------------------------
18302 -- Iterate_Call_Parameters --
18303 -----------------------------
18305 procedure Iterate_Call_Parameters (Call : Node_Id) is
18306 Actual : Node_Id := First_Actual (Call);
18307 Formal : Entity_Id := First_Formal (Get_Called_Entity (Call));
18310 while Present (Formal) and then Present (Actual) loop
18311 Handle_Parameter (Formal, Actual);
18313 Next_Formal (Formal);
18314 Next_Actual (Actual);
18317 pragma Assert (No (Formal));
18318 pragma Assert (No (Actual));
18319 end Iterate_Call_Parameters;
18321 ---------------------------
18322 -- Itype_Has_Declaration --
18323 ---------------------------
18325 function Itype_Has_Declaration (Id : Entity_Id) return Boolean is
18327 pragma Assert (Is_Itype (Id));
18328 return Present (Parent (Id))
18329 and then Nkind_In (Parent (Id), N_Full_Type_Declaration,
18330 N_Subtype_Declaration)
18331 and then Defining_Entity (Parent (Id)) = Id;
18332 end Itype_Has_Declaration;
18334 -------------------------
18335 -- Kill_Current_Values --
18336 -------------------------
18338 procedure Kill_Current_Values
18340 Last_Assignment_Only : Boolean := False)
18343 if Is_Assignable (Ent) then
18344 Set_Last_Assignment (Ent, Empty);
18347 if Is_Object (Ent) then
18348 if not Last_Assignment_Only then
18350 Set_Current_Value (Ent, Empty);
18352 -- Do not reset the Is_Known_[Non_]Null and Is_Known_Valid flags
18353 -- for a constant. Once the constant is elaborated, its value is
18354 -- not changed, therefore the associated flags that describe the
18355 -- value should not be modified either.
18357 if Ekind (Ent) = E_Constant then
18360 -- Non-constant entities
18363 if not Can_Never_Be_Null (Ent) then
18364 Set_Is_Known_Non_Null (Ent, False);
18367 Set_Is_Known_Null (Ent, False);
18369 -- Reset the Is_Known_Valid flag unless the type is always
18370 -- valid. This does not apply to a loop parameter because its
18371 -- bounds are defined by the loop header and therefore always
18374 if not Is_Known_Valid (Etype (Ent))
18375 and then Ekind (Ent) /= E_Loop_Parameter
18377 Set_Is_Known_Valid (Ent, False);
18382 end Kill_Current_Values;
18384 procedure Kill_Current_Values (Last_Assignment_Only : Boolean := False) is
18387 procedure Kill_Current_Values_For_Entity_Chain (E : Entity_Id);
18388 -- Clear current value for entity E and all entities chained to E
18390 ------------------------------------------
18391 -- Kill_Current_Values_For_Entity_Chain --
18392 ------------------------------------------
18394 procedure Kill_Current_Values_For_Entity_Chain (E : Entity_Id) is
18398 while Present (Ent) loop
18399 Kill_Current_Values (Ent, Last_Assignment_Only);
18402 end Kill_Current_Values_For_Entity_Chain;
18404 -- Start of processing for Kill_Current_Values
18407 -- Kill all saved checks, a special case of killing saved values
18409 if not Last_Assignment_Only then
18413 -- Loop through relevant scopes, which includes the current scope and
18414 -- any parent scopes if the current scope is a block or a package.
18416 S := Current_Scope;
18419 -- Clear current values of all entities in current scope
18421 Kill_Current_Values_For_Entity_Chain (First_Entity (S));
18423 -- If scope is a package, also clear current values of all private
18424 -- entities in the scope.
18426 if Is_Package_Or_Generic_Package (S)
18427 or else Is_Concurrent_Type (S)
18429 Kill_Current_Values_For_Entity_Chain (First_Private_Entity (S));
18432 -- If this is a not a subprogram, deal with parents
18434 if not Is_Subprogram (S) then
18436 exit Scope_Loop when S = Standard_Standard;
18440 end loop Scope_Loop;
18441 end Kill_Current_Values;
18443 --------------------------
18444 -- Kill_Size_Check_Code --
18445 --------------------------
18447 procedure Kill_Size_Check_Code (E : Entity_Id) is
18449 if (Ekind (E) = E_Constant or else Ekind (E) = E_Variable)
18450 and then Present (Size_Check_Code (E))
18452 Remove (Size_Check_Code (E));
18453 Set_Size_Check_Code (E, Empty);
18455 end Kill_Size_Check_Code;
18457 --------------------
18458 -- Known_Non_Null --
18459 --------------------
18461 function Known_Non_Null (N : Node_Id) return Boolean is
18462 Status : constant Null_Status_Kind := Null_Status (N);
18469 -- The expression yields a non-null value ignoring simple flow analysis
18471 if Status = Is_Non_Null then
18474 -- Otherwise check whether N is a reference to an entity that appears
18475 -- within a conditional construct.
18477 elsif Is_Entity_Name (N) and then Present (Entity (N)) then
18479 -- First check if we are in decisive conditional
18481 Get_Current_Value_Condition (N, Op, Val);
18483 if Known_Null (Val) then
18484 if Op = N_Op_Eq then
18486 elsif Op = N_Op_Ne then
18491 -- If OK to do replacement, test Is_Known_Non_Null flag
18495 if OK_To_Do_Constant_Replacement (Id) then
18496 return Is_Known_Non_Null (Id);
18500 -- Otherwise it is not possible to determine whether N yields a non-null
18504 end Known_Non_Null;
18510 function Known_Null (N : Node_Id) return Boolean is
18511 Status : constant Null_Status_Kind := Null_Status (N);
18518 -- The expression yields a null value ignoring simple flow analysis
18520 if Status = Is_Null then
18523 -- Otherwise check whether N is a reference to an entity that appears
18524 -- within a conditional construct.
18526 elsif Is_Entity_Name (N) and then Present (Entity (N)) then
18528 -- First check if we are in decisive conditional
18530 Get_Current_Value_Condition (N, Op, Val);
18532 if Known_Null (Val) then
18533 if Op = N_Op_Eq then
18535 elsif Op = N_Op_Ne then
18540 -- If OK to do replacement, test Is_Known_Null flag
18544 if OK_To_Do_Constant_Replacement (Id) then
18545 return Is_Known_Null (Id);
18549 -- Otherwise it is not possible to determine whether N yields a null
18555 --------------------------
18556 -- Known_To_Be_Assigned --
18557 --------------------------
18559 function Known_To_Be_Assigned (N : Node_Id) return Boolean is
18560 P : constant Node_Id := Parent (N);
18565 -- Test left side of assignment
18567 when N_Assignment_Statement =>
18568 return N = Name (P);
18570 -- Function call arguments are never lvalues
18572 when N_Function_Call =>
18575 -- Positional parameter for procedure or accept call
18577 when N_Accept_Statement
18578 | N_Procedure_Call_Statement
18586 Proc := Get_Subprogram_Entity (P);
18592 -- If we are not a list member, something is strange, so
18593 -- be conservative and return False.
18595 if not Is_List_Member (N) then
18599 -- We are going to find the right formal by stepping forward
18600 -- through the formals, as we step backwards in the actuals.
18602 Form := First_Formal (Proc);
18605 -- If no formal, something is weird, so be conservative
18606 -- and return False.
18613 exit when No (Act);
18614 Next_Formal (Form);
18617 return Ekind (Form) /= E_In_Parameter;
18620 -- Named parameter for procedure or accept call
18622 when N_Parameter_Association =>
18628 Proc := Get_Subprogram_Entity (Parent (P));
18634 -- Loop through formals to find the one that matches
18636 Form := First_Formal (Proc);
18638 -- If no matching formal, that's peculiar, some kind of
18639 -- previous error, so return False to be conservative.
18640 -- Actually this also happens in legal code in the case
18641 -- where P is a parameter association for an Extra_Formal???
18647 -- Else test for match
18649 if Chars (Form) = Chars (Selector_Name (P)) then
18650 return Ekind (Form) /= E_In_Parameter;
18653 Next_Formal (Form);
18657 -- Test for appearing in a conversion that itself appears
18658 -- in an lvalue context, since this should be an lvalue.
18660 when N_Type_Conversion =>
18661 return Known_To_Be_Assigned (P);
18663 -- All other references are definitely not known to be modifications
18668 end Known_To_Be_Assigned;
18670 ---------------------------
18671 -- Last_Source_Statement --
18672 ---------------------------
18674 function Last_Source_Statement (HSS : Node_Id) return Node_Id is
18678 N := Last (Statements (HSS));
18679 while Present (N) loop
18680 exit when Comes_From_Source (N);
18685 end Last_Source_Statement;
18687 -----------------------
18688 -- Mark_Coextensions --
18689 -----------------------
18691 procedure Mark_Coextensions (Context_Nod : Node_Id; Root_Nod : Node_Id) is
18692 Is_Dynamic : Boolean;
18693 -- Indicates whether the context causes nested coextensions to be
18694 -- dynamic or static
18696 function Mark_Allocator (N : Node_Id) return Traverse_Result;
18697 -- Recognize an allocator node and label it as a dynamic coextension
18699 --------------------
18700 -- Mark_Allocator --
18701 --------------------
18703 function Mark_Allocator (N : Node_Id) return Traverse_Result is
18705 if Nkind (N) = N_Allocator then
18707 Set_Is_Static_Coextension (N, False);
18708 Set_Is_Dynamic_Coextension (N);
18710 -- If the allocator expression is potentially dynamic, it may
18711 -- be expanded out of order and require dynamic allocation
18712 -- anyway, so we treat the coextension itself as dynamic.
18713 -- Potential optimization ???
18715 elsif Nkind (Expression (N)) = N_Qualified_Expression
18716 and then Nkind (Expression (Expression (N))) = N_Op_Concat
18718 Set_Is_Static_Coextension (N, False);
18719 Set_Is_Dynamic_Coextension (N);
18721 Set_Is_Dynamic_Coextension (N, False);
18722 Set_Is_Static_Coextension (N);
18727 end Mark_Allocator;
18729 procedure Mark_Allocators is new Traverse_Proc (Mark_Allocator);
18731 -- Start of processing for Mark_Coextensions
18734 -- An allocator that appears on the right-hand side of an assignment is
18735 -- treated as a potentially dynamic coextension when the right-hand side
18736 -- is an allocator or a qualified expression.
18738 -- Obj := new ...'(new Coextension ...);
18740 if Nkind (Context_Nod) = N_Assignment_Statement then
18742 Nkind_In (Expression (Context_Nod), N_Allocator,
18743 N_Qualified_Expression);
18745 -- An allocator that appears within the expression of a simple return
18746 -- statement is treated as a potentially dynamic coextension when the
18747 -- expression is either aggregate, allocator, or qualified expression.
18749 -- return (new Coextension ...);
18750 -- return new ...'(new Coextension ...);
18752 elsif Nkind (Context_Nod) = N_Simple_Return_Statement then
18754 Nkind_In (Expression (Context_Nod), N_Aggregate,
18756 N_Qualified_Expression);
18758 -- An alloctor that appears within the initialization expression of an
18759 -- object declaration is considered a potentially dynamic coextension
18760 -- when the initialization expression is an allocator or a qualified
18763 -- Obj : ... := new ...'(new Coextension ...);
18765 -- A similar case arises when the object declaration is part of an
18766 -- extended return statement.
18768 -- return Obj : ... := new ...'(new Coextension ...);
18769 -- return Obj : ... := (new Coextension ...);
18771 elsif Nkind (Context_Nod) = N_Object_Declaration then
18773 Nkind_In (Root_Nod, N_Allocator, N_Qualified_Expression)
18775 Nkind (Parent (Context_Nod)) = N_Extended_Return_Statement;
18777 -- This routine should not be called with constructs that cannot contain
18781 raise Program_Error;
18784 Mark_Allocators (Root_Nod);
18785 end Mark_Coextensions;
18787 ---------------------------------
18788 -- Mark_Elaboration_Attributes --
18789 ---------------------------------
18791 procedure Mark_Elaboration_Attributes
18792 (N_Id : Node_Or_Entity_Id;
18793 Checks : Boolean := False;
18794 Level : Boolean := False;
18795 Modes : Boolean := False;
18796 Warnings : Boolean := False)
18798 function Elaboration_Checks_OK
18799 (Target_Id : Entity_Id;
18800 Context_Id : Entity_Id) return Boolean;
18801 -- Determine whether elaboration checks are enabled for target Target_Id
18802 -- which resides within context Context_Id.
18804 procedure Mark_Elaboration_Attributes_Id (Id : Entity_Id);
18805 -- Preserve relevant attributes of the context in arbitrary entity Id
18807 procedure Mark_Elaboration_Attributes_Node (N : Node_Id);
18808 -- Preserve relevant attributes of the context in arbitrary node N
18810 ---------------------------
18811 -- Elaboration_Checks_OK --
18812 ---------------------------
18814 function Elaboration_Checks_OK
18815 (Target_Id : Entity_Id;
18816 Context_Id : Entity_Id) return Boolean
18818 Encl_Scop : Entity_Id;
18821 -- Elaboration checks are suppressed for the target
18823 if Elaboration_Checks_Suppressed (Target_Id) then
18827 -- Otherwise elaboration checks are OK for the target, but may be
18828 -- suppressed for the context where the target is declared.
18830 Encl_Scop := Context_Id;
18831 while Present (Encl_Scop) and then Encl_Scop /= Standard_Standard loop
18832 if Elaboration_Checks_Suppressed (Encl_Scop) then
18836 Encl_Scop := Scope (Encl_Scop);
18839 -- Neither the target nor its declarative context have elaboration
18840 -- checks suppressed.
18843 end Elaboration_Checks_OK;
18845 ------------------------------------
18846 -- Mark_Elaboration_Attributes_Id --
18847 ------------------------------------
18849 procedure Mark_Elaboration_Attributes_Id (Id : Entity_Id) is
18851 -- Mark the status of elaboration checks in effect. Do not reset the
18852 -- status in case the entity is reanalyzed with checks suppressed.
18854 if Checks and then not Is_Elaboration_Checks_OK_Id (Id) then
18855 Set_Is_Elaboration_Checks_OK_Id (Id,
18856 Elaboration_Checks_OK
18858 Context_Id => Scope (Id)));
18861 -- Mark the status of elaboration warnings in effect. Do not reset
18862 -- the status in case the entity is reanalyzed with warnings off.
18864 if Warnings and then not Is_Elaboration_Warnings_OK_Id (Id) then
18865 Set_Is_Elaboration_Warnings_OK_Id (Id, Elab_Warnings);
18867 end Mark_Elaboration_Attributes_Id;
18869 --------------------------------------
18870 -- Mark_Elaboration_Attributes_Node --
18871 --------------------------------------
18873 procedure Mark_Elaboration_Attributes_Node (N : Node_Id) is
18874 function Extract_Name (N : Node_Id) return Node_Id;
18875 -- Obtain the Name attribute of call or instantiation N
18881 function Extract_Name (N : Node_Id) return Node_Id is
18887 -- A call to an entry family appears in indexed form
18889 if Nkind (Nam) = N_Indexed_Component then
18890 Nam := Prefix (Nam);
18893 -- The name may also appear in qualified form
18895 if Nkind (Nam) = N_Selected_Component then
18896 Nam := Selector_Name (Nam);
18904 Context_Id : Entity_Id;
18907 -- Start of processing for Mark_Elaboration_Attributes_Node
18910 -- Mark the status of elaboration checks in effect. Do not reset the
18911 -- status in case the node is reanalyzed with checks suppressed.
18913 if Checks and then not Is_Elaboration_Checks_OK_Node (N) then
18915 -- Assignments, attribute references, and variable references do
18916 -- not have a "declarative" context.
18918 Context_Id := Empty;
18920 -- The status of elaboration checks for calls and instantiations
18921 -- depends on the most recent pragma Suppress/Unsuppress, as well
18922 -- as the suppression status of the context where the target is
18926 -- function Func ...;
18930 -- procedure Main is
18931 -- pragma Suppress (Elaboration_Checks, Pack);
18932 -- X : ... := Pack.Func;
18935 -- In the example above, the call to Func has elaboration checks
18936 -- enabled because there is no active general purpose suppression
18937 -- pragma, however the elaboration checks of Pack are explicitly
18938 -- suppressed. As a result the elaboration checks of the call must
18939 -- be disabled in order to preserve this dependency.
18941 if Nkind_In (N, N_Entry_Call_Statement,
18943 N_Function_Instantiation,
18944 N_Package_Instantiation,
18945 N_Procedure_Call_Statement,
18946 N_Procedure_Instantiation)
18948 Nam := Extract_Name (N);
18950 if Is_Entity_Name (Nam) and then Present (Entity (Nam)) then
18951 Context_Id := Scope (Entity (Nam));
18955 Set_Is_Elaboration_Checks_OK_Node (N,
18956 Elaboration_Checks_OK
18957 (Target_Id => Empty,
18958 Context_Id => Context_Id));
18961 -- Mark the enclosing level of the node. Do not reset the status in
18962 -- case the node is relocated and reanalyzed.
18964 if Level and then not Is_Declaration_Level_Node (N) then
18965 Set_Is_Declaration_Level_Node (N,
18966 Find_Enclosing_Level (N) = Declaration_Level);
18969 -- Mark the Ghost and SPARK mode in effect
18972 if Ghost_Mode = Ignore then
18973 Set_Is_Ignored_Ghost_Node (N);
18976 if SPARK_Mode = On then
18977 Set_Is_SPARK_Mode_On_Node (N);
18981 -- Mark the status of elaboration warnings in effect. Do not reset
18982 -- the status in case the node is reanalyzed with warnings off.
18984 if Warnings and then not Is_Elaboration_Warnings_OK_Node (N) then
18985 Set_Is_Elaboration_Warnings_OK_Node (N, Elab_Warnings);
18987 end Mark_Elaboration_Attributes_Node;
18989 -- Start of processing for Mark_Elaboration_Attributes
18992 -- Do not capture any elaboration-related attributes when switch -gnatH
18993 -- (legacy elaboration checking mode enabled) is in effect because the
18994 -- attributes are useless to the legacy model.
18996 if Legacy_Elaboration_Checks then
19000 if Nkind (N_Id) in N_Entity then
19001 Mark_Elaboration_Attributes_Id (N_Id);
19003 Mark_Elaboration_Attributes_Node (N_Id);
19005 end Mark_Elaboration_Attributes;
19007 ----------------------------------------
19008 -- Mark_Save_Invocation_Graph_Of_Body --
19009 ----------------------------------------
19011 procedure Mark_Save_Invocation_Graph_Of_Body is
19012 Main : constant Node_Id := Cunit (Main_Unit);
19013 Main_Unit : constant Node_Id := Unit (Main);
19014 Aux_Id : Entity_Id;
19017 Set_Save_Invocation_Graph_Of_Body (Main);
19019 -- Assume that the main unit does not have a complimentary unit
19023 -- Obtain the complimentary unit of the main unit
19025 if Nkind_In (Main_Unit, N_Generic_Package_Declaration,
19026 N_Generic_Subprogram_Declaration,
19027 N_Package_Declaration,
19028 N_Subprogram_Declaration)
19030 Aux_Id := Corresponding_Body (Main_Unit);
19032 elsif Nkind_In (Main_Unit, N_Package_Body,
19034 N_Subprogram_Renaming_Declaration)
19036 Aux_Id := Corresponding_Spec (Main_Unit);
19039 if Present (Aux_Id) then
19040 Set_Save_Invocation_Graph_Of_Body
19041 (Parent (Unit_Declaration_Node (Aux_Id)));
19043 end Mark_Save_Invocation_Graph_Of_Body;
19045 ----------------------------------
19046 -- Matching_Static_Array_Bounds --
19047 ----------------------------------
19049 function Matching_Static_Array_Bounds
19051 R_Typ : Node_Id) return Boolean
19053 L_Ndims : constant Nat := Number_Dimensions (L_Typ);
19054 R_Ndims : constant Nat := Number_Dimensions (R_Typ);
19056 L_Index : Node_Id := Empty; -- init to ...
19057 R_Index : Node_Id := Empty; -- ...avoid warnings
19066 if L_Ndims /= R_Ndims then
19070 -- Unconstrained types do not have static bounds
19072 if not Is_Constrained (L_Typ) or else not Is_Constrained (R_Typ) then
19076 -- First treat specially the first dimension, as the lower bound and
19077 -- length of string literals are not stored like those of arrays.
19079 if Ekind (L_Typ) = E_String_Literal_Subtype then
19080 L_Low := String_Literal_Low_Bound (L_Typ);
19081 L_Len := String_Literal_Length (L_Typ);
19083 L_Index := First_Index (L_Typ);
19084 Get_Index_Bounds (L_Index, L_Low, L_High);
19086 if Is_OK_Static_Expression (L_Low)
19088 Is_OK_Static_Expression (L_High)
19090 if Expr_Value (L_High) < Expr_Value (L_Low) then
19093 L_Len := (Expr_Value (L_High) - Expr_Value (L_Low)) + 1;
19100 if Ekind (R_Typ) = E_String_Literal_Subtype then
19101 R_Low := String_Literal_Low_Bound (R_Typ);
19102 R_Len := String_Literal_Length (R_Typ);
19104 R_Index := First_Index (R_Typ);
19105 Get_Index_Bounds (R_Index, R_Low, R_High);
19107 if Is_OK_Static_Expression (R_Low)
19109 Is_OK_Static_Expression (R_High)
19111 if Expr_Value (R_High) < Expr_Value (R_Low) then
19114 R_Len := (Expr_Value (R_High) - Expr_Value (R_Low)) + 1;
19121 if (Is_OK_Static_Expression (L_Low)
19123 Is_OK_Static_Expression (R_Low))
19124 and then Expr_Value (L_Low) = Expr_Value (R_Low)
19125 and then L_Len = R_Len
19132 -- Then treat all other dimensions
19134 for Indx in 2 .. L_Ndims loop
19138 Get_Index_Bounds (L_Index, L_Low, L_High);
19139 Get_Index_Bounds (R_Index, R_Low, R_High);
19141 if (Is_OK_Static_Expression (L_Low) and then
19142 Is_OK_Static_Expression (L_High) and then
19143 Is_OK_Static_Expression (R_Low) and then
19144 Is_OK_Static_Expression (R_High))
19145 and then (Expr_Value (L_Low) = Expr_Value (R_Low)
19147 Expr_Value (L_High) = Expr_Value (R_High))
19155 -- If we fall through the loop, all indexes matched
19158 end Matching_Static_Array_Bounds;
19160 -------------------
19161 -- May_Be_Lvalue --
19162 -------------------
19164 function May_Be_Lvalue (N : Node_Id) return Boolean is
19165 P : constant Node_Id := Parent (N);
19170 -- Test left side of assignment
19172 when N_Assignment_Statement =>
19173 return N = Name (P);
19175 -- Test prefix of component or attribute. Note that the prefix of an
19176 -- explicit or implicit dereference cannot be an l-value. In the case
19177 -- of a 'Read attribute, the reference can be an actual in the
19178 -- argument list of the attribute.
19180 when N_Attribute_Reference =>
19181 return (N = Prefix (P)
19182 and then Name_Implies_Lvalue_Prefix (Attribute_Name (P)))
19184 Attribute_Name (P) = Name_Read;
19186 -- For an expanded name, the name is an lvalue if the expanded name
19187 -- is an lvalue, but the prefix is never an lvalue, since it is just
19188 -- the scope where the name is found.
19190 when N_Expanded_Name =>
19191 if N = Prefix (P) then
19192 return May_Be_Lvalue (P);
19197 -- For a selected component A.B, A is certainly an lvalue if A.B is.
19198 -- B is a little interesting, if we have A.B := 3, there is some
19199 -- discussion as to whether B is an lvalue or not, we choose to say
19200 -- it is. Note however that A is not an lvalue if it is of an access
19201 -- type since this is an implicit dereference.
19203 when N_Selected_Component =>
19205 and then Present (Etype (N))
19206 and then Is_Access_Type (Etype (N))
19210 return May_Be_Lvalue (P);
19213 -- For an indexed component or slice, the index or slice bounds is
19214 -- never an lvalue. The prefix is an lvalue if the indexed component
19215 -- or slice is an lvalue, except if it is an access type, where we
19216 -- have an implicit dereference.
19218 when N_Indexed_Component
19222 or else (Present (Etype (N)) and then Is_Access_Type (Etype (N)))
19226 return May_Be_Lvalue (P);
19229 -- Prefix of a reference is an lvalue if the reference is an lvalue
19231 when N_Reference =>
19232 return May_Be_Lvalue (P);
19234 -- Prefix of explicit dereference is never an lvalue
19236 when N_Explicit_Dereference =>
19239 -- Positional parameter for subprogram, entry, or accept call.
19240 -- In older versions of Ada function call arguments are never
19241 -- lvalues. In Ada 2012 functions can have in-out parameters.
19243 when N_Accept_Statement
19244 | N_Entry_Call_Statement
19245 | N_Subprogram_Call
19247 if Nkind (P) = N_Function_Call and then Ada_Version < Ada_2012 then
19251 -- The following mechanism is clumsy and fragile. A single flag
19252 -- set in Resolve_Actuals would be preferable ???
19260 Proc := Get_Subprogram_Entity (P);
19266 -- If we are not a list member, something is strange, so be
19267 -- conservative and return True.
19269 if not Is_List_Member (N) then
19273 -- We are going to find the right formal by stepping forward
19274 -- through the formals, as we step backwards in the actuals.
19276 Form := First_Formal (Proc);
19279 -- If no formal, something is weird, so be conservative and
19287 exit when No (Act);
19288 Next_Formal (Form);
19291 return Ekind (Form) /= E_In_Parameter;
19294 -- Named parameter for procedure or accept call
19296 when N_Parameter_Association =>
19302 Proc := Get_Subprogram_Entity (Parent (P));
19308 -- Loop through formals to find the one that matches
19310 Form := First_Formal (Proc);
19312 -- If no matching formal, that's peculiar, some kind of
19313 -- previous error, so return True to be conservative.
19314 -- Actually happens with legal code for an unresolved call
19315 -- where we may get the wrong homonym???
19321 -- Else test for match
19323 if Chars (Form) = Chars (Selector_Name (P)) then
19324 return Ekind (Form) /= E_In_Parameter;
19327 Next_Formal (Form);
19331 -- Test for appearing in a conversion that itself appears in an
19332 -- lvalue context, since this should be an lvalue.
19334 when N_Type_Conversion =>
19335 return May_Be_Lvalue (P);
19337 -- Test for appearance in object renaming declaration
19339 when N_Object_Renaming_Declaration =>
19342 -- All other references are definitely not lvalues
19353 function Might_Raise (N : Node_Id) return Boolean is
19354 Result : Boolean := False;
19356 function Process (N : Node_Id) return Traverse_Result;
19357 -- Set Result to True if we find something that could raise an exception
19363 function Process (N : Node_Id) return Traverse_Result is
19365 if Nkind_In (N, N_Procedure_Call_Statement,
19368 N_Raise_Constraint_Error,
19369 N_Raise_Program_Error,
19370 N_Raise_Storage_Error)
19379 procedure Set_Result is new Traverse_Proc (Process);
19381 -- Start of processing for Might_Raise
19384 -- False if exceptions can't be propagated
19386 if No_Exception_Handlers_Set then
19390 -- If the checks handled by the back end are not disabled, we cannot
19391 -- ensure that no exception will be raised.
19393 if not Access_Checks_Suppressed (Empty)
19394 or else not Discriminant_Checks_Suppressed (Empty)
19395 or else not Range_Checks_Suppressed (Empty)
19396 or else not Index_Checks_Suppressed (Empty)
19397 or else Opt.Stack_Checking_Enabled
19406 --------------------------------
19407 -- Nearest_Enclosing_Instance --
19408 --------------------------------
19410 function Nearest_Enclosing_Instance (E : Entity_Id) return Entity_Id is
19415 while Present (Inst) and then Inst /= Standard_Standard loop
19416 if Is_Generic_Instance (Inst) then
19420 Inst := Scope (Inst);
19424 end Nearest_Enclosing_Instance;
19426 ------------------------
19427 -- Needs_Finalization --
19428 ------------------------
19430 function Needs_Finalization (Typ : Entity_Id) return Boolean is
19431 function Has_Some_Controlled_Component
19432 (Input_Typ : Entity_Id) return Boolean;
19433 -- Determine whether type Input_Typ has at least one controlled
19436 -----------------------------------
19437 -- Has_Some_Controlled_Component --
19438 -----------------------------------
19440 function Has_Some_Controlled_Component
19441 (Input_Typ : Entity_Id) return Boolean
19446 -- When a type is already frozen and has at least one controlled
19447 -- component, or is manually decorated, it is sufficient to inspect
19448 -- flag Has_Controlled_Component.
19450 if Has_Controlled_Component (Input_Typ) then
19453 -- Otherwise inspect the internals of the type
19455 elsif not Is_Frozen (Input_Typ) then
19456 if Is_Array_Type (Input_Typ) then
19457 return Needs_Finalization (Component_Type (Input_Typ));
19459 elsif Is_Record_Type (Input_Typ) then
19460 Comp := First_Component (Input_Typ);
19461 while Present (Comp) loop
19462 if Needs_Finalization (Etype (Comp)) then
19466 Next_Component (Comp);
19472 end Has_Some_Controlled_Component;
19474 -- Start of processing for Needs_Finalization
19477 -- Certain run-time configurations and targets do not provide support
19478 -- for controlled types.
19480 if Restriction_Active (No_Finalization) then
19483 -- C++ types are not considered controlled. It is assumed that the non-
19484 -- Ada side will handle their clean up.
19486 elsif Convention (Typ) = Convention_CPP then
19489 -- Class-wide types are treated as controlled because derivations from
19490 -- the root type may introduce controlled components.
19492 elsif Is_Class_Wide_Type (Typ) then
19495 -- Concurrent types are controlled as long as their corresponding record
19498 elsif Is_Concurrent_Type (Typ)
19499 and then Present (Corresponding_Record_Type (Typ))
19500 and then Needs_Finalization (Corresponding_Record_Type (Typ))
19504 -- Otherwise the type is controlled when it is either derived from type
19505 -- [Limited_]Controlled and not subject to aspect Disable_Controlled, or
19506 -- contains at least one controlled component.
19510 Is_Controlled (Typ) or else Has_Some_Controlled_Component (Typ);
19512 end Needs_Finalization;
19514 ----------------------
19515 -- Needs_One_Actual --
19516 ----------------------
19518 function Needs_One_Actual (E : Entity_Id) return Boolean is
19519 Formal : Entity_Id;
19522 -- Ada 2005 or later, and formals present. The first formal must be
19523 -- of a type that supports prefix notation: a controlling argument,
19524 -- a class-wide type, or an access to such.
19526 if Ada_Version >= Ada_2005
19527 and then Present (First_Formal (E))
19528 and then No (Default_Value (First_Formal (E)))
19530 (Is_Controlling_Formal (First_Formal (E))
19531 or else Is_Class_Wide_Type (Etype (First_Formal (E)))
19532 or else Is_Anonymous_Access_Type (Etype (First_Formal (E))))
19534 Formal := Next_Formal (First_Formal (E));
19535 while Present (Formal) loop
19536 if No (Default_Value (Formal)) then
19540 Next_Formal (Formal);
19545 -- Ada 83/95 or no formals
19550 end Needs_One_Actual;
19552 ---------------------------------
19553 -- Needs_Simple_Initialization --
19554 ---------------------------------
19556 function Needs_Simple_Initialization
19558 Consider_IS : Boolean := True) return Boolean
19560 Consider_IS_NS : constant Boolean :=
19561 Normalize_Scalars or (Initialize_Scalars and Consider_IS);
19564 -- Never need initialization if it is suppressed
19566 if Initialization_Suppressed (Typ) then
19570 -- Check for private type, in which case test applies to the underlying
19571 -- type of the private type.
19573 if Is_Private_Type (Typ) then
19575 RT : constant Entity_Id := Underlying_Type (Typ);
19577 if Present (RT) then
19578 return Needs_Simple_Initialization (RT);
19584 -- Scalar type with Default_Value aspect requires initialization
19586 elsif Is_Scalar_Type (Typ) and then Has_Default_Aspect (Typ) then
19589 -- Cases needing simple initialization are access types, and, if pragma
19590 -- Normalize_Scalars or Initialize_Scalars is in effect, then all scalar
19593 elsif Is_Access_Type (Typ)
19594 or else (Consider_IS_NS and then (Is_Scalar_Type (Typ)))
19598 -- If Initialize/Normalize_Scalars is in effect, string objects also
19599 -- need initialization, unless they are created in the course of
19600 -- expanding an aggregate (since in the latter case they will be
19601 -- filled with appropriate initializing values before they are used).
19603 elsif Consider_IS_NS
19604 and then Is_Standard_String_Type (Typ)
19606 (not Is_Itype (Typ)
19607 or else Nkind (Associated_Node_For_Itype (Typ)) /= N_Aggregate)
19614 end Needs_Simple_Initialization;
19616 -------------------------------------
19617 -- Needs_Variable_Reference_Marker --
19618 -------------------------------------
19620 function Needs_Variable_Reference_Marker
19622 Calls_OK : Boolean) return Boolean
19624 function Within_Suitable_Context (Ref : Node_Id) return Boolean;
19625 -- Deteremine whether variable reference Ref appears within a suitable
19626 -- context that allows the creation of a marker.
19628 -----------------------------
19629 -- Within_Suitable_Context --
19630 -----------------------------
19632 function Within_Suitable_Context (Ref : Node_Id) return Boolean is
19637 while Present (Par) loop
19639 -- The context is not suitable when the reference appears within
19640 -- the formal part of an instantiation which acts as compilation
19641 -- unit because there is no proper list for the insertion of the
19644 if Nkind (Par) = N_Generic_Association
19645 and then Nkind (Parent (Par)) in N_Generic_Instantiation
19646 and then Nkind (Parent (Parent (Par))) = N_Compilation_Unit
19650 -- The context is not suitable when the reference appears within
19651 -- a pragma. If the pragma has run-time semantics, the reference
19652 -- will be reconsidered once the pragma is expanded.
19654 elsif Nkind (Par) = N_Pragma then
19657 -- The context is not suitable when the reference appears within a
19658 -- subprogram call, and the caller requests this behavior.
19661 and then Nkind_In (Par, N_Entry_Call_Statement,
19663 N_Procedure_Call_Statement)
19667 -- Prevent the search from going too far
19669 elsif Is_Body_Or_Package_Declaration (Par) then
19673 Par := Parent (Par);
19677 end Within_Suitable_Context;
19682 Var_Id : Entity_Id;
19684 -- Start of processing for Needs_Variable_Reference_Marker
19687 -- No marker needs to be created when switch -gnatH (legacy elaboration
19688 -- checking mode enabled) is in effect because the legacy ABE mechanism
19689 -- does not use markers.
19691 if Legacy_Elaboration_Checks then
19694 -- No marker needs to be created for ASIS because ABE diagnostics and
19695 -- checks are not performed in this mode.
19697 elsif ASIS_Mode then
19700 -- No marker needs to be created when the reference is preanalyzed
19701 -- because the marker will be inserted in the wrong place.
19703 elsif Preanalysis_Active then
19706 -- Only references warrant a marker
19708 elsif not Nkind_In (N, N_Expanded_Name, N_Identifier) then
19711 -- Only source references warrant a marker
19713 elsif not Comes_From_Source (N) then
19716 -- No marker needs to be created when the reference is erroneous, left
19717 -- in a bad state, or does not denote a variable.
19719 elsif not (Present (Entity (N))
19720 and then Ekind (Entity (N)) = E_Variable
19721 and then Entity (N) /= Any_Id)
19726 Var_Id := Entity (N);
19727 Prag := SPARK_Pragma (Var_Id);
19729 -- Both the variable and reference must appear in SPARK_Mode On regions
19730 -- because this elaboration scenario falls under the SPARK rules.
19732 if not (Comes_From_Source (Var_Id)
19733 and then Present (Prag)
19734 and then Get_SPARK_Mode_From_Annotation (Prag) = On
19735 and then Is_SPARK_Mode_On_Node (N))
19739 -- No marker needs to be created when the reference does not appear
19740 -- within a suitable context (see body for details).
19742 -- Performance note: parent traversal
19744 elsif not Within_Suitable_Context (N) then
19748 -- At this point it is known that the variable reference will play a
19749 -- role in ABE diagnostics and requires a marker.
19752 end Needs_Variable_Reference_Marker;
19754 ------------------------
19755 -- New_Copy_List_Tree --
19756 ------------------------
19758 function New_Copy_List_Tree (List : List_Id) return List_Id is
19763 if List = No_List then
19770 while Present (E) loop
19771 Append (New_Copy_Tree (E), NL);
19777 end New_Copy_List_Tree;
19779 -------------------
19780 -- New_Copy_Tree --
19781 -------------------
19783 -- The following tables play a key role in replicating entities and Itypes.
19784 -- They are intentionally declared at the library level rather than within
19785 -- New_Copy_Tree to avoid elaborating them on each call. This performance
19786 -- optimization saves up to 2% of the entire compilation time spent in the
19787 -- front end. Care should be taken to reset the tables on each new call to
19790 NCT_Table_Max : constant := 511;
19792 subtype NCT_Table_Index is Nat range 0 .. NCT_Table_Max - 1;
19794 function NCT_Table_Hash (Key : Node_Or_Entity_Id) return NCT_Table_Index;
19795 -- Obtain the hash value of node or entity Key
19797 --------------------
19798 -- NCT_Table_Hash --
19799 --------------------
19801 function NCT_Table_Hash (Key : Node_Or_Entity_Id) return NCT_Table_Index is
19803 return NCT_Table_Index (Key mod NCT_Table_Max);
19804 end NCT_Table_Hash;
19806 ----------------------
19807 -- NCT_New_Entities --
19808 ----------------------
19810 -- The following table maps old entities and Itypes to their corresponding
19811 -- new entities and Itypes.
19815 package NCT_New_Entities is new Simple_HTable (
19816 Header_Num => NCT_Table_Index,
19817 Element => Entity_Id,
19818 No_Element => Empty,
19820 Hash => NCT_Table_Hash,
19823 ------------------------
19824 -- NCT_Pending_Itypes --
19825 ------------------------
19827 -- The following table maps old Associated_Node_For_Itype nodes to a set of
19828 -- new itypes. Given a set of old Itypes Aaa, Bbb, and Ccc, where all three
19829 -- have the same Associated_Node_For_Itype Ppp, and their corresponding new
19830 -- Itypes Xxx, Yyy, Zzz, the table contains the following mapping:
19832 -- Ppp -> (Xxx, Yyy, Zzz)
19834 -- The set is expressed as an Elist
19836 package NCT_Pending_Itypes is new Simple_HTable (
19837 Header_Num => NCT_Table_Index,
19838 Element => Elist_Id,
19839 No_Element => No_Elist,
19841 Hash => NCT_Table_Hash,
19844 NCT_Tables_In_Use : Boolean := False;
19845 -- This flag keeps track of whether the two tables NCT_New_Entities and
19846 -- NCT_Pending_Itypes are in use. The flag is part of an optimization
19847 -- where certain operations are not performed if the tables are not in
19848 -- use. This saves up to 8% of the entire compilation time spent in the
19851 -------------------
19852 -- New_Copy_Tree --
19853 -------------------
19855 function New_Copy_Tree
19857 Map : Elist_Id := No_Elist;
19858 New_Sloc : Source_Ptr := No_Location;
19859 New_Scope : Entity_Id := Empty;
19860 Scopes_In_EWA_OK : Boolean := False) return Node_Id
19862 -- This routine performs low-level tree manipulations and needs access
19863 -- to the internals of the tree.
19865 use Atree.Unchecked_Access;
19866 use Atree_Private_Part;
19868 EWA_Level : Nat := 0;
19869 -- This counter keeps track of how many N_Expression_With_Actions nodes
19870 -- are encountered during a depth-first traversal of the subtree. These
19871 -- nodes may define new entities in their Actions lists and thus require
19872 -- special processing.
19874 EWA_Inner_Scope_Level : Nat := 0;
19875 -- This counter keeps track of how many scoping constructs appear within
19876 -- an N_Expression_With_Actions node.
19878 procedure Add_New_Entity (Old_Id : Entity_Id; New_Id : Entity_Id);
19879 pragma Inline (Add_New_Entity);
19880 -- Add an entry in the NCT_New_Entities table which maps key Old_Id to
19881 -- value New_Id. Old_Id is an entity which appears within the Actions
19882 -- list of an N_Expression_With_Actions node, or within an entity map.
19883 -- New_Id is the corresponding new entity generated during Phase 1.
19885 procedure Add_Pending_Itype (Assoc_Nod : Node_Id; Itype : Entity_Id);
19886 pragma Inline (Add_New_Entity);
19887 -- Add an entry in the NCT_Pending_Itypes which maps key Assoc_Nod to
19888 -- value Itype. Assoc_Nod is the associated node of an itype. Itype is
19891 procedure Build_NCT_Tables (Entity_Map : Elist_Id);
19892 pragma Inline (Build_NCT_Tables);
19893 -- Populate tables NCT_New_Entities and NCT_Pending_Itypes with the
19894 -- information supplied in entity map Entity_Map. The format of the
19895 -- entity map must be as follows:
19897 -- Old_Id1, New_Id1, Old_Id2, New_Id2, .., Old_IdN, New_IdN
19899 function Copy_Any_Node_With_Replacement
19900 (N : Node_Or_Entity_Id) return Node_Or_Entity_Id;
19901 pragma Inline (Copy_Any_Node_With_Replacement);
19902 -- Replicate entity or node N by invoking one of the following routines:
19904 -- Copy_Node_With_Replacement
19905 -- Corresponding_Entity
19907 function Copy_Elist_With_Replacement (List : Elist_Id) return Elist_Id;
19908 -- Replicate the elements of entity list List
19910 function Copy_Field_With_Replacement
19912 Old_Par : Node_Id := Empty;
19913 New_Par : Node_Id := Empty;
19914 Semantic : Boolean := False) return Union_Id;
19915 -- Replicate field Field by invoking one of the following routines:
19917 -- Copy_Elist_With_Replacement
19918 -- Copy_List_With_Replacement
19919 -- Copy_Node_With_Replacement
19920 -- Corresponding_Entity
19922 -- If the field is not an entity list, entity, itype, syntactic list,
19923 -- or node, then the field is returned unchanged. The routine always
19924 -- replicates entities, itypes, and valid syntactic fields. Old_Par is
19925 -- the expected parent of a syntactic field. New_Par is the new parent
19926 -- associated with a replicated syntactic field. Flag Semantic should
19927 -- be set when the input is a semantic field.
19929 function Copy_List_With_Replacement (List : List_Id) return List_Id;
19930 -- Replicate the elements of syntactic list List
19932 function Copy_Node_With_Replacement (N : Node_Id) return Node_Id;
19933 -- Replicate node N
19935 function Corresponding_Entity (Id : Entity_Id) return Entity_Id;
19936 pragma Inline (Corresponding_Entity);
19937 -- Return the corresponding new entity of Id generated during Phase 1.
19938 -- If there is no such entity, return Id.
19940 function In_Entity_Map
19942 Entity_Map : Elist_Id) return Boolean;
19943 pragma Inline (In_Entity_Map);
19944 -- Determine whether entity Id is one of the old ids specified in entity
19945 -- map Entity_Map. The format of the entity map must be as follows:
19947 -- Old_Id1, New_Id1, Old_Id2, New_Id2, .., Old_IdN, New_IdN
19949 procedure Update_CFS_Sloc (N : Node_Or_Entity_Id);
19950 pragma Inline (Update_CFS_Sloc);
19951 -- Update the Comes_From_Source and Sloc attributes of node or entity N
19953 procedure Update_First_Real_Statement
19954 (Old_HSS : Node_Id;
19955 New_HSS : Node_Id);
19956 pragma Inline (Update_First_Real_Statement);
19957 -- Update semantic attribute First_Real_Statement of handled sequence of
19958 -- statements New_HSS based on handled sequence of statements Old_HSS.
19960 procedure Update_Named_Associations
19961 (Old_Call : Node_Id;
19962 New_Call : Node_Id);
19963 pragma Inline (Update_Named_Associations);
19964 -- Update semantic chain First/Next_Named_Association of call New_call
19965 -- based on call Old_Call.
19967 procedure Update_New_Entities (Entity_Map : Elist_Id);
19968 pragma Inline (Update_New_Entities);
19969 -- Update the semantic attributes of all new entities generated during
19970 -- Phase 1 that do not appear in entity map Entity_Map. The format of
19971 -- the entity map must be as follows:
19973 -- Old_Id1, New_Id1, Old_Id2, New_Id2, .., Old_IdN, New_IdN
19975 procedure Update_Pending_Itypes
19976 (Old_Assoc : Node_Id;
19977 New_Assoc : Node_Id);
19978 pragma Inline (Update_Pending_Itypes);
19979 -- Update semantic attribute Associated_Node_For_Itype to refer to node
19980 -- New_Assoc for all itypes whose associated node is Old_Assoc.
19982 procedure Update_Semantic_Fields (Id : Entity_Id);
19983 pragma Inline (Update_Semantic_Fields);
19984 -- Subsidiary to Update_New_Entities. Update semantic fields of entity
19987 procedure Visit_Any_Node (N : Node_Or_Entity_Id);
19988 pragma Inline (Visit_Any_Node);
19989 -- Visit entity of node N by invoking one of the following routines:
19995 procedure Visit_Elist (List : Elist_Id);
19996 -- Visit the elements of entity list List
19998 procedure Visit_Entity (Id : Entity_Id);
19999 -- Visit entity Id. This action may create a new entity of Id and save
20000 -- it in table NCT_New_Entities.
20002 procedure Visit_Field
20004 Par_Nod : Node_Id := Empty;
20005 Semantic : Boolean := False);
20006 -- Visit field Field by invoking one of the following routines:
20014 -- If the field is not an entity list, entity, itype, syntactic list,
20015 -- or node, then the field is not visited. The routine always visits
20016 -- valid syntactic fields. Par_Nod is the expected parent of the
20017 -- syntactic field. Flag Semantic should be set when the input is a
20020 procedure Visit_Itype (Itype : Entity_Id);
20021 -- Visit itype Itype. This action may create a new entity for Itype and
20022 -- save it in table NCT_New_Entities. In addition, the routine may map
20023 -- the associated node of Itype to the new itype in NCT_Pending_Itypes.
20025 procedure Visit_List (List : List_Id);
20026 -- Visit the elements of syntactic list List
20028 procedure Visit_Node (N : Node_Id);
20031 procedure Visit_Semantic_Fields (Id : Entity_Id);
20032 pragma Inline (Visit_Semantic_Fields);
20033 -- Subsidiary to Visit_Entity and Visit_Itype. Visit common semantic
20034 -- fields of entity or itype Id.
20036 --------------------
20037 -- Add_New_Entity --
20038 --------------------
20040 procedure Add_New_Entity (Old_Id : Entity_Id; New_Id : Entity_Id) is
20042 pragma Assert (Present (Old_Id));
20043 pragma Assert (Present (New_Id));
20044 pragma Assert (Nkind (Old_Id) in N_Entity);
20045 pragma Assert (Nkind (New_Id) in N_Entity);
20047 NCT_Tables_In_Use := True;
20049 -- Sanity check the NCT_New_Entities table. No previous mapping with
20050 -- key Old_Id should exist.
20052 pragma Assert (No (NCT_New_Entities.Get (Old_Id)));
20054 -- Establish the mapping
20056 -- Old_Id -> New_Id
20058 NCT_New_Entities.Set (Old_Id, New_Id);
20059 end Add_New_Entity;
20061 -----------------------
20062 -- Add_Pending_Itype --
20063 -----------------------
20065 procedure Add_Pending_Itype (Assoc_Nod : Node_Id; Itype : Entity_Id) is
20069 pragma Assert (Present (Assoc_Nod));
20070 pragma Assert (Present (Itype));
20071 pragma Assert (Nkind (Itype) in N_Entity);
20072 pragma Assert (Is_Itype (Itype));
20074 NCT_Tables_In_Use := True;
20076 -- It is not possible to sanity check the NCT_Pendint_Itypes table
20077 -- directly because a single node may act as the associated node for
20078 -- multiple itypes.
20080 Itypes := NCT_Pending_Itypes.Get (Assoc_Nod);
20082 if No (Itypes) then
20083 Itypes := New_Elmt_List;
20084 NCT_Pending_Itypes.Set (Assoc_Nod, Itypes);
20087 -- Establish the mapping
20089 -- Assoc_Nod -> (Itype, ...)
20091 -- Avoid inserting the same itype multiple times. This involves a
20092 -- linear search, however the set of itypes with the same associated
20093 -- node is very small.
20095 Append_Unique_Elmt (Itype, Itypes);
20096 end Add_Pending_Itype;
20098 ----------------------
20099 -- Build_NCT_Tables --
20100 ----------------------
20102 procedure Build_NCT_Tables (Entity_Map : Elist_Id) is
20104 Old_Id : Entity_Id;
20105 New_Id : Entity_Id;
20108 -- Nothing to do when there is no entity map
20110 if No (Entity_Map) then
20114 Elmt := First_Elmt (Entity_Map);
20115 while Present (Elmt) loop
20117 -- Extract the (Old_Id, New_Id) pair from the entity map
20119 Old_Id := Node (Elmt);
20122 New_Id := Node (Elmt);
20125 -- Establish the following mapping within table NCT_New_Entities
20127 -- Old_Id -> New_Id
20129 Add_New_Entity (Old_Id, New_Id);
20131 -- Establish the following mapping within table NCT_Pending_Itypes
20132 -- when the new entity is an itype.
20134 -- Assoc_Nod -> (New_Id, ...)
20136 -- IMPORTANT: the associated node is that of the old itype because
20137 -- the node will be replicated in Phase 2.
20139 if Is_Itype (Old_Id) then
20141 (Assoc_Nod => Associated_Node_For_Itype (Old_Id),
20145 end Build_NCT_Tables;
20147 ------------------------------------
20148 -- Copy_Any_Node_With_Replacement --
20149 ------------------------------------
20151 function Copy_Any_Node_With_Replacement
20152 (N : Node_Or_Entity_Id) return Node_Or_Entity_Id
20155 if Nkind (N) in N_Entity then
20156 return Corresponding_Entity (N);
20158 return Copy_Node_With_Replacement (N);
20160 end Copy_Any_Node_With_Replacement;
20162 ---------------------------------
20163 -- Copy_Elist_With_Replacement --
20164 ---------------------------------
20166 function Copy_Elist_With_Replacement (List : Elist_Id) return Elist_Id is
20171 -- Copy the contents of the old list. Note that the list itself may
20172 -- be empty, in which case the routine returns a new empty list. This
20173 -- avoids sharing lists between subtrees. The element of an entity
20174 -- list could be an entity or a node, hence the invocation of routine
20175 -- Copy_Any_Node_With_Replacement.
20177 if Present (List) then
20178 Result := New_Elmt_List;
20180 Elmt := First_Elmt (List);
20181 while Present (Elmt) loop
20183 (Copy_Any_Node_With_Replacement (Node (Elmt)), Result);
20188 -- Otherwise the list does not exist
20191 Result := No_Elist;
20195 end Copy_Elist_With_Replacement;
20197 ---------------------------------
20198 -- Copy_Field_With_Replacement --
20199 ---------------------------------
20201 function Copy_Field_With_Replacement
20203 Old_Par : Node_Id := Empty;
20204 New_Par : Node_Id := Empty;
20205 Semantic : Boolean := False) return Union_Id
20208 -- The field is empty
20210 if Field = Union_Id (Empty) then
20213 -- The field is an entity/itype/node
20215 elsif Field in Node_Range then
20217 Old_N : constant Node_Id := Node_Id (Field);
20218 Syntactic : constant Boolean := Parent (Old_N) = Old_Par;
20223 -- The field is an entity/itype
20225 if Nkind (Old_N) in N_Entity then
20227 -- An entity/itype is always replicated
20229 New_N := Corresponding_Entity (Old_N);
20231 -- Update the parent pointer when the entity is a syntactic
20232 -- field. Note that itypes do not have parent pointers.
20234 if Syntactic and then New_N /= Old_N then
20235 Set_Parent (New_N, New_Par);
20238 -- The field is a node
20241 -- A node is replicated when it is either a syntactic field
20242 -- or when the caller treats it as a semantic attribute.
20244 if Syntactic or else Semantic then
20245 New_N := Copy_Node_With_Replacement (Old_N);
20247 -- Update the parent pointer when the node is a syntactic
20250 if Syntactic and then New_N /= Old_N then
20251 Set_Parent (New_N, New_Par);
20254 -- Otherwise the node is returned unchanged
20261 return Union_Id (New_N);
20264 -- The field is an entity list
20266 elsif Field in Elist_Range then
20267 return Union_Id (Copy_Elist_With_Replacement (Elist_Id (Field)));
20269 -- The field is a syntactic list
20271 elsif Field in List_Range then
20273 Old_List : constant List_Id := List_Id (Field);
20274 Syntactic : constant Boolean := Parent (Old_List) = Old_Par;
20276 New_List : List_Id;
20279 -- A list is replicated when it is either a syntactic field or
20280 -- when the caller treats it as a semantic attribute.
20282 if Syntactic or else Semantic then
20283 New_List := Copy_List_With_Replacement (Old_List);
20285 -- Update the parent pointer when the list is a syntactic
20288 if Syntactic and then New_List /= Old_List then
20289 Set_Parent (New_List, New_Par);
20292 -- Otherwise the list is returned unchanged
20295 New_List := Old_List;
20298 return Union_Id (New_List);
20301 -- Otherwise the field denotes an attribute that does not need to be
20302 -- replicated (Chars, literals, etc).
20307 end Copy_Field_With_Replacement;
20309 --------------------------------
20310 -- Copy_List_With_Replacement --
20311 --------------------------------
20313 function Copy_List_With_Replacement (List : List_Id) return List_Id is
20318 -- Copy the contents of the old list. Note that the list itself may
20319 -- be empty, in which case the routine returns a new empty list. This
20320 -- avoids sharing lists between subtrees. The element of a syntactic
20321 -- list is always a node, never an entity or itype, hence the call to
20322 -- routine Copy_Node_With_Replacement.
20324 if Present (List) then
20325 Result := New_List;
20327 Elmt := First (List);
20328 while Present (Elmt) loop
20329 Append (Copy_Node_With_Replacement (Elmt), Result);
20334 -- Otherwise the list does not exist
20341 end Copy_List_With_Replacement;
20343 --------------------------------
20344 -- Copy_Node_With_Replacement --
20345 --------------------------------
20347 function Copy_Node_With_Replacement (N : Node_Id) return Node_Id is
20351 -- Assume that the node must be returned unchanged
20355 if N > Empty_Or_Error then
20356 pragma Assert (Nkind (N) not in N_Entity);
20358 Result := New_Copy (N);
20360 Set_Field1 (Result,
20361 Copy_Field_With_Replacement
20362 (Field => Field1 (Result),
20364 New_Par => Result));
20366 Set_Field2 (Result,
20367 Copy_Field_With_Replacement
20368 (Field => Field2 (Result),
20370 New_Par => Result));
20372 Set_Field3 (Result,
20373 Copy_Field_With_Replacement
20374 (Field => Field3 (Result),
20376 New_Par => Result));
20378 Set_Field4 (Result,
20379 Copy_Field_With_Replacement
20380 (Field => Field4 (Result),
20382 New_Par => Result));
20384 Set_Field5 (Result,
20385 Copy_Field_With_Replacement
20386 (Field => Field5 (Result),
20388 New_Par => Result));
20390 -- Update the Comes_From_Source and Sloc attributes of the node
20391 -- in case the caller has supplied new values.
20393 Update_CFS_Sloc (Result);
20395 -- Update the Associated_Node_For_Itype attribute of all itypes
20396 -- created during Phase 1 whose associated node is N. As a result
20397 -- the Associated_Node_For_Itype refers to the replicated node.
20398 -- No action needs to be taken when the Associated_Node_For_Itype
20399 -- refers to an entity because this was already handled during
20400 -- Phase 1, in Visit_Itype.
20402 Update_Pending_Itypes
20404 New_Assoc => Result);
20406 -- Update the First/Next_Named_Association chain for a replicated
20409 if Nkind_In (N, N_Entry_Call_Statement,
20411 N_Procedure_Call_Statement)
20413 Update_Named_Associations
20415 New_Call => Result);
20417 -- Update the Renamed_Object attribute of a replicated object
20420 elsif Nkind (N) = N_Object_Renaming_Declaration then
20421 Set_Renamed_Object (Defining_Entity (Result), Name (Result));
20423 -- Update the First_Real_Statement attribute of a replicated
20424 -- handled sequence of statements.
20426 elsif Nkind (N) = N_Handled_Sequence_Of_Statements then
20427 Update_First_Real_Statement
20429 New_HSS => Result);
20434 end Copy_Node_With_Replacement;
20436 --------------------------
20437 -- Corresponding_Entity --
20438 --------------------------
20440 function Corresponding_Entity (Id : Entity_Id) return Entity_Id is
20441 New_Id : Entity_Id;
20442 Result : Entity_Id;
20445 -- Assume that the entity must be returned unchanged
20449 if Id > Empty_Or_Error then
20450 pragma Assert (Nkind (Id) in N_Entity);
20452 -- Determine whether the entity has a corresponding new entity
20453 -- generated during Phase 1 and if it does, use it.
20455 if NCT_Tables_In_Use then
20456 New_Id := NCT_New_Entities.Get (Id);
20458 if Present (New_Id) then
20465 end Corresponding_Entity;
20467 -------------------
20468 -- In_Entity_Map --
20469 -------------------
20471 function In_Entity_Map
20473 Entity_Map : Elist_Id) return Boolean
20476 Old_Id : Entity_Id;
20479 -- The entity map contains pairs (Old_Id, New_Id). The advancement
20480 -- step always skips the New_Id portion of the pair.
20482 if Present (Entity_Map) then
20483 Elmt := First_Elmt (Entity_Map);
20484 while Present (Elmt) loop
20485 Old_Id := Node (Elmt);
20487 if Old_Id = Id then
20499 ---------------------
20500 -- Update_CFS_Sloc --
20501 ---------------------
20503 procedure Update_CFS_Sloc (N : Node_Or_Entity_Id) is
20505 -- A new source location defaults the Comes_From_Source attribute
20507 if New_Sloc /= No_Location then
20508 Set_Comes_From_Source (N, Default_Node.Comes_From_Source);
20509 Set_Sloc (N, New_Sloc);
20511 end Update_CFS_Sloc;
20513 ---------------------------------
20514 -- Update_First_Real_Statement --
20515 ---------------------------------
20517 procedure Update_First_Real_Statement
20518 (Old_HSS : Node_Id;
20521 Old_First_Stmt : constant Node_Id := First_Real_Statement (Old_HSS);
20523 New_Stmt : Node_Id;
20524 Old_Stmt : Node_Id;
20527 -- Recreate the First_Real_Statement attribute of a handled sequence
20528 -- of statements by traversing the statement lists of both sequences
20531 if Present (Old_First_Stmt) then
20532 New_Stmt := First (Statements (New_HSS));
20533 Old_Stmt := First (Statements (Old_HSS));
20534 while Present (Old_Stmt) and then Old_Stmt /= Old_First_Stmt loop
20539 pragma Assert (Present (New_Stmt));
20540 pragma Assert (Present (Old_Stmt));
20542 Set_First_Real_Statement (New_HSS, New_Stmt);
20544 end Update_First_Real_Statement;
20546 -------------------------------
20547 -- Update_Named_Associations --
20548 -------------------------------
20550 procedure Update_Named_Associations
20551 (Old_Call : Node_Id;
20552 New_Call : Node_Id)
20555 New_Next : Node_Id;
20557 Old_Next : Node_Id;
20560 -- Recreate the First/Next_Named_Actual chain of a call by traversing
20561 -- the chains of both the old and new calls in parallel.
20563 New_Act := First (Parameter_Associations (New_Call));
20564 Old_Act := First (Parameter_Associations (Old_Call));
20565 while Present (Old_Act) loop
20566 if Nkind (Old_Act) = N_Parameter_Association
20567 and then Present (Next_Named_Actual (Old_Act))
20569 if First_Named_Actual (Old_Call) =
20570 Explicit_Actual_Parameter (Old_Act)
20572 Set_First_Named_Actual (New_Call,
20573 Explicit_Actual_Parameter (New_Act));
20576 -- Scan the actual parameter list to find the next suitable
20577 -- named actual. Note that the list may be out of order.
20579 New_Next := First (Parameter_Associations (New_Call));
20580 Old_Next := First (Parameter_Associations (Old_Call));
20581 while Nkind (Old_Next) /= N_Parameter_Association
20582 or else Explicit_Actual_Parameter (Old_Next) /=
20583 Next_Named_Actual (Old_Act)
20589 Set_Next_Named_Actual (New_Act,
20590 Explicit_Actual_Parameter (New_Next));
20596 end Update_Named_Associations;
20598 -------------------------
20599 -- Update_New_Entities --
20600 -------------------------
20602 procedure Update_New_Entities (Entity_Map : Elist_Id) is
20603 New_Id : Entity_Id := Empty;
20604 Old_Id : Entity_Id := Empty;
20607 if NCT_Tables_In_Use then
20608 NCT_New_Entities.Get_First (Old_Id, New_Id);
20610 -- Update the semantic fields of all new entities created during
20611 -- Phase 1 which were not supplied via an entity map.
20612 -- ??? Is there a better way of distinguishing those?
20614 while Present (Old_Id) and then Present (New_Id) loop
20615 if not (Present (Entity_Map)
20616 and then In_Entity_Map (Old_Id, Entity_Map))
20618 Update_Semantic_Fields (New_Id);
20621 NCT_New_Entities.Get_Next (Old_Id, New_Id);
20624 end Update_New_Entities;
20626 ---------------------------
20627 -- Update_Pending_Itypes --
20628 ---------------------------
20630 procedure Update_Pending_Itypes
20631 (Old_Assoc : Node_Id;
20632 New_Assoc : Node_Id)
20638 if NCT_Tables_In_Use then
20639 Itypes := NCT_Pending_Itypes.Get (Old_Assoc);
20641 -- Update the Associated_Node_For_Itype attribute for all itypes
20642 -- which originally refer to Old_Assoc to designate New_Assoc.
20644 if Present (Itypes) then
20645 Item := First_Elmt (Itypes);
20646 while Present (Item) loop
20647 Set_Associated_Node_For_Itype (Node (Item), New_Assoc);
20653 end Update_Pending_Itypes;
20655 ----------------------------
20656 -- Update_Semantic_Fields --
20657 ----------------------------
20659 procedure Update_Semantic_Fields (Id : Entity_Id) is
20661 -- Discriminant_Constraint
20663 if Is_Type (Id) and then Has_Discriminants (Base_Type (Id)) then
20664 Set_Discriminant_Constraint (Id, Elist_Id (
20665 Copy_Field_With_Replacement
20666 (Field => Union_Id (Discriminant_Constraint (Id)),
20667 Semantic => True)));
20672 Set_Etype (Id, Node_Id (
20673 Copy_Field_With_Replacement
20674 (Field => Union_Id (Etype (Id)),
20675 Semantic => True)));
20678 -- Packed_Array_Impl_Type
20680 if Is_Array_Type (Id) then
20681 if Present (First_Index (Id)) then
20682 Set_First_Index (Id, First (List_Id (
20683 Copy_Field_With_Replacement
20684 (Field => Union_Id (List_Containing (First_Index (Id))),
20685 Semantic => True))));
20688 if Is_Packed (Id) then
20689 Set_Packed_Array_Impl_Type (Id, Node_Id (
20690 Copy_Field_With_Replacement
20691 (Field => Union_Id (Packed_Array_Impl_Type (Id)),
20692 Semantic => True)));
20698 Set_Prev_Entity (Id, Node_Id (
20699 Copy_Field_With_Replacement
20700 (Field => Union_Id (Prev_Entity (Id)),
20701 Semantic => True)));
20705 Set_Next_Entity (Id, Node_Id (
20706 Copy_Field_With_Replacement
20707 (Field => Union_Id (Next_Entity (Id)),
20708 Semantic => True)));
20712 if Is_Discrete_Type (Id) then
20713 Set_Scalar_Range (Id, Node_Id (
20714 Copy_Field_With_Replacement
20715 (Field => Union_Id (Scalar_Range (Id)),
20716 Semantic => True)));
20721 -- Update the scope when the caller specified an explicit one
20723 if Present (New_Scope) then
20724 Set_Scope (Id, New_Scope);
20726 Set_Scope (Id, Node_Id (
20727 Copy_Field_With_Replacement
20728 (Field => Union_Id (Scope (Id)),
20729 Semantic => True)));
20731 end Update_Semantic_Fields;
20733 --------------------
20734 -- Visit_Any_Node --
20735 --------------------
20737 procedure Visit_Any_Node (N : Node_Or_Entity_Id) is
20739 if Nkind (N) in N_Entity then
20740 if Is_Itype (N) then
20748 end Visit_Any_Node;
20754 procedure Visit_Elist (List : Elist_Id) is
20758 -- The element of an entity list could be an entity, itype, or a
20759 -- node, hence the call to Visit_Any_Node.
20761 if Present (List) then
20762 Elmt := First_Elmt (List);
20763 while Present (Elmt) loop
20764 Visit_Any_Node (Node (Elmt));
20775 procedure Visit_Entity (Id : Entity_Id) is
20776 New_Id : Entity_Id;
20779 pragma Assert (Nkind (Id) in N_Entity);
20780 pragma Assert (not Is_Itype (Id));
20782 -- Nothing to do when the entity is not defined in the Actions list
20783 -- of an N_Expression_With_Actions node.
20785 if EWA_Level = 0 then
20788 -- Nothing to do when the entity is defined in a scoping construct
20789 -- within an N_Expression_With_Actions node, unless the caller has
20790 -- requested their replication.
20792 -- ??? should this restriction be eliminated?
20794 elsif EWA_Inner_Scope_Level > 0 and then not Scopes_In_EWA_OK then
20797 -- Nothing to do when the entity does not denote a construct that
20798 -- may appear within an N_Expression_With_Actions node. Relaxing
20799 -- this restriction leads to a performance penalty.
20801 -- ??? this list is flaky, and may hide dormant bugs
20803 elsif not Ekind_In (Id, E_Block,
20808 and then not Is_Type (Id)
20812 -- Nothing to do when the entity was already visited
20814 elsif NCT_Tables_In_Use
20815 and then Present (NCT_New_Entities.Get (Id))
20819 -- Nothing to do when the declaration node of the entity is not in
20820 -- the subtree being replicated.
20822 elsif not In_Subtree
20823 (N => Declaration_Node (Id),
20829 -- Create a new entity by directly copying the old entity. This
20830 -- action causes all attributes of the old entity to be inherited.
20832 New_Id := New_Copy (Id);
20834 -- Create a new name for the new entity because the back end needs
20835 -- distinct names for debugging purposes.
20837 Set_Chars (New_Id, New_Internal_Name ('T'));
20839 -- Update the Comes_From_Source and Sloc attributes of the entity in
20840 -- case the caller has supplied new values.
20842 Update_CFS_Sloc (New_Id);
20844 -- Establish the following mapping within table NCT_New_Entities:
20848 Add_New_Entity (Id, New_Id);
20850 -- Deal with the semantic fields of entities. The fields are visited
20851 -- because they may mention entities which reside within the subtree
20854 Visit_Semantic_Fields (Id);
20861 procedure Visit_Field
20863 Par_Nod : Node_Id := Empty;
20864 Semantic : Boolean := False)
20867 -- The field is empty
20869 if Field = Union_Id (Empty) then
20872 -- The field is an entity/itype/node
20874 elsif Field in Node_Range then
20876 N : constant Node_Id := Node_Id (Field);
20879 -- The field is an entity/itype
20881 if Nkind (N) in N_Entity then
20883 -- Itypes are always visited
20885 if Is_Itype (N) then
20888 -- An entity is visited when it is either a syntactic field
20889 -- or when the caller treats it as a semantic attribute.
20891 elsif Parent (N) = Par_Nod or else Semantic then
20895 -- The field is a node
20898 -- A node is visited when it is either a syntactic field or
20899 -- when the caller treats it as a semantic attribute.
20901 if Parent (N) = Par_Nod or else Semantic then
20907 -- The field is an entity list
20909 elsif Field in Elist_Range then
20910 Visit_Elist (Elist_Id (Field));
20912 -- The field is a syntax list
20914 elsif Field in List_Range then
20916 List : constant List_Id := List_Id (Field);
20919 -- A syntax list is visited when it is either a syntactic field
20920 -- or when the caller treats it as a semantic attribute.
20922 if Parent (List) = Par_Nod or else Semantic then
20927 -- Otherwise the field denotes information which does not need to be
20928 -- visited (chars, literals, etc.).
20939 procedure Visit_Itype (Itype : Entity_Id) is
20940 New_Assoc : Node_Id;
20941 New_Itype : Entity_Id;
20942 Old_Assoc : Node_Id;
20945 pragma Assert (Nkind (Itype) in N_Entity);
20946 pragma Assert (Is_Itype (Itype));
20948 -- Itypes that describe the designated type of access to subprograms
20949 -- have the structure of subprogram declarations, with signatures,
20950 -- etc. Either we duplicate the signatures completely, or choose to
20951 -- share such itypes, which is fine because their elaboration will
20952 -- have no side effects.
20954 if Ekind (Itype) = E_Subprogram_Type then
20957 -- Nothing to do if the itype was already visited
20959 elsif NCT_Tables_In_Use
20960 and then Present (NCT_New_Entities.Get (Itype))
20964 -- Nothing to do if the associated node of the itype is not within
20965 -- the subtree being replicated.
20967 elsif not In_Subtree
20968 (N => Associated_Node_For_Itype (Itype),
20974 -- Create a new itype by directly copying the old itype. This action
20975 -- causes all attributes of the old itype to be inherited.
20977 New_Itype := New_Copy (Itype);
20979 -- Create a new name for the new itype because the back end requires
20980 -- distinct names for debugging purposes.
20982 Set_Chars (New_Itype, New_Internal_Name ('T'));
20984 -- Update the Comes_From_Source and Sloc attributes of the itype in
20985 -- case the caller has supplied new values.
20987 Update_CFS_Sloc (New_Itype);
20989 -- Establish the following mapping within table NCT_New_Entities:
20991 -- Itype -> New_Itype
20993 Add_New_Entity (Itype, New_Itype);
20995 -- The new itype must be unfrozen because the resulting subtree may
20996 -- be inserted anywhere and cause an earlier or later freezing.
20998 if Present (Freeze_Node (New_Itype)) then
20999 Set_Freeze_Node (New_Itype, Empty);
21000 Set_Is_Frozen (New_Itype, False);
21003 -- If a record subtype is simply copied, the entity list will be
21004 -- shared. Thus cloned_Subtype must be set to indicate the sharing.
21005 -- ??? What does this do?
21007 if Ekind_In (Itype, E_Class_Wide_Subtype, E_Record_Subtype) then
21008 Set_Cloned_Subtype (New_Itype, Itype);
21011 -- The associated node may denote an entity, in which case it may
21012 -- already have a new corresponding entity created during a prior
21013 -- call to Visit_Entity or Visit_Itype for the same subtree.
21016 -- Old_Assoc ---------> New_Assoc
21018 -- Created by Visit_Itype
21019 -- Itype -------------> New_Itype
21020 -- ANFI = Old_Assoc ANFI = Old_Assoc < must be updated
21022 -- In the example above, Old_Assoc is an arbitrary entity that was
21023 -- already visited for the same subtree and has a corresponding new
21024 -- entity New_Assoc. Old_Assoc was inherited by New_Itype by virtue
21025 -- of copying entities, however it must be updated to New_Assoc.
21027 Old_Assoc := Associated_Node_For_Itype (Itype);
21029 if Nkind (Old_Assoc) in N_Entity then
21030 if NCT_Tables_In_Use then
21031 New_Assoc := NCT_New_Entities.Get (Old_Assoc);
21033 if Present (New_Assoc) then
21034 Set_Associated_Node_For_Itype (New_Itype, New_Assoc);
21038 -- Otherwise the associated node denotes a node. Postpone the update
21039 -- until Phase 2 when the node is replicated. Establish the following
21040 -- mapping within table NCT_Pending_Itypes:
21042 -- Old_Assoc -> (New_Type, ...)
21045 Add_Pending_Itype (Old_Assoc, New_Itype);
21048 -- Deal with the semantic fields of itypes. The fields are visited
21049 -- because they may mention entities that reside within the subtree
21052 Visit_Semantic_Fields (Itype);
21059 procedure Visit_List (List : List_Id) is
21063 -- Note that the element of a syntactic list is always a node, never
21064 -- an entity or itype, hence the call to Visit_Node.
21066 if Present (List) then
21067 Elmt := First (List);
21068 while Present (Elmt) loop
21080 procedure Visit_Node (N : Node_Or_Entity_Id) is
21082 pragma Assert (Nkind (N) not in N_Entity);
21084 if Nkind (N) = N_Expression_With_Actions then
21085 EWA_Level := EWA_Level + 1;
21087 elsif EWA_Level > 0
21088 and then Nkind_In (N, N_Block_Statement,
21090 N_Subprogram_Declaration)
21092 EWA_Inner_Scope_Level := EWA_Inner_Scope_Level + 1;
21096 (Field => Field1 (N),
21100 (Field => Field2 (N),
21104 (Field => Field3 (N),
21108 (Field => Field4 (N),
21112 (Field => Field5 (N),
21116 and then Nkind_In (N, N_Block_Statement,
21118 N_Subprogram_Declaration)
21120 EWA_Inner_Scope_Level := EWA_Inner_Scope_Level - 1;
21122 elsif Nkind (N) = N_Expression_With_Actions then
21123 EWA_Level := EWA_Level - 1;
21127 ---------------------------
21128 -- Visit_Semantic_Fields --
21129 ---------------------------
21131 procedure Visit_Semantic_Fields (Id : Entity_Id) is
21133 pragma Assert (Nkind (Id) in N_Entity);
21135 -- Discriminant_Constraint
21137 if Is_Type (Id) and then Has_Discriminants (Base_Type (Id)) then
21139 (Field => Union_Id (Discriminant_Constraint (Id)),
21146 (Field => Union_Id (Etype (Id)),
21150 -- Packed_Array_Impl_Type
21152 if Is_Array_Type (Id) then
21153 if Present (First_Index (Id)) then
21155 (Field => Union_Id (List_Containing (First_Index (Id))),
21159 if Is_Packed (Id) then
21161 (Field => Union_Id (Packed_Array_Impl_Type (Id)),
21168 if Is_Discrete_Type (Id) then
21170 (Field => Union_Id (Scalar_Range (Id)),
21173 end Visit_Semantic_Fields;
21175 -- Start of processing for New_Copy_Tree
21178 -- Routine New_Copy_Tree performs a deep copy of a subtree by creating
21179 -- shallow copies for each node within, and then updating the child and
21180 -- parent pointers accordingly. This process is straightforward, however
21181 -- the routine must deal with the following complications:
21183 -- * Entities defined within N_Expression_With_Actions nodes must be
21184 -- replicated rather than shared to avoid introducing two identical
21185 -- symbols within the same scope. Note that no other expression can
21186 -- currently define entities.
21189 -- Source_Low : ...;
21190 -- Source_High : ...;
21192 -- <reference to Source_Low>
21193 -- <reference to Source_High>
21196 -- New_Copy_Tree handles this case by first creating new entities
21197 -- and then updating all existing references to point to these new
21204 -- <reference to New_Low>
21205 -- <reference to New_High>
21208 -- * Itypes defined within the subtree must be replicated to avoid any
21209 -- dependencies on invalid or inaccessible data.
21211 -- subtype Source_Itype is ... range Source_Low .. Source_High;
21213 -- New_Copy_Tree handles this case by first creating a new itype in
21214 -- the same fashion as entities, and then updating various relevant
21217 -- subtype New_Itype is ... range New_Low .. New_High;
21219 -- * The Associated_Node_For_Itype field of itypes must be updated to
21220 -- reference the proper replicated entity or node.
21222 -- * Semantic fields of entities such as Etype and Scope must be
21223 -- updated to reference the proper replicated entities.
21225 -- * Semantic fields of nodes such as First_Real_Statement must be
21226 -- updated to reference the proper replicated nodes.
21228 -- To meet all these demands, routine New_Copy_Tree is split into two
21231 -- Phase 1 traverses the tree in order to locate entities and itypes
21232 -- defined within the subtree. New entities are generated and saved in
21233 -- table NCT_New_Entities. The semantic fields of all new entities and
21234 -- itypes are then updated accordingly.
21236 -- Phase 2 traverses the tree in order to replicate each node. Various
21237 -- semantic fields of nodes and entities are updated accordingly.
21239 -- Preparatory phase. Clear the contents of tables NCT_New_Entities and
21240 -- NCT_Pending_Itypes in case a previous call to New_Copy_Tree left some
21243 if NCT_Tables_In_Use then
21244 NCT_Tables_In_Use := False;
21246 NCT_New_Entities.Reset;
21247 NCT_Pending_Itypes.Reset;
21250 -- Populate tables NCT_New_Entities and NCT_Pending_Itypes with data
21251 -- supplied by a linear entity map. The tables offer faster access to
21254 Build_NCT_Tables (Map);
21256 -- Execute Phase 1. Traverse the subtree and generate new entities for
21257 -- the following cases:
21259 -- * An entity defined within an N_Expression_With_Actions node
21261 -- * An itype referenced within the subtree where the associated node
21262 -- is also in the subtree.
21264 -- All new entities are accessible via table NCT_New_Entities, which
21265 -- contains mappings of the form:
21267 -- Old_Entity -> New_Entity
21268 -- Old_Itype -> New_Itype
21270 -- In addition, the associated nodes of all new itypes are mapped in
21271 -- table NCT_Pending_Itypes:
21273 -- Assoc_Nod -> (New_Itype1, New_Itype2, .., New_ItypeN)
21275 Visit_Any_Node (Source);
21277 -- Update the semantic attributes of all new entities generated during
21278 -- Phase 1 before starting Phase 2. The updates could be performed in
21279 -- routine Corresponding_Entity, however this may cause the same entity
21280 -- to be updated multiple times, effectively generating useless nodes.
21281 -- Keeping the updates separates from Phase 2 ensures that only one set
21282 -- of attributes is generated for an entity at any one time.
21284 Update_New_Entities (Map);
21286 -- Execute Phase 2. Replicate the source subtree one node at a time.
21287 -- The following transformations take place:
21289 -- * References to entities and itypes are updated to refer to the
21290 -- new entities and itypes generated during Phase 1.
21292 -- * All Associated_Node_For_Itype attributes of itypes are updated
21293 -- to refer to the new replicated Associated_Node_For_Itype.
21295 return Copy_Node_With_Replacement (Source);
21298 -------------------------
21299 -- New_External_Entity --
21300 -------------------------
21302 function New_External_Entity
21303 (Kind : Entity_Kind;
21304 Scope_Id : Entity_Id;
21305 Sloc_Value : Source_Ptr;
21306 Related_Id : Entity_Id;
21307 Suffix : Character;
21308 Suffix_Index : Int := 0;
21309 Prefix : Character := ' ') return Entity_Id
21311 N : constant Entity_Id :=
21312 Make_Defining_Identifier (Sloc_Value,
21314 (Chars (Related_Id), Suffix, Suffix_Index, Prefix));
21317 Set_Ekind (N, Kind);
21318 Set_Is_Internal (N, True);
21319 Append_Entity (N, Scope_Id);
21320 Set_Public_Status (N);
21322 if Kind in Type_Kind then
21323 Init_Size_Align (N);
21327 end New_External_Entity;
21329 -------------------------
21330 -- New_Internal_Entity --
21331 -------------------------
21333 function New_Internal_Entity
21334 (Kind : Entity_Kind;
21335 Scope_Id : Entity_Id;
21336 Sloc_Value : Source_Ptr;
21337 Id_Char : Character) return Entity_Id
21339 N : constant Entity_Id := Make_Temporary (Sloc_Value, Id_Char);
21342 Set_Ekind (N, Kind);
21343 Set_Is_Internal (N, True);
21344 Append_Entity (N, Scope_Id);
21346 if Kind in Type_Kind then
21347 Init_Size_Align (N);
21351 end New_Internal_Entity;
21357 function Next_Actual (Actual_Id : Node_Id) return Node_Id is
21358 Par : constant Node_Id := Parent (Actual_Id);
21362 -- If we are pointing at a positional parameter, it is a member of a
21363 -- node list (the list of parameters), and the next parameter is the
21364 -- next node on the list, unless we hit a parameter association, then
21365 -- we shift to using the chain whose head is the First_Named_Actual in
21366 -- the parent, and then is threaded using the Next_Named_Actual of the
21367 -- Parameter_Association. All this fiddling is because the original node
21368 -- list is in the textual call order, and what we need is the
21369 -- declaration order.
21371 if Is_List_Member (Actual_Id) then
21372 N := Next (Actual_Id);
21374 if Nkind (N) = N_Parameter_Association then
21376 -- In case of a build-in-place call, the call will no longer be a
21377 -- call; it will have been rewritten.
21379 if Nkind_In (Par, N_Entry_Call_Statement,
21381 N_Procedure_Call_Statement)
21383 return First_Named_Actual (Par);
21385 -- In case of a call rewritten in GNATprove mode while "inlining
21386 -- for proof" go to the original call.
21388 elsif Nkind (Par) = N_Null_Statement then
21392 Nkind (Original_Node (Par)) in N_Subprogram_Call);
21394 return First_Named_Actual (Original_Node (Par));
21403 return Next_Named_Actual (Parent (Actual_Id));
21407 procedure Next_Actual (Actual_Id : in out Node_Id) is
21409 Actual_Id := Next_Actual (Actual_Id);
21416 function Next_Global (Node : Node_Id) return Node_Id is
21418 -- The global item may either be in a list, or by itself, in which case
21419 -- there is no next global item with the same mode.
21421 if Is_List_Member (Node) then
21422 return Next (Node);
21428 procedure Next_Global (Node : in out Node_Id) is
21430 Node := Next_Global (Node);
21433 ----------------------------------
21434 -- New_Requires_Transient_Scope --
21435 ----------------------------------
21437 function New_Requires_Transient_Scope (Id : Entity_Id) return Boolean is
21438 function Caller_Known_Size_Record (Typ : Entity_Id) return Boolean;
21439 -- This is called for untagged records and protected types, with
21440 -- nondefaulted discriminants. Returns True if the size of function
21441 -- results is known at the call site, False otherwise. Returns False
21442 -- if there is a variant part that depends on the discriminants of
21443 -- this type, or if there is an array constrained by the discriminants
21444 -- of this type. ???Currently, this is overly conservative (the array
21445 -- could be nested inside some other record that is constrained by
21446 -- nondiscriminants). That is, the recursive calls are too conservative.
21448 function Large_Max_Size_Mutable (Typ : Entity_Id) return Boolean;
21449 -- Returns True if Typ is a nonlimited record with defaulted
21450 -- discriminants whose max size makes it unsuitable for allocating on
21451 -- the primary stack.
21453 ------------------------------
21454 -- Caller_Known_Size_Record --
21455 ------------------------------
21457 function Caller_Known_Size_Record (Typ : Entity_Id) return Boolean is
21458 pragma Assert (Typ = Underlying_Type (Typ));
21461 if Has_Variant_Part (Typ) and then not Is_Definite_Subtype (Typ) then
21469 Comp := First_Entity (Typ);
21470 while Present (Comp) loop
21472 -- Only look at E_Component entities. No need to look at
21473 -- E_Discriminant entities, and we must ignore internal
21474 -- subtypes generated for constrained components.
21476 if Ekind (Comp) = E_Component then
21478 Comp_Type : constant Entity_Id :=
21479 Underlying_Type (Etype (Comp));
21482 if Is_Record_Type (Comp_Type)
21484 Is_Protected_Type (Comp_Type)
21486 if not Caller_Known_Size_Record (Comp_Type) then
21490 elsif Is_Array_Type (Comp_Type) then
21491 if Size_Depends_On_Discriminant (Comp_Type) then
21498 Next_Entity (Comp);
21503 end Caller_Known_Size_Record;
21505 ------------------------------
21506 -- Large_Max_Size_Mutable --
21507 ------------------------------
21509 function Large_Max_Size_Mutable (Typ : Entity_Id) return Boolean is
21510 pragma Assert (Typ = Underlying_Type (Typ));
21512 function Is_Large_Discrete_Type (T : Entity_Id) return Boolean;
21513 -- Returns true if the discrete type T has a large range
21515 ----------------------------
21516 -- Is_Large_Discrete_Type --
21517 ----------------------------
21519 function Is_Large_Discrete_Type (T : Entity_Id) return Boolean is
21520 Threshold : constant Int := 16;
21521 -- Arbitrary threshold above which we consider it "large". We want
21522 -- a fairly large threshold, because these large types really
21523 -- shouldn't have default discriminants in the first place, in
21527 return UI_To_Int (RM_Size (T)) > Threshold;
21528 end Is_Large_Discrete_Type;
21530 -- Start of processing for Large_Max_Size_Mutable
21533 if Is_Record_Type (Typ)
21534 and then not Is_Limited_View (Typ)
21535 and then Has_Defaulted_Discriminants (Typ)
21537 -- Loop through the components, looking for an array whose upper
21538 -- bound(s) depends on discriminants, where both the subtype of
21539 -- the discriminant and the index subtype are too large.
21545 Comp := First_Entity (Typ);
21546 while Present (Comp) loop
21547 if Ekind (Comp) = E_Component then
21549 Comp_Type : constant Entity_Id :=
21550 Underlying_Type (Etype (Comp));
21557 if Is_Array_Type (Comp_Type) then
21558 Indx := First_Index (Comp_Type);
21560 while Present (Indx) loop
21561 Ityp := Etype (Indx);
21562 Hi := Type_High_Bound (Ityp);
21564 if Nkind (Hi) = N_Identifier
21565 and then Ekind (Entity (Hi)) = E_Discriminant
21566 and then Is_Large_Discrete_Type (Ityp)
21567 and then Is_Large_Discrete_Type
21568 (Etype (Entity (Hi)))
21579 Next_Entity (Comp);
21585 end Large_Max_Size_Mutable;
21587 -- Local declarations
21589 Typ : constant Entity_Id := Underlying_Type (Id);
21591 -- Start of processing for New_Requires_Transient_Scope
21594 -- This is a private type which is not completed yet. This can only
21595 -- happen in a default expression (of a formal parameter or of a
21596 -- record component). Do not expand transient scope in this case.
21601 -- Do not expand transient scope for non-existent procedure return or
21602 -- string literal types.
21604 elsif Typ = Standard_Void_Type
21605 or else Ekind (Typ) = E_String_Literal_Subtype
21609 -- If Typ is a generic formal incomplete type, then we want to look at
21610 -- the actual type.
21612 elsif Ekind (Typ) = E_Record_Subtype
21613 and then Present (Cloned_Subtype (Typ))
21615 return New_Requires_Transient_Scope (Cloned_Subtype (Typ));
21617 -- Functions returning specific tagged types may dispatch on result, so
21618 -- their returned value is allocated on the secondary stack, even in the
21619 -- definite case. We must treat nondispatching functions the same way,
21620 -- because access-to-function types can point at both, so the calling
21621 -- conventions must be compatible. Is_Tagged_Type includes controlled
21622 -- types and class-wide types. Controlled type temporaries need
21625 -- ???It's not clear why we need to return noncontrolled types with
21626 -- controlled components on the secondary stack.
21628 elsif Is_Tagged_Type (Typ) or else Has_Controlled_Component (Typ) then
21631 -- Untagged definite subtypes are known size. This includes all
21632 -- elementary [sub]types. Tasks are known size even if they have
21633 -- discriminants. So we return False here, with one exception:
21634 -- For a type like:
21635 -- type T (Last : Natural := 0) is
21636 -- X : String (1 .. Last);
21638 -- we return True. That's because for "P(F(...));", where F returns T,
21639 -- we don't know the size of the result at the call site, so if we
21640 -- allocated it on the primary stack, we would have to allocate the
21641 -- maximum size, which is way too big.
21643 elsif Is_Definite_Subtype (Typ) or else Is_Task_Type (Typ) then
21644 return Large_Max_Size_Mutable (Typ);
21646 -- Indefinite (discriminated) untagged record or protected type
21648 elsif Is_Record_Type (Typ) or else Is_Protected_Type (Typ) then
21649 return not Caller_Known_Size_Record (Typ);
21651 -- Unconstrained array
21654 pragma Assert (Is_Array_Type (Typ) and not Is_Definite_Subtype (Typ));
21657 end New_Requires_Transient_Scope;
21659 ------------------------
21660 -- No_Caching_Enabled --
21661 ------------------------
21663 function No_Caching_Enabled (Id : Entity_Id) return Boolean is
21664 Prag : constant Node_Id := Get_Pragma (Id, Pragma_No_Caching);
21668 if Present (Prag) then
21669 Arg1 := First (Pragma_Argument_Associations (Prag));
21671 -- The pragma has an optional Boolean expression, the related
21672 -- property is enabled only when the expression evaluates to True.
21674 if Present (Arg1) then
21675 return Is_True (Expr_Value (Get_Pragma_Arg (Arg1)));
21677 -- Otherwise the lack of expression enables the property by
21684 -- The property was never set in the first place
21689 end No_Caching_Enabled;
21691 --------------------------
21692 -- No_Heap_Finalization --
21693 --------------------------
21695 function No_Heap_Finalization (Typ : Entity_Id) return Boolean is
21697 if Ekind_In (Typ, E_Access_Type, E_General_Access_Type)
21698 and then Is_Library_Level_Entity (Typ)
21700 -- A global No_Heap_Finalization pragma applies to all library-level
21701 -- named access-to-object types.
21703 if Present (No_Heap_Finalization_Pragma) then
21706 -- The library-level named access-to-object type itself is subject to
21707 -- pragma No_Heap_Finalization.
21709 elsif Present (Get_Pragma (Typ, Pragma_No_Heap_Finalization)) then
21715 end No_Heap_Finalization;
21717 -----------------------
21718 -- Normalize_Actuals --
21719 -----------------------
21721 -- Chain actuals according to formals of subprogram. If there are no named
21722 -- associations, the chain is simply the list of Parameter Associations,
21723 -- since the order is the same as the declaration order. If there are named
21724 -- associations, then the First_Named_Actual field in the N_Function_Call
21725 -- or N_Procedure_Call_Statement node points to the Parameter_Association
21726 -- node for the parameter that comes first in declaration order. The
21727 -- remaining named parameters are then chained in declaration order using
21728 -- Next_Named_Actual.
21730 -- This routine also verifies that the number of actuals is compatible with
21731 -- the number and default values of formals, but performs no type checking
21732 -- (type checking is done by the caller).
21734 -- If the matching succeeds, Success is set to True and the caller proceeds
21735 -- with type-checking. If the match is unsuccessful, then Success is set to
21736 -- False, and the caller attempts a different interpretation, if there is
21739 -- If the flag Report is on, the call is not overloaded, and a failure to
21740 -- match can be reported here, rather than in the caller.
21742 procedure Normalize_Actuals
21746 Success : out Boolean)
21748 Actuals : constant List_Id := Parameter_Associations (N);
21749 Actual : Node_Id := Empty;
21750 Formal : Entity_Id;
21751 Last : Node_Id := Empty;
21752 First_Named : Node_Id := Empty;
21755 Formals_To_Match : Integer := 0;
21756 Actuals_To_Match : Integer := 0;
21758 procedure Chain (A : Node_Id);
21759 -- Add named actual at the proper place in the list, using the
21760 -- Next_Named_Actual link.
21762 function Reporting return Boolean;
21763 -- Determines if an error is to be reported. To report an error, we
21764 -- need Report to be True, and also we do not report errors caused
21765 -- by calls to init procs that occur within other init procs. Such
21766 -- errors must always be cascaded errors, since if all the types are
21767 -- declared correctly, the compiler will certainly build decent calls.
21773 procedure Chain (A : Node_Id) is
21777 -- Call node points to first actual in list
21779 Set_First_Named_Actual (N, Explicit_Actual_Parameter (A));
21782 Set_Next_Named_Actual (Last, Explicit_Actual_Parameter (A));
21786 Set_Next_Named_Actual (Last, Empty);
21793 function Reporting return Boolean is
21798 elsif not Within_Init_Proc then
21801 elsif Is_Init_Proc (Entity (Name (N))) then
21809 -- Start of processing for Normalize_Actuals
21812 if Is_Access_Type (S) then
21814 -- The name in the call is a function call that returns an access
21815 -- to subprogram. The designated type has the list of formals.
21817 Formal := First_Formal (Designated_Type (S));
21819 Formal := First_Formal (S);
21822 while Present (Formal) loop
21823 Formals_To_Match := Formals_To_Match + 1;
21824 Next_Formal (Formal);
21827 -- Find if there is a named association, and verify that no positional
21828 -- associations appear after named ones.
21830 if Present (Actuals) then
21831 Actual := First (Actuals);
21834 while Present (Actual)
21835 and then Nkind (Actual) /= N_Parameter_Association
21837 Actuals_To_Match := Actuals_To_Match + 1;
21841 if No (Actual) and Actuals_To_Match = Formals_To_Match then
21843 -- Most common case: positional notation, no defaults
21848 elsif Actuals_To_Match > Formals_To_Match then
21850 -- Too many actuals: will not work
21853 if Is_Entity_Name (Name (N)) then
21854 Error_Msg_N ("too many arguments in call to&", Name (N));
21856 Error_Msg_N ("too many arguments in call", N);
21864 First_Named := Actual;
21866 while Present (Actual) loop
21867 if Nkind (Actual) /= N_Parameter_Association then
21869 ("positional parameters not allowed after named ones", Actual);
21874 Actuals_To_Match := Actuals_To_Match + 1;
21880 if Present (Actuals) then
21881 Actual := First (Actuals);
21884 Formal := First_Formal (S);
21885 while Present (Formal) loop
21887 -- Match the formals in order. If the corresponding actual is
21888 -- positional, nothing to do. Else scan the list of named actuals
21889 -- to find the one with the right name.
21891 if Present (Actual)
21892 and then Nkind (Actual) /= N_Parameter_Association
21895 Actuals_To_Match := Actuals_To_Match - 1;
21896 Formals_To_Match := Formals_To_Match - 1;
21899 -- For named parameters, search the list of actuals to find
21900 -- one that matches the next formal name.
21902 Actual := First_Named;
21904 while Present (Actual) loop
21905 if Chars (Selector_Name (Actual)) = Chars (Formal) then
21908 Actuals_To_Match := Actuals_To_Match - 1;
21909 Formals_To_Match := Formals_To_Match - 1;
21917 if Ekind (Formal) /= E_In_Parameter
21918 or else No (Default_Value (Formal))
21921 if (Comes_From_Source (S)
21922 or else Sloc (S) = Standard_Location)
21923 and then Is_Overloadable (S)
21927 Nkind_In (Parent (N), N_Procedure_Call_Statement,
21929 N_Parameter_Association)
21930 and then Ekind (S) /= E_Function
21932 Set_Etype (N, Etype (S));
21935 Error_Msg_Name_1 := Chars (S);
21936 Error_Msg_Sloc := Sloc (S);
21938 ("missing argument for parameter & "
21939 & "in call to % declared #", N, Formal);
21942 elsif Is_Overloadable (S) then
21943 Error_Msg_Name_1 := Chars (S);
21945 -- Point to type derivation that generated the
21948 Error_Msg_Sloc := Sloc (Parent (S));
21951 ("missing argument for parameter & "
21952 & "in call to % (inherited) #", N, Formal);
21956 ("missing argument for parameter &", N, Formal);
21964 Formals_To_Match := Formals_To_Match - 1;
21969 Next_Formal (Formal);
21972 if Formals_To_Match = 0 and then Actuals_To_Match = 0 then
21979 -- Find some superfluous named actual that did not get
21980 -- attached to the list of associations.
21982 Actual := First (Actuals);
21983 while Present (Actual) loop
21984 if Nkind (Actual) = N_Parameter_Association
21985 and then Actual /= Last
21986 and then No (Next_Named_Actual (Actual))
21988 -- A validity check may introduce a copy of a call that
21989 -- includes an extra actual (for example for an unrelated
21990 -- accessibility check). Check that the extra actual matches
21991 -- some extra formal, which must exist already because
21992 -- subprogram must be frozen at this point.
21994 if Present (Extra_Formals (S))
21995 and then not Comes_From_Source (Actual)
21996 and then Nkind (Actual) = N_Parameter_Association
21997 and then Chars (Extra_Formals (S)) =
21998 Chars (Selector_Name (Actual))
22003 ("unmatched actual & in call", Selector_Name (Actual));
22015 end Normalize_Actuals;
22017 --------------------------------
22018 -- Note_Possible_Modification --
22019 --------------------------------
22021 procedure Note_Possible_Modification (N : Node_Id; Sure : Boolean) is
22022 Modification_Comes_From_Source : constant Boolean :=
22023 Comes_From_Source (Parent (N));
22029 -- Loop to find referenced entity, if there is one
22035 if Is_Entity_Name (Exp) then
22036 Ent := Entity (Exp);
22038 -- If the entity is missing, it is an undeclared identifier,
22039 -- and there is nothing to annotate.
22045 elsif Nkind (Exp) = N_Explicit_Dereference then
22047 P : constant Node_Id := Prefix (Exp);
22050 -- In formal verification mode, keep track of all reads and
22051 -- writes through explicit dereferences.
22053 if GNATprove_Mode then
22054 SPARK_Specific.Generate_Dereference (N, 'm');
22057 if Nkind (P) = N_Selected_Component
22058 and then Present (Entry_Formal (Entity (Selector_Name (P))))
22060 -- Case of a reference to an entry formal
22062 Ent := Entry_Formal (Entity (Selector_Name (P)));
22064 elsif Nkind (P) = N_Identifier
22065 and then Nkind (Parent (Entity (P))) = N_Object_Declaration
22066 and then Present (Expression (Parent (Entity (P))))
22067 and then Nkind (Expression (Parent (Entity (P)))) =
22070 -- Case of a reference to a value on which side effects have
22073 Exp := Prefix (Expression (Parent (Entity (P))));
22081 elsif Nkind_In (Exp, N_Type_Conversion,
22082 N_Unchecked_Type_Conversion)
22084 Exp := Expression (Exp);
22087 elsif Nkind_In (Exp, N_Slice,
22088 N_Indexed_Component,
22089 N_Selected_Component)
22091 -- Special check, if the prefix is an access type, then return
22092 -- since we are modifying the thing pointed to, not the prefix.
22093 -- When we are expanding, most usually the prefix is replaced
22094 -- by an explicit dereference, and this test is not needed, but
22095 -- in some cases (notably -gnatc mode and generics) when we do
22096 -- not do full expansion, we need this special test.
22098 if Is_Access_Type (Etype (Prefix (Exp))) then
22101 -- Otherwise go to prefix and keep going
22104 Exp := Prefix (Exp);
22108 -- All other cases, not a modification
22114 -- Now look for entity being referenced
22116 if Present (Ent) then
22117 if Is_Object (Ent) then
22118 if Comes_From_Source (Exp)
22119 or else Modification_Comes_From_Source
22121 -- Give warning if pragma unmodified is given and we are
22122 -- sure this is a modification.
22124 if Has_Pragma_Unmodified (Ent) and then Sure then
22126 -- Note that the entity may be present only as a result
22127 -- of pragma Unused.
22129 if Has_Pragma_Unused (Ent) then
22130 Error_Msg_NE ("??pragma Unused given for &!", N, Ent);
22133 ("??pragma Unmodified given for &!", N, Ent);
22137 Set_Never_Set_In_Source (Ent, False);
22140 Set_Is_True_Constant (Ent, False);
22141 Set_Current_Value (Ent, Empty);
22142 Set_Is_Known_Null (Ent, False);
22144 if not Can_Never_Be_Null (Ent) then
22145 Set_Is_Known_Non_Null (Ent, False);
22148 -- Follow renaming chain
22150 if (Ekind (Ent) = E_Variable or else Ekind (Ent) = E_Constant)
22151 and then Present (Renamed_Object (Ent))
22153 Exp := Renamed_Object (Ent);
22155 -- If the entity is the loop variable in an iteration over
22156 -- a container, retrieve container expression to indicate
22157 -- possible modification.
22159 if Present (Related_Expression (Ent))
22160 and then Nkind (Parent (Related_Expression (Ent))) =
22161 N_Iterator_Specification
22163 Exp := Original_Node (Related_Expression (Ent));
22168 -- The expression may be the renaming of a subcomponent of an
22169 -- array or container. The assignment to the subcomponent is
22170 -- a modification of the container.
22172 elsif Comes_From_Source (Original_Node (Exp))
22173 and then Nkind_In (Original_Node (Exp), N_Selected_Component,
22174 N_Indexed_Component)
22176 Exp := Prefix (Original_Node (Exp));
22180 -- Generate a reference only if the assignment comes from
22181 -- source. This excludes, for example, calls to a dispatching
22182 -- assignment operation when the left-hand side is tagged. In
22183 -- GNATprove mode, we need those references also on generated
22184 -- code, as these are used to compute the local effects of
22187 if Modification_Comes_From_Source or GNATprove_Mode then
22188 Generate_Reference (Ent, Exp, 'm');
22190 -- If the target of the assignment is the bound variable
22191 -- in an iterator, indicate that the corresponding array
22192 -- or container is also modified.
22194 if Ada_Version >= Ada_2012
22195 and then Nkind (Parent (Ent)) = N_Iterator_Specification
22198 Domain : constant Node_Id := Name (Parent (Ent));
22201 -- TBD : in the full version of the construct, the
22202 -- domain of iteration can be given by an expression.
22204 if Is_Entity_Name (Domain) then
22205 Generate_Reference (Entity (Domain), Exp, 'm');
22206 Set_Is_True_Constant (Entity (Domain), False);
22207 Set_Never_Set_In_Source (Entity (Domain), False);
22216 -- If we are sure this is a modification from source, and we know
22217 -- this modifies a constant, then give an appropriate warning.
22220 and then Modification_Comes_From_Source
22221 and then Overlays_Constant (Ent)
22222 and then Address_Clause_Overlay_Warnings
22225 Addr : constant Node_Id := Address_Clause (Ent);
22230 Find_Overlaid_Entity (Addr, O_Ent, Off);
22232 Error_Msg_Sloc := Sloc (Addr);
22234 ("??constant& may be modified via address clause#",
22245 end Note_Possible_Modification;
22251 function Null_Status (N : Node_Id) return Null_Status_Kind is
22252 function Is_Null_Excluding_Def (Def : Node_Id) return Boolean;
22253 -- Determine whether definition Def carries a null exclusion
22255 function Null_Status_Of_Entity (Id : Entity_Id) return Null_Status_Kind;
22256 -- Determine the null status of arbitrary entity Id
22258 function Null_Status_Of_Type (Typ : Entity_Id) return Null_Status_Kind;
22259 -- Determine the null status of type Typ
22261 ---------------------------
22262 -- Is_Null_Excluding_Def --
22263 ---------------------------
22265 function Is_Null_Excluding_Def (Def : Node_Id) return Boolean is
22268 Nkind_In (Def, N_Access_Definition,
22269 N_Access_Function_Definition,
22270 N_Access_Procedure_Definition,
22271 N_Access_To_Object_Definition,
22272 N_Component_Definition,
22273 N_Derived_Type_Definition)
22274 and then Null_Exclusion_Present (Def);
22275 end Is_Null_Excluding_Def;
22277 ---------------------------
22278 -- Null_Status_Of_Entity --
22279 ---------------------------
22281 function Null_Status_Of_Entity
22282 (Id : Entity_Id) return Null_Status_Kind
22284 Decl : constant Node_Id := Declaration_Node (Id);
22288 -- The value of an imported or exported entity may be set externally
22289 -- regardless of a null exclusion. As a result, the value cannot be
22290 -- determined statically.
22292 if Is_Imported (Id) or else Is_Exported (Id) then
22295 elsif Nkind_In (Decl, N_Component_Declaration,
22296 N_Discriminant_Specification,
22297 N_Formal_Object_Declaration,
22298 N_Object_Declaration,
22299 N_Object_Renaming_Declaration,
22300 N_Parameter_Specification)
22302 -- A component declaration yields a non-null value when either
22303 -- its component definition or access definition carries a null
22306 if Nkind (Decl) = N_Component_Declaration then
22307 Def := Component_Definition (Decl);
22309 if Is_Null_Excluding_Def (Def) then
22310 return Is_Non_Null;
22313 Def := Access_Definition (Def);
22315 if Present (Def) and then Is_Null_Excluding_Def (Def) then
22316 return Is_Non_Null;
22319 -- A formal object declaration yields a non-null value if its
22320 -- access definition carries a null exclusion. If the object is
22321 -- default initialized, then the value depends on the expression.
22323 elsif Nkind (Decl) = N_Formal_Object_Declaration then
22324 Def := Access_Definition (Decl);
22326 if Present (Def) and then Is_Null_Excluding_Def (Def) then
22327 return Is_Non_Null;
22330 -- A constant may yield a null or non-null value depending on its
22331 -- initialization expression.
22333 elsif Ekind (Id) = E_Constant then
22334 return Null_Status (Constant_Value (Id));
22336 -- The construct yields a non-null value when it has a null
22339 elsif Null_Exclusion_Present (Decl) then
22340 return Is_Non_Null;
22342 -- An object renaming declaration yields a non-null value if its
22343 -- access definition carries a null exclusion. Otherwise the value
22344 -- depends on the renamed name.
22346 elsif Nkind (Decl) = N_Object_Renaming_Declaration then
22347 Def := Access_Definition (Decl);
22349 if Present (Def) and then Is_Null_Excluding_Def (Def) then
22350 return Is_Non_Null;
22353 return Null_Status (Name (Decl));
22358 -- At this point the declaration of the entity does not carry a null
22359 -- exclusion and lacks an initialization expression. Check the status
22362 return Null_Status_Of_Type (Etype (Id));
22363 end Null_Status_Of_Entity;
22365 -------------------------
22366 -- Null_Status_Of_Type --
22367 -------------------------
22369 function Null_Status_Of_Type (Typ : Entity_Id) return Null_Status_Kind is
22374 -- Traverse the type chain looking for types with null exclusion
22377 while Present (Curr) and then Etype (Curr) /= Curr loop
22378 Decl := Parent (Curr);
22380 -- Guard against itypes which do not always have declarations. A
22381 -- type yields a non-null value if it carries a null exclusion.
22383 if Present (Decl) then
22384 if Nkind (Decl) = N_Full_Type_Declaration
22385 and then Is_Null_Excluding_Def (Type_Definition (Decl))
22387 return Is_Non_Null;
22389 elsif Nkind (Decl) = N_Subtype_Declaration
22390 and then Null_Exclusion_Present (Decl)
22392 return Is_Non_Null;
22396 Curr := Etype (Curr);
22399 -- The type chain does not contain any null excluding types
22402 end Null_Status_Of_Type;
22404 -- Start of processing for Null_Status
22407 -- Prevent cascaded errors or infinite loops when trying to determine
22408 -- the null status of an erroneous construct.
22410 if Error_Posted (N) then
22413 -- An allocator always creates a non-null value
22415 elsif Nkind (N) = N_Allocator then
22416 return Is_Non_Null;
22418 -- Taking the 'Access of something yields a non-null value
22420 elsif Nkind (N) = N_Attribute_Reference
22421 and then Nam_In (Attribute_Name (N), Name_Access,
22422 Name_Unchecked_Access,
22423 Name_Unrestricted_Access)
22425 return Is_Non_Null;
22427 -- "null" yields null
22429 elsif Nkind (N) = N_Null then
22432 -- Check the status of the operand of a type conversion
22434 elsif Nkind (N) = N_Type_Conversion then
22435 return Null_Status (Expression (N));
22437 -- The input denotes a reference to an entity. Determine whether the
22438 -- entity or its type yields a null or non-null value.
22440 elsif Is_Entity_Name (N) and then Present (Entity (N)) then
22441 return Null_Status_Of_Entity (Entity (N));
22444 -- Otherwise it is not possible to determine the null status of the
22445 -- subexpression at compile time without resorting to simple flow
22451 --------------------------------------
22452 -- Null_To_Null_Address_Convert_OK --
22453 --------------------------------------
22455 function Null_To_Null_Address_Convert_OK
22457 Typ : Entity_Id := Empty) return Boolean
22460 if not Relaxed_RM_Semantics then
22464 if Nkind (N) = N_Null then
22465 return Present (Typ) and then Is_Descendant_Of_Address (Typ);
22467 elsif Nkind_In (N, N_Op_Eq, N_Op_Ge, N_Op_Gt, N_Op_Le, N_Op_Lt, N_Op_Ne)
22470 L : constant Node_Id := Left_Opnd (N);
22471 R : constant Node_Id := Right_Opnd (N);
22474 -- We check the Etype of the complementary operand since the
22475 -- N_Null node is not decorated at this stage.
22478 ((Nkind (L) = N_Null
22479 and then Is_Descendant_Of_Address (Etype (R)))
22481 (Nkind (R) = N_Null
22482 and then Is_Descendant_Of_Address (Etype (L))));
22487 end Null_To_Null_Address_Convert_OK;
22489 ---------------------------------
22490 -- Number_Of_Elements_In_Array --
22491 ---------------------------------
22493 function Number_Of_Elements_In_Array (T : Entity_Id) return Int is
22501 pragma Assert (Is_Array_Type (T));
22503 Indx := First_Index (T);
22504 while Present (Indx) loop
22505 Typ := Underlying_Type (Etype (Indx));
22507 -- Never look at junk bounds of a generic type
22509 if Is_Generic_Type (Typ) then
22513 -- Check the array bounds are known at compile time and return zero
22514 -- if they are not.
22516 Low := Type_Low_Bound (Typ);
22517 High := Type_High_Bound (Typ);
22519 if not Compile_Time_Known_Value (Low) then
22521 elsif not Compile_Time_Known_Value (High) then
22525 Num * UI_To_Int ((Expr_Value (High) - Expr_Value (Low) + 1));
22532 end Number_Of_Elements_In_Array;
22534 -------------------------
22535 -- Object_Access_Level --
22536 -------------------------
22538 -- Returns the static accessibility level of the view denoted by Obj. Note
22539 -- that the value returned is the result of a call to Scope_Depth. Only
22540 -- scope depths associated with dynamic scopes can actually be returned.
22541 -- Since only relative levels matter for accessibility checking, the fact
22542 -- that the distance between successive levels of accessibility is not
22543 -- always one is immaterial (invariant: if level(E2) is deeper than
22544 -- level(E1), then Scope_Depth(E1) < Scope_Depth(E2)).
22546 function Object_Access_Level (Obj : Node_Id) return Uint is
22547 function Is_Interface_Conversion (N : Node_Id) return Boolean;
22548 -- Determine whether N is a construct of the form
22549 -- Some_Type (Operand._tag'Address)
22550 -- This construct appears in the context of dispatching calls.
22552 function Reference_To (Obj : Node_Id) return Node_Id;
22553 -- An explicit dereference is created when removing side effects from
22554 -- expressions for constraint checking purposes. In this case a local
22555 -- access type is created for it. The correct access level is that of
22556 -- the original source node. We detect this case by noting that the
22557 -- prefix of the dereference is created by an object declaration whose
22558 -- initial expression is a reference.
22560 -----------------------------
22561 -- Is_Interface_Conversion --
22562 -----------------------------
22564 function Is_Interface_Conversion (N : Node_Id) return Boolean is
22566 return Nkind (N) = N_Unchecked_Type_Conversion
22567 and then Nkind (Expression (N)) = N_Attribute_Reference
22568 and then Attribute_Name (Expression (N)) = Name_Address;
22569 end Is_Interface_Conversion;
22575 function Reference_To (Obj : Node_Id) return Node_Id is
22576 Pref : constant Node_Id := Prefix (Obj);
22578 if Is_Entity_Name (Pref)
22579 and then Nkind (Parent (Entity (Pref))) = N_Object_Declaration
22580 and then Present (Expression (Parent (Entity (Pref))))
22581 and then Nkind (Expression (Parent (Entity (Pref)))) = N_Reference
22583 return (Prefix (Expression (Parent (Entity (Pref)))));
22593 -- Start of processing for Object_Access_Level
22596 if Nkind (Obj) = N_Defining_Identifier
22597 or else Is_Entity_Name (Obj)
22599 if Nkind (Obj) = N_Defining_Identifier then
22605 if Is_Prival (E) then
22606 E := Prival_Link (E);
22609 -- If E is a type then it denotes a current instance. For this case
22610 -- we add one to the normal accessibility level of the type to ensure
22611 -- that current instances are treated as always being deeper than
22612 -- than the level of any visible named access type (see 3.10.2(21)).
22614 if Is_Type (E) then
22615 return Type_Access_Level (E) + 1;
22617 elsif Present (Renamed_Object (E)) then
22618 return Object_Access_Level (Renamed_Object (E));
22620 -- Similarly, if E is a component of the current instance of a
22621 -- protected type, any instance of it is assumed to be at a deeper
22622 -- level than the type. For a protected object (whose type is an
22623 -- anonymous protected type) its components are at the same level
22624 -- as the type itself.
22626 elsif not Is_Overloadable (E)
22627 and then Ekind (Scope (E)) = E_Protected_Type
22628 and then Comes_From_Source (Scope (E))
22630 return Type_Access_Level (Scope (E)) + 1;
22633 -- Aliased formals of functions take their access level from the
22634 -- point of call, i.e. require a dynamic check. For static check
22635 -- purposes, this is smaller than the level of the subprogram
22636 -- itself. For procedures the aliased makes no difference.
22639 and then Is_Aliased (E)
22640 and then Ekind (Scope (E)) = E_Function
22642 return Type_Access_Level (Etype (E));
22645 return Scope_Depth (Enclosing_Dynamic_Scope (E));
22649 elsif Nkind_In (Obj, N_Indexed_Component, N_Selected_Component) then
22650 if Is_Access_Type (Etype (Prefix (Obj))) then
22651 return Type_Access_Level (Etype (Prefix (Obj)));
22653 return Object_Access_Level (Prefix (Obj));
22656 elsif Nkind (Obj) = N_Explicit_Dereference then
22658 -- If the prefix is a selected access discriminant then we make a
22659 -- recursive call on the prefix, which will in turn check the level
22660 -- of the prefix object of the selected discriminant.
22662 -- In Ada 2012, if the discriminant has implicit dereference and
22663 -- the context is a selected component, treat this as an object of
22664 -- unknown scope (see below). This is necessary in compile-only mode;
22665 -- otherwise expansion will already have transformed the prefix into
22668 if Nkind (Prefix (Obj)) = N_Selected_Component
22669 and then Ekind (Etype (Prefix (Obj))) = E_Anonymous_Access_Type
22671 Ekind (Entity (Selector_Name (Prefix (Obj)))) = E_Discriminant
22673 (not Has_Implicit_Dereference
22674 (Entity (Selector_Name (Prefix (Obj))))
22675 or else Nkind (Parent (Obj)) /= N_Selected_Component)
22677 return Object_Access_Level (Prefix (Obj));
22679 -- Detect an interface conversion in the context of a dispatching
22680 -- call. Use the original form of the conversion to find the access
22681 -- level of the operand.
22683 elsif Is_Interface (Etype (Obj))
22684 and then Is_Interface_Conversion (Prefix (Obj))
22685 and then Nkind (Original_Node (Obj)) = N_Type_Conversion
22687 return Object_Access_Level (Original_Node (Obj));
22689 elsif not Comes_From_Source (Obj) then
22691 Ref : constant Node_Id := Reference_To (Obj);
22693 if Present (Ref) then
22694 return Object_Access_Level (Ref);
22696 return Type_Access_Level (Etype (Prefix (Obj)));
22701 return Type_Access_Level (Etype (Prefix (Obj)));
22704 elsif Nkind_In (Obj, N_Type_Conversion, N_Unchecked_Type_Conversion) then
22705 return Object_Access_Level (Expression (Obj));
22707 elsif Nkind (Obj) = N_Function_Call then
22709 -- Function results are objects, so we get either the access level of
22710 -- the function or, in the case of an indirect call, the level of the
22711 -- access-to-subprogram type. (This code is used for Ada 95, but it
22712 -- looks wrong, because it seems that we should be checking the level
22713 -- of the call itself, even for Ada 95. However, using the Ada 2005
22714 -- version of the code causes regressions in several tests that are
22715 -- compiled with -gnat95. ???)
22717 if Ada_Version < Ada_2005 then
22718 if Is_Entity_Name (Name (Obj)) then
22719 return Subprogram_Access_Level (Entity (Name (Obj)));
22721 return Type_Access_Level (Etype (Prefix (Name (Obj))));
22724 -- For Ada 2005, the level of the result object of a function call is
22725 -- defined to be the level of the call's innermost enclosing master.
22726 -- We determine that by querying the depth of the innermost enclosing
22730 Return_Master_Scope_Depth_Of_Call : declare
22731 function Innermost_Master_Scope_Depth
22732 (N : Node_Id) return Uint;
22733 -- Returns the scope depth of the given node's innermost
22734 -- enclosing dynamic scope (effectively the accessibility
22735 -- level of the innermost enclosing master).
22737 ----------------------------------
22738 -- Innermost_Master_Scope_Depth --
22739 ----------------------------------
22741 function Innermost_Master_Scope_Depth
22742 (N : Node_Id) return Uint
22744 Node_Par : Node_Id := Parent (N);
22747 -- Locate the nearest enclosing node (by traversing Parents)
22748 -- that Defining_Entity can be applied to, and return the
22749 -- depth of that entity's nearest enclosing dynamic scope.
22751 while Present (Node_Par) loop
22752 case Nkind (Node_Par) is
22753 when N_Abstract_Subprogram_Declaration
22754 | N_Block_Statement
22756 | N_Component_Declaration
22758 | N_Entry_Declaration
22759 | N_Exception_Declaration
22760 | N_Formal_Object_Declaration
22761 | N_Formal_Package_Declaration
22762 | N_Formal_Subprogram_Declaration
22763 | N_Formal_Type_Declaration
22764 | N_Full_Type_Declaration
22765 | N_Function_Specification
22766 | N_Generic_Declaration
22767 | N_Generic_Instantiation
22768 | N_Implicit_Label_Declaration
22769 | N_Incomplete_Type_Declaration
22770 | N_Loop_Parameter_Specification
22771 | N_Number_Declaration
22772 | N_Object_Declaration
22773 | N_Package_Declaration
22774 | N_Package_Specification
22775 | N_Parameter_Specification
22776 | N_Private_Extension_Declaration
22777 | N_Private_Type_Declaration
22778 | N_Procedure_Specification
22780 | N_Protected_Type_Declaration
22781 | N_Renaming_Declaration
22782 | N_Single_Protected_Declaration
22783 | N_Single_Task_Declaration
22784 | N_Subprogram_Declaration
22785 | N_Subtype_Declaration
22787 | N_Task_Type_Declaration
22790 (Nearest_Dynamic_Scope
22791 (Defining_Entity (Node_Par)));
22793 -- For a return statement within a function, return
22794 -- the depth of the function itself. This is not just
22795 -- a small optimization, but matters when analyzing
22796 -- the expression in an expression function before
22797 -- the body is created.
22799 when N_Simple_Return_Statement =>
22800 if Ekind (Current_Scope) = E_Function then
22801 return Scope_Depth (Current_Scope);
22808 Node_Par := Parent (Node_Par);
22811 pragma Assert (False);
22813 -- Should never reach the following return
22815 return Scope_Depth (Current_Scope) + 1;
22816 end Innermost_Master_Scope_Depth;
22818 -- Start of processing for Return_Master_Scope_Depth_Of_Call
22821 return Innermost_Master_Scope_Depth (Obj);
22822 end Return_Master_Scope_Depth_Of_Call;
22825 -- For convenience we handle qualified expressions, even though they
22826 -- aren't technically object names.
22828 elsif Nkind (Obj) = N_Qualified_Expression then
22829 return Object_Access_Level (Expression (Obj));
22831 -- Ditto for aggregates. They have the level of the temporary that
22832 -- will hold their value.
22834 elsif Nkind (Obj) = N_Aggregate then
22835 return Object_Access_Level (Current_Scope);
22837 -- Otherwise return the scope level of Standard. (If there are cases
22838 -- that fall through to this point they will be treated as having
22839 -- global accessibility for now. ???)
22842 return Scope_Depth (Standard_Standard);
22844 end Object_Access_Level;
22846 ----------------------------------
22847 -- Old_Requires_Transient_Scope --
22848 ----------------------------------
22850 function Old_Requires_Transient_Scope (Id : Entity_Id) return Boolean is
22851 Typ : constant Entity_Id := Underlying_Type (Id);
22854 -- This is a private type which is not completed yet. This can only
22855 -- happen in a default expression (of a formal parameter or of a
22856 -- record component). Do not expand transient scope in this case.
22861 -- Do not expand transient scope for non-existent procedure return
22863 elsif Typ = Standard_Void_Type then
22866 -- Elementary types do not require a transient scope
22868 elsif Is_Elementary_Type (Typ) then
22871 -- Generally, indefinite subtypes require a transient scope, since the
22872 -- back end cannot generate temporaries, since this is not a valid type
22873 -- for declaring an object. It might be possible to relax this in the
22874 -- future, e.g. by declaring the maximum possible space for the type.
22876 elsif not Is_Definite_Subtype (Typ) then
22879 -- Functions returning tagged types may dispatch on result so their
22880 -- returned value is allocated on the secondary stack. Controlled
22881 -- type temporaries need finalization.
22883 elsif Is_Tagged_Type (Typ) or else Has_Controlled_Component (Typ) then
22888 elsif Is_Record_Type (Typ) then
22893 Comp := First_Entity (Typ);
22894 while Present (Comp) loop
22895 if Ekind (Comp) = E_Component then
22897 -- ???It's not clear we need a full recursive call to
22898 -- Old_Requires_Transient_Scope here. Note that the
22899 -- following can't happen.
22901 pragma Assert (Is_Definite_Subtype (Etype (Comp)));
22902 pragma Assert (not Has_Controlled_Component (Etype (Comp)));
22904 if Old_Requires_Transient_Scope (Etype (Comp)) then
22909 Next_Entity (Comp);
22915 -- String literal types never require transient scope
22917 elsif Ekind (Typ) = E_String_Literal_Subtype then
22920 -- Array type. Note that we already know that this is a constrained
22921 -- array, since unconstrained arrays will fail the indefinite test.
22923 elsif Is_Array_Type (Typ) then
22925 -- If component type requires a transient scope, the array does too
22927 if Old_Requires_Transient_Scope (Component_Type (Typ)) then
22930 -- Otherwise, we only need a transient scope if the size depends on
22931 -- the value of one or more discriminants.
22934 return Size_Depends_On_Discriminant (Typ);
22937 -- All other cases do not require a transient scope
22940 pragma Assert (Is_Protected_Type (Typ) or else Is_Task_Type (Typ));
22943 end Old_Requires_Transient_Scope;
22945 ---------------------------------
22946 -- Original_Aspect_Pragma_Name --
22947 ---------------------------------
22949 function Original_Aspect_Pragma_Name (N : Node_Id) return Name_Id is
22951 Item_Nam : Name_Id;
22954 pragma Assert (Nkind_In (N, N_Aspect_Specification, N_Pragma));
22958 -- The pragma was generated to emulate an aspect, use the original
22959 -- aspect specification.
22961 if Nkind (Item) = N_Pragma and then From_Aspect_Specification (Item) then
22962 Item := Corresponding_Aspect (Item);
22965 -- Retrieve the name of the aspect/pragma. Note that Pre, Pre_Class,
22966 -- Post and Post_Class rewrite their pragma identifier to preserve the
22968 -- ??? this is kludgey
22970 if Nkind (Item) = N_Pragma then
22971 Item_Nam := Chars (Original_Node (Pragma_Identifier (Item)));
22974 pragma Assert (Nkind (Item) = N_Aspect_Specification);
22975 Item_Nam := Chars (Identifier (Item));
22978 -- Deal with 'Class by converting the name to its _XXX form
22980 if Class_Present (Item) then
22981 if Item_Nam = Name_Invariant then
22982 Item_Nam := Name_uInvariant;
22984 elsif Item_Nam = Name_Post then
22985 Item_Nam := Name_uPost;
22987 elsif Item_Nam = Name_Pre then
22988 Item_Nam := Name_uPre;
22990 elsif Nam_In (Item_Nam, Name_Type_Invariant,
22991 Name_Type_Invariant_Class)
22993 Item_Nam := Name_uType_Invariant;
22995 -- Nothing to do for other cases (e.g. a Check that derived from
22996 -- Pre_Class and has the flag set). Also we do nothing if the name
22997 -- is already in special _xxx form.
23003 end Original_Aspect_Pragma_Name;
23005 --------------------------------------
23006 -- Original_Corresponding_Operation --
23007 --------------------------------------
23009 function Original_Corresponding_Operation (S : Entity_Id) return Entity_Id
23011 Typ : constant Entity_Id := Find_Dispatching_Type (S);
23014 -- If S is an inherited primitive S2 the original corresponding
23015 -- operation of S is the original corresponding operation of S2
23017 if Present (Alias (S))
23018 and then Find_Dispatching_Type (Alias (S)) /= Typ
23020 return Original_Corresponding_Operation (Alias (S));
23022 -- If S overrides an inherited subprogram S2 the original corresponding
23023 -- operation of S is the original corresponding operation of S2
23025 elsif Present (Overridden_Operation (S)) then
23026 return Original_Corresponding_Operation (Overridden_Operation (S));
23028 -- otherwise it is S itself
23033 end Original_Corresponding_Operation;
23035 -------------------
23036 -- Output_Entity --
23037 -------------------
23039 procedure Output_Entity (Id : Entity_Id) is
23043 Scop := Scope (Id);
23045 -- The entity may lack a scope when it is in the process of being
23046 -- analyzed. Use the current scope as an approximation.
23049 Scop := Current_Scope;
23052 Output_Name (Chars (Id), Scop);
23059 procedure Output_Name (Nam : Name_Id; Scop : Entity_Id := Current_Scope) is
23063 (Get_Qualified_Name
23070 ----------------------
23071 -- Policy_In_Effect --
23072 ----------------------
23074 function Policy_In_Effect (Policy : Name_Id) return Name_Id is
23075 function Policy_In_List (List : Node_Id) return Name_Id;
23076 -- Determine the mode of a policy in a N_Pragma list
23078 --------------------
23079 -- Policy_In_List --
23080 --------------------
23082 function Policy_In_List (List : Node_Id) return Name_Id is
23089 while Present (Prag) loop
23090 Arg1 := First (Pragma_Argument_Associations (Prag));
23091 Arg2 := Next (Arg1);
23093 Arg1 := Get_Pragma_Arg (Arg1);
23094 Arg2 := Get_Pragma_Arg (Arg2);
23096 -- The current Check_Policy pragma matches the requested policy or
23097 -- appears in the single argument form (Assertion, policy_id).
23099 if Nam_In (Chars (Arg1), Name_Assertion, Policy) then
23100 return Chars (Arg2);
23103 Prag := Next_Pragma (Prag);
23107 end Policy_In_List;
23113 -- Start of processing for Policy_In_Effect
23116 if not Is_Valid_Assertion_Kind (Policy) then
23117 raise Program_Error;
23120 -- Inspect all policy pragmas that appear within scopes (if any)
23122 Kind := Policy_In_List (Check_Policy_List);
23124 -- Inspect all configuration policy pragmas (if any)
23126 if Kind = No_Name then
23127 Kind := Policy_In_List (Check_Policy_List_Config);
23130 -- The context lacks policy pragmas, determine the mode based on whether
23131 -- assertions are enabled at the configuration level. This ensures that
23132 -- the policy is preserved when analyzing generics.
23134 if Kind = No_Name then
23135 if Assertions_Enabled_Config then
23136 Kind := Name_Check;
23138 Kind := Name_Ignore;
23142 -- In CodePeer mode and GNATprove mode, we need to consider all
23143 -- assertions, unless they are disabled. Force Name_Check on
23144 -- ignored assertions.
23146 if Nam_In (Kind, Name_Ignore, Name_Off)
23147 and then (CodePeer_Mode or GNATprove_Mode)
23149 Kind := Name_Check;
23153 end Policy_In_Effect;
23155 ----------------------------------
23156 -- Predicate_Tests_On_Arguments --
23157 ----------------------------------
23159 function Predicate_Tests_On_Arguments (Subp : Entity_Id) return Boolean is
23161 -- Always test predicates on indirect call
23163 if Ekind (Subp) = E_Subprogram_Type then
23166 -- Do not test predicates on call to generated default Finalize, since
23167 -- we are not interested in whether something we are finalizing (and
23168 -- typically destroying) satisfies its predicates.
23170 elsif Chars (Subp) = Name_Finalize
23171 and then not Comes_From_Source (Subp)
23175 -- Do not test predicates on any internally generated routines
23177 elsif Is_Internal_Name (Chars (Subp)) then
23180 -- Do not test predicates on call to Init_Proc, since if needed the
23181 -- predicate test will occur at some other point.
23183 elsif Is_Init_Proc (Subp) then
23186 -- Do not test predicates on call to predicate function, since this
23187 -- would cause infinite recursion.
23189 elsif Ekind (Subp) = E_Function
23190 and then (Is_Predicate_Function (Subp)
23192 Is_Predicate_Function_M (Subp))
23196 -- For now, no other exceptions
23201 end Predicate_Tests_On_Arguments;
23203 -----------------------
23204 -- Private_Component --
23205 -----------------------
23207 function Private_Component (Type_Id : Entity_Id) return Entity_Id is
23208 Ancestor : constant Entity_Id := Base_Type (Type_Id);
23210 function Trace_Components
23212 Check : Boolean) return Entity_Id;
23213 -- Recursive function that does the work, and checks against circular
23214 -- definition for each subcomponent type.
23216 ----------------------
23217 -- Trace_Components --
23218 ----------------------
23220 function Trace_Components
23222 Check : Boolean) return Entity_Id
23224 Btype : constant Entity_Id := Base_Type (T);
23225 Component : Entity_Id;
23227 Candidate : Entity_Id := Empty;
23230 if Check and then Btype = Ancestor then
23231 Error_Msg_N ("circular type definition", Type_Id);
23235 if Is_Private_Type (Btype) and then not Is_Generic_Type (Btype) then
23236 if Present (Full_View (Btype))
23237 and then Is_Record_Type (Full_View (Btype))
23238 and then not Is_Frozen (Btype)
23240 -- To indicate that the ancestor depends on a private type, the
23241 -- current Btype is sufficient. However, to check for circular
23242 -- definition we must recurse on the full view.
23244 Candidate := Trace_Components (Full_View (Btype), True);
23246 if Candidate = Any_Type then
23256 elsif Is_Array_Type (Btype) then
23257 return Trace_Components (Component_Type (Btype), True);
23259 elsif Is_Record_Type (Btype) then
23260 Component := First_Entity (Btype);
23261 while Present (Component)
23262 and then Comes_From_Source (Component)
23264 -- Skip anonymous types generated by constrained components
23266 if not Is_Type (Component) then
23267 P := Trace_Components (Etype (Component), True);
23269 if Present (P) then
23270 if P = Any_Type then
23278 Next_Entity (Component);
23286 end Trace_Components;
23288 -- Start of processing for Private_Component
23291 return Trace_Components (Type_Id, False);
23292 end Private_Component;
23294 ---------------------------
23295 -- Primitive_Names_Match --
23296 ---------------------------
23298 function Primitive_Names_Match (E1, E2 : Entity_Id) return Boolean is
23299 function Non_Internal_Name (E : Entity_Id) return Name_Id;
23300 -- Given an internal name, returns the corresponding non-internal name
23302 ------------------------
23303 -- Non_Internal_Name --
23304 ------------------------
23306 function Non_Internal_Name (E : Entity_Id) return Name_Id is
23308 Get_Name_String (Chars (E));
23309 Name_Len := Name_Len - 1;
23311 end Non_Internal_Name;
23313 -- Start of processing for Primitive_Names_Match
23316 pragma Assert (Present (E1) and then Present (E2));
23318 return Chars (E1) = Chars (E2)
23320 (not Is_Internal_Name (Chars (E1))
23321 and then Is_Internal_Name (Chars (E2))
23322 and then Non_Internal_Name (E2) = Chars (E1))
23324 (not Is_Internal_Name (Chars (E2))
23325 and then Is_Internal_Name (Chars (E1))
23326 and then Non_Internal_Name (E1) = Chars (E2))
23328 (Is_Predefined_Dispatching_Operation (E1)
23329 and then Is_Predefined_Dispatching_Operation (E2)
23330 and then Same_TSS (E1, E2))
23332 (Is_Init_Proc (E1) and then Is_Init_Proc (E2));
23333 end Primitive_Names_Match;
23335 -----------------------
23336 -- Process_End_Label --
23337 -----------------------
23339 procedure Process_End_Label
23348 Label_Ref : Boolean;
23349 -- Set True if reference to end label itself is required
23352 -- Gets set to the operator symbol or identifier that references the
23353 -- entity Ent. For the child unit case, this is the identifier from the
23354 -- designator. For other cases, this is simply Endl.
23356 procedure Generate_Parent_Ref (N : Node_Id; E : Entity_Id);
23357 -- N is an identifier node that appears as a parent unit reference in
23358 -- the case where Ent is a child unit. This procedure generates an
23359 -- appropriate cross-reference entry. E is the corresponding entity.
23361 -------------------------
23362 -- Generate_Parent_Ref --
23363 -------------------------
23365 procedure Generate_Parent_Ref (N : Node_Id; E : Entity_Id) is
23367 -- If names do not match, something weird, skip reference
23369 if Chars (E) = Chars (N) then
23371 -- Generate the reference. We do NOT consider this as a reference
23372 -- for unreferenced symbol purposes.
23374 Generate_Reference (E, N, 'r', Set_Ref => False, Force => True);
23376 if Style_Check then
23377 Style.Check_Identifier (N, E);
23380 end Generate_Parent_Ref;
23382 -- Start of processing for Process_End_Label
23385 -- If no node, ignore. This happens in some error situations, and
23386 -- also for some internally generated structures where no end label
23387 -- references are required in any case.
23393 -- Nothing to do if no End_Label, happens for internally generated
23394 -- constructs where we don't want an end label reference anyway. Also
23395 -- nothing to do if Endl is a string literal, which means there was
23396 -- some prior error (bad operator symbol)
23398 Endl := End_Label (N);
23400 if No (Endl) or else Nkind (Endl) = N_String_Literal then
23404 -- Reference node is not in extended main source unit
23406 if not In_Extended_Main_Source_Unit (N) then
23408 -- Generally we do not collect references except for the extended
23409 -- main source unit. The one exception is the 'e' entry for a
23410 -- package spec, where it is useful for a client to have the
23411 -- ending information to define scopes.
23417 Label_Ref := False;
23419 -- For this case, we can ignore any parent references, but we
23420 -- need the package name itself for the 'e' entry.
23422 if Nkind (Endl) = N_Designator then
23423 Endl := Identifier (Endl);
23427 -- Reference is in extended main source unit
23432 -- For designator, generate references for the parent entries
23434 if Nkind (Endl) = N_Designator then
23436 -- Generate references for the prefix if the END line comes from
23437 -- source (otherwise we do not need these references) We climb the
23438 -- scope stack to find the expected entities.
23440 if Comes_From_Source (Endl) then
23441 Nam := Name (Endl);
23442 Scop := Current_Scope;
23443 while Nkind (Nam) = N_Selected_Component loop
23444 Scop := Scope (Scop);
23445 exit when No (Scop);
23446 Generate_Parent_Ref (Selector_Name (Nam), Scop);
23447 Nam := Prefix (Nam);
23450 if Present (Scop) then
23451 Generate_Parent_Ref (Nam, Scope (Scop));
23455 Endl := Identifier (Endl);
23459 -- If the end label is not for the given entity, then either we have
23460 -- some previous error, or this is a generic instantiation for which
23461 -- we do not need to make a cross-reference in this case anyway. In
23462 -- either case we simply ignore the call.
23464 if Chars (Ent) /= Chars (Endl) then
23468 -- If label was really there, then generate a normal reference and then
23469 -- adjust the location in the end label to point past the name (which
23470 -- should almost always be the semicolon).
23472 Loc := Sloc (Endl);
23474 if Comes_From_Source (Endl) then
23476 -- If a label reference is required, then do the style check and
23477 -- generate an l-type cross-reference entry for the label
23480 if Style_Check then
23481 Style.Check_Identifier (Endl, Ent);
23484 Generate_Reference (Ent, Endl, 'l', Set_Ref => False);
23487 -- Set the location to point past the label (normally this will
23488 -- mean the semicolon immediately following the label). This is
23489 -- done for the sake of the 'e' or 't' entry generated below.
23491 Get_Decoded_Name_String (Chars (Endl));
23492 Set_Sloc (Endl, Sloc (Endl) + Source_Ptr (Name_Len));
23495 -- In SPARK mode, no missing label is allowed for packages and
23496 -- subprogram bodies. Detect those cases by testing whether
23497 -- Process_End_Label was called for a body (Typ = 't') or a package.
23499 if Restriction_Check_Required (SPARK_05)
23500 and then (Typ = 't' or else Ekind (Ent) = E_Package)
23502 Error_Msg_Node_1 := Endl;
23503 Check_SPARK_05_Restriction
23504 ("`END &` required", Endl, Force => True);
23508 -- Now generate the e/t reference
23510 Generate_Reference (Ent, Endl, Typ, Set_Ref => False, Force => True);
23512 -- Restore Sloc, in case modified above, since we have an identifier
23513 -- and the normal Sloc should be left set in the tree.
23515 Set_Sloc (Endl, Loc);
23516 end Process_End_Label;
23518 --------------------------------
23519 -- Propagate_Concurrent_Flags --
23520 --------------------------------
23522 procedure Propagate_Concurrent_Flags
23524 Comp_Typ : Entity_Id)
23527 if Has_Task (Comp_Typ) then
23528 Set_Has_Task (Typ);
23531 if Has_Protected (Comp_Typ) then
23532 Set_Has_Protected (Typ);
23535 if Has_Timing_Event (Comp_Typ) then
23536 Set_Has_Timing_Event (Typ);
23538 end Propagate_Concurrent_Flags;
23540 ------------------------------
23541 -- Propagate_DIC_Attributes --
23542 ------------------------------
23544 procedure Propagate_DIC_Attributes
23546 From_Typ : Entity_Id)
23548 DIC_Proc : Entity_Id;
23551 if Present (Typ) and then Present (From_Typ) then
23552 pragma Assert (Is_Type (Typ) and then Is_Type (From_Typ));
23554 -- Nothing to do if both the source and the destination denote the
23557 if From_Typ = Typ then
23560 -- Nothing to do when the destination denotes an incomplete type
23561 -- because the DIC is associated with the current instance of a
23562 -- private type, thus it can never apply to an incomplete type.
23564 elsif Is_Incomplete_Type (Typ) then
23568 DIC_Proc := DIC_Procedure (From_Typ);
23570 -- The setting of the attributes is intentionally conservative. This
23571 -- prevents accidental clobbering of enabled attributes.
23573 if Has_Inherited_DIC (From_Typ)
23574 and then not Has_Inherited_DIC (Typ)
23576 Set_Has_Inherited_DIC (Typ);
23579 if Has_Own_DIC (From_Typ) and then not Has_Own_DIC (Typ) then
23580 Set_Has_Own_DIC (Typ);
23583 if Present (DIC_Proc) and then No (DIC_Procedure (Typ)) then
23584 Set_DIC_Procedure (Typ, DIC_Proc);
23587 end Propagate_DIC_Attributes;
23589 ------------------------------------
23590 -- Propagate_Invariant_Attributes --
23591 ------------------------------------
23593 procedure Propagate_Invariant_Attributes
23595 From_Typ : Entity_Id)
23597 Full_IP : Entity_Id;
23598 Part_IP : Entity_Id;
23601 if Present (Typ) and then Present (From_Typ) then
23602 pragma Assert (Is_Type (Typ) and then Is_Type (From_Typ));
23604 -- Nothing to do if both the source and the destination denote the
23607 if From_Typ = Typ then
23611 Full_IP := Invariant_Procedure (From_Typ);
23612 Part_IP := Partial_Invariant_Procedure (From_Typ);
23614 -- The setting of the attributes is intentionally conservative. This
23615 -- prevents accidental clobbering of enabled attributes.
23617 if Has_Inheritable_Invariants (From_Typ)
23618 and then not Has_Inheritable_Invariants (Typ)
23620 Set_Has_Inheritable_Invariants (Typ);
23623 if Has_Inherited_Invariants (From_Typ)
23624 and then not Has_Inherited_Invariants (Typ)
23626 Set_Has_Inherited_Invariants (Typ);
23629 if Has_Own_Invariants (From_Typ)
23630 and then not Has_Own_Invariants (Typ)
23632 Set_Has_Own_Invariants (Typ);
23635 if Present (Full_IP) and then No (Invariant_Procedure (Typ)) then
23636 Set_Invariant_Procedure (Typ, Full_IP);
23639 if Present (Part_IP) and then No (Partial_Invariant_Procedure (Typ))
23641 Set_Partial_Invariant_Procedure (Typ, Part_IP);
23644 end Propagate_Invariant_Attributes;
23646 ---------------------------------------
23647 -- Record_Possible_Part_Of_Reference --
23648 ---------------------------------------
23650 procedure Record_Possible_Part_Of_Reference
23651 (Var_Id : Entity_Id;
23654 Encap : constant Entity_Id := Encapsulating_State (Var_Id);
23658 -- The variable is a constituent of a single protected/task type. Such
23659 -- a variable acts as a component of the type and must appear within a
23660 -- specific region (SPARK RM 9(3)). Instead of recording the reference,
23661 -- verify its legality now.
23663 if Present (Encap) and then Is_Single_Concurrent_Object (Encap) then
23664 Check_Part_Of_Reference (Var_Id, Ref);
23666 -- The variable is subject to pragma Part_Of and may eventually become a
23667 -- constituent of a single protected/task type. Record the reference to
23668 -- verify its placement when the contract of the variable is analyzed.
23670 elsif Present (Get_Pragma (Var_Id, Pragma_Part_Of)) then
23671 Refs := Part_Of_References (Var_Id);
23674 Refs := New_Elmt_List;
23675 Set_Part_Of_References (Var_Id, Refs);
23678 Append_Elmt (Ref, Refs);
23680 end Record_Possible_Part_Of_Reference;
23686 function Referenced (Id : Entity_Id; Expr : Node_Id) return Boolean is
23687 Seen : Boolean := False;
23689 function Is_Reference (N : Node_Id) return Traverse_Result;
23690 -- Determine whether node N denotes a reference to Id. If this is the
23691 -- case, set global flag Seen to True and stop the traversal.
23697 function Is_Reference (N : Node_Id) return Traverse_Result is
23699 if Is_Entity_Name (N)
23700 and then Present (Entity (N))
23701 and then Entity (N) = Id
23710 procedure Inspect_Expression is new Traverse_Proc (Is_Reference);
23712 -- Start of processing for Referenced
23715 Inspect_Expression (Expr);
23719 ------------------------------------
23720 -- References_Generic_Formal_Type --
23721 ------------------------------------
23723 function References_Generic_Formal_Type (N : Node_Id) return Boolean is
23725 function Process (N : Node_Id) return Traverse_Result;
23726 -- Process one node in search for generic formal type
23732 function Process (N : Node_Id) return Traverse_Result is
23734 if Nkind (N) in N_Has_Entity then
23736 E : constant Entity_Id := Entity (N);
23738 if Present (E) then
23739 if Is_Generic_Type (E) then
23741 elsif Present (Etype (E))
23742 and then Is_Generic_Type (Etype (E))
23753 function Traverse is new Traverse_Func (Process);
23754 -- Traverse tree to look for generic type
23757 if Inside_A_Generic then
23758 return Traverse (N) = Abandon;
23762 end References_Generic_Formal_Type;
23764 -------------------------------
23765 -- Remove_Entity_And_Homonym --
23766 -------------------------------
23768 procedure Remove_Entity_And_Homonym (Id : Entity_Id) is
23770 Remove_Entity (Id);
23771 Remove_Homonym (Id);
23772 end Remove_Entity_And_Homonym;
23774 --------------------
23775 -- Remove_Homonym --
23776 --------------------
23778 procedure Remove_Homonym (Id : Entity_Id) is
23780 Prev : Entity_Id := Empty;
23783 if Id = Current_Entity (Id) then
23784 if Present (Homonym (Id)) then
23785 Set_Current_Entity (Homonym (Id));
23787 Set_Name_Entity_Id (Chars (Id), Empty);
23791 Hom := Current_Entity (Id);
23792 while Present (Hom) and then Hom /= Id loop
23794 Hom := Homonym (Hom);
23797 -- If Id is not on the homonym chain, nothing to do
23799 if Present (Hom) then
23800 Set_Homonym (Prev, Homonym (Id));
23803 end Remove_Homonym;
23805 ------------------------------
23806 -- Remove_Overloaded_Entity --
23807 ------------------------------
23809 procedure Remove_Overloaded_Entity (Id : Entity_Id) is
23810 procedure Remove_Primitive_Of (Typ : Entity_Id);
23811 -- Remove primitive subprogram Id from the list of primitives that
23812 -- belong to type Typ.
23814 -------------------------
23815 -- Remove_Primitive_Of --
23816 -------------------------
23818 procedure Remove_Primitive_Of (Typ : Entity_Id) is
23822 if Is_Tagged_Type (Typ) then
23823 Prims := Direct_Primitive_Operations (Typ);
23825 if Present (Prims) then
23826 Remove (Prims, Id);
23829 end Remove_Primitive_Of;
23833 Formal : Entity_Id;
23835 -- Start of processing for Remove_Overloaded_Entity
23838 Remove_Entity_And_Homonym (Id);
23840 -- The entity denotes a primitive subprogram. Remove it from the list of
23841 -- primitives of the associated controlling type.
23843 if Ekind_In (Id, E_Function, E_Procedure) and then Is_Primitive (Id) then
23844 Formal := First_Formal (Id);
23845 while Present (Formal) loop
23846 if Is_Controlling_Formal (Formal) then
23847 Remove_Primitive_Of (Etype (Formal));
23851 Next_Formal (Formal);
23854 if Ekind (Id) = E_Function and then Has_Controlling_Result (Id) then
23855 Remove_Primitive_Of (Etype (Id));
23858 end Remove_Overloaded_Entity;
23860 ---------------------
23861 -- Rep_To_Pos_Flag --
23862 ---------------------
23864 function Rep_To_Pos_Flag (E : Entity_Id; Loc : Source_Ptr) return Node_Id is
23866 return New_Occurrence_Of
23867 (Boolean_Literals (not Range_Checks_Suppressed (E)), Loc);
23868 end Rep_To_Pos_Flag;
23870 --------------------
23871 -- Require_Entity --
23872 --------------------
23874 procedure Require_Entity (N : Node_Id) is
23876 if Is_Entity_Name (N) and then No (Entity (N)) then
23877 if Total_Errors_Detected /= 0 then
23878 Set_Entity (N, Any_Id);
23880 raise Program_Error;
23883 end Require_Entity;
23885 ------------------------------
23886 -- Requires_Transient_Scope --
23887 ------------------------------
23889 -- A transient scope is required when variable-sized temporaries are
23890 -- allocated on the secondary stack, or when finalization actions must be
23891 -- generated before the next instruction.
23893 function Requires_Transient_Scope (Id : Entity_Id) return Boolean is
23894 Old_Result : constant Boolean := Old_Requires_Transient_Scope (Id);
23897 if Debug_Flag_QQ then
23902 New_Result : constant Boolean := New_Requires_Transient_Scope (Id);
23905 -- Assert that we're not putting things on the secondary stack if we
23906 -- didn't before; we are trying to AVOID secondary stack when
23909 if not Old_Result then
23910 pragma Assert (not New_Result);
23914 if New_Result /= Old_Result then
23915 Results_Differ (Id, Old_Result, New_Result);
23920 end Requires_Transient_Scope;
23922 --------------------
23923 -- Results_Differ --
23924 --------------------
23926 procedure Results_Differ
23932 if False then -- False to disable; True for debugging
23933 Treepr.Print_Tree_Node (Id);
23935 if Old_Val = New_Val then
23936 raise Program_Error;
23939 end Results_Differ;
23941 --------------------------
23942 -- Reset_Analyzed_Flags --
23943 --------------------------
23945 procedure Reset_Analyzed_Flags (N : Node_Id) is
23946 function Clear_Analyzed (N : Node_Id) return Traverse_Result;
23947 -- Function used to reset Analyzed flags in tree. Note that we do
23948 -- not reset Analyzed flags in entities, since there is no need to
23949 -- reanalyze entities, and indeed, it is wrong to do so, since it
23950 -- can result in generating auxiliary stuff more than once.
23952 --------------------
23953 -- Clear_Analyzed --
23954 --------------------
23956 function Clear_Analyzed (N : Node_Id) return Traverse_Result is
23958 if Nkind (N) not in N_Entity then
23959 Set_Analyzed (N, False);
23963 end Clear_Analyzed;
23965 procedure Reset_Analyzed is new Traverse_Proc (Clear_Analyzed);
23967 -- Start of processing for Reset_Analyzed_Flags
23970 Reset_Analyzed (N);
23971 end Reset_Analyzed_Flags;
23973 ------------------------
23974 -- Restore_SPARK_Mode --
23975 ------------------------
23977 procedure Restore_SPARK_Mode
23978 (Mode : SPARK_Mode_Type;
23982 SPARK_Mode := Mode;
23983 SPARK_Mode_Pragma := Prag;
23984 end Restore_SPARK_Mode;
23986 --------------------------------
23987 -- Returns_Unconstrained_Type --
23988 --------------------------------
23990 function Returns_Unconstrained_Type (Subp : Entity_Id) return Boolean is
23992 return Ekind (Subp) = E_Function
23993 and then not Is_Scalar_Type (Etype (Subp))
23994 and then not Is_Access_Type (Etype (Subp))
23995 and then not Is_Constrained (Etype (Subp));
23996 end Returns_Unconstrained_Type;
23998 ----------------------------
23999 -- Root_Type_Of_Full_View --
24000 ----------------------------
24002 function Root_Type_Of_Full_View (T : Entity_Id) return Entity_Id is
24003 Rtyp : constant Entity_Id := Root_Type (T);
24006 -- The root type of the full view may itself be a private type. Keep
24007 -- looking for the ultimate derivation parent.
24009 if Is_Private_Type (Rtyp) and then Present (Full_View (Rtyp)) then
24010 return Root_Type_Of_Full_View (Full_View (Rtyp));
24014 end Root_Type_Of_Full_View;
24016 ---------------------------
24017 -- Safe_To_Capture_Value --
24018 ---------------------------
24020 function Safe_To_Capture_Value
24023 Cond : Boolean := False) return Boolean
24026 -- The only entities for which we track constant values are variables
24027 -- which are not renamings, constants, out parameters, and in out
24028 -- parameters, so check if we have this case.
24030 -- Note: it may seem odd to track constant values for constants, but in
24031 -- fact this routine is used for other purposes than simply capturing
24032 -- the value. In particular, the setting of Known[_Non]_Null.
24034 if (Ekind (Ent) = E_Variable and then No (Renamed_Object (Ent)))
24036 Ekind_In (Ent, E_Constant, E_Out_Parameter, E_In_Out_Parameter)
24040 -- For conditionals, we also allow loop parameters and all formals,
24041 -- including in parameters.
24043 elsif Cond and then Ekind_In (Ent, E_Loop_Parameter, E_In_Parameter) then
24046 -- For all other cases, not just unsafe, but impossible to capture
24047 -- Current_Value, since the above are the only entities which have
24048 -- Current_Value fields.
24054 -- Skip if volatile or aliased, since funny things might be going on in
24055 -- these cases which we cannot necessarily track. Also skip any variable
24056 -- for which an address clause is given, or whose address is taken. Also
24057 -- never capture value of library level variables (an attempt to do so
24058 -- can occur in the case of package elaboration code).
24060 if Treat_As_Volatile (Ent)
24061 or else Is_Aliased (Ent)
24062 or else Present (Address_Clause (Ent))
24063 or else Address_Taken (Ent)
24064 or else (Is_Library_Level_Entity (Ent)
24065 and then Ekind (Ent) = E_Variable)
24070 -- OK, all above conditions are met. We also require that the scope of
24071 -- the reference be the same as the scope of the entity, not counting
24072 -- packages and blocks and loops.
24075 E_Scope : constant Entity_Id := Scope (Ent);
24076 R_Scope : Entity_Id;
24079 R_Scope := Current_Scope;
24080 while R_Scope /= Standard_Standard loop
24081 exit when R_Scope = E_Scope;
24083 if not Ekind_In (R_Scope, E_Package, E_Block, E_Loop) then
24086 R_Scope := Scope (R_Scope);
24091 -- We also require that the reference does not appear in a context
24092 -- where it is not sure to be executed (i.e. a conditional context
24093 -- or an exception handler). We skip this if Cond is True, since the
24094 -- capturing of values from conditional tests handles this ok.
24107 -- Seems dubious that case expressions are not handled here ???
24110 while Present (P) loop
24111 if Nkind (P) = N_If_Statement
24112 or else Nkind (P) = N_Case_Statement
24113 or else (Nkind (P) in N_Short_Circuit
24114 and then Desc = Right_Opnd (P))
24115 or else (Nkind (P) = N_If_Expression
24116 and then Desc /= First (Expressions (P)))
24117 or else Nkind (P) = N_Exception_Handler
24118 or else Nkind (P) = N_Selective_Accept
24119 or else Nkind (P) = N_Conditional_Entry_Call
24120 or else Nkind (P) = N_Timed_Entry_Call
24121 or else Nkind (P) = N_Asynchronous_Select
24129 -- A special Ada 2012 case: the original node may be part
24130 -- of the else_actions of a conditional expression, in which
24131 -- case it might not have been expanded yet, and appears in
24132 -- a non-syntactic list of actions. In that case it is clearly
24133 -- not safe to save a value.
24136 and then Is_List_Member (Desc)
24137 and then No (Parent (List_Containing (Desc)))
24145 -- OK, looks safe to set value
24148 end Safe_To_Capture_Value;
24154 function Same_Name (N1, N2 : Node_Id) return Boolean is
24155 K1 : constant Node_Kind := Nkind (N1);
24156 K2 : constant Node_Kind := Nkind (N2);
24159 if (K1 = N_Identifier or else K1 = N_Defining_Identifier)
24160 and then (K2 = N_Identifier or else K2 = N_Defining_Identifier)
24162 return Chars (N1) = Chars (N2);
24164 elsif (K1 = N_Selected_Component or else K1 = N_Expanded_Name)
24165 and then (K2 = N_Selected_Component or else K2 = N_Expanded_Name)
24167 return Same_Name (Selector_Name (N1), Selector_Name (N2))
24168 and then Same_Name (Prefix (N1), Prefix (N2));
24179 function Same_Object (Node1, Node2 : Node_Id) return Boolean is
24180 N1 : constant Node_Id := Original_Node (Node1);
24181 N2 : constant Node_Id := Original_Node (Node2);
24182 -- We do the tests on original nodes, since we are most interested
24183 -- in the original source, not any expansion that got in the way.
24185 K1 : constant Node_Kind := Nkind (N1);
24186 K2 : constant Node_Kind := Nkind (N2);
24189 -- First case, both are entities with same entity
24191 if K1 in N_Has_Entity and then K2 in N_Has_Entity then
24193 EN1 : constant Entity_Id := Entity (N1);
24194 EN2 : constant Entity_Id := Entity (N2);
24196 if Present (EN1) and then Present (EN2)
24197 and then (Ekind_In (EN1, E_Variable, E_Constant)
24198 or else Is_Formal (EN1))
24206 -- Second case, selected component with same selector, same record
24208 if K1 = N_Selected_Component
24209 and then K2 = N_Selected_Component
24210 and then Chars (Selector_Name (N1)) = Chars (Selector_Name (N2))
24212 return Same_Object (Prefix (N1), Prefix (N2));
24214 -- Third case, indexed component with same subscripts, same array
24216 elsif K1 = N_Indexed_Component
24217 and then K2 = N_Indexed_Component
24218 and then Same_Object (Prefix (N1), Prefix (N2))
24223 E1 := First (Expressions (N1));
24224 E2 := First (Expressions (N2));
24225 while Present (E1) loop
24226 if not Same_Value (E1, E2) then
24237 -- Fourth case, slice of same array with same bounds
24240 and then K2 = N_Slice
24241 and then Nkind (Discrete_Range (N1)) = N_Range
24242 and then Nkind (Discrete_Range (N2)) = N_Range
24243 and then Same_Value (Low_Bound (Discrete_Range (N1)),
24244 Low_Bound (Discrete_Range (N2)))
24245 and then Same_Value (High_Bound (Discrete_Range (N1)),
24246 High_Bound (Discrete_Range (N2)))
24248 return Same_Name (Prefix (N1), Prefix (N2));
24250 -- All other cases, not clearly the same object
24261 function Same_Type (T1, T2 : Entity_Id) return Boolean is
24266 elsif not Is_Constrained (T1)
24267 and then not Is_Constrained (T2)
24268 and then Base_Type (T1) = Base_Type (T2)
24272 -- For now don't bother with case of identical constraints, to be
24273 -- fiddled with later on perhaps (this is only used for optimization
24274 -- purposes, so it is not critical to do a best possible job)
24285 function Same_Value (Node1, Node2 : Node_Id) return Boolean is
24287 if Compile_Time_Known_Value (Node1)
24288 and then Compile_Time_Known_Value (Node2)
24290 -- Handle properly compile-time expressions that are not
24293 if Is_String_Type (Etype (Node1)) then
24294 return Expr_Value_S (Node1) = Expr_Value_S (Node2);
24297 return Expr_Value (Node1) = Expr_Value (Node2);
24300 elsif Same_Object (Node1, Node2) then
24307 --------------------
24308 -- Set_SPARK_Mode --
24309 --------------------
24311 procedure Set_SPARK_Mode (Context : Entity_Id) is
24313 -- Do not consider illegal or partially decorated constructs
24315 if Ekind (Context) = E_Void or else Error_Posted (Context) then
24318 elsif Present (SPARK_Pragma (Context)) then
24320 (Mode => Get_SPARK_Mode_From_Annotation (SPARK_Pragma (Context)),
24321 Prag => SPARK_Pragma (Context));
24323 end Set_SPARK_Mode;
24325 -------------------------
24326 -- Scalar_Part_Present --
24327 -------------------------
24329 function Scalar_Part_Present (Typ : Entity_Id) return Boolean is
24330 Val_Typ : constant Entity_Id := Validated_View (Typ);
24334 if Is_Scalar_Type (Val_Typ) then
24337 elsif Is_Array_Type (Val_Typ) then
24338 return Scalar_Part_Present (Component_Type (Val_Typ));
24340 elsif Is_Record_Type (Val_Typ) then
24341 Field := First_Component_Or_Discriminant (Val_Typ);
24342 while Present (Field) loop
24343 if Scalar_Part_Present (Etype (Field)) then
24347 Next_Component_Or_Discriminant (Field);
24352 end Scalar_Part_Present;
24354 ------------------------
24355 -- Scope_Is_Transient --
24356 ------------------------
24358 function Scope_Is_Transient return Boolean is
24360 return Scope_Stack.Table (Scope_Stack.Last).Is_Transient;
24361 end Scope_Is_Transient;
24367 function Scope_Within
24368 (Inner : Entity_Id;
24369 Outer : Entity_Id) return Boolean
24375 while Present (Curr) and then Curr /= Standard_Standard loop
24376 Curr := Scope (Curr);
24378 if Curr = Outer then
24381 -- A selective accept body appears within a task type, but the
24382 -- enclosing subprogram is the procedure of the task body.
24384 elsif Ekind (Curr) = E_Task_Type
24385 and then Outer = Task_Body_Procedure (Curr)
24389 -- Ditto for the body of a protected operation
24391 elsif Is_Subprogram (Curr)
24392 and then Outer = Protected_Body_Subprogram (Curr)
24396 -- Outside of its scope, a synchronized type may just be private
24398 elsif Is_Private_Type (Curr)
24399 and then Present (Full_View (Curr))
24400 and then Is_Concurrent_Type (Full_View (Curr))
24402 return Scope_Within (Full_View (Curr), Outer);
24409 --------------------------
24410 -- Scope_Within_Or_Same --
24411 --------------------------
24413 function Scope_Within_Or_Same
24414 (Inner : Entity_Id;
24415 Outer : Entity_Id) return Boolean
24417 Curr : Entity_Id := Inner;
24420 -- Similar to the above, but check for scope identity first
24422 while Present (Curr) and then Curr /= Standard_Standard loop
24423 if Curr = Outer then
24426 elsif Ekind (Curr) = E_Task_Type
24427 and then Outer = Task_Body_Procedure (Curr)
24431 elsif Is_Subprogram (Curr)
24432 and then Outer = Protected_Body_Subprogram (Curr)
24436 elsif Is_Private_Type (Curr)
24437 and then Present (Full_View (Curr))
24439 if Full_View (Curr) = Outer then
24442 return Scope_Within (Full_View (Curr), Outer);
24446 Curr := Scope (Curr);
24450 end Scope_Within_Or_Same;
24452 --------------------
24453 -- Set_Convention --
24454 --------------------
24456 procedure Set_Convention (E : Entity_Id; Val : Snames.Convention_Id) is
24458 Basic_Set_Convention (E, Val);
24461 and then Is_Access_Subprogram_Type (Base_Type (E))
24462 and then Has_Foreign_Convention (E)
24464 Set_Can_Use_Internal_Rep (E, False);
24467 -- If E is an object, including a component, and the type of E is an
24468 -- anonymous access type with no convention set, then also set the
24469 -- convention of the anonymous access type. We do not do this for
24470 -- anonymous protected types, since protected types always have the
24471 -- default convention.
24473 if Present (Etype (E))
24474 and then (Is_Object (E)
24476 -- Allow E_Void (happens for pragma Convention appearing
24477 -- in the middle of a record applying to a component)
24479 or else Ekind (E) = E_Void)
24482 Typ : constant Entity_Id := Etype (E);
24485 if Ekind_In (Typ, E_Anonymous_Access_Type,
24486 E_Anonymous_Access_Subprogram_Type)
24487 and then not Has_Convention_Pragma (Typ)
24489 Basic_Set_Convention (Typ, Val);
24490 Set_Has_Convention_Pragma (Typ);
24492 -- And for the access subprogram type, deal similarly with the
24493 -- designated E_Subprogram_Type, which is always internal.
24495 if Ekind (Typ) = E_Anonymous_Access_Subprogram_Type then
24497 Dtype : constant Entity_Id := Designated_Type (Typ);
24499 if Ekind (Dtype) = E_Subprogram_Type
24500 and then not Has_Convention_Pragma (Dtype)
24502 Basic_Set_Convention (Dtype, Val);
24503 Set_Has_Convention_Pragma (Dtype);
24510 end Set_Convention;
24512 ------------------------
24513 -- Set_Current_Entity --
24514 ------------------------
24516 -- The given entity is to be set as the currently visible definition of its
24517 -- associated name (i.e. the Node_Id associated with its name). All we have
24518 -- to do is to get the name from the identifier, and then set the
24519 -- associated Node_Id to point to the given entity.
24521 procedure Set_Current_Entity (E : Entity_Id) is
24523 Set_Name_Entity_Id (Chars (E), E);
24524 end Set_Current_Entity;
24526 ---------------------------
24527 -- Set_Debug_Info_Needed --
24528 ---------------------------
24530 procedure Set_Debug_Info_Needed (T : Entity_Id) is
24532 procedure Set_Debug_Info_Needed_If_Not_Set (E : Entity_Id);
24533 pragma Inline (Set_Debug_Info_Needed_If_Not_Set);
24534 -- Used to set debug info in a related node if not set already
24536 --------------------------------------
24537 -- Set_Debug_Info_Needed_If_Not_Set --
24538 --------------------------------------
24540 procedure Set_Debug_Info_Needed_If_Not_Set (E : Entity_Id) is
24542 if Present (E) and then not Needs_Debug_Info (E) then
24543 Set_Debug_Info_Needed (E);
24545 -- For a private type, indicate that the full view also needs
24546 -- debug information.
24549 and then Is_Private_Type (E)
24550 and then Present (Full_View (E))
24552 Set_Debug_Info_Needed (Full_View (E));
24555 end Set_Debug_Info_Needed_If_Not_Set;
24557 -- Start of processing for Set_Debug_Info_Needed
24560 -- Nothing to do if there is no available entity
24565 -- Nothing to do for an entity with suppressed debug information
24567 elsif Debug_Info_Off (T) then
24570 -- Nothing to do for an ignored Ghost entity because the entity will be
24571 -- eliminated from the tree.
24573 elsif Is_Ignored_Ghost_Entity (T) then
24576 -- Nothing to do if entity comes from a predefined file. Library files
24577 -- are compiled without debug information, but inlined bodies of these
24578 -- routines may appear in user code, and debug information on them ends
24579 -- up complicating debugging the user code.
24581 elsif In_Inlined_Body and then In_Predefined_Unit (T) then
24582 Set_Needs_Debug_Info (T, False);
24585 -- Set flag in entity itself. Note that we will go through the following
24586 -- circuitry even if the flag is already set on T. That's intentional,
24587 -- it makes sure that the flag will be set in subsidiary entities.
24589 Set_Needs_Debug_Info (T);
24591 -- Set flag on subsidiary entities if not set already
24593 if Is_Object (T) then
24594 Set_Debug_Info_Needed_If_Not_Set (Etype (T));
24596 elsif Is_Type (T) then
24597 Set_Debug_Info_Needed_If_Not_Set (Etype (T));
24599 if Is_Record_Type (T) then
24601 Ent : Entity_Id := First_Entity (T);
24603 while Present (Ent) loop
24604 Set_Debug_Info_Needed_If_Not_Set (Ent);
24609 -- For a class wide subtype, we also need debug information
24610 -- for the equivalent type.
24612 if Ekind (T) = E_Class_Wide_Subtype then
24613 Set_Debug_Info_Needed_If_Not_Set (Equivalent_Type (T));
24616 elsif Is_Array_Type (T) then
24617 Set_Debug_Info_Needed_If_Not_Set (Component_Type (T));
24620 Indx : Node_Id := First_Index (T);
24622 while Present (Indx) loop
24623 Set_Debug_Info_Needed_If_Not_Set (Etype (Indx));
24624 Indx := Next_Index (Indx);
24628 -- For a packed array type, we also need debug information for
24629 -- the type used to represent the packed array. Conversely, we
24630 -- also need it for the former if we need it for the latter.
24632 if Is_Packed (T) then
24633 Set_Debug_Info_Needed_If_Not_Set (Packed_Array_Impl_Type (T));
24636 if Is_Packed_Array_Impl_Type (T) then
24637 Set_Debug_Info_Needed_If_Not_Set (Original_Array_Type (T));
24640 elsif Is_Access_Type (T) then
24641 Set_Debug_Info_Needed_If_Not_Set (Directly_Designated_Type (T));
24643 elsif Is_Private_Type (T) then
24645 FV : constant Entity_Id := Full_View (T);
24648 Set_Debug_Info_Needed_If_Not_Set (FV);
24650 -- If the full view is itself a derived private type, we need
24651 -- debug information on its underlying type.
24654 and then Is_Private_Type (FV)
24655 and then Present (Underlying_Full_View (FV))
24657 Set_Needs_Debug_Info (Underlying_Full_View (FV));
24661 elsif Is_Protected_Type (T) then
24662 Set_Debug_Info_Needed_If_Not_Set (Corresponding_Record_Type (T));
24664 elsif Is_Scalar_Type (T) then
24666 -- If the subrange bounds are materialized by dedicated constant
24667 -- objects, also include them in the debug info to make sure the
24668 -- debugger can properly use them.
24670 if Present (Scalar_Range (T))
24671 and then Nkind (Scalar_Range (T)) = N_Range
24674 Low_Bnd : constant Node_Id := Type_Low_Bound (T);
24675 High_Bnd : constant Node_Id := Type_High_Bound (T);
24678 if Is_Entity_Name (Low_Bnd) then
24679 Set_Debug_Info_Needed_If_Not_Set (Entity (Low_Bnd));
24682 if Is_Entity_Name (High_Bnd) then
24683 Set_Debug_Info_Needed_If_Not_Set (Entity (High_Bnd));
24689 end Set_Debug_Info_Needed;
24691 ----------------------------
24692 -- Set_Entity_With_Checks --
24693 ----------------------------
24695 procedure Set_Entity_With_Checks (N : Node_Id; Val : Entity_Id) is
24696 Val_Actual : Entity_Id;
24698 Post_Node : Node_Id;
24701 -- Unconditionally set the entity
24703 Set_Entity (N, Val);
24705 -- The node to post on is the selector in the case of an expanded name,
24706 -- and otherwise the node itself.
24708 if Nkind (N) = N_Expanded_Name then
24709 Post_Node := Selector_Name (N);
24714 -- Check for violation of No_Fixed_IO
24716 if Restriction_Check_Required (No_Fixed_IO)
24718 ((RTU_Loaded (Ada_Text_IO)
24719 and then (Is_RTE (Val, RE_Decimal_IO)
24721 Is_RTE (Val, RE_Fixed_IO)))
24724 (RTU_Loaded (Ada_Wide_Text_IO)
24725 and then (Is_RTE (Val, RO_WT_Decimal_IO)
24727 Is_RTE (Val, RO_WT_Fixed_IO)))
24730 (RTU_Loaded (Ada_Wide_Wide_Text_IO)
24731 and then (Is_RTE (Val, RO_WW_Decimal_IO)
24733 Is_RTE (Val, RO_WW_Fixed_IO))))
24735 -- A special extra check, don't complain about a reference from within
24736 -- the Ada.Interrupts package itself!
24738 and then not In_Same_Extended_Unit (N, Val)
24740 Check_Restriction (No_Fixed_IO, Post_Node);
24743 -- Remaining checks are only done on source nodes. Note that we test
24744 -- for violation of No_Fixed_IO even on non-source nodes, because the
24745 -- cases for checking violations of this restriction are instantiations
24746 -- where the reference in the instance has Comes_From_Source False.
24748 if not Comes_From_Source (N) then
24752 -- Check for violation of No_Abort_Statements, which is triggered by
24753 -- call to Ada.Task_Identification.Abort_Task.
24755 if Restriction_Check_Required (No_Abort_Statements)
24756 and then (Is_RTE (Val, RE_Abort_Task))
24758 -- A special extra check, don't complain about a reference from within
24759 -- the Ada.Task_Identification package itself!
24761 and then not In_Same_Extended_Unit (N, Val)
24763 Check_Restriction (No_Abort_Statements, Post_Node);
24766 if Val = Standard_Long_Long_Integer then
24767 Check_Restriction (No_Long_Long_Integers, Post_Node);
24770 -- Check for violation of No_Dynamic_Attachment
24772 if Restriction_Check_Required (No_Dynamic_Attachment)
24773 and then RTU_Loaded (Ada_Interrupts)
24774 and then (Is_RTE (Val, RE_Is_Reserved) or else
24775 Is_RTE (Val, RE_Is_Attached) or else
24776 Is_RTE (Val, RE_Current_Handler) or else
24777 Is_RTE (Val, RE_Attach_Handler) or else
24778 Is_RTE (Val, RE_Exchange_Handler) or else
24779 Is_RTE (Val, RE_Detach_Handler) or else
24780 Is_RTE (Val, RE_Reference))
24782 -- A special extra check, don't complain about a reference from within
24783 -- the Ada.Interrupts package itself!
24785 and then not In_Same_Extended_Unit (N, Val)
24787 Check_Restriction (No_Dynamic_Attachment, Post_Node);
24790 -- Check for No_Implementation_Identifiers
24792 if Restriction_Check_Required (No_Implementation_Identifiers) then
24794 -- We have an implementation defined entity if it is marked as
24795 -- implementation defined, or is defined in a package marked as
24796 -- implementation defined. However, library packages themselves
24797 -- are excluded (we don't want to flag Interfaces itself, just
24798 -- the entities within it).
24800 if (Is_Implementation_Defined (Val)
24802 (Present (Scope (Val))
24803 and then Is_Implementation_Defined (Scope (Val))))
24804 and then not (Ekind_In (Val, E_Package, E_Generic_Package)
24805 and then Is_Library_Level_Entity (Val))
24807 Check_Restriction (No_Implementation_Identifiers, Post_Node);
24811 -- Do the style check
24814 and then not Suppress_Style_Checks (Val)
24815 and then not In_Instance
24817 if Nkind (N) = N_Identifier then
24819 elsif Nkind (N) = N_Expanded_Name then
24820 Nod := Selector_Name (N);
24825 -- A special situation arises for derived operations, where we want
24826 -- to do the check against the parent (since the Sloc of the derived
24827 -- operation points to the derived type declaration itself).
24830 while not Comes_From_Source (Val_Actual)
24831 and then Nkind (Val_Actual) in N_Entity
24832 and then (Ekind (Val_Actual) = E_Enumeration_Literal
24833 or else Is_Subprogram_Or_Generic_Subprogram (Val_Actual))
24834 and then Present (Alias (Val_Actual))
24836 Val_Actual := Alias (Val_Actual);
24839 -- Renaming declarations for generic actuals do not come from source,
24840 -- and have a different name from that of the entity they rename, so
24841 -- there is no style check to perform here.
24843 if Chars (Nod) = Chars (Val_Actual) then
24844 Style.Check_Identifier (Nod, Val_Actual);
24848 Set_Entity (N, Val);
24849 end Set_Entity_With_Checks;
24851 ------------------------------
24852 -- Set_Invalid_Scalar_Value --
24853 ------------------------------
24855 procedure Set_Invalid_Scalar_Value
24856 (Scal_Typ : Float_Scalar_Id;
24859 Slot : Ureal renames Invalid_Floats (Scal_Typ);
24862 -- Detect an attempt to set a different value for the same scalar type
24864 pragma Assert (Slot = No_Ureal);
24866 end Set_Invalid_Scalar_Value;
24868 ------------------------------
24869 -- Set_Invalid_Scalar_Value --
24870 ------------------------------
24872 procedure Set_Invalid_Scalar_Value
24873 (Scal_Typ : Integer_Scalar_Id;
24876 Slot : Uint renames Invalid_Integers (Scal_Typ);
24879 -- Detect an attempt to set a different value for the same scalar type
24881 pragma Assert (Slot = No_Uint);
24883 end Set_Invalid_Scalar_Value;
24885 ------------------------
24886 -- Set_Name_Entity_Id --
24887 ------------------------
24889 procedure Set_Name_Entity_Id (Id : Name_Id; Val : Entity_Id) is
24891 Set_Name_Table_Int (Id, Int (Val));
24892 end Set_Name_Entity_Id;
24894 ---------------------
24895 -- Set_Next_Actual --
24896 ---------------------
24898 procedure Set_Next_Actual (Ass1_Id : Node_Id; Ass2_Id : Node_Id) is
24900 if Nkind (Parent (Ass1_Id)) = N_Parameter_Association then
24901 Set_First_Named_Actual (Parent (Ass1_Id), Ass2_Id);
24903 end Set_Next_Actual;
24905 ----------------------------------
24906 -- Set_Optimize_Alignment_Flags --
24907 ----------------------------------
24909 procedure Set_Optimize_Alignment_Flags (E : Entity_Id) is
24911 if Optimize_Alignment = 'S' then
24912 Set_Optimize_Alignment_Space (E);
24913 elsif Optimize_Alignment = 'T' then
24914 Set_Optimize_Alignment_Time (E);
24916 end Set_Optimize_Alignment_Flags;
24918 -----------------------
24919 -- Set_Public_Status --
24920 -----------------------
24922 procedure Set_Public_Status (Id : Entity_Id) is
24923 S : constant Entity_Id := Current_Scope;
24925 function Within_HSS_Or_If (E : Entity_Id) return Boolean;
24926 -- Determines if E is defined within handled statement sequence or
24927 -- an if statement, returns True if so, False otherwise.
24929 ----------------------
24930 -- Within_HSS_Or_If --
24931 ----------------------
24933 function Within_HSS_Or_If (E : Entity_Id) return Boolean is
24936 N := Declaration_Node (E);
24943 elsif Nkind_In (N, N_Handled_Sequence_Of_Statements,
24949 end Within_HSS_Or_If;
24951 -- Start of processing for Set_Public_Status
24954 -- Everything in the scope of Standard is public
24956 if S = Standard_Standard then
24957 Set_Is_Public (Id);
24959 -- Entity is definitely not public if enclosing scope is not public
24961 elsif not Is_Public (S) then
24964 -- An object or function declaration that occurs in a handled sequence
24965 -- of statements or within an if statement is the declaration for a
24966 -- temporary object or local subprogram generated by the expander. It
24967 -- never needs to be made public and furthermore, making it public can
24968 -- cause back end problems.
24970 elsif Nkind_In (Parent (Id), N_Object_Declaration,
24971 N_Function_Specification)
24972 and then Within_HSS_Or_If (Id)
24976 -- Entities in public packages or records are public
24978 elsif Ekind (S) = E_Package or Is_Record_Type (S) then
24979 Set_Is_Public (Id);
24981 -- The bounds of an entry family declaration can generate object
24982 -- declarations that are visible to the back-end, e.g. in the
24983 -- the declaration of a composite type that contains tasks.
24985 elsif Is_Concurrent_Type (S)
24986 and then not Has_Completion (S)
24987 and then Nkind (Parent (Id)) = N_Object_Declaration
24989 Set_Is_Public (Id);
24991 end Set_Public_Status;
24993 -----------------------------
24994 -- Set_Referenced_Modified --
24995 -----------------------------
24997 procedure Set_Referenced_Modified (N : Node_Id; Out_Param : Boolean) is
25001 -- Deal with indexed or selected component where prefix is modified
25003 if Nkind_In (N, N_Indexed_Component, N_Selected_Component) then
25004 Pref := Prefix (N);
25006 -- If prefix is access type, then it is the designated object that is
25007 -- being modified, which means we have no entity to set the flag on.
25009 if No (Etype (Pref)) or else Is_Access_Type (Etype (Pref)) then
25012 -- Otherwise chase the prefix
25015 Set_Referenced_Modified (Pref, Out_Param);
25018 -- Otherwise see if we have an entity name (only other case to process)
25020 elsif Is_Entity_Name (N) and then Present (Entity (N)) then
25021 Set_Referenced_As_LHS (Entity (N), not Out_Param);
25022 Set_Referenced_As_Out_Parameter (Entity (N), Out_Param);
25024 end Set_Referenced_Modified;
25030 procedure Set_Rep_Info (T1 : Entity_Id; T2 : Entity_Id) is
25032 Set_Is_Atomic (T1, Is_Atomic (T2));
25033 Set_Is_Independent (T1, Is_Independent (T2));
25034 Set_Is_Volatile_Full_Access (T1, Is_Volatile_Full_Access (T2));
25036 if Is_Base_Type (T1) then
25037 Set_Is_Volatile (T1, Is_Volatile (T2));
25041 ----------------------------
25042 -- Set_Scope_Is_Transient --
25043 ----------------------------
25045 procedure Set_Scope_Is_Transient (V : Boolean := True) is
25047 Scope_Stack.Table (Scope_Stack.Last).Is_Transient := V;
25048 end Set_Scope_Is_Transient;
25050 -------------------
25051 -- Set_Size_Info --
25052 -------------------
25054 procedure Set_Size_Info (T1, T2 : Entity_Id) is
25056 -- We copy Esize, but not RM_Size, since in general RM_Size is
25057 -- subtype specific and does not get inherited by all subtypes.
25059 Set_Esize (T1, Esize (T2));
25060 Set_Has_Biased_Representation (T1, Has_Biased_Representation (T2));
25062 if Is_Discrete_Or_Fixed_Point_Type (T1)
25064 Is_Discrete_Or_Fixed_Point_Type (T2)
25066 Set_Is_Unsigned_Type (T1, Is_Unsigned_Type (T2));
25069 Set_Alignment (T1, Alignment (T2));
25072 ------------------------------
25073 -- Should_Ignore_Pragma_Par --
25074 ------------------------------
25076 function Should_Ignore_Pragma_Par (Prag_Name : Name_Id) return Boolean is
25077 pragma Assert (Compiler_State = Parsing);
25078 -- This one can't work during semantic analysis, because we don't have a
25079 -- correct Current_Source_File.
25081 Result : constant Boolean :=
25082 Get_Name_Table_Boolean3 (Prag_Name)
25083 and then not Is_Internal_File_Name
25084 (File_Name (Current_Source_File));
25087 end Should_Ignore_Pragma_Par;
25089 ------------------------------
25090 -- Should_Ignore_Pragma_Sem --
25091 ------------------------------
25093 function Should_Ignore_Pragma_Sem (N : Node_Id) return Boolean is
25094 pragma Assert (Compiler_State = Analyzing);
25095 Prag_Name : constant Name_Id := Pragma_Name (N);
25096 Result : constant Boolean :=
25097 Get_Name_Table_Boolean3 (Prag_Name)
25098 and then not In_Internal_Unit (N);
25102 end Should_Ignore_Pragma_Sem;
25104 --------------------
25105 -- Static_Boolean --
25106 --------------------
25108 function Static_Boolean (N : Node_Id) return Uint is
25110 Analyze_And_Resolve (N, Standard_Boolean);
25113 or else Error_Posted (N)
25114 or else Etype (N) = Any_Type
25119 if Is_OK_Static_Expression (N) then
25120 if not Raises_Constraint_Error (N) then
25121 return Expr_Value (N);
25126 elsif Etype (N) = Any_Type then
25130 Flag_Non_Static_Expr
25131 ("static boolean expression required here", N);
25134 end Static_Boolean;
25136 --------------------
25137 -- Static_Integer --
25138 --------------------
25140 function Static_Integer (N : Node_Id) return Uint is
25142 Analyze_And_Resolve (N, Any_Integer);
25145 or else Error_Posted (N)
25146 or else Etype (N) = Any_Type
25151 if Is_OK_Static_Expression (N) then
25152 if not Raises_Constraint_Error (N) then
25153 return Expr_Value (N);
25158 elsif Etype (N) = Any_Type then
25162 Flag_Non_Static_Expr
25163 ("static integer expression required here", N);
25166 end Static_Integer;
25168 --------------------------
25169 -- Statically_Different --
25170 --------------------------
25172 function Statically_Different (E1, E2 : Node_Id) return Boolean is
25173 R1 : constant Node_Id := Get_Referenced_Object (E1);
25174 R2 : constant Node_Id := Get_Referenced_Object (E2);
25176 return Is_Entity_Name (R1)
25177 and then Is_Entity_Name (R2)
25178 and then Entity (R1) /= Entity (R2)
25179 and then not Is_Formal (Entity (R1))
25180 and then not Is_Formal (Entity (R2));
25181 end Statically_Different;
25183 --------------------------------------
25184 -- Subject_To_Loop_Entry_Attributes --
25185 --------------------------------------
25187 function Subject_To_Loop_Entry_Attributes (N : Node_Id) return Boolean is
25193 -- The expansion mechanism transform a loop subject to at least one
25194 -- 'Loop_Entry attribute into a conditional block. Infinite loops lack
25195 -- the conditional part.
25197 if Nkind_In (Stmt, N_Block_Statement, N_If_Statement)
25198 and then Nkind (Original_Node (N)) = N_Loop_Statement
25200 Stmt := Original_Node (N);
25204 Nkind (Stmt) = N_Loop_Statement
25205 and then Present (Identifier (Stmt))
25206 and then Present (Entity (Identifier (Stmt)))
25207 and then Has_Loop_Entry_Attributes (Entity (Identifier (Stmt)));
25208 end Subject_To_Loop_Entry_Attributes;
25210 -----------------------------
25211 -- Subprogram_Access_Level --
25212 -----------------------------
25214 function Subprogram_Access_Level (Subp : Entity_Id) return Uint is
25216 if Present (Alias (Subp)) then
25217 return Subprogram_Access_Level (Alias (Subp));
25219 return Scope_Depth (Enclosing_Dynamic_Scope (Subp));
25221 end Subprogram_Access_Level;
25223 ---------------------
25224 -- Subprogram_Name --
25225 ---------------------
25227 function Subprogram_Name (N : Node_Id) return String is
25228 Buf : Bounded_String;
25229 Ent : Node_Id := N;
25233 while Present (Ent) loop
25234 case Nkind (Ent) is
25235 when N_Subprogram_Body =>
25236 Ent := Defining_Unit_Name (Specification (Ent));
25239 when N_Subprogram_Declaration =>
25240 Nod := Corresponding_Body (Ent);
25242 if Present (Nod) then
25245 Ent := Defining_Unit_Name (Specification (Ent));
25250 when N_Subprogram_Instantiation
25252 | N_Package_Specification
25254 Ent := Defining_Unit_Name (Ent);
25257 when N_Protected_Type_Declaration =>
25258 Ent := Corresponding_Body (Ent);
25261 when N_Protected_Body
25264 Ent := Defining_Identifier (Ent);
25271 Ent := Parent (Ent);
25275 return "unknown subprogram:unknown file:0:0";
25278 -- If the subprogram is a child unit, use its simple name to start the
25279 -- construction of the fully qualified name.
25281 if Nkind (Ent) = N_Defining_Program_Unit_Name then
25282 Ent := Defining_Identifier (Ent);
25285 Append_Entity_Name (Buf, Ent);
25287 -- Append homonym number if needed
25289 if Nkind (N) in N_Entity and then Has_Homonym (N) then
25291 H : Entity_Id := Homonym (N);
25295 while Present (H) loop
25296 if Scope (H) = Scope (N) then
25310 -- Append source location of Ent to Buf so that the string will
25311 -- look like "subp:file:line:col".
25314 Loc : constant Source_Ptr := Sloc (Ent);
25317 Append (Buf, Reference_Name (Get_Source_File_Index (Loc)));
25319 Append (Buf, Nat (Get_Logical_Line_Number (Loc)));
25321 Append (Buf, Nat (Get_Column_Number (Loc)));
25325 end Subprogram_Name;
25327 -------------------------------
25328 -- Support_Atomic_Primitives --
25329 -------------------------------
25331 function Support_Atomic_Primitives (Typ : Entity_Id) return Boolean is
25335 -- Verify the alignment of Typ is known
25337 if not Known_Alignment (Typ) then
25341 if Known_Static_Esize (Typ) then
25342 Size := UI_To_Int (Esize (Typ));
25344 -- If the Esize (Object_Size) is unknown at compile time, look at the
25345 -- RM_Size (Value_Size) which may have been set by an explicit rep item.
25347 elsif Known_Static_RM_Size (Typ) then
25348 Size := UI_To_Int (RM_Size (Typ));
25350 -- Otherwise, the size is considered to be unknown.
25356 -- Check that the size of the component is 8, 16, 32, or 64 bits and
25357 -- that Typ is properly aligned.
25360 when 8 | 16 | 32 | 64 =>
25361 return Size = UI_To_Int (Alignment (Typ)) * 8;
25366 end Support_Atomic_Primitives;
25372 procedure Trace_Scope (N : Node_Id; E : Entity_Id; Msg : String) is
25374 if Debug_Flag_W then
25375 for J in 0 .. Scope_Stack.Last loop
25380 Write_Name (Chars (E));
25381 Write_Str (" from ");
25382 Write_Location (Sloc (N));
25387 -----------------------
25388 -- Transfer_Entities --
25389 -----------------------
25391 procedure Transfer_Entities (From : Entity_Id; To : Entity_Id) is
25392 procedure Set_Public_Status_Of (Id : Entity_Id);
25393 -- Set the Is_Public attribute of arbitrary entity Id by calling routine
25394 -- Set_Public_Status. If successful and Id denotes a record type, set
25395 -- the Is_Public attribute of its fields.
25397 --------------------------
25398 -- Set_Public_Status_Of --
25399 --------------------------
25401 procedure Set_Public_Status_Of (Id : Entity_Id) is
25405 if not Is_Public (Id) then
25406 Set_Public_Status (Id);
25408 -- When the input entity is a public record type, ensure that all
25409 -- its internal fields are also exposed to the linker. The fields
25410 -- of a class-wide type are never made public.
25413 and then Is_Record_Type (Id)
25414 and then not Is_Class_Wide_Type (Id)
25416 Field := First_Entity (Id);
25417 while Present (Field) loop
25418 Set_Is_Public (Field);
25419 Next_Entity (Field);
25423 end Set_Public_Status_Of;
25427 Full_Id : Entity_Id;
25430 -- Start of processing for Transfer_Entities
25433 Id := First_Entity (From);
25435 if Present (Id) then
25437 -- Merge the entity chain of the source scope with that of the
25438 -- destination scope.
25440 if Present (Last_Entity (To)) then
25441 Link_Entities (Last_Entity (To), Id);
25443 Set_First_Entity (To, Id);
25446 Set_Last_Entity (To, Last_Entity (From));
25448 -- Inspect the entities of the source scope and update their Scope
25451 while Present (Id) loop
25452 Set_Scope (Id, To);
25453 Set_Public_Status_Of (Id);
25455 -- Handle an internally generated full view for a private type
25457 if Is_Private_Type (Id)
25458 and then Present (Full_View (Id))
25459 and then Is_Itype (Full_View (Id))
25461 Full_Id := Full_View (Id);
25463 Set_Scope (Full_Id, To);
25464 Set_Public_Status_Of (Full_Id);
25470 Set_First_Entity (From, Empty);
25471 Set_Last_Entity (From, Empty);
25473 end Transfer_Entities;
25475 ------------------------
25476 -- Traverse_More_Func --
25477 ------------------------
25479 function Traverse_More_Func (Node : Node_Id) return Traverse_Final_Result is
25481 Processing_Itype : Boolean := False;
25482 -- Set to True while traversing the nodes under an Itype, to prevent
25483 -- looping on Itype handling during that traversal.
25485 function Process_More (N : Node_Id) return Traverse_Result;
25486 -- Wrapper over the Process callback to handle parts of the AST that
25487 -- are not normally traversed as syntactic children.
25489 function Traverse_Rec (N : Node_Id) return Traverse_Final_Result;
25490 -- Main recursive traversal implemented as an instantiation of
25491 -- Traverse_Func over a modified Process callback.
25497 function Process_More (N : Node_Id) return Traverse_Result is
25499 procedure Traverse_More (N : Node_Id;
25500 Res : in out Traverse_Result);
25501 procedure Traverse_More (L : List_Id;
25502 Res : in out Traverse_Result);
25503 -- Traverse a node or list and update the traversal result to value
25504 -- Abandon when needed.
25506 -------------------
25507 -- Traverse_More --
25508 -------------------
25510 procedure Traverse_More (N : Node_Id;
25511 Res : in out Traverse_Result)
25514 -- Do not process any more nodes if Abandon was reached
25516 if Res = Abandon then
25520 if Traverse_Rec (N) = Abandon then
25525 procedure Traverse_More (L : List_Id;
25526 Res : in out Traverse_Result)
25528 N : Node_Id := First (L);
25531 -- Do not process any more nodes if Abandon was reached
25533 if Res = Abandon then
25537 while Present (N) loop
25538 Traverse_More (N, Res);
25546 Result : Traverse_Result;
25548 -- Start of processing for Process_More
25551 -- Initial callback to Process. Return immediately on Skip/Abandon.
25552 -- Otherwise update the value of Node for further processing of
25553 -- non-syntactic children.
25555 Result := Process (N);
25558 when OK => Node := N;
25559 when OK_Orig => Node := Original_Node (N);
25560 when Skip => return Skip;
25561 when Abandon => return Abandon;
25564 -- Process the relevant semantic children which are a logical part of
25565 -- the AST under this node before returning for the processing of
25566 -- syntactic children.
25568 -- Start with all non-syntactic lists of action nodes
25570 case Nkind (Node) is
25571 when N_Component_Association =>
25572 Traverse_More (Loop_Actions (Node), Result);
25574 when N_Elsif_Part =>
25575 Traverse_More (Condition_Actions (Node), Result);
25577 when N_Short_Circuit =>
25578 Traverse_More (Actions (Node), Result);
25580 when N_Case_Expression_Alternative =>
25581 Traverse_More (Actions (Node), Result);
25583 when N_Iteration_Scheme =>
25584 Traverse_More (Condition_Actions (Node), Result);
25586 when N_If_Expression =>
25587 Traverse_More (Then_Actions (Node), Result);
25588 Traverse_More (Else_Actions (Node), Result);
25590 -- Various nodes have a field Actions as a syntactic node,
25591 -- so it will be traversed in the regular syntactic traversal.
25593 when N_Compilation_Unit_Aux
25594 | N_Compound_Statement
25595 | N_Expression_With_Actions
25604 -- If Process_Itypes is True, process unattached nodes which come
25605 -- from Itypes. This only concerns currently ranges of scalar
25606 -- (possibly as index) types. This traversal is protected against
25607 -- looping with Processing_Itype.
25610 and then not Processing_Itype
25611 and then Nkind (Node) in N_Has_Etype
25612 and then Present (Etype (Node))
25613 and then Is_Itype (Etype (Node))
25616 Typ : constant Entity_Id := Etype (Node);
25618 Processing_Itype := True;
25620 case Ekind (Typ) is
25621 when Scalar_Kind =>
25622 Traverse_More (Scalar_Range (Typ), Result);
25626 Index : Node_Id := First_Index (Typ);
25629 while Present (Index) loop
25630 if Nkind (Index) in N_Has_Entity then
25631 Rng := Scalar_Range (Entity (Index));
25636 Traverse_More (Rng, Result);
25637 Next_Index (Index);
25644 Processing_Itype := False;
25651 -- Define Traverse_Rec as a renaming of the instantiation, as an
25652 -- instantiation cannot complete a previous spec.
25654 function Traverse_Recursive is new Traverse_Func (Process_More);
25655 function Traverse_Rec (N : Node_Id) return Traverse_Final_Result
25656 renames Traverse_Recursive;
25658 -- Start of processing for Traverse_More_Func
25661 return Traverse_Rec (Node);
25662 end Traverse_More_Func;
25664 ------------------------
25665 -- Traverse_More_Proc --
25666 ------------------------
25668 procedure Traverse_More_Proc (Node : Node_Id) is
25669 function Traverse is new Traverse_More_Func (Process, Process_Itypes);
25670 Discard : Traverse_Final_Result;
25671 pragma Warnings (Off, Discard);
25673 Discard := Traverse (Node);
25674 end Traverse_More_Proc;
25676 -----------------------
25677 -- Type_Access_Level --
25678 -----------------------
25680 function Type_Access_Level (Typ : Entity_Id) return Uint is
25684 Btyp := Base_Type (Typ);
25686 -- Ada 2005 (AI-230): For most cases of anonymous access types, we
25687 -- simply use the level where the type is declared. This is true for
25688 -- stand-alone object declarations, and for anonymous access types
25689 -- associated with components the level is the same as that of the
25690 -- enclosing composite type. However, special treatment is needed for
25691 -- the cases of access parameters, return objects of an anonymous access
25692 -- type, and, in Ada 95, access discriminants of limited types.
25694 if Is_Access_Type (Btyp) then
25695 if Ekind (Btyp) = E_Anonymous_Access_Type then
25697 -- If the type is a nonlocal anonymous access type (such as for
25698 -- an access parameter) we treat it as being declared at the
25699 -- library level to ensure that names such as X.all'access don't
25700 -- fail static accessibility checks.
25702 if not Is_Local_Anonymous_Access (Typ) then
25703 return Scope_Depth (Standard_Standard);
25705 -- If this is a return object, the accessibility level is that of
25706 -- the result subtype of the enclosing function. The test here is
25707 -- little complicated, because we have to account for extended
25708 -- return statements that have been rewritten as blocks, in which
25709 -- case we have to find and the Is_Return_Object attribute of the
25710 -- itype's associated object. It would be nice to find a way to
25711 -- simplify this test, but it doesn't seem worthwhile to add a new
25712 -- flag just for purposes of this test. ???
25714 elsif Ekind (Scope (Btyp)) = E_Return_Statement
25717 and then Nkind (Associated_Node_For_Itype (Btyp)) =
25718 N_Object_Declaration
25719 and then Is_Return_Object
25720 (Defining_Identifier
25721 (Associated_Node_For_Itype (Btyp))))
25727 Scop := Scope (Scope (Btyp));
25728 while Present (Scop) loop
25729 exit when Ekind (Scop) = E_Function;
25730 Scop := Scope (Scop);
25733 -- Treat the return object's type as having the level of the
25734 -- function's result subtype (as per RM05-6.5(5.3/2)).
25736 return Type_Access_Level (Etype (Scop));
25741 Btyp := Root_Type (Btyp);
25743 -- The accessibility level of anonymous access types associated with
25744 -- discriminants is that of the current instance of the type, and
25745 -- that's deeper than the type itself (AARM 3.10.2 (12.3.21)).
25747 -- AI-402: access discriminants have accessibility based on the
25748 -- object rather than the type in Ada 2005, so the above paragraph
25751 -- ??? Needs completion with rules from AI-416
25753 if Ada_Version <= Ada_95
25754 and then Ekind (Typ) = E_Anonymous_Access_Type
25755 and then Present (Associated_Node_For_Itype (Typ))
25756 and then Nkind (Associated_Node_For_Itype (Typ)) =
25757 N_Discriminant_Specification
25759 return Scope_Depth (Enclosing_Dynamic_Scope (Btyp)) + 1;
25763 -- Return library level for a generic formal type. This is done because
25764 -- RM(10.3.2) says that "The statically deeper relationship does not
25765 -- apply to ... a descendant of a generic formal type". Rather than
25766 -- checking at each point where a static accessibility check is
25767 -- performed to see if we are dealing with a formal type, this rule is
25768 -- implemented by having Type_Access_Level and Deepest_Type_Access_Level
25769 -- return extreme values for a formal type; Deepest_Type_Access_Level
25770 -- returns Int'Last. By calling the appropriate function from among the
25771 -- two, we ensure that the static accessibility check will pass if we
25772 -- happen to run into a formal type. More specifically, we should call
25773 -- Deepest_Type_Access_Level instead of Type_Access_Level whenever the
25774 -- call occurs as part of a static accessibility check and the error
25775 -- case is the case where the type's level is too shallow (as opposed
25778 if Is_Generic_Type (Root_Type (Btyp)) then
25779 return Scope_Depth (Standard_Standard);
25782 return Scope_Depth (Enclosing_Dynamic_Scope (Btyp));
25783 end Type_Access_Level;
25785 ------------------------------------
25786 -- Type_Without_Stream_Operation --
25787 ------------------------------------
25789 function Type_Without_Stream_Operation
25791 Op : TSS_Name_Type := TSS_Null) return Entity_Id
25793 BT : constant Entity_Id := Base_Type (T);
25794 Op_Missing : Boolean;
25797 if not Restriction_Active (No_Default_Stream_Attributes) then
25801 if Is_Elementary_Type (T) then
25802 if Op = TSS_Null then
25804 No (TSS (BT, TSS_Stream_Read))
25805 or else No (TSS (BT, TSS_Stream_Write));
25808 Op_Missing := No (TSS (BT, Op));
25817 elsif Is_Array_Type (T) then
25818 return Type_Without_Stream_Operation (Component_Type (T), Op);
25820 elsif Is_Record_Type (T) then
25826 Comp := First_Component (T);
25827 while Present (Comp) loop
25828 C_Typ := Type_Without_Stream_Operation (Etype (Comp), Op);
25830 if Present (C_Typ) then
25834 Next_Component (Comp);
25840 elsif Is_Private_Type (T) and then Present (Full_View (T)) then
25841 return Type_Without_Stream_Operation (Full_View (T), Op);
25845 end Type_Without_Stream_Operation;
25847 ---------------------
25848 -- Ultimate_Prefix --
25849 ---------------------
25851 function Ultimate_Prefix (N : Node_Id) return Node_Id is
25856 while Nkind_In (Pref, N_Explicit_Dereference,
25857 N_Indexed_Component,
25858 N_Selected_Component,
25861 Pref := Prefix (Pref);
25865 end Ultimate_Prefix;
25867 ----------------------------
25868 -- Unique_Defining_Entity --
25869 ----------------------------
25871 function Unique_Defining_Entity (N : Node_Id) return Entity_Id is
25873 return Unique_Entity (Defining_Entity (N));
25874 end Unique_Defining_Entity;
25876 -------------------
25877 -- Unique_Entity --
25878 -------------------
25880 function Unique_Entity (E : Entity_Id) return Entity_Id is
25881 U : Entity_Id := E;
25887 if Present (Full_View (E)) then
25888 U := Full_View (E);
25892 if Nkind (Parent (E)) = N_Entry_Body then
25894 Prot_Item : Entity_Id;
25895 Prot_Type : Entity_Id;
25898 if Ekind (E) = E_Entry then
25899 Prot_Type := Scope (E);
25901 -- Bodies of entry families are nested within an extra scope
25902 -- that contains an entry index declaration.
25905 Prot_Type := Scope (Scope (E));
25908 -- A protected type may be declared as a private type, in
25909 -- which case we need to get its full view.
25911 if Is_Private_Type (Prot_Type) then
25912 Prot_Type := Full_View (Prot_Type);
25915 -- Full view may not be present on error, in which case
25916 -- return E by default.
25918 if Present (Prot_Type) then
25919 pragma Assert (Ekind (Prot_Type) = E_Protected_Type);
25921 -- Traverse the entity list of the protected type and
25922 -- locate an entry declaration which matches the entry
25925 Prot_Item := First_Entity (Prot_Type);
25926 while Present (Prot_Item) loop
25927 if Ekind (Prot_Item) in Entry_Kind
25928 and then Corresponding_Body (Parent (Prot_Item)) = E
25934 Next_Entity (Prot_Item);
25940 when Formal_Kind =>
25941 if Present (Spec_Entity (E)) then
25942 U := Spec_Entity (E);
25945 when E_Package_Body =>
25948 if Nkind (P) = N_Defining_Program_Unit_Name then
25952 if Nkind (P) = N_Package_Body
25953 and then Present (Corresponding_Spec (P))
25955 U := Corresponding_Spec (P);
25957 elsif Nkind (P) = N_Package_Body_Stub
25958 and then Present (Corresponding_Spec_Of_Stub (P))
25960 U := Corresponding_Spec_Of_Stub (P);
25963 when E_Protected_Body =>
25966 if Nkind (P) = N_Protected_Body
25967 and then Present (Corresponding_Spec (P))
25969 U := Corresponding_Spec (P);
25971 elsif Nkind (P) = N_Protected_Body_Stub
25972 and then Present (Corresponding_Spec_Of_Stub (P))
25974 U := Corresponding_Spec_Of_Stub (P);
25976 if Is_Single_Protected_Object (U) then
25981 if Is_Private_Type (U) then
25982 U := Full_View (U);
25985 when E_Subprogram_Body =>
25988 if Nkind (P) = N_Defining_Program_Unit_Name then
25994 if Nkind (P) = N_Subprogram_Body
25995 and then Present (Corresponding_Spec (P))
25997 U := Corresponding_Spec (P);
25999 elsif Nkind (P) = N_Subprogram_Body_Stub
26000 and then Present (Corresponding_Spec_Of_Stub (P))
26002 U := Corresponding_Spec_Of_Stub (P);
26004 elsif Nkind (P) = N_Subprogram_Renaming_Declaration then
26005 U := Corresponding_Spec (P);
26008 when E_Task_Body =>
26011 if Nkind (P) = N_Task_Body
26012 and then Present (Corresponding_Spec (P))
26014 U := Corresponding_Spec (P);
26016 elsif Nkind (P) = N_Task_Body_Stub
26017 and then Present (Corresponding_Spec_Of_Stub (P))
26019 U := Corresponding_Spec_Of_Stub (P);
26021 if Is_Single_Task_Object (U) then
26026 if Is_Private_Type (U) then
26027 U := Full_View (U);
26031 if Present (Full_View (E)) then
26032 U := Full_View (E);
26046 function Unique_Name (E : Entity_Id) return String is
26048 -- Names in E_Subprogram_Body or E_Package_Body entities are not
26049 -- reliable, as they may not include the overloading suffix. Instead,
26050 -- when looking for the name of E or one of its enclosing scope, we get
26051 -- the name of the corresponding Unique_Entity.
26053 U : constant Entity_Id := Unique_Entity (E);
26055 function This_Name return String;
26061 function This_Name return String is
26063 return Get_Name_String (Chars (U));
26066 -- Start of processing for Unique_Name
26069 if E = Standard_Standard
26070 or else Has_Fully_Qualified_Name (E)
26074 elsif Ekind (E) = E_Enumeration_Literal then
26075 return Unique_Name (Etype (E)) & "__" & This_Name;
26079 S : constant Entity_Id := Scope (U);
26080 pragma Assert (Present (S));
26083 -- Prefix names of predefined types with standard__, but leave
26084 -- names of user-defined packages and subprograms without prefix
26085 -- (even if technically they are nested in the Standard package).
26087 if S = Standard_Standard then
26088 if Ekind (U) = E_Package or else Is_Subprogram (U) then
26091 return Unique_Name (S) & "__" & This_Name;
26094 -- For intances of generic subprograms use the name of the related
26095 -- instace and skip the scope of its wrapper package.
26097 elsif Is_Wrapper_Package (S) then
26098 pragma Assert (Scope (S) = Scope (Related_Instance (S)));
26099 -- Wrapper package and the instantiation are in the same scope
26102 Enclosing_Name : constant String :=
26103 Unique_Name (Scope (S)) & "__" &
26104 Get_Name_String (Chars (Related_Instance (S)));
26107 if Is_Subprogram (U)
26108 and then not Is_Generic_Actual_Subprogram (U)
26110 return Enclosing_Name;
26112 return Enclosing_Name & "__" & This_Name;
26116 elsif Is_Child_Unit (U) then
26117 return Child_Prefix & Unique_Name (S) & "__" & This_Name;
26119 return Unique_Name (S) & "__" & This_Name;
26125 ---------------------
26126 -- Unit_Is_Visible --
26127 ---------------------
26129 function Unit_Is_Visible (U : Entity_Id) return Boolean is
26130 Curr : constant Node_Id := Cunit (Current_Sem_Unit);
26131 Curr_Entity : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
26133 function Unit_In_Parent_Context (Par_Unit : Node_Id) return Boolean;
26134 -- For a child unit, check whether unit appears in a with_clause
26137 function Unit_In_Context (Comp_Unit : Node_Id) return Boolean;
26138 -- Scan the context clause of one compilation unit looking for a
26139 -- with_clause for the unit in question.
26141 ----------------------------
26142 -- Unit_In_Parent_Context --
26143 ----------------------------
26145 function Unit_In_Parent_Context (Par_Unit : Node_Id) return Boolean is
26147 if Unit_In_Context (Par_Unit) then
26150 elsif Is_Child_Unit (Defining_Entity (Unit (Par_Unit))) then
26151 return Unit_In_Parent_Context (Parent_Spec (Unit (Par_Unit)));
26156 end Unit_In_Parent_Context;
26158 ---------------------
26159 -- Unit_In_Context --
26160 ---------------------
26162 function Unit_In_Context (Comp_Unit : Node_Id) return Boolean is
26166 Clause := First (Context_Items (Comp_Unit));
26167 while Present (Clause) loop
26168 if Nkind (Clause) = N_With_Clause then
26169 if Library_Unit (Clause) = U then
26172 -- The with_clause may denote a renaming of the unit we are
26173 -- looking for, eg. Text_IO which renames Ada.Text_IO.
26176 Renamed_Entity (Entity (Name (Clause))) =
26177 Defining_Entity (Unit (U))
26187 end Unit_In_Context;
26189 -- Start of processing for Unit_Is_Visible
26192 -- The currrent unit is directly visible
26197 elsif Unit_In_Context (Curr) then
26200 -- If the current unit is a body, check the context of the spec
26202 elsif Nkind (Unit (Curr)) = N_Package_Body
26204 (Nkind (Unit (Curr)) = N_Subprogram_Body
26205 and then not Acts_As_Spec (Unit (Curr)))
26207 if Unit_In_Context (Library_Unit (Curr)) then
26212 -- If the spec is a child unit, examine the parents
26214 if Is_Child_Unit (Curr_Entity) then
26215 if Nkind (Unit (Curr)) in N_Unit_Body then
26217 Unit_In_Parent_Context
26218 (Parent_Spec (Unit (Library_Unit (Curr))));
26220 return Unit_In_Parent_Context (Parent_Spec (Unit (Curr)));
26226 end Unit_Is_Visible;
26228 ------------------------------
26229 -- Universal_Interpretation --
26230 ------------------------------
26232 function Universal_Interpretation (Opnd : Node_Id) return Entity_Id is
26233 Index : Interp_Index;
26237 -- The argument may be a formal parameter of an operator or subprogram
26238 -- with multiple interpretations, or else an expression for an actual.
26240 if Nkind (Opnd) = N_Defining_Identifier
26241 or else not Is_Overloaded (Opnd)
26243 if Etype (Opnd) = Universal_Integer
26244 or else Etype (Opnd) = Universal_Real
26246 return Etype (Opnd);
26252 Get_First_Interp (Opnd, Index, It);
26253 while Present (It.Typ) loop
26254 if It.Typ = Universal_Integer
26255 or else It.Typ = Universal_Real
26260 Get_Next_Interp (Index, It);
26265 end Universal_Interpretation;
26271 function Unqualify (Expr : Node_Id) return Node_Id is
26273 -- Recurse to handle unlikely case of multiple levels of qualification
26275 if Nkind (Expr) = N_Qualified_Expression then
26276 return Unqualify (Expression (Expr));
26278 -- Normal case, not a qualified expression
26289 function Unqual_Conv (Expr : Node_Id) return Node_Id is
26291 -- Recurse to handle unlikely case of multiple levels of qualification
26292 -- and/or conversion.
26294 if Nkind_In (Expr, N_Qualified_Expression,
26296 N_Unchecked_Type_Conversion)
26298 return Unqual_Conv (Expression (Expr));
26300 -- Normal case, not a qualified expression
26307 --------------------
26308 -- Validated_View --
26309 --------------------
26311 function Validated_View (Typ : Entity_Id) return Entity_Id is
26312 Continue : Boolean;
26313 Val_Typ : Entity_Id;
26317 Val_Typ := Base_Type (Typ);
26319 -- Obtain the full view of the input type by stripping away concurrency,
26320 -- derivations, and privacy.
26322 while Continue loop
26325 if Is_Concurrent_Type (Val_Typ) then
26326 if Present (Corresponding_Record_Type (Val_Typ)) then
26328 Val_Typ := Corresponding_Record_Type (Val_Typ);
26331 elsif Is_Derived_Type (Val_Typ) then
26333 Val_Typ := Etype (Val_Typ);
26335 elsif Is_Private_Type (Val_Typ) then
26336 if Present (Underlying_Full_View (Val_Typ)) then
26338 Val_Typ := Underlying_Full_View (Val_Typ);
26340 elsif Present (Full_View (Val_Typ)) then
26342 Val_Typ := Full_View (Val_Typ);
26348 end Validated_View;
26350 -----------------------
26351 -- Visible_Ancestors --
26352 -----------------------
26354 function Visible_Ancestors (Typ : Entity_Id) return Elist_Id is
26360 pragma Assert (Is_Record_Type (Typ) and then Is_Tagged_Type (Typ));
26362 -- Collect all the parents and progenitors of Typ. If the full-view of
26363 -- private parents and progenitors is available then it is used to
26364 -- generate the list of visible ancestors; otherwise their partial
26365 -- view is added to the resulting list.
26370 Use_Full_View => True);
26374 Ifaces_List => List_2,
26375 Exclude_Parents => True,
26376 Use_Full_View => True);
26378 -- Join the two lists. Avoid duplications because an interface may
26379 -- simultaneously be parent and progenitor of a type.
26381 Elmt := First_Elmt (List_2);
26382 while Present (Elmt) loop
26383 Append_Unique_Elmt (Node (Elmt), List_1);
26388 end Visible_Ancestors;
26390 ----------------------
26391 -- Within_Init_Proc --
26392 ----------------------
26394 function Within_Init_Proc return Boolean is
26398 S := Current_Scope;
26399 while not Is_Overloadable (S) loop
26400 if S = Standard_Standard then
26407 return Is_Init_Proc (S);
26408 end Within_Init_Proc;
26410 ---------------------------
26411 -- Within_Protected_Type --
26412 ---------------------------
26414 function Within_Protected_Type (E : Entity_Id) return Boolean is
26415 Scop : Entity_Id := Scope (E);
26418 while Present (Scop) loop
26419 if Ekind (Scop) = E_Protected_Type then
26423 Scop := Scope (Scop);
26427 end Within_Protected_Type;
26433 function Within_Scope (E : Entity_Id; S : Entity_Id) return Boolean is
26435 return Scope_Within_Or_Same (Scope (E), S);
26438 ----------------------------
26439 -- Within_Subprogram_Call --
26440 ----------------------------
26442 function Within_Subprogram_Call (N : Node_Id) return Boolean is
26446 -- Climb the parent chain looking for a function or procedure call
26449 while Present (Par) loop
26450 if Nkind_In (Par, N_Entry_Call_Statement,
26452 N_Procedure_Call_Statement)
26456 -- Prevent the search from going too far
26458 elsif Is_Body_Or_Package_Declaration (Par) then
26462 Par := Parent (Par);
26466 end Within_Subprogram_Call;
26472 procedure Wrong_Type (Expr : Node_Id; Expected_Type : Entity_Id) is
26473 Found_Type : constant Entity_Id := First_Subtype (Etype (Expr));
26474 Expec_Type : constant Entity_Id := First_Subtype (Expected_Type);
26476 Matching_Field : Entity_Id;
26477 -- Entity to give a more precise suggestion on how to write a one-
26478 -- element positional aggregate.
26480 function Has_One_Matching_Field return Boolean;
26481 -- Determines if Expec_Type is a record type with a single component or
26482 -- discriminant whose type matches the found type or is one dimensional
26483 -- array whose component type matches the found type. In the case of
26484 -- one discriminant, we ignore the variant parts. That's not accurate,
26485 -- but good enough for the warning.
26487 ----------------------------
26488 -- Has_One_Matching_Field --
26489 ----------------------------
26491 function Has_One_Matching_Field return Boolean is
26495 Matching_Field := Empty;
26497 if Is_Array_Type (Expec_Type)
26498 and then Number_Dimensions (Expec_Type) = 1
26499 and then Covers (Etype (Component_Type (Expec_Type)), Found_Type)
26501 -- Use type name if available. This excludes multidimensional
26502 -- arrays and anonymous arrays.
26504 if Comes_From_Source (Expec_Type) then
26505 Matching_Field := Expec_Type;
26507 -- For an assignment, use name of target
26509 elsif Nkind (Parent (Expr)) = N_Assignment_Statement
26510 and then Is_Entity_Name (Name (Parent (Expr)))
26512 Matching_Field := Entity (Name (Parent (Expr)));
26517 elsif not Is_Record_Type (Expec_Type) then
26521 E := First_Entity (Expec_Type);
26526 elsif not Ekind_In (E, E_Discriminant, E_Component)
26527 or else Nam_In (Chars (E), Name_uTag, Name_uParent)
26536 if not Covers (Etype (E), Found_Type) then
26539 elsif Present (Next_Entity (E))
26540 and then (Ekind (E) = E_Component
26541 or else Ekind (Next_Entity (E)) = E_Discriminant)
26546 Matching_Field := E;
26550 end Has_One_Matching_Field;
26552 -- Start of processing for Wrong_Type
26555 -- Don't output message if either type is Any_Type, or if a message
26556 -- has already been posted for this node. We need to do the latter
26557 -- check explicitly (it is ordinarily done in Errout), because we
26558 -- are using ! to force the output of the error messages.
26560 if Expec_Type = Any_Type
26561 or else Found_Type = Any_Type
26562 or else Error_Posted (Expr)
26566 -- If one of the types is a Taft-Amendment type and the other it its
26567 -- completion, it must be an illegal use of a TAT in the spec, for
26568 -- which an error was already emitted. Avoid cascaded errors.
26570 elsif Is_Incomplete_Type (Expec_Type)
26571 and then Has_Completion_In_Body (Expec_Type)
26572 and then Full_View (Expec_Type) = Etype (Expr)
26576 elsif Is_Incomplete_Type (Etype (Expr))
26577 and then Has_Completion_In_Body (Etype (Expr))
26578 and then Full_View (Etype (Expr)) = Expec_Type
26582 -- In an instance, there is an ongoing problem with completion of
26583 -- type derived from private types. Their structure is what Gigi
26584 -- expects, but the Etype is the parent type rather than the
26585 -- derived private type itself. Do not flag error in this case. The
26586 -- private completion is an entity without a parent, like an Itype.
26587 -- Similarly, full and partial views may be incorrect in the instance.
26588 -- There is no simple way to insure that it is consistent ???
26590 -- A similar view discrepancy can happen in an inlined body, for the
26591 -- same reason: inserted body may be outside of the original package
26592 -- and only partial views are visible at the point of insertion.
26594 elsif In_Instance or else In_Inlined_Body then
26595 if Etype (Etype (Expr)) = Etype (Expected_Type)
26597 (Has_Private_Declaration (Expected_Type)
26598 or else Has_Private_Declaration (Etype (Expr)))
26599 and then No (Parent (Expected_Type))
26603 elsif Nkind (Parent (Expr)) = N_Qualified_Expression
26604 and then Entity (Subtype_Mark (Parent (Expr))) = Expected_Type
26608 elsif Is_Private_Type (Expected_Type)
26609 and then Present (Full_View (Expected_Type))
26610 and then Covers (Full_View (Expected_Type), Etype (Expr))
26614 -- Conversely, type of expression may be the private one
26616 elsif Is_Private_Type (Base_Type (Etype (Expr)))
26617 and then Full_View (Base_Type (Etype (Expr))) = Expected_Type
26623 -- An interesting special check. If the expression is parenthesized
26624 -- and its type corresponds to the type of the sole component of the
26625 -- expected record type, or to the component type of the expected one
26626 -- dimensional array type, then assume we have a bad aggregate attempt.
26628 if Nkind (Expr) in N_Subexpr
26629 and then Paren_Count (Expr) /= 0
26630 and then Has_One_Matching_Field
26632 Error_Msg_N ("positional aggregate cannot have one component", Expr);
26634 if Present (Matching_Field) then
26635 if Is_Array_Type (Expec_Type) then
26637 ("\write instead `&''First ='> ...`", Expr, Matching_Field);
26640 ("\write instead `& ='> ...`", Expr, Matching_Field);
26644 -- Another special check, if we are looking for a pool-specific access
26645 -- type and we found an E_Access_Attribute_Type, then we have the case
26646 -- of an Access attribute being used in a context which needs a pool-
26647 -- specific type, which is never allowed. The one extra check we make
26648 -- is that the expected designated type covers the Found_Type.
26650 elsif Is_Access_Type (Expec_Type)
26651 and then Ekind (Found_Type) = E_Access_Attribute_Type
26652 and then Ekind (Base_Type (Expec_Type)) /= E_General_Access_Type
26653 and then Ekind (Base_Type (Expec_Type)) /= E_Anonymous_Access_Type
26655 (Designated_Type (Expec_Type), Designated_Type (Found_Type))
26657 Error_Msg_N -- CODEFIX
26658 ("result must be general access type!", Expr);
26659 Error_Msg_NE -- CODEFIX
26660 ("add ALL to }!", Expr, Expec_Type);
26662 -- Another special check, if the expected type is an integer type,
26663 -- but the expression is of type System.Address, and the parent is
26664 -- an addition or subtraction operation whose left operand is the
26665 -- expression in question and whose right operand is of an integral
26666 -- type, then this is an attempt at address arithmetic, so give
26667 -- appropriate message.
26669 elsif Is_Integer_Type (Expec_Type)
26670 and then Is_RTE (Found_Type, RE_Address)
26671 and then Nkind_In (Parent (Expr), N_Op_Add, N_Op_Subtract)
26672 and then Expr = Left_Opnd (Parent (Expr))
26673 and then Is_Integer_Type (Etype (Right_Opnd (Parent (Expr))))
26676 ("address arithmetic not predefined in package System",
26679 ("\possible missing with/use of System.Storage_Elements",
26683 -- If the expected type is an anonymous access type, as for access
26684 -- parameters and discriminants, the error is on the designated types.
26686 elsif Ekind (Expec_Type) = E_Anonymous_Access_Type then
26687 if Comes_From_Source (Expec_Type) then
26688 Error_Msg_NE ("expected}!", Expr, Expec_Type);
26691 ("expected an access type with designated}",
26692 Expr, Designated_Type (Expec_Type));
26695 if Is_Access_Type (Found_Type)
26696 and then not Comes_From_Source (Found_Type)
26699 ("\\found an access type with designated}!",
26700 Expr, Designated_Type (Found_Type));
26702 if From_Limited_With (Found_Type) then
26703 Error_Msg_NE ("\\found incomplete}!", Expr, Found_Type);
26704 Error_Msg_Qual_Level := 99;
26705 Error_Msg_NE -- CODEFIX
26706 ("\\missing `WITH &;", Expr, Scope (Found_Type));
26707 Error_Msg_Qual_Level := 0;
26709 Error_Msg_NE ("found}!", Expr, Found_Type);
26713 -- Normal case of one type found, some other type expected
26716 -- If the names of the two types are the same, see if some number
26717 -- of levels of qualification will help. Don't try more than three
26718 -- levels, and if we get to standard, it's no use (and probably
26719 -- represents an error in the compiler) Also do not bother with
26720 -- internal scope names.
26723 Expec_Scope : Entity_Id;
26724 Found_Scope : Entity_Id;
26727 Expec_Scope := Expec_Type;
26728 Found_Scope := Found_Type;
26730 for Levels in Nat range 0 .. 3 loop
26731 if Chars (Expec_Scope) /= Chars (Found_Scope) then
26732 Error_Msg_Qual_Level := Levels;
26736 Expec_Scope := Scope (Expec_Scope);
26737 Found_Scope := Scope (Found_Scope);
26739 exit when Expec_Scope = Standard_Standard
26740 or else Found_Scope = Standard_Standard
26741 or else not Comes_From_Source (Expec_Scope)
26742 or else not Comes_From_Source (Found_Scope);
26746 if Is_Record_Type (Expec_Type)
26747 and then Present (Corresponding_Remote_Type (Expec_Type))
26749 Error_Msg_NE ("expected}!", Expr,
26750 Corresponding_Remote_Type (Expec_Type));
26752 Error_Msg_NE ("expected}!", Expr, Expec_Type);
26755 if Is_Entity_Name (Expr)
26756 and then Is_Package_Or_Generic_Package (Entity (Expr))
26758 Error_Msg_N ("\\found package name!", Expr);
26760 elsif Is_Entity_Name (Expr)
26761 and then Ekind_In (Entity (Expr), E_Procedure, E_Generic_Procedure)
26763 if Ekind (Expec_Type) = E_Access_Subprogram_Type then
26765 ("found procedure name, possibly missing Access attribute!",
26769 ("\\found procedure name instead of function!", Expr);
26772 elsif Nkind (Expr) = N_Function_Call
26773 and then Ekind (Expec_Type) = E_Access_Subprogram_Type
26774 and then Etype (Designated_Type (Expec_Type)) = Etype (Expr)
26775 and then No (Parameter_Associations (Expr))
26778 ("found function name, possibly missing Access attribute!",
26781 -- Catch common error: a prefix or infix operator which is not
26782 -- directly visible because the type isn't.
26784 elsif Nkind (Expr) in N_Op
26785 and then Is_Overloaded (Expr)
26786 and then not Is_Immediately_Visible (Expec_Type)
26787 and then not Is_Potentially_Use_Visible (Expec_Type)
26788 and then not In_Use (Expec_Type)
26789 and then Has_Compatible_Type (Right_Opnd (Expr), Expec_Type)
26792 ("operator of the type is not directly visible!", Expr);
26794 elsif Ekind (Found_Type) = E_Void
26795 and then Present (Parent (Found_Type))
26796 and then Nkind (Parent (Found_Type)) = N_Full_Type_Declaration
26798 Error_Msg_NE ("\\found premature usage of}!", Expr, Found_Type);
26801 Error_Msg_NE ("\\found}!", Expr, Found_Type);
26804 -- A special check for cases like M1 and M2 = 0 where M1 and M2 are
26805 -- of the same modular type, and (M1 and M2) = 0 was intended.
26807 if Expec_Type = Standard_Boolean
26808 and then Is_Modular_Integer_Type (Found_Type)
26809 and then Nkind_In (Parent (Expr), N_Op_And, N_Op_Or, N_Op_Xor)
26810 and then Nkind (Right_Opnd (Parent (Expr))) in N_Op_Compare
26813 Op : constant Node_Id := Right_Opnd (Parent (Expr));
26814 L : constant Node_Id := Left_Opnd (Op);
26815 R : constant Node_Id := Right_Opnd (Op);
26818 -- The case for the message is when the left operand of the
26819 -- comparison is the same modular type, or when it is an
26820 -- integer literal (or other universal integer expression),
26821 -- which would have been typed as the modular type if the
26822 -- parens had been there.
26824 if (Etype (L) = Found_Type
26826 Etype (L) = Universal_Integer)
26827 and then Is_Integer_Type (Etype (R))
26830 ("\\possible missing parens for modular operation", Expr);
26835 -- Reset error message qualification indication
26837 Error_Msg_Qual_Level := 0;
26841 --------------------------------
26842 -- Yields_Synchronized_Object --
26843 --------------------------------
26845 function Yields_Synchronized_Object (Typ : Entity_Id) return Boolean is
26846 Has_Sync_Comp : Boolean := False;
26850 -- An array type yields a synchronized object if its component type
26851 -- yields a synchronized object.
26853 if Is_Array_Type (Typ) then
26854 return Yields_Synchronized_Object (Component_Type (Typ));
26856 -- A descendant of type Ada.Synchronous_Task_Control.Suspension_Object
26857 -- yields a synchronized object by default.
26859 elsif Is_Descendant_Of_Suspension_Object (Typ) then
26862 -- A protected type yields a synchronized object by default
26864 elsif Is_Protected_Type (Typ) then
26867 -- A record type or type extension yields a synchronized object when its
26868 -- discriminants (if any) lack default values and all components are of
26869 -- a type that yields a synchronized object.
26871 elsif Is_Record_Type (Typ) then
26873 -- Inspect all entities defined in the scope of the type, looking for
26874 -- components of a type that does not yield a synchronized object or
26875 -- for discriminants with default values.
26877 Id := First_Entity (Typ);
26878 while Present (Id) loop
26879 if Comes_From_Source (Id) then
26880 if Ekind (Id) = E_Component then
26881 if Yields_Synchronized_Object (Etype (Id)) then
26882 Has_Sync_Comp := True;
26884 -- The component does not yield a synchronized object
26890 elsif Ekind (Id) = E_Discriminant
26891 and then Present (Expression (Parent (Id)))
26900 -- Ensure that the parent type of a type extension yields a
26901 -- synchronized object.
26903 if Etype (Typ) /= Typ
26904 and then not Is_Private_Type (Etype (Typ))
26905 and then not Yields_Synchronized_Object (Etype (Typ))
26910 -- If we get here, then all discriminants lack default values and all
26911 -- components are of a type that yields a synchronized object.
26913 return Has_Sync_Comp;
26915 -- A synchronized interface type yields a synchronized object by default
26917 elsif Is_Synchronized_Interface (Typ) then
26920 -- A task type yields a synchronized object by default
26922 elsif Is_Task_Type (Typ) then
26925 -- A private type yields a synchronized object if its underlying type
26928 elsif Is_Private_Type (Typ)
26929 and then Present (Underlying_Type (Typ))
26931 return Yields_Synchronized_Object (Underlying_Type (Typ));
26933 -- Otherwise the type does not yield a synchronized object
26938 end Yields_Synchronized_Object;
26940 ---------------------------
26941 -- Yields_Universal_Type --
26942 ---------------------------
26944 function Yields_Universal_Type (N : Node_Id) return Boolean is
26946 -- Integer and real literals are of a universal type
26948 if Nkind_In (N, N_Integer_Literal, N_Real_Literal) then
26951 -- The values of certain attributes are of a universal type
26953 elsif Nkind (N) = N_Attribute_Reference then
26955 Universal_Type_Attribute (Get_Attribute_Id (Attribute_Name (N)));
26957 -- ??? There are possibly other cases to consider
26962 end Yields_Universal_Type;
26965 Erroutc.Subprogram_Name_Ptr := Subprogram_Name'Access;