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.Heap_Sort_G;
71 with GNAT.HTable; use GNAT.HTable;
73 package body Sem_Util is
75 ---------------------------
76 -- Local Data Structures --
77 ---------------------------
79 Invalid_Binder_Values : array (Scalar_Id) of Entity_Id := (others => Empty);
80 -- A collection to hold the entities of the variables declared in package
81 -- System.Scalar_Values which describe the invalid values of scalar types.
83 Invalid_Binder_Values_Set : Boolean := False;
84 -- This flag prevents multiple attempts to initialize Invalid_Binder_Values
86 Invalid_Floats : array (Float_Scalar_Id) of Ureal := (others => No_Ureal);
87 -- A collection to hold the invalid values of float types as specified by
88 -- pragma Initialize_Scalars.
90 Invalid_Integers : array (Integer_Scalar_Id) of Uint := (others => No_Uint);
91 -- A collection to hold the invalid values of integer types as specified
92 -- by pragma Initialize_Scalars.
94 -----------------------
95 -- Local Subprograms --
96 -----------------------
98 function Build_Component_Subtype
101 T : Entity_Id) return Node_Id;
102 -- This function builds the subtype for Build_Actual_Subtype_Of_Component
103 -- and Build_Discriminal_Subtype_Of_Component. C is a list of constraints,
104 -- Loc is the source location, T is the original subtype.
106 procedure Examine_Array_Bounds
108 All_Static : out Boolean;
109 Has_Empty : out Boolean);
110 -- Inspect the index constraints of array type Typ. Flag All_Static is set
111 -- when all ranges are static. Flag Has_Empty is set only when All_Static
112 -- is set and indicates that at least one range is empty.
114 function Has_Enabled_Property
115 (Item_Id : Entity_Id;
116 Property : Name_Id) return Boolean;
117 -- Subsidiary to routines Async_xxx_Enabled and Effective_xxx_Enabled.
118 -- Determine whether an abstract state or a variable denoted by entity
119 -- Item_Id has enabled property Property.
121 function Has_Null_Extension (T : Entity_Id) return Boolean;
122 -- T is a derived tagged type. Check whether the type extension is null.
123 -- If the parent type is fully initialized, T can be treated as such.
125 function Is_Atomic_Object_Entity (Id : Entity_Id) return Boolean;
126 -- Determine whether arbitrary entity Id denotes an atomic object as per
129 function Is_Fully_Initialized_Variant (Typ : Entity_Id) return Boolean;
130 -- Subsidiary to Is_Fully_Initialized_Type. For an unconstrained type
131 -- with discriminants whose default values are static, examine only the
132 -- components in the selected variant to determine whether all of them
135 type Null_Status_Kind is
137 -- This value indicates that a subexpression is known to have a null
138 -- value at compile time.
141 -- This value indicates that a subexpression is known to have a non-null
142 -- value at compile time.
145 -- This value indicates that it cannot be determined at compile time
146 -- whether a subexpression yields a null or non-null value.
148 function Null_Status (N : Node_Id) return Null_Status_Kind;
149 -- Determine whether subexpression N of an access type yields a null value,
150 -- a non-null value, or the value cannot be determined at compile time. The
151 -- routine does not take simple flow diagnostics into account, it relies on
152 -- static facts such as the presence of null exclusions.
154 function Old_Requires_Transient_Scope (Id : Entity_Id) return Boolean;
155 function New_Requires_Transient_Scope (Id : Entity_Id) return Boolean;
156 -- ???We retain the old and new algorithms for Requires_Transient_Scope for
157 -- the time being. New_Requires_Transient_Scope is used by default; the
158 -- debug switch -gnatdQ can be used to do Old_Requires_Transient_Scope
159 -- instead. The intent is to use this temporarily to measure before/after
160 -- efficiency. Note: when this temporary code is removed, the documentation
161 -- of dQ in debug.adb should be removed.
163 procedure Results_Differ
167 -- ???Debugging code. Called when the Old_Val and New_Val differ. This
168 -- routine will be removed eventially when New_Requires_Transient_Scope
169 -- becomes Requires_Transient_Scope and Old_Requires_Transient_Scope is
172 function Subprogram_Name (N : Node_Id) return String;
173 -- Return the fully qualified name of the enclosing subprogram for the
174 -- given node N, with file:line:col information appended, e.g.
175 -- "subp:file:line:col", corresponding to the source location of the
176 -- body of the subprogram.
178 ------------------------------
179 -- Abstract_Interface_List --
180 ------------------------------
182 function Abstract_Interface_List (Typ : Entity_Id) return List_Id is
186 if Is_Concurrent_Type (Typ) then
188 -- If we are dealing with a synchronized subtype, go to the base
189 -- type, whose declaration has the interface list.
191 Nod := Declaration_Node (Base_Type (Typ));
193 if Nkind_In (Nod, N_Full_Type_Declaration,
194 N_Private_Type_Declaration)
199 elsif Ekind (Typ) = E_Record_Type_With_Private then
200 if Nkind (Parent (Typ)) = N_Full_Type_Declaration then
201 Nod := Type_Definition (Parent (Typ));
203 elsif Nkind (Parent (Typ)) = N_Private_Type_Declaration then
204 if Present (Full_View (Typ))
206 Nkind (Parent (Full_View (Typ))) = N_Full_Type_Declaration
208 Nod := Type_Definition (Parent (Full_View (Typ)));
210 -- If the full-view is not available we cannot do anything else
211 -- here (the source has errors).
217 -- Support for generic formals with interfaces is still missing ???
219 elsif Nkind (Parent (Typ)) = N_Formal_Type_Declaration then
224 (Nkind (Parent (Typ)) = N_Private_Extension_Declaration);
228 elsif Ekind (Typ) = E_Record_Subtype then
229 Nod := Type_Definition (Parent (Etype (Typ)));
231 elsif Ekind (Typ) = E_Record_Subtype_With_Private then
233 -- Recurse, because parent may still be a private extension. Also
234 -- note that the full view of the subtype or the full view of its
235 -- base type may (both) be unavailable.
237 return Abstract_Interface_List (Etype (Typ));
239 elsif Ekind (Typ) = E_Record_Type then
240 if Nkind (Parent (Typ)) = N_Formal_Type_Declaration then
241 Nod := Formal_Type_Definition (Parent (Typ));
243 Nod := Type_Definition (Parent (Typ));
246 -- Otherwise the type is of a kind which does not implement interfaces
252 return Interface_List (Nod);
253 end Abstract_Interface_List;
255 ----------------------------------
256 -- Acquire_Warning_Match_String --
257 ----------------------------------
259 function Acquire_Warning_Match_String (Str_Lit : Node_Id) return String is
260 S : constant String := To_String (Strval (Str_Lit));
265 -- Put "*" before or after or both, if it's not already there
268 F : constant Boolean := S (S'First) = '*';
269 L : constant Boolean := S (S'Last) = '*';
281 return "*" & S & "*";
286 end Acquire_Warning_Match_String;
288 --------------------------------
289 -- Add_Access_Type_To_Process --
290 --------------------------------
292 procedure Add_Access_Type_To_Process (E : Entity_Id; A : Entity_Id) is
296 Ensure_Freeze_Node (E);
297 L := Access_Types_To_Process (Freeze_Node (E));
301 Set_Access_Types_To_Process (Freeze_Node (E), L);
305 end Add_Access_Type_To_Process;
307 --------------------------
308 -- Add_Block_Identifier --
309 --------------------------
311 procedure Add_Block_Identifier (N : Node_Id; Id : out Entity_Id) is
312 Loc : constant Source_Ptr := Sloc (N);
315 pragma Assert (Nkind (N) = N_Block_Statement);
317 -- The block already has a label, return its entity
319 if Present (Identifier (N)) then
320 Id := Entity (Identifier (N));
322 -- Create a new block label and set its attributes
325 Id := New_Internal_Entity (E_Block, Current_Scope, Loc, 'B');
326 Set_Etype (Id, Standard_Void_Type);
329 Set_Identifier (N, New_Occurrence_Of (Id, Loc));
330 Set_Block_Node (Id, Identifier (N));
332 end Add_Block_Identifier;
334 ----------------------------
335 -- Add_Global_Declaration --
336 ----------------------------
338 procedure Add_Global_Declaration (N : Node_Id) is
339 Aux_Node : constant Node_Id := Aux_Decls_Node (Cunit (Current_Sem_Unit));
342 if No (Declarations (Aux_Node)) then
343 Set_Declarations (Aux_Node, New_List);
346 Append_To (Declarations (Aux_Node), N);
348 end Add_Global_Declaration;
350 --------------------------------
351 -- Address_Integer_Convert_OK --
352 --------------------------------
354 function Address_Integer_Convert_OK (T1, T2 : Entity_Id) return Boolean is
356 if Allow_Integer_Address
357 and then ((Is_Descendant_Of_Address (T1)
358 and then Is_Private_Type (T1)
359 and then Is_Integer_Type (T2))
361 (Is_Descendant_Of_Address (T2)
362 and then Is_Private_Type (T2)
363 and then Is_Integer_Type (T1)))
369 end Address_Integer_Convert_OK;
375 function Address_Value (N : Node_Id) return Node_Id is
380 -- For constant, get constant expression
382 if Is_Entity_Name (Expr)
383 and then Ekind (Entity (Expr)) = E_Constant
385 Expr := Constant_Value (Entity (Expr));
387 -- For unchecked conversion, get result to convert
389 elsif Nkind (Expr) = N_Unchecked_Type_Conversion then
390 Expr := Expression (Expr);
392 -- For (common case) of To_Address call, get argument
394 elsif Nkind (Expr) = N_Function_Call
395 and then Is_Entity_Name (Name (Expr))
396 and then Is_RTE (Entity (Name (Expr)), RE_To_Address)
398 Expr := First (Parameter_Associations (Expr));
400 if Nkind (Expr) = N_Parameter_Association then
401 Expr := Explicit_Actual_Parameter (Expr);
404 -- We finally have the real expression
418 -- For now, just 8/16/32/64
420 function Addressable (V : Uint) return Boolean is
422 return V = Uint_8 or else
428 function Addressable (V : Int) return Boolean is
436 ---------------------------------
437 -- Aggregate_Constraint_Checks --
438 ---------------------------------
440 procedure Aggregate_Constraint_Checks
442 Check_Typ : Entity_Id)
444 Exp_Typ : constant Entity_Id := Etype (Exp);
447 if Raises_Constraint_Error (Exp) then
451 -- Ada 2005 (AI-230): Generate a conversion to an anonymous access
452 -- component's type to force the appropriate accessibility checks.
454 -- Ada 2005 (AI-231): Generate conversion to the null-excluding type to
455 -- force the corresponding run-time check
457 if Is_Access_Type (Check_Typ)
458 and then Is_Local_Anonymous_Access (Check_Typ)
460 Rewrite (Exp, Convert_To (Check_Typ, Relocate_Node (Exp)));
461 Analyze_And_Resolve (Exp, Check_Typ);
462 Check_Unset_Reference (Exp);
465 -- What follows is really expansion activity, so check that expansion
466 -- is on and is allowed. In GNATprove mode, we also want check flags to
467 -- be added in the tree, so that the formal verification can rely on
468 -- those to be present. In GNATprove mode for formal verification, some
469 -- treatment typically only done during expansion needs to be performed
470 -- on the tree, but it should not be applied inside generics. Otherwise,
471 -- this breaks the name resolution mechanism for generic instances.
473 if not Expander_Active
474 and (Inside_A_Generic or not Full_Analysis or not GNATprove_Mode)
479 if Is_Access_Type (Check_Typ)
480 and then Can_Never_Be_Null (Check_Typ)
481 and then not Can_Never_Be_Null (Exp_Typ)
483 Install_Null_Excluding_Check (Exp);
486 -- First check if we have to insert discriminant checks
488 if Has_Discriminants (Exp_Typ) then
489 Apply_Discriminant_Check (Exp, Check_Typ);
491 -- Next emit length checks for array aggregates
493 elsif Is_Array_Type (Exp_Typ) then
494 Apply_Length_Check (Exp, Check_Typ);
496 -- Finally emit scalar and string checks. If we are dealing with a
497 -- scalar literal we need to check by hand because the Etype of
498 -- literals is not necessarily correct.
500 elsif Is_Scalar_Type (Exp_Typ)
501 and then Compile_Time_Known_Value (Exp)
503 if Is_Out_Of_Range (Exp, Base_Type (Check_Typ)) then
504 Apply_Compile_Time_Constraint_Error
505 (Exp, "value not in range of}??", CE_Range_Check_Failed,
506 Ent => Base_Type (Check_Typ),
507 Typ => Base_Type (Check_Typ));
509 elsif Is_Out_Of_Range (Exp, Check_Typ) then
510 Apply_Compile_Time_Constraint_Error
511 (Exp, "value not in range of}??", CE_Range_Check_Failed,
515 elsif not Range_Checks_Suppressed (Check_Typ) then
516 Apply_Scalar_Range_Check (Exp, Check_Typ);
519 -- Verify that target type is also scalar, to prevent view anomalies
520 -- in instantiations.
522 elsif (Is_Scalar_Type (Exp_Typ)
523 or else Nkind (Exp) = N_String_Literal)
524 and then Is_Scalar_Type (Check_Typ)
525 and then Exp_Typ /= Check_Typ
527 if Is_Entity_Name (Exp)
528 and then Ekind (Entity (Exp)) = E_Constant
530 -- If expression is a constant, it is worthwhile checking whether
531 -- it is a bound of the type.
533 if (Is_Entity_Name (Type_Low_Bound (Check_Typ))
534 and then Entity (Exp) = Entity (Type_Low_Bound (Check_Typ)))
536 (Is_Entity_Name (Type_High_Bound (Check_Typ))
537 and then Entity (Exp) = Entity (Type_High_Bound (Check_Typ)))
542 Rewrite (Exp, Convert_To (Check_Typ, Relocate_Node (Exp)));
543 Analyze_And_Resolve (Exp, Check_Typ);
544 Check_Unset_Reference (Exp);
547 -- Could use a comment on this case ???
550 Rewrite (Exp, Convert_To (Check_Typ, Relocate_Node (Exp)));
551 Analyze_And_Resolve (Exp, Check_Typ);
552 Check_Unset_Reference (Exp);
556 end Aggregate_Constraint_Checks;
558 -----------------------
559 -- Alignment_In_Bits --
560 -----------------------
562 function Alignment_In_Bits (E : Entity_Id) return Uint is
564 return Alignment (E) * System_Storage_Unit;
565 end Alignment_In_Bits;
567 --------------------------------------
568 -- All_Composite_Constraints_Static --
569 --------------------------------------
571 function All_Composite_Constraints_Static
572 (Constr : Node_Id) return Boolean
575 if No (Constr) or else Error_Posted (Constr) then
579 case Nkind (Constr) is
581 if Nkind (Constr) in N_Has_Entity
582 and then Present (Entity (Constr))
584 if Is_Type (Entity (Constr)) then
586 not Is_Discrete_Type (Entity (Constr))
587 or else Is_OK_Static_Subtype (Entity (Constr));
590 elsif Nkind (Constr) = N_Range then
592 Is_OK_Static_Expression (Low_Bound (Constr))
594 Is_OK_Static_Expression (High_Bound (Constr));
596 elsif Nkind (Constr) = N_Attribute_Reference
597 and then Attribute_Name (Constr) = Name_Range
600 Is_OK_Static_Expression
601 (Type_Low_Bound (Etype (Prefix (Constr))))
603 Is_OK_Static_Expression
604 (Type_High_Bound (Etype (Prefix (Constr))));
608 not Present (Etype (Constr)) -- previous error
609 or else not Is_Discrete_Type (Etype (Constr))
610 or else Is_OK_Static_Expression (Constr);
612 when N_Discriminant_Association =>
613 return All_Composite_Constraints_Static (Expression (Constr));
615 when N_Range_Constraint =>
617 All_Composite_Constraints_Static (Range_Expression (Constr));
619 when N_Index_Or_Discriminant_Constraint =>
621 One_Cstr : Entity_Id;
623 One_Cstr := First (Constraints (Constr));
624 while Present (One_Cstr) loop
625 if not All_Composite_Constraints_Static (One_Cstr) then
635 when N_Subtype_Indication =>
637 All_Composite_Constraints_Static (Subtype_Mark (Constr))
639 All_Composite_Constraints_Static (Constraint (Constr));
644 end All_Composite_Constraints_Static;
646 ------------------------
647 -- Append_Entity_Name --
648 ------------------------
650 procedure Append_Entity_Name (Buf : in out Bounded_String; E : Entity_Id) is
651 Temp : Bounded_String;
653 procedure Inner (E : Entity_Id);
654 -- Inner recursive routine, keep outer routine nonrecursive to ease
655 -- debugging when we get strange results from this routine.
661 procedure Inner (E : Entity_Id) is
665 -- If entity has an internal name, skip by it, and print its scope.
666 -- Note that we strip a final R from the name before the test; this
667 -- is needed for some cases of instantiations.
670 E_Name : Bounded_String;
673 Append (E_Name, Chars (E));
675 if E_Name.Chars (E_Name.Length) = 'R' then
676 E_Name.Length := E_Name.Length - 1;
679 if Is_Internal_Name (E_Name) then
687 -- Just print entity name if its scope is at the outer level
689 if Scop = Standard_Standard then
692 -- If scope comes from source, write scope and entity
694 elsif Comes_From_Source (Scop) then
695 Append_Entity_Name (Temp, Scop);
698 -- If in wrapper package skip past it
700 elsif Present (Scop) and then Is_Wrapper_Package (Scop) then
701 Append_Entity_Name (Temp, Scope (Scop));
704 -- Otherwise nothing to output (happens in unnamed block statements)
713 E_Name : Bounded_String;
716 Append_Unqualified_Decoded (E_Name, Chars (E));
718 -- Remove trailing upper-case letters from the name (useful for
719 -- dealing with some cases of internal names generated in the case
720 -- of references from within a generic).
722 while E_Name.Length > 1
723 and then E_Name.Chars (E_Name.Length) in 'A' .. 'Z'
725 E_Name.Length := E_Name.Length - 1;
728 -- Adjust casing appropriately (gets name from source if possible)
730 Adjust_Name_Case (E_Name, Sloc (E));
731 Append (Temp, E_Name);
735 -- Start of processing for Append_Entity_Name
740 end Append_Entity_Name;
742 ---------------------------------
743 -- Append_Inherited_Subprogram --
744 ---------------------------------
746 procedure Append_Inherited_Subprogram (S : Entity_Id) is
747 Par : constant Entity_Id := Alias (S);
748 -- The parent subprogram
750 Scop : constant Entity_Id := Scope (Par);
751 -- The scope of definition of the parent subprogram
753 Typ : constant Entity_Id := Defining_Entity (Parent (S));
754 -- The derived type of which S is a primitive operation
760 if Ekind (Current_Scope) = E_Package
761 and then In_Private_Part (Current_Scope)
762 and then Has_Private_Declaration (Typ)
763 and then Is_Tagged_Type (Typ)
764 and then Scop = Current_Scope
766 -- The inherited operation is available at the earliest place after
767 -- the derived type declaration (RM 7.3.1 (6/1)). This is only
768 -- relevant for type extensions. If the parent operation appears
769 -- after the type extension, the operation is not visible.
772 (Visible_Declarations
773 (Package_Specification (Current_Scope)));
774 while Present (Decl) loop
775 if Nkind (Decl) = N_Private_Extension_Declaration
776 and then Defining_Entity (Decl) = Typ
778 if Sloc (Decl) > Sloc (Par) then
779 Next_E := Next_Entity (Par);
780 Link_Entities (Par, S);
781 Link_Entities (S, Next_E);
793 -- If partial view is not a type extension, or it appears before the
794 -- subprogram declaration, insert normally at end of entity list.
796 Append_Entity (S, Current_Scope);
797 end Append_Inherited_Subprogram;
799 -----------------------------------------
800 -- Apply_Compile_Time_Constraint_Error --
801 -----------------------------------------
803 procedure Apply_Compile_Time_Constraint_Error
806 Reason : RT_Exception_Code;
807 Ent : Entity_Id := Empty;
808 Typ : Entity_Id := Empty;
809 Loc : Source_Ptr := No_Location;
810 Rep : Boolean := True;
811 Warn : Boolean := False)
813 Stat : constant Boolean := Is_Static_Expression (N);
814 R_Stat : constant Node_Id :=
815 Make_Raise_Constraint_Error (Sloc (N), Reason => Reason);
826 (Compile_Time_Constraint_Error (N, Msg, Ent, Loc, Warn => Warn));
828 -- In GNATprove mode, do not replace the node with an exception raised.
829 -- In such a case, either the call to Compile_Time_Constraint_Error
830 -- issues an error which stops analysis, or it issues a warning in
831 -- a few cases where a suitable check flag is set for GNATprove to
832 -- generate a check message.
834 if not Rep or GNATprove_Mode then
838 -- Now we replace the node by an N_Raise_Constraint_Error node
839 -- This does not need reanalyzing, so set it as analyzed now.
842 Set_Analyzed (N, True);
845 Set_Raises_Constraint_Error (N);
847 -- Now deal with possible local raise handling
849 Possible_Local_Raise (N, Standard_Constraint_Error);
851 -- If the original expression was marked as static, the result is
852 -- still marked as static, but the Raises_Constraint_Error flag is
853 -- always set so that further static evaluation is not attempted.
856 Set_Is_Static_Expression (N);
858 end Apply_Compile_Time_Constraint_Error;
860 ---------------------------
861 -- Async_Readers_Enabled --
862 ---------------------------
864 function Async_Readers_Enabled (Id : Entity_Id) return Boolean is
866 return Has_Enabled_Property (Id, Name_Async_Readers);
867 end Async_Readers_Enabled;
869 ---------------------------
870 -- Async_Writers_Enabled --
871 ---------------------------
873 function Async_Writers_Enabled (Id : Entity_Id) return Boolean is
875 return Has_Enabled_Property (Id, Name_Async_Writers);
876 end Async_Writers_Enabled;
878 --------------------------------------
879 -- Available_Full_View_Of_Component --
880 --------------------------------------
882 function Available_Full_View_Of_Component (T : Entity_Id) return Boolean is
883 ST : constant Entity_Id := Scope (T);
884 SCT : constant Entity_Id := Scope (Component_Type (T));
886 return In_Open_Scopes (ST)
887 and then In_Open_Scopes (SCT)
888 and then Scope_Depth (ST) >= Scope_Depth (SCT);
889 end Available_Full_View_Of_Component;
895 procedure Bad_Attribute
898 Warn : Boolean := False)
901 Error_Msg_Warn := Warn;
902 Error_Msg_N ("unrecognized attribute&<<", N);
904 -- Check for possible misspelling
906 Error_Msg_Name_1 := First_Attribute_Name;
907 while Error_Msg_Name_1 <= Last_Attribute_Name loop
908 if Is_Bad_Spelling_Of (Nam, Error_Msg_Name_1) then
909 Error_Msg_N -- CODEFIX
910 ("\possible misspelling of %<<", N);
914 Error_Msg_Name_1 := Error_Msg_Name_1 + 1;
918 --------------------------------
919 -- Bad_Predicated_Subtype_Use --
920 --------------------------------
922 procedure Bad_Predicated_Subtype_Use
926 Suggest_Static : Boolean := False)
931 -- Avoid cascaded errors
933 if Error_Posted (N) then
937 if Inside_A_Generic then
938 Gen := Current_Scope;
939 while Present (Gen) and then Ekind (Gen) /= E_Generic_Package loop
947 if Is_Generic_Formal (Typ) and then Is_Discrete_Type (Typ) then
948 Set_No_Predicate_On_Actual (Typ);
951 elsif Has_Predicates (Typ) then
952 if Is_Generic_Actual_Type (Typ) then
954 -- The restriction on loop parameters is only that the type
955 -- should have no dynamic predicates.
957 if Nkind (Parent (N)) = N_Loop_Parameter_Specification
958 and then not Has_Dynamic_Predicate_Aspect (Typ)
959 and then Is_OK_Static_Subtype (Typ)
964 Gen := Current_Scope;
965 while not Is_Generic_Instance (Gen) loop
969 pragma Assert (Present (Gen));
971 if Ekind (Gen) = E_Package and then In_Package_Body (Gen) then
972 Error_Msg_Warn := SPARK_Mode /= On;
973 Error_Msg_FE (Msg & "<<", N, Typ);
974 Error_Msg_F ("\Program_Error [<<", N);
977 Make_Raise_Program_Error (Sloc (N),
978 Reason => PE_Bad_Predicated_Generic_Type));
981 Error_Msg_FE (Msg & "<<", N, Typ);
985 Error_Msg_FE (Msg, N, Typ);
988 -- Emit an optional suggestion on how to remedy the error if the
989 -- context warrants it.
991 if Suggest_Static and then Has_Static_Predicate (Typ) then
992 Error_Msg_FE ("\predicate of & should be marked static", N, Typ);
995 end Bad_Predicated_Subtype_Use;
997 -----------------------------------------
998 -- Bad_Unordered_Enumeration_Reference --
999 -----------------------------------------
1001 function Bad_Unordered_Enumeration_Reference
1003 T : Entity_Id) return Boolean
1006 return Is_Enumeration_Type (T)
1007 and then Warn_On_Unordered_Enumeration_Type
1008 and then not Is_Generic_Type (T)
1009 and then Comes_From_Source (N)
1010 and then not Has_Pragma_Ordered (T)
1011 and then not In_Same_Extended_Unit (N, T);
1012 end Bad_Unordered_Enumeration_Reference;
1014 ----------------------------
1015 -- Begin_Keyword_Location --
1016 ----------------------------
1018 function Begin_Keyword_Location (N : Node_Id) return Source_Ptr is
1022 pragma Assert (Nkind_In (N, N_Block_Statement,
1028 HSS := Handled_Statement_Sequence (N);
1030 -- When the handled sequence of statements comes from source, the
1031 -- location of the "begin" keyword is that of the sequence itself.
1032 -- Note that an internal construct may inherit a source sequence.
1034 if Comes_From_Source (HSS) then
1037 -- The parser generates an internal handled sequence of statements to
1038 -- capture the location of the "begin" keyword if present in the source.
1039 -- Since there are no source statements, the location of the "begin"
1040 -- keyword is effectively that of the "end" keyword.
1042 elsif Comes_From_Source (N) then
1045 -- Otherwise the construct is internal and should carry the location of
1046 -- the original construct which prompted its creation.
1051 end Begin_Keyword_Location;
1053 --------------------------
1054 -- Build_Actual_Subtype --
1055 --------------------------
1057 function Build_Actual_Subtype
1059 N : Node_Or_Entity_Id) return Node_Id
1062 -- Normally Sloc (N), but may point to corresponding body in some cases
1064 Constraints : List_Id;
1070 Disc_Type : Entity_Id;
1076 if Nkind (N) = N_Defining_Identifier then
1077 Obj := New_Occurrence_Of (N, Loc);
1079 -- If this is a formal parameter of a subprogram declaration, and
1080 -- we are compiling the body, we want the declaration for the
1081 -- actual subtype to carry the source position of the body, to
1082 -- prevent anomalies in gdb when stepping through the code.
1084 if Is_Formal (N) then
1086 Decl : constant Node_Id := Unit_Declaration_Node (Scope (N));
1088 if Nkind (Decl) = N_Subprogram_Declaration
1089 and then Present (Corresponding_Body (Decl))
1091 Loc := Sloc (Corresponding_Body (Decl));
1100 if Is_Array_Type (T) then
1101 Constraints := New_List;
1102 for J in 1 .. Number_Dimensions (T) loop
1104 -- Build an array subtype declaration with the nominal subtype and
1105 -- the bounds of the actual. Add the declaration in front of the
1106 -- local declarations for the subprogram, for analysis before any
1107 -- reference to the formal in the body.
1110 Make_Attribute_Reference (Loc,
1112 Duplicate_Subexpr_No_Checks (Obj, Name_Req => True),
1113 Attribute_Name => Name_First,
1114 Expressions => New_List (
1115 Make_Integer_Literal (Loc, J)));
1118 Make_Attribute_Reference (Loc,
1120 Duplicate_Subexpr_No_Checks (Obj, Name_Req => True),
1121 Attribute_Name => Name_Last,
1122 Expressions => New_List (
1123 Make_Integer_Literal (Loc, J)));
1125 Append (Make_Range (Loc, Lo, Hi), Constraints);
1128 -- If the type has unknown discriminants there is no constrained
1129 -- subtype to build. This is never called for a formal or for a
1130 -- lhs, so returning the type is ok ???
1132 elsif Has_Unknown_Discriminants (T) then
1136 Constraints := New_List;
1138 -- Type T is a generic derived type, inherit the discriminants from
1141 if Is_Private_Type (T)
1142 and then No (Full_View (T))
1144 -- T was flagged as an error if it was declared as a formal
1145 -- derived type with known discriminants. In this case there
1146 -- is no need to look at the parent type since T already carries
1147 -- its own discriminants.
1149 and then not Error_Posted (T)
1151 Disc_Type := Etype (Base_Type (T));
1156 Discr := First_Discriminant (Disc_Type);
1157 while Present (Discr) loop
1158 Append_To (Constraints,
1159 Make_Selected_Component (Loc,
1161 Duplicate_Subexpr_No_Checks (Obj),
1162 Selector_Name => New_Occurrence_Of (Discr, Loc)));
1163 Next_Discriminant (Discr);
1167 Subt := Make_Temporary (Loc, 'S', Related_Node => N);
1168 Set_Is_Internal (Subt);
1171 Make_Subtype_Declaration (Loc,
1172 Defining_Identifier => Subt,
1173 Subtype_Indication =>
1174 Make_Subtype_Indication (Loc,
1175 Subtype_Mark => New_Occurrence_Of (T, Loc),
1177 Make_Index_Or_Discriminant_Constraint (Loc,
1178 Constraints => Constraints)));
1180 Mark_Rewrite_Insertion (Decl);
1182 end Build_Actual_Subtype;
1184 ---------------------------------------
1185 -- Build_Actual_Subtype_Of_Component --
1186 ---------------------------------------
1188 function Build_Actual_Subtype_Of_Component
1190 N : Node_Id) return Node_Id
1192 Loc : constant Source_Ptr := Sloc (N);
1193 P : constant Node_Id := Prefix (N);
1197 Index_Typ : Entity_Id;
1198 Sel : Entity_Id := Empty;
1200 Desig_Typ : Entity_Id;
1201 -- This is either a copy of T, or if T is an access type, then it is
1202 -- the directly designated type of this access type.
1204 function Build_Access_Record_Constraint (C : List_Id) return List_Id;
1205 -- If the record component is a constrained access to the current
1206 -- record, the subtype has not been constructed during analysis of
1207 -- the enclosing record type (see Analyze_Access). In that case, build
1208 -- a constrained access subtype after replacing references to the
1209 -- enclosing discriminants with the corresponding discriminant values
1212 function Build_Actual_Array_Constraint return List_Id;
1213 -- If one or more of the bounds of the component depends on
1214 -- discriminants, build actual constraint using the discriminants
1215 -- of the prefix, as above.
1217 function Build_Actual_Record_Constraint return List_Id;
1218 -- Similar to previous one, for discriminated components constrained
1219 -- by the discriminant of the enclosing object.
1221 -----------------------------------
1222 -- Build_Actual_Array_Constraint --
1223 -----------------------------------
1225 function Build_Actual_Array_Constraint return List_Id is
1226 Constraints : constant List_Id := New_List;
1234 Indx := First_Index (Desig_Typ);
1235 while Present (Indx) loop
1236 Old_Lo := Type_Low_Bound (Etype (Indx));
1237 Old_Hi := Type_High_Bound (Etype (Indx));
1239 if Denotes_Discriminant (Old_Lo) then
1241 Make_Selected_Component (Loc,
1242 Prefix => New_Copy_Tree (P),
1243 Selector_Name => New_Occurrence_Of (Entity (Old_Lo), Loc));
1246 Lo := New_Copy_Tree (Old_Lo);
1248 -- The new bound will be reanalyzed in the enclosing
1249 -- declaration. For literal bounds that come from a type
1250 -- declaration, the type of the context must be imposed, so
1251 -- insure that analysis will take place. For non-universal
1252 -- types this is not strictly necessary.
1254 Set_Analyzed (Lo, False);
1257 if Denotes_Discriminant (Old_Hi) then
1259 Make_Selected_Component (Loc,
1260 Prefix => New_Copy_Tree (P),
1261 Selector_Name => New_Occurrence_Of (Entity (Old_Hi), Loc));
1264 Hi := New_Copy_Tree (Old_Hi);
1265 Set_Analyzed (Hi, False);
1268 Append (Make_Range (Loc, Lo, Hi), Constraints);
1273 end Build_Actual_Array_Constraint;
1275 ------------------------------------
1276 -- Build_Actual_Record_Constraint --
1277 ------------------------------------
1279 function Build_Actual_Record_Constraint return List_Id is
1280 Constraints : constant List_Id := New_List;
1285 D := First_Elmt (Discriminant_Constraint (Desig_Typ));
1286 while Present (D) loop
1287 if Denotes_Discriminant (Node (D)) then
1288 D_Val := Make_Selected_Component (Loc,
1289 Prefix => New_Copy_Tree (P),
1290 Selector_Name => New_Occurrence_Of (Entity (Node (D)), Loc));
1293 D_Val := New_Copy_Tree (Node (D));
1296 Append (D_Val, Constraints);
1301 end Build_Actual_Record_Constraint;
1303 ------------------------------------
1304 -- Build_Access_Record_Constraint --
1305 ------------------------------------
1307 function Build_Access_Record_Constraint (C : List_Id) return List_Id is
1308 Constraints : constant List_Id := New_List;
1313 -- Retrieve the constraint from the component declaration, because
1314 -- the component subtype has not been constructed and the component
1315 -- type is an unconstrained access.
1318 while Present (D) loop
1319 if Nkind (D) = N_Discriminant_Association
1320 and then Denotes_Discriminant (Expression (D))
1322 D_Val := New_Copy_Tree (D);
1323 Set_Expression (D_Val,
1324 Make_Selected_Component (Loc,
1325 Prefix => New_Copy_Tree (P),
1327 New_Occurrence_Of (Entity (Expression (D)), Loc)));
1329 elsif Denotes_Discriminant (D) then
1330 D_Val := Make_Selected_Component (Loc,
1331 Prefix => New_Copy_Tree (P),
1332 Selector_Name => New_Occurrence_Of (Entity (D), Loc));
1335 D_Val := New_Copy_Tree (D);
1338 Append (D_Val, Constraints);
1343 end Build_Access_Record_Constraint;
1345 -- Start of processing for Build_Actual_Subtype_Of_Component
1348 -- The subtype does not need to be created for a selected component
1349 -- in a Spec_Expression.
1351 if In_Spec_Expression then
1354 -- More comments for the rest of this body would be good ???
1356 elsif Nkind (N) = N_Explicit_Dereference then
1357 if Is_Composite_Type (T)
1358 and then not Is_Constrained (T)
1359 and then not (Is_Class_Wide_Type (T)
1360 and then Is_Constrained (Root_Type (T)))
1361 and then not Has_Unknown_Discriminants (T)
1363 -- If the type of the dereference is already constrained, it is an
1366 if Is_Array_Type (Etype (N))
1367 and then Is_Constrained (Etype (N))
1371 Remove_Side_Effects (P);
1372 return Build_Actual_Subtype (T, N);
1379 elsif Nkind (N) = N_Selected_Component then
1380 -- The entity of the selected component allows us to retrieve
1381 -- the original constraint from its component declaration.
1383 Sel := Entity (Selector_Name (N));
1384 if Nkind (Parent (Sel)) /= N_Component_Declaration then
1389 if Is_Access_Type (T) then
1390 Desig_Typ := Designated_Type (T);
1396 if Ekind (Desig_Typ) = E_Array_Subtype then
1397 Id := First_Index (Desig_Typ);
1399 -- Check whether an index bound is constrained by a discriminant.
1401 while Present (Id) loop
1402 Index_Typ := Underlying_Type (Etype (Id));
1404 if Denotes_Discriminant (Type_Low_Bound (Index_Typ))
1406 Denotes_Discriminant (Type_High_Bound (Index_Typ))
1408 Remove_Side_Effects (P);
1410 Build_Component_Subtype
1411 (Build_Actual_Array_Constraint, Loc, Base_Type (T));
1417 elsif Is_Composite_Type (Desig_Typ)
1418 and then Has_Discriminants (Desig_Typ)
1419 and then not Is_Empty_Elmt_List (Discriminant_Constraint (Desig_Typ))
1420 and then not Has_Unknown_Discriminants (Desig_Typ)
1422 if Is_Private_Type (Desig_Typ)
1423 and then No (Discriminant_Constraint (Desig_Typ))
1425 Desig_Typ := Full_View (Desig_Typ);
1428 D := First_Elmt (Discriminant_Constraint (Desig_Typ));
1429 while Present (D) loop
1430 if Denotes_Discriminant (Node (D)) then
1431 Remove_Side_Effects (P);
1433 Build_Component_Subtype (
1434 Build_Actual_Record_Constraint, Loc, Base_Type (T));
1440 -- Special processing for an access record component that is
1441 -- the target of an assignment. If the designated type is an
1442 -- unconstrained discriminated record we create its actual
1445 elsif Ekind (T) = E_Access_Type
1446 and then Present (Sel)
1447 and then Has_Per_Object_Constraint (Sel)
1448 and then Nkind (Parent (N)) = N_Assignment_Statement
1449 and then N = Name (Parent (N))
1450 -- and then not Inside_Init_Proc
1451 -- and then Has_Discriminants (Desig_Typ)
1452 -- and then not Is_Constrained (Desig_Typ)
1455 S_Indic : constant Node_Id :=
1457 (Component_Definition (Parent (Sel))));
1460 if Nkind (S_Indic) = N_Subtype_Indication then
1461 Discs := Constraints (Constraint (S_Indic));
1463 Remove_Side_Effects (P);
1464 return Build_Component_Subtype
1465 (Build_Access_Record_Constraint (Discs), Loc, T);
1472 -- If none of the above, the actual and nominal subtypes are the same
1475 end Build_Actual_Subtype_Of_Component;
1477 ---------------------------------
1478 -- Build_Class_Wide_Clone_Body --
1479 ---------------------------------
1481 procedure Build_Class_Wide_Clone_Body
1482 (Spec_Id : Entity_Id;
1485 Loc : constant Source_Ptr := Sloc (Bod);
1486 Clone_Id : constant Entity_Id := Class_Wide_Clone (Spec_Id);
1487 Clone_Body : Node_Id;
1490 -- The declaration of the class-wide clone was created when the
1491 -- corresponding class-wide condition was analyzed.
1494 Make_Subprogram_Body (Loc,
1496 Copy_Subprogram_Spec (Parent (Clone_Id)),
1497 Declarations => Declarations (Bod),
1498 Handled_Statement_Sequence => Handled_Statement_Sequence (Bod));
1500 -- The new operation is internal and overriding indicators do not apply
1501 -- (the original primitive may have carried one).
1503 Set_Must_Override (Specification (Clone_Body), False);
1505 -- If the subprogram body is the proper body of a stub, insert the
1506 -- subprogram after the stub, i.e. the same declarative region as
1507 -- the original sugprogram.
1509 if Nkind (Parent (Bod)) = N_Subunit then
1510 Insert_After (Corresponding_Stub (Parent (Bod)), Clone_Body);
1513 Insert_Before (Bod, Clone_Body);
1516 Analyze (Clone_Body);
1517 end Build_Class_Wide_Clone_Body;
1519 ---------------------------------
1520 -- Build_Class_Wide_Clone_Call --
1521 ---------------------------------
1523 function Build_Class_Wide_Clone_Call
1526 Spec_Id : Entity_Id;
1527 Spec : Node_Id) return Node_Id
1529 Clone_Id : constant Entity_Id := Class_Wide_Clone (Spec_Id);
1530 Par_Type : constant Entity_Id := Find_Dispatching_Type (Spec_Id);
1536 New_F_Spec : Entity_Id;
1537 New_Formal : Entity_Id;
1540 Actuals := Empty_List;
1541 Formal := First_Formal (Spec_Id);
1542 New_F_Spec := First (Parameter_Specifications (Spec));
1544 -- Build parameter association for call to class-wide clone.
1546 while Present (Formal) loop
1547 New_Formal := Defining_Identifier (New_F_Spec);
1549 -- If controlling argument and operation is inherited, add conversion
1550 -- to parent type for the call.
1552 if Etype (Formal) = Par_Type
1553 and then not Is_Empty_List (Decls)
1556 Make_Type_Conversion (Loc,
1557 New_Occurrence_Of (Par_Type, Loc),
1558 New_Occurrence_Of (New_Formal, Loc)));
1561 Append_To (Actuals, New_Occurrence_Of (New_Formal, Loc));
1564 Next_Formal (Formal);
1568 if Ekind (Spec_Id) = E_Procedure then
1570 Make_Procedure_Call_Statement (Loc,
1571 Name => New_Occurrence_Of (Clone_Id, Loc),
1572 Parameter_Associations => Actuals);
1575 Make_Simple_Return_Statement (Loc,
1577 Make_Function_Call (Loc,
1578 Name => New_Occurrence_Of (Clone_Id, Loc),
1579 Parameter_Associations => Actuals));
1583 Make_Subprogram_Body (Loc,
1585 Copy_Subprogram_Spec (Spec),
1586 Declarations => Decls,
1587 Handled_Statement_Sequence =>
1588 Make_Handled_Sequence_Of_Statements (Loc,
1589 Statements => New_List (Call),
1590 End_Label => Make_Identifier (Loc, Chars (Spec_Id))));
1593 end Build_Class_Wide_Clone_Call;
1595 ---------------------------------
1596 -- Build_Class_Wide_Clone_Decl --
1597 ---------------------------------
1599 procedure Build_Class_Wide_Clone_Decl (Spec_Id : Entity_Id) is
1600 Loc : constant Source_Ptr := Sloc (Spec_Id);
1601 Clone_Id : constant Entity_Id :=
1602 Make_Defining_Identifier (Loc,
1603 New_External_Name (Chars (Spec_Id), Suffix => "CL"));
1609 Spec := Copy_Subprogram_Spec (Parent (Spec_Id));
1610 Set_Must_Override (Spec, False);
1611 Set_Must_Not_Override (Spec, False);
1612 Set_Defining_Unit_Name (Spec, Clone_Id);
1614 Decl := Make_Subprogram_Declaration (Loc, Spec);
1615 Append (Decl, List_Containing (Unit_Declaration_Node (Spec_Id)));
1617 -- Link clone to original subprogram, for use when building body and
1618 -- wrapper call to inherited operation.
1620 Set_Class_Wide_Clone (Spec_Id, Clone_Id);
1621 end Build_Class_Wide_Clone_Decl;
1623 -----------------------------
1624 -- Build_Component_Subtype --
1625 -----------------------------
1627 function Build_Component_Subtype
1630 T : Entity_Id) return Node_Id
1636 -- Unchecked_Union components do not require component subtypes
1638 if Is_Unchecked_Union (T) then
1642 Subt := Make_Temporary (Loc, 'S');
1643 Set_Is_Internal (Subt);
1646 Make_Subtype_Declaration (Loc,
1647 Defining_Identifier => Subt,
1648 Subtype_Indication =>
1649 Make_Subtype_Indication (Loc,
1650 Subtype_Mark => New_Occurrence_Of (Base_Type (T), Loc),
1652 Make_Index_Or_Discriminant_Constraint (Loc,
1653 Constraints => C)));
1655 Mark_Rewrite_Insertion (Decl);
1657 end Build_Component_Subtype;
1659 ---------------------------
1660 -- Build_Default_Subtype --
1661 ---------------------------
1663 function Build_Default_Subtype
1665 N : Node_Id) return Entity_Id
1667 Loc : constant Source_Ptr := Sloc (N);
1671 -- The base type that is to be constrained by the defaults
1674 if not Has_Discriminants (T) or else Is_Constrained (T) then
1678 Bas := Base_Type (T);
1680 -- If T is non-private but its base type is private, this is the
1681 -- completion of a subtype declaration whose parent type is private
1682 -- (see Complete_Private_Subtype in Sem_Ch3). The proper discriminants
1683 -- are to be found in the full view of the base. Check that the private
1684 -- status of T and its base differ.
1686 if Is_Private_Type (Bas)
1687 and then not Is_Private_Type (T)
1688 and then Present (Full_View (Bas))
1690 Bas := Full_View (Bas);
1693 Disc := First_Discriminant (T);
1695 if No (Discriminant_Default_Value (Disc)) then
1700 Act : constant Entity_Id := Make_Temporary (Loc, 'S');
1701 Constraints : constant List_Id := New_List;
1705 while Present (Disc) loop
1706 Append_To (Constraints,
1707 New_Copy_Tree (Discriminant_Default_Value (Disc)));
1708 Next_Discriminant (Disc);
1712 Make_Subtype_Declaration (Loc,
1713 Defining_Identifier => Act,
1714 Subtype_Indication =>
1715 Make_Subtype_Indication (Loc,
1716 Subtype_Mark => New_Occurrence_Of (Bas, Loc),
1718 Make_Index_Or_Discriminant_Constraint (Loc,
1719 Constraints => Constraints)));
1721 Insert_Action (N, Decl);
1723 -- If the context is a component declaration the subtype declaration
1724 -- will be analyzed when the enclosing type is frozen, otherwise do
1727 if Ekind (Current_Scope) /= E_Record_Type then
1733 end Build_Default_Subtype;
1735 --------------------------------------------
1736 -- Build_Discriminal_Subtype_Of_Component --
1737 --------------------------------------------
1739 function Build_Discriminal_Subtype_Of_Component
1740 (T : Entity_Id) return Node_Id
1742 Loc : constant Source_Ptr := Sloc (T);
1746 function Build_Discriminal_Array_Constraint return List_Id;
1747 -- If one or more of the bounds of the component depends on
1748 -- discriminants, build actual constraint using the discriminants
1751 function Build_Discriminal_Record_Constraint return List_Id;
1752 -- Similar to previous one, for discriminated components constrained by
1753 -- the discriminant of the enclosing object.
1755 ----------------------------------------
1756 -- Build_Discriminal_Array_Constraint --
1757 ----------------------------------------
1759 function Build_Discriminal_Array_Constraint return List_Id is
1760 Constraints : constant List_Id := New_List;
1768 Indx := First_Index (T);
1769 while Present (Indx) loop
1770 Old_Lo := Type_Low_Bound (Etype (Indx));
1771 Old_Hi := Type_High_Bound (Etype (Indx));
1773 if Denotes_Discriminant (Old_Lo) then
1774 Lo := New_Occurrence_Of (Discriminal (Entity (Old_Lo)), Loc);
1777 Lo := New_Copy_Tree (Old_Lo);
1780 if Denotes_Discriminant (Old_Hi) then
1781 Hi := New_Occurrence_Of (Discriminal (Entity (Old_Hi)), Loc);
1784 Hi := New_Copy_Tree (Old_Hi);
1787 Append (Make_Range (Loc, Lo, Hi), Constraints);
1792 end Build_Discriminal_Array_Constraint;
1794 -----------------------------------------
1795 -- Build_Discriminal_Record_Constraint --
1796 -----------------------------------------
1798 function Build_Discriminal_Record_Constraint return List_Id is
1799 Constraints : constant List_Id := New_List;
1804 D := First_Elmt (Discriminant_Constraint (T));
1805 while Present (D) loop
1806 if Denotes_Discriminant (Node (D)) then
1808 New_Occurrence_Of (Discriminal (Entity (Node (D))), Loc);
1810 D_Val := New_Copy_Tree (Node (D));
1813 Append (D_Val, Constraints);
1818 end Build_Discriminal_Record_Constraint;
1820 -- Start of processing for Build_Discriminal_Subtype_Of_Component
1823 if Ekind (T) = E_Array_Subtype then
1824 Id := First_Index (T);
1825 while Present (Id) loop
1826 if Denotes_Discriminant (Type_Low_Bound (Etype (Id)))
1828 Denotes_Discriminant (Type_High_Bound (Etype (Id)))
1830 return Build_Component_Subtype
1831 (Build_Discriminal_Array_Constraint, Loc, T);
1837 elsif Ekind (T) = E_Record_Subtype
1838 and then Has_Discriminants (T)
1839 and then not Has_Unknown_Discriminants (T)
1841 D := First_Elmt (Discriminant_Constraint (T));
1842 while Present (D) loop
1843 if Denotes_Discriminant (Node (D)) then
1844 return Build_Component_Subtype
1845 (Build_Discriminal_Record_Constraint, Loc, T);
1852 -- If none of the above, the actual and nominal subtypes are the same
1855 end Build_Discriminal_Subtype_Of_Component;
1857 ------------------------------
1858 -- Build_Elaboration_Entity --
1859 ------------------------------
1861 procedure Build_Elaboration_Entity (N : Node_Id; Spec_Id : Entity_Id) is
1862 Loc : constant Source_Ptr := Sloc (N);
1864 Elab_Ent : Entity_Id;
1866 procedure Set_Package_Name (Ent : Entity_Id);
1867 -- Given an entity, sets the fully qualified name of the entity in
1868 -- Name_Buffer, with components separated by double underscores. This
1869 -- is a recursive routine that climbs the scope chain to Standard.
1871 ----------------------
1872 -- Set_Package_Name --
1873 ----------------------
1875 procedure Set_Package_Name (Ent : Entity_Id) is
1877 if Scope (Ent) /= Standard_Standard then
1878 Set_Package_Name (Scope (Ent));
1881 Nam : constant String := Get_Name_String (Chars (Ent));
1883 Name_Buffer (Name_Len + 1) := '_';
1884 Name_Buffer (Name_Len + 2) := '_';
1885 Name_Buffer (Name_Len + 3 .. Name_Len + Nam'Length + 2) := Nam;
1886 Name_Len := Name_Len + Nam'Length + 2;
1890 Get_Name_String (Chars (Ent));
1892 end Set_Package_Name;
1894 -- Start of processing for Build_Elaboration_Entity
1897 -- Ignore call if already constructed
1899 if Present (Elaboration_Entity (Spec_Id)) then
1902 -- Ignore in ASIS mode, elaboration entity is not in source and plays
1903 -- no role in analysis.
1905 elsif ASIS_Mode then
1908 -- Do not generate an elaboration entity in GNATprove move because the
1909 -- elaboration counter is a form of expansion.
1911 elsif GNATprove_Mode then
1914 -- See if we need elaboration entity
1916 -- We always need an elaboration entity when preserving control flow, as
1917 -- we want to remain explicit about the unit's elaboration order.
1919 elsif Opt.Suppress_Control_Flow_Optimizations then
1922 -- We always need an elaboration entity for the dynamic elaboration
1923 -- model, since it is needed to properly generate the PE exception for
1924 -- access before elaboration.
1926 elsif Dynamic_Elaboration_Checks then
1929 -- For the static model, we don't need the elaboration counter if this
1930 -- unit is sure to have no elaboration code, since that means there
1931 -- is no elaboration unit to be called. Note that we can't just decide
1932 -- after the fact by looking to see whether there was elaboration code,
1933 -- because that's too late to make this decision.
1935 elsif Restriction_Active (No_Elaboration_Code) then
1938 -- Similarly, for the static model, we can skip the elaboration counter
1939 -- if we have the No_Multiple_Elaboration restriction, since for the
1940 -- static model, that's the only purpose of the counter (to avoid
1941 -- multiple elaboration).
1943 elsif Restriction_Active (No_Multiple_Elaboration) then
1947 -- Here we need the elaboration entity
1949 -- Construct name of elaboration entity as xxx_E, where xxx is the unit
1950 -- name with dots replaced by double underscore. We have to manually
1951 -- construct this name, since it will be elaborated in the outer scope,
1952 -- and thus will not have the unit name automatically prepended.
1954 Set_Package_Name (Spec_Id);
1955 Add_Str_To_Name_Buffer ("_E");
1957 -- Create elaboration counter
1959 Elab_Ent := Make_Defining_Identifier (Loc, Chars => Name_Find);
1960 Set_Elaboration_Entity (Spec_Id, Elab_Ent);
1963 Make_Object_Declaration (Loc,
1964 Defining_Identifier => Elab_Ent,
1965 Object_Definition =>
1966 New_Occurrence_Of (Standard_Short_Integer, Loc),
1967 Expression => Make_Integer_Literal (Loc, Uint_0));
1969 Push_Scope (Standard_Standard);
1970 Add_Global_Declaration (Decl);
1973 -- Reset True_Constant indication, since we will indeed assign a value
1974 -- to the variable in the binder main. We also kill the Current_Value
1975 -- and Last_Assignment fields for the same reason.
1977 Set_Is_True_Constant (Elab_Ent, False);
1978 Set_Current_Value (Elab_Ent, Empty);
1979 Set_Last_Assignment (Elab_Ent, Empty);
1981 -- We do not want any further qualification of the name (if we did not
1982 -- do this, we would pick up the name of the generic package in the case
1983 -- of a library level generic instantiation).
1985 Set_Has_Qualified_Name (Elab_Ent);
1986 Set_Has_Fully_Qualified_Name (Elab_Ent);
1987 end Build_Elaboration_Entity;
1989 --------------------------------
1990 -- Build_Explicit_Dereference --
1991 --------------------------------
1993 procedure Build_Explicit_Dereference
1997 Loc : constant Source_Ptr := Sloc (Expr);
2002 -- An entity of a type with a reference aspect is overloaded with
2003 -- both interpretations: with and without the dereference. Now that
2004 -- the dereference is made explicit, set the type of the node properly,
2005 -- to prevent anomalies in the backend. Same if the expression is an
2006 -- overloaded function call whose return type has a reference aspect.
2008 if Is_Entity_Name (Expr) then
2009 Set_Etype (Expr, Etype (Entity (Expr)));
2011 -- The designated entity will not be examined again when resolving
2012 -- the dereference, so generate a reference to it now.
2014 Generate_Reference (Entity (Expr), Expr);
2016 elsif Nkind (Expr) = N_Function_Call then
2018 -- If the name of the indexing function is overloaded, locate the one
2019 -- whose return type has an implicit dereference on the desired
2020 -- discriminant, and set entity and type of function call.
2022 if Is_Overloaded (Name (Expr)) then
2023 Get_First_Interp (Name (Expr), I, It);
2025 while Present (It.Nam) loop
2026 if Ekind ((It.Typ)) = E_Record_Type
2027 and then First_Entity ((It.Typ)) = Disc
2029 Set_Entity (Name (Expr), It.Nam);
2030 Set_Etype (Name (Expr), Etype (It.Nam));
2034 Get_Next_Interp (I, It);
2038 -- Set type of call from resolved function name.
2040 Set_Etype (Expr, Etype (Name (Expr)));
2043 Set_Is_Overloaded (Expr, False);
2045 -- The expression will often be a generalized indexing that yields a
2046 -- container element that is then dereferenced, in which case the
2047 -- generalized indexing call is also non-overloaded.
2049 if Nkind (Expr) = N_Indexed_Component
2050 and then Present (Generalized_Indexing (Expr))
2052 Set_Is_Overloaded (Generalized_Indexing (Expr), False);
2056 Make_Explicit_Dereference (Loc,
2058 Make_Selected_Component (Loc,
2059 Prefix => Relocate_Node (Expr),
2060 Selector_Name => New_Occurrence_Of (Disc, Loc))));
2061 Set_Etype (Prefix (Expr), Etype (Disc));
2062 Set_Etype (Expr, Designated_Type (Etype (Disc)));
2063 end Build_Explicit_Dereference;
2065 ---------------------------
2066 -- Build_Overriding_Spec --
2067 ---------------------------
2069 function Build_Overriding_Spec
2071 Typ : Entity_Id) return Node_Id
2073 Loc : constant Source_Ptr := Sloc (Typ);
2074 Par_Typ : constant Entity_Id := Find_Dispatching_Type (Op);
2075 Spec : constant Node_Id := Specification (Unit_Declaration_Node (Op));
2077 Formal_Spec : Node_Id;
2078 Formal_Type : Node_Id;
2082 New_Spec := Copy_Subprogram_Spec (Spec);
2084 Formal_Spec := First (Parameter_Specifications (New_Spec));
2085 while Present (Formal_Spec) loop
2086 Formal_Type := Parameter_Type (Formal_Spec);
2088 if Is_Entity_Name (Formal_Type)
2089 and then Entity (Formal_Type) = Par_Typ
2091 Rewrite (Formal_Type, New_Occurrence_Of (Typ, Loc));
2094 -- Nothing needs to be done for access parameters
2100 end Build_Overriding_Spec;
2102 -----------------------------------
2103 -- Cannot_Raise_Constraint_Error --
2104 -----------------------------------
2106 function Cannot_Raise_Constraint_Error (Expr : Node_Id) return Boolean is
2108 if Compile_Time_Known_Value (Expr) then
2111 elsif Do_Range_Check (Expr) then
2114 elsif Raises_Constraint_Error (Expr) then
2118 case Nkind (Expr) is
2119 when N_Identifier =>
2122 when N_Expanded_Name =>
2125 when N_Selected_Component =>
2126 return not Do_Discriminant_Check (Expr);
2128 when N_Attribute_Reference =>
2129 if Do_Overflow_Check (Expr) then
2132 elsif No (Expressions (Expr)) then
2140 N := First (Expressions (Expr));
2141 while Present (N) loop
2142 if Cannot_Raise_Constraint_Error (N) then
2153 when N_Type_Conversion =>
2154 if Do_Overflow_Check (Expr)
2155 or else Do_Length_Check (Expr)
2156 or else Do_Tag_Check (Expr)
2160 return Cannot_Raise_Constraint_Error (Expression (Expr));
2163 when N_Unchecked_Type_Conversion =>
2164 return Cannot_Raise_Constraint_Error (Expression (Expr));
2167 if Do_Overflow_Check (Expr) then
2170 return Cannot_Raise_Constraint_Error (Right_Opnd (Expr));
2177 if Do_Division_Check (Expr)
2179 Do_Overflow_Check (Expr)
2184 Cannot_Raise_Constraint_Error (Left_Opnd (Expr))
2186 Cannot_Raise_Constraint_Error (Right_Opnd (Expr));
2205 | N_Op_Shift_Right_Arithmetic
2209 if Do_Overflow_Check (Expr) then
2213 Cannot_Raise_Constraint_Error (Left_Opnd (Expr))
2215 Cannot_Raise_Constraint_Error (Right_Opnd (Expr));
2222 end Cannot_Raise_Constraint_Error;
2224 -----------------------------------------
2225 -- Check_Dynamically_Tagged_Expression --
2226 -----------------------------------------
2228 procedure Check_Dynamically_Tagged_Expression
2231 Related_Nod : Node_Id)
2234 pragma Assert (Is_Tagged_Type (Typ));
2236 -- In order to avoid spurious errors when analyzing the expanded code,
2237 -- this check is done only for nodes that come from source and for
2238 -- actuals of generic instantiations.
2240 if (Comes_From_Source (Related_Nod)
2241 or else In_Generic_Actual (Expr))
2242 and then (Is_Class_Wide_Type (Etype (Expr))
2243 or else Is_Dynamically_Tagged (Expr))
2244 and then not Is_Class_Wide_Type (Typ)
2246 Error_Msg_N ("dynamically tagged expression not allowed!", Expr);
2248 end Check_Dynamically_Tagged_Expression;
2250 --------------------------
2251 -- Check_Fully_Declared --
2252 --------------------------
2254 procedure Check_Fully_Declared (T : Entity_Id; N : Node_Id) is
2256 if Ekind (T) = E_Incomplete_Type then
2258 -- Ada 2005 (AI-50217): If the type is available through a limited
2259 -- with_clause, verify that its full view has been analyzed.
2261 if From_Limited_With (T)
2262 and then Present (Non_Limited_View (T))
2263 and then Ekind (Non_Limited_View (T)) /= E_Incomplete_Type
2265 -- The non-limited view is fully declared
2271 ("premature usage of incomplete}", N, First_Subtype (T));
2274 -- Need comments for these tests ???
2276 elsif Has_Private_Component (T)
2277 and then not Is_Generic_Type (Root_Type (T))
2278 and then not In_Spec_Expression
2280 -- Special case: if T is the anonymous type created for a single
2281 -- task or protected object, use the name of the source object.
2283 if Is_Concurrent_Type (T)
2284 and then not Comes_From_Source (T)
2285 and then Nkind (N) = N_Object_Declaration
2288 ("type of& has incomplete component",
2289 N, Defining_Identifier (N));
2292 ("premature usage of incomplete}",
2293 N, First_Subtype (T));
2296 end Check_Fully_Declared;
2298 -------------------------------------------
2299 -- Check_Function_With_Address_Parameter --
2300 -------------------------------------------
2302 procedure Check_Function_With_Address_Parameter (Subp_Id : Entity_Id) is
2307 F := First_Formal (Subp_Id);
2308 while Present (F) loop
2311 if Is_Private_Type (T) and then Present (Full_View (T)) then
2315 if Is_Descendant_Of_Address (T) or else Is_Limited_Type (T) then
2316 Set_Is_Pure (Subp_Id, False);
2322 end Check_Function_With_Address_Parameter;
2324 -------------------------------------
2325 -- Check_Function_Writable_Actuals --
2326 -------------------------------------
2328 procedure Check_Function_Writable_Actuals (N : Node_Id) is
2329 Writable_Actuals_List : Elist_Id := No_Elist;
2330 Identifiers_List : Elist_Id := No_Elist;
2331 Aggr_Error_Node : Node_Id := Empty;
2332 Error_Node : Node_Id := Empty;
2334 procedure Collect_Identifiers (N : Node_Id);
2335 -- In a single traversal of subtree N collect in Writable_Actuals_List
2336 -- all the actuals of functions with writable actuals, and in the list
2337 -- Identifiers_List collect all the identifiers that are not actuals of
2338 -- functions with writable actuals. If a writable actual is referenced
2339 -- twice as writable actual then Error_Node is set to reference its
2340 -- second occurrence, the error is reported, and the tree traversal
2343 procedure Preanalyze_Without_Errors (N : Node_Id);
2344 -- Preanalyze N without reporting errors. Very dubious, you can't just
2345 -- go analyzing things more than once???
2347 -------------------------
2348 -- Collect_Identifiers --
2349 -------------------------
2351 procedure Collect_Identifiers (N : Node_Id) is
2353 function Check_Node (N : Node_Id) return Traverse_Result;
2354 -- Process a single node during the tree traversal to collect the
2355 -- writable actuals of functions and all the identifiers which are
2356 -- not writable actuals of functions.
2358 function Contains (List : Elist_Id; N : Node_Id) return Boolean;
2359 -- Returns True if List has a node whose Entity is Entity (N)
2365 function Check_Node (N : Node_Id) return Traverse_Result is
2366 Is_Writable_Actual : Boolean := False;
2370 if Nkind (N) = N_Identifier then
2372 -- No analysis possible if the entity is not decorated
2374 if No (Entity (N)) then
2377 -- Don't collect identifiers of packages, called functions, etc
2379 elsif Ekind_In (Entity (N), E_Package,
2386 -- For rewritten nodes, continue the traversal in the original
2387 -- subtree. Needed to handle aggregates in original expressions
2388 -- extracted from the tree by Remove_Side_Effects.
2390 elsif Is_Rewrite_Substitution (N) then
2391 Collect_Identifiers (Original_Node (N));
2394 -- For now we skip aggregate discriminants, since they require
2395 -- performing the analysis in two phases to identify conflicts:
2396 -- first one analyzing discriminants and second one analyzing
2397 -- the rest of components (since at run time, discriminants are
2398 -- evaluated prior to components): too much computation cost
2399 -- to identify a corner case???
2401 elsif Nkind (Parent (N)) = N_Component_Association
2402 and then Nkind_In (Parent (Parent (N)),
2404 N_Extension_Aggregate)
2407 Choice : constant Node_Id := First (Choices (Parent (N)));
2410 if Ekind (Entity (N)) = E_Discriminant then
2413 elsif Expression (Parent (N)) = N
2414 and then Nkind (Choice) = N_Identifier
2415 and then Ekind (Entity (Choice)) = E_Discriminant
2421 -- Analyze if N is a writable actual of a function
2423 elsif Nkind (Parent (N)) = N_Function_Call then
2425 Call : constant Node_Id := Parent (N);
2430 Id := Get_Called_Entity (Call);
2432 -- In case of previous error, no check is possible
2438 if Ekind_In (Id, E_Function, E_Generic_Function)
2439 and then Has_Out_Or_In_Out_Parameter (Id)
2441 Formal := First_Formal (Id);
2442 Actual := First_Actual (Call);
2443 while Present (Actual) and then Present (Formal) loop
2445 if Ekind_In (Formal, E_Out_Parameter,
2448 Is_Writable_Actual := True;
2454 Next_Formal (Formal);
2455 Next_Actual (Actual);
2461 if Is_Writable_Actual then
2463 -- Skip checking the error in non-elementary types since
2464 -- RM 6.4.1(6.15/3) is restricted to elementary types, but
2465 -- store this actual in Writable_Actuals_List since it is
2466 -- needed to perform checks on other constructs that have
2467 -- arbitrary order of evaluation (for example, aggregates).
2469 if not Is_Elementary_Type (Etype (N)) then
2470 if not Contains (Writable_Actuals_List, N) then
2471 Append_New_Elmt (N, To => Writable_Actuals_List);
2474 -- Second occurrence of an elementary type writable actual
2476 elsif Contains (Writable_Actuals_List, N) then
2478 -- Report the error on the second occurrence of the
2479 -- identifier. We cannot assume that N is the second
2480 -- occurrence (according to their location in the
2481 -- sources), since Traverse_Func walks through Field2
2482 -- last (see comment in the body of Traverse_Func).
2488 Elmt := First_Elmt (Writable_Actuals_List);
2489 while Present (Elmt)
2490 and then Entity (Node (Elmt)) /= Entity (N)
2495 if Sloc (N) > Sloc (Node (Elmt)) then
2498 Error_Node := Node (Elmt);
2502 ("value may be affected by call to & "
2503 & "because order of evaluation is arbitrary",
2508 -- First occurrence of a elementary type writable actual
2511 Append_New_Elmt (N, To => Writable_Actuals_List);
2515 if Identifiers_List = No_Elist then
2516 Identifiers_List := New_Elmt_List;
2519 Append_Unique_Elmt (N, Identifiers_List);
2532 N : Node_Id) return Boolean
2534 pragma Assert (Nkind (N) in N_Has_Entity);
2539 if List = No_Elist then
2543 Elmt := First_Elmt (List);
2544 while Present (Elmt) loop
2545 if Entity (Node (Elmt)) = Entity (N) then
2559 procedure Do_Traversal is new Traverse_Proc (Check_Node);
2560 -- The traversal procedure
2562 -- Start of processing for Collect_Identifiers
2565 if Present (Error_Node) then
2569 if Nkind (N) in N_Subexpr and then Is_OK_Static_Expression (N) then
2574 end Collect_Identifiers;
2576 -------------------------------
2577 -- Preanalyze_Without_Errors --
2578 -------------------------------
2580 procedure Preanalyze_Without_Errors (N : Node_Id) is
2581 Status : constant Boolean := Get_Ignore_Errors;
2583 Set_Ignore_Errors (True);
2585 Set_Ignore_Errors (Status);
2586 end Preanalyze_Without_Errors;
2588 -- Start of processing for Check_Function_Writable_Actuals
2591 -- The check only applies to Ada 2012 code on which Check_Actuals has
2592 -- been set, and only to constructs that have multiple constituents
2593 -- whose order of evaluation is not specified by the language.
2595 if Ada_Version < Ada_2012
2596 or else not Check_Actuals (N)
2597 or else (not (Nkind (N) in N_Op)
2598 and then not (Nkind (N) in N_Membership_Test)
2599 and then not Nkind_In (N, N_Range,
2601 N_Extension_Aggregate,
2602 N_Full_Type_Declaration,
2604 N_Procedure_Call_Statement,
2605 N_Entry_Call_Statement))
2606 or else (Nkind (N) = N_Full_Type_Declaration
2607 and then not Is_Record_Type (Defining_Identifier (N)))
2609 -- In addition, this check only applies to source code, not to code
2610 -- generated by constraint checks.
2612 or else not Comes_From_Source (N)
2617 -- If a construct C has two or more direct constituents that are names
2618 -- or expressions whose evaluation may occur in an arbitrary order, at
2619 -- least one of which contains a function call with an in out or out
2620 -- parameter, then the construct is legal only if: for each name N that
2621 -- is passed as a parameter of mode in out or out to some inner function
2622 -- call C2 (not including the construct C itself), there is no other
2623 -- name anywhere within a direct constituent of the construct C other
2624 -- than the one containing C2, that is known to refer to the same
2625 -- object (RM 6.4.1(6.17/3)).
2629 Collect_Identifiers (Low_Bound (N));
2630 Collect_Identifiers (High_Bound (N));
2632 when N_Membership_Test
2639 Collect_Identifiers (Left_Opnd (N));
2641 if Present (Right_Opnd (N)) then
2642 Collect_Identifiers (Right_Opnd (N));
2645 if Nkind_In (N, N_In, N_Not_In)
2646 and then Present (Alternatives (N))
2648 Expr := First (Alternatives (N));
2649 while Present (Expr) loop
2650 Collect_Identifiers (Expr);
2657 when N_Full_Type_Declaration =>
2659 function Get_Record_Part (N : Node_Id) return Node_Id;
2660 -- Return the record part of this record type definition
2662 function Get_Record_Part (N : Node_Id) return Node_Id is
2663 Type_Def : constant Node_Id := Type_Definition (N);
2665 if Nkind (Type_Def) = N_Derived_Type_Definition then
2666 return Record_Extension_Part (Type_Def);
2670 end Get_Record_Part;
2673 Def_Id : Entity_Id := Defining_Identifier (N);
2674 Rec : Node_Id := Get_Record_Part (N);
2677 -- No need to perform any analysis if the record has no
2680 if No (Rec) or else No (Component_List (Rec)) then
2684 -- Collect the identifiers starting from the deepest
2685 -- derivation. Done to report the error in the deepest
2689 if Present (Component_List (Rec)) then
2690 Comp := First (Component_Items (Component_List (Rec)));
2691 while Present (Comp) loop
2692 if Nkind (Comp) = N_Component_Declaration
2693 and then Present (Expression (Comp))
2695 Collect_Identifiers (Expression (Comp));
2702 exit when No (Underlying_Type (Etype (Def_Id)))
2703 or else Base_Type (Underlying_Type (Etype (Def_Id)))
2706 Def_Id := Base_Type (Underlying_Type (Etype (Def_Id)));
2707 Rec := Get_Record_Part (Parent (Def_Id));
2711 when N_Entry_Call_Statement
2715 Id : constant Entity_Id := Get_Called_Entity (N);
2720 Formal := First_Formal (Id);
2721 Actual := First_Actual (N);
2722 while Present (Actual) and then Present (Formal) loop
2723 if Ekind_In (Formal, E_Out_Parameter,
2726 Collect_Identifiers (Actual);
2729 Next_Formal (Formal);
2730 Next_Actual (Actual);
2735 | N_Extension_Aggregate
2740 Comp_Expr : Node_Id;
2743 -- Handle the N_Others_Choice of array aggregates with static
2744 -- bounds. There is no need to perform this analysis in
2745 -- aggregates without static bounds since we cannot evaluate
2746 -- if the N_Others_Choice covers several elements. There is
2747 -- no need to handle the N_Others choice of record aggregates
2748 -- since at this stage it has been already expanded by
2749 -- Resolve_Record_Aggregate.
2751 if Is_Array_Type (Etype (N))
2752 and then Nkind (N) = N_Aggregate
2753 and then Present (Aggregate_Bounds (N))
2754 and then Compile_Time_Known_Bounds (Etype (N))
2755 and then Expr_Value (High_Bound (Aggregate_Bounds (N)))
2757 Expr_Value (Low_Bound (Aggregate_Bounds (N)))
2760 Count_Components : Uint := Uint_0;
2761 Num_Components : Uint;
2762 Others_Assoc : Node_Id := Empty;
2763 Others_Choice : Node_Id := Empty;
2764 Others_Box_Present : Boolean := False;
2767 -- Count positional associations
2769 if Present (Expressions (N)) then
2770 Comp_Expr := First (Expressions (N));
2771 while Present (Comp_Expr) loop
2772 Count_Components := Count_Components + 1;
2777 -- Count the rest of elements and locate the N_Others
2780 Assoc := First (Component_Associations (N));
2781 while Present (Assoc) loop
2782 Choice := First (Choices (Assoc));
2783 while Present (Choice) loop
2784 if Nkind (Choice) = N_Others_Choice then
2785 Others_Assoc := Assoc;
2786 Others_Choice := Choice;
2787 Others_Box_Present := Box_Present (Assoc);
2789 -- Count several components
2791 elsif Nkind_In (Choice, N_Range,
2792 N_Subtype_Indication)
2793 or else (Is_Entity_Name (Choice)
2794 and then Is_Type (Entity (Choice)))
2799 Get_Index_Bounds (Choice, L, H);
2801 (Compile_Time_Known_Value (L)
2802 and then Compile_Time_Known_Value (H));
2805 + Expr_Value (H) - Expr_Value (L) + 1;
2808 -- Count single component. No other case available
2809 -- since we are handling an aggregate with static
2813 pragma Assert (Is_OK_Static_Expression (Choice)
2814 or else Nkind (Choice) = N_Identifier
2815 or else Nkind (Choice) = N_Integer_Literal);
2817 Count_Components := Count_Components + 1;
2827 Expr_Value (High_Bound (Aggregate_Bounds (N))) -
2828 Expr_Value (Low_Bound (Aggregate_Bounds (N))) + 1;
2830 pragma Assert (Count_Components <= Num_Components);
2832 -- Handle the N_Others choice if it covers several
2835 if Present (Others_Choice)
2836 and then (Num_Components - Count_Components) > 1
2838 if not Others_Box_Present then
2840 -- At this stage, if expansion is active, the
2841 -- expression of the others choice has not been
2842 -- analyzed. Hence we generate a duplicate and
2843 -- we analyze it silently to have available the
2844 -- minimum decoration required to collect the
2847 pragma Assert (Present (Others_Assoc));
2849 if not Expander_Active then
2850 Comp_Expr := Expression (Others_Assoc);
2853 New_Copy_Tree (Expression (Others_Assoc));
2854 Preanalyze_Without_Errors (Comp_Expr);
2857 Collect_Identifiers (Comp_Expr);
2859 if Writable_Actuals_List /= No_Elist then
2861 -- As suggested by Robert, at current stage we
2862 -- report occurrences of this case as warnings.
2865 ("writable function parameter may affect "
2866 & "value in other component because order "
2867 & "of evaluation is unspecified??",
2868 Node (First_Elmt (Writable_Actuals_List)));
2874 -- For an array aggregate, a discrete_choice_list that has
2875 -- a nonstatic range is considered as two or more separate
2876 -- occurrences of the expression (RM 6.4.1(20/3)).
2878 elsif Is_Array_Type (Etype (N))
2879 and then Nkind (N) = N_Aggregate
2880 and then Present (Aggregate_Bounds (N))
2881 and then not Compile_Time_Known_Bounds (Etype (N))
2883 -- Collect identifiers found in the dynamic bounds
2886 Count_Components : Natural := 0;
2887 Low, High : Node_Id;
2890 Assoc := First (Component_Associations (N));
2891 while Present (Assoc) loop
2892 Choice := First (Choices (Assoc));
2893 while Present (Choice) loop
2894 if Nkind_In (Choice, N_Range,
2895 N_Subtype_Indication)
2896 or else (Is_Entity_Name (Choice)
2897 and then Is_Type (Entity (Choice)))
2899 Get_Index_Bounds (Choice, Low, High);
2901 if not Compile_Time_Known_Value (Low) then
2902 Collect_Identifiers (Low);
2904 if No (Aggr_Error_Node) then
2905 Aggr_Error_Node := Low;
2909 if not Compile_Time_Known_Value (High) then
2910 Collect_Identifiers (High);
2912 if No (Aggr_Error_Node) then
2913 Aggr_Error_Node := High;
2917 -- The RM rule is violated if there is more than
2918 -- a single choice in a component association.
2921 Count_Components := Count_Components + 1;
2923 if No (Aggr_Error_Node)
2924 and then Count_Components > 1
2926 Aggr_Error_Node := Choice;
2929 if not Compile_Time_Known_Value (Choice) then
2930 Collect_Identifiers (Choice);
2942 -- Handle ancestor part of extension aggregates
2944 if Nkind (N) = N_Extension_Aggregate then
2945 Collect_Identifiers (Ancestor_Part (N));
2948 -- Handle positional associations
2950 if Present (Expressions (N)) then
2951 Comp_Expr := First (Expressions (N));
2952 while Present (Comp_Expr) loop
2953 if not Is_OK_Static_Expression (Comp_Expr) then
2954 Collect_Identifiers (Comp_Expr);
2961 -- Handle discrete associations
2963 if Present (Component_Associations (N)) then
2964 Assoc := First (Component_Associations (N));
2965 while Present (Assoc) loop
2967 if not Box_Present (Assoc) then
2968 Choice := First (Choices (Assoc));
2969 while Present (Choice) loop
2971 -- For now we skip discriminants since it requires
2972 -- performing the analysis in two phases: first one
2973 -- analyzing discriminants and second one analyzing
2974 -- the rest of components since discriminants are
2975 -- evaluated prior to components: too much extra
2976 -- work to detect a corner case???
2978 if Nkind (Choice) in N_Has_Entity
2979 and then Present (Entity (Choice))
2980 and then Ekind (Entity (Choice)) = E_Discriminant
2984 elsif Box_Present (Assoc) then
2988 if not Analyzed (Expression (Assoc)) then
2990 New_Copy_Tree (Expression (Assoc));
2991 Set_Parent (Comp_Expr, Parent (N));
2992 Preanalyze_Without_Errors (Comp_Expr);
2994 Comp_Expr := Expression (Assoc);
2997 Collect_Identifiers (Comp_Expr);
3013 -- No further action needed if we already reported an error
3015 if Present (Error_Node) then
3019 -- Check violation of RM 6.20/3 in aggregates
3021 if Present (Aggr_Error_Node)
3022 and then Writable_Actuals_List /= No_Elist
3025 ("value may be affected by call in other component because they "
3026 & "are evaluated in unspecified order",
3027 Node (First_Elmt (Writable_Actuals_List)));
3031 -- Check if some writable argument of a function is referenced
3033 if Writable_Actuals_List /= No_Elist
3034 and then Identifiers_List /= No_Elist
3041 Elmt_1 := First_Elmt (Writable_Actuals_List);
3042 while Present (Elmt_1) loop
3043 Elmt_2 := First_Elmt (Identifiers_List);
3044 while Present (Elmt_2) loop
3045 if Entity (Node (Elmt_1)) = Entity (Node (Elmt_2)) then
3046 case Nkind (Parent (Node (Elmt_2))) is
3048 | N_Component_Association
3049 | N_Component_Declaration
3052 ("value may be affected by call in other "
3053 & "component because they are evaluated "
3054 & "in unspecified order",
3061 ("value may be affected by call in other "
3062 & "alternative because they are evaluated "
3063 & "in unspecified order",
3068 ("value of actual may be affected by call in "
3069 & "other actual because they are evaluated "
3070 & "in unspecified order",
3082 end Check_Function_Writable_Actuals;
3084 --------------------------------
3085 -- Check_Implicit_Dereference --
3086 --------------------------------
3088 procedure Check_Implicit_Dereference (N : Node_Id; Typ : Entity_Id) is
3094 if Nkind (N) = N_Indexed_Component
3095 and then Present (Generalized_Indexing (N))
3097 Nam := Generalized_Indexing (N);
3102 if Ada_Version < Ada_2012
3103 or else not Has_Implicit_Dereference (Base_Type (Typ))
3107 elsif not Comes_From_Source (N)
3108 and then Nkind (N) /= N_Indexed_Component
3112 elsif Is_Entity_Name (Nam) and then Is_Type (Entity (Nam)) then
3116 Disc := First_Discriminant (Typ);
3117 while Present (Disc) loop
3118 if Has_Implicit_Dereference (Disc) then
3119 Desig := Designated_Type (Etype (Disc));
3120 Add_One_Interp (Nam, Disc, Desig);
3122 -- If the node is a generalized indexing, add interpretation
3123 -- to that node as well, for subsequent resolution.
3125 if Nkind (N) = N_Indexed_Component then
3126 Add_One_Interp (N, Disc, Desig);
3129 -- If the operation comes from a generic unit and the context
3130 -- is a selected component, the selector name may be global
3131 -- and set in the instance already. Remove the entity to
3132 -- force resolution of the selected component, and the
3133 -- generation of an explicit dereference if needed.
3136 and then Nkind (Parent (Nam)) = N_Selected_Component
3138 Set_Entity (Selector_Name (Parent (Nam)), Empty);
3144 Next_Discriminant (Disc);
3147 end Check_Implicit_Dereference;
3149 ----------------------------------
3150 -- Check_Internal_Protected_Use --
3151 ----------------------------------
3153 procedure Check_Internal_Protected_Use (N : Node_Id; Nam : Entity_Id) is
3161 while Present (S) loop
3162 if S = Standard_Standard then
3165 elsif Ekind (S) = E_Function
3166 and then Ekind (Scope (S)) = E_Protected_Type
3176 and then Scope (Nam) = Prot
3177 and then Ekind (Nam) /= E_Function
3179 -- An indirect function call (e.g. a callback within a protected
3180 -- function body) is not statically illegal. If the access type is
3181 -- anonymous and is the type of an access parameter, the scope of Nam
3182 -- will be the protected type, but it is not a protected operation.
3184 if Ekind (Nam) = E_Subprogram_Type
3185 and then Nkind (Associated_Node_For_Itype (Nam)) =
3186 N_Function_Specification
3190 elsif Nkind (N) = N_Subprogram_Renaming_Declaration then
3192 ("within protected function cannot use protected procedure in "
3193 & "renaming or as generic actual", N);
3195 elsif Nkind (N) = N_Attribute_Reference then
3197 ("within protected function cannot take access of protected "
3202 ("within protected function, protected object is constant", N);
3204 ("\cannot call operation that may modify it", N);
3208 -- Verify that an internal call does not appear within a precondition
3209 -- of a protected operation. This implements AI12-0166.
3210 -- The precondition aspect has been rewritten as a pragma Precondition
3211 -- and we check whether the scope of the called subprogram is the same
3212 -- as that of the entity to which the aspect applies.
3214 if Convention (Nam) = Convention_Protected then
3220 while Present (P) loop
3221 if Nkind (P) = N_Pragma
3222 and then Chars (Pragma_Identifier (P)) = Name_Precondition
3223 and then From_Aspect_Specification (P)
3225 Scope (Entity (Corresponding_Aspect (P))) = Scope (Nam)
3228 ("internal call cannot appear in precondition of "
3229 & "protected operation", N);
3232 elsif Nkind (P) = N_Pragma
3233 and then Chars (Pragma_Identifier (P)) = Name_Contract_Cases
3235 -- Check whether call is in a case guard. It is legal in a
3239 while Present (P) loop
3240 if Nkind (Parent (P)) = N_Component_Association
3241 and then P /= Expression (Parent (P))
3244 ("internal call cannot appear in case guard in a "
3245 & "contract case", N);
3253 elsif Nkind (P) = N_Parameter_Specification
3254 and then Scope (Current_Scope) = Scope (Nam)
3255 and then Nkind_In (Parent (P), N_Entry_Declaration,
3256 N_Subprogram_Declaration)
3259 ("internal call cannot appear in default for formal of "
3260 & "protected operation", N);
3268 end Check_Internal_Protected_Use;
3270 ---------------------------------------
3271 -- Check_Later_Vs_Basic_Declarations --
3272 ---------------------------------------
3274 procedure Check_Later_Vs_Basic_Declarations
3276 During_Parsing : Boolean)
3278 Body_Sloc : Source_Ptr;
3281 function Is_Later_Declarative_Item (Decl : Node_Id) return Boolean;
3282 -- Return whether Decl is considered as a declarative item.
3283 -- When During_Parsing is True, the semantics of Ada 83 is followed.
3284 -- When During_Parsing is False, the semantics of SPARK is followed.
3286 -------------------------------
3287 -- Is_Later_Declarative_Item --
3288 -------------------------------
3290 function Is_Later_Declarative_Item (Decl : Node_Id) return Boolean is
3292 if Nkind (Decl) in N_Later_Decl_Item then
3295 elsif Nkind (Decl) = N_Pragma then
3298 elsif During_Parsing then
3301 -- In SPARK, a package declaration is not considered as a later
3302 -- declarative item.
3304 elsif Nkind (Decl) = N_Package_Declaration then
3307 -- In SPARK, a renaming is considered as a later declarative item
3309 elsif Nkind (Decl) in N_Renaming_Declaration then
3315 end Is_Later_Declarative_Item;
3317 -- Start of processing for Check_Later_Vs_Basic_Declarations
3320 Decl := First (Decls);
3322 -- Loop through sequence of basic declarative items
3324 Outer : while Present (Decl) loop
3325 if not Nkind_In (Decl, N_Subprogram_Body, N_Package_Body, N_Task_Body)
3326 and then Nkind (Decl) not in N_Body_Stub
3330 -- Once a body is encountered, we only allow later declarative
3331 -- items. The inner loop checks the rest of the list.
3334 Body_Sloc := Sloc (Decl);
3336 Inner : while Present (Decl) loop
3337 if not Is_Later_Declarative_Item (Decl) then
3338 if During_Parsing then
3339 if Ada_Version = Ada_83 then
3340 Error_Msg_Sloc := Body_Sloc;
3342 ("(Ada 83) decl cannot appear after body#", Decl);
3345 Error_Msg_Sloc := Body_Sloc;
3346 Check_SPARK_05_Restriction
3347 ("decl cannot appear after body#", Decl);
3355 end Check_Later_Vs_Basic_Declarations;
3357 ---------------------------
3358 -- Check_No_Hidden_State --
3359 ---------------------------
3361 procedure Check_No_Hidden_State (Id : Entity_Id) is
3362 Context : Entity_Id := Empty;
3363 Not_Visible : Boolean := False;
3367 pragma Assert (Ekind_In (Id, E_Abstract_State, E_Variable));
3369 -- Nothing to do for internally-generated abstract states and variables
3370 -- because they do not represent the hidden state of the source unit.
3372 if not Comes_From_Source (Id) then
3376 -- Find the proper context where the object or state appears
3379 while Present (Scop) loop
3382 -- Keep track of the context's visibility
3384 Not_Visible := Not_Visible or else In_Private_Part (Context);
3386 -- Prevent the search from going too far
3388 if Context = Standard_Standard then
3391 -- Objects and states that appear immediately within a subprogram or
3392 -- entry inside a construct nested within a subprogram do not
3393 -- introduce a hidden state. They behave as local variable
3394 -- declarations. The same is true for elaboration code inside a block
3397 elsif Is_Subprogram_Or_Entry (Context)
3398 or else Ekind_In (Context, E_Block, E_Task_Type)
3403 -- Stop the traversal when a package subject to a null abstract state
3406 if Is_Package_Or_Generic_Package (Context)
3407 and then Has_Null_Abstract_State (Context)
3412 Scop := Scope (Scop);
3415 -- At this point we know that there is at least one package with a null
3416 -- abstract state in visibility. Emit an error message unconditionally
3417 -- if the entity being processed is a state because the placement of the
3418 -- related package is irrelevant. This is not the case for objects as
3419 -- the intermediate context matters.
3421 if Present (Context)
3422 and then (Ekind (Id) = E_Abstract_State or else Not_Visible)
3424 Error_Msg_N ("cannot introduce hidden state &", Id);
3425 Error_Msg_NE ("\package & has null abstract state", Id, Context);
3427 end Check_No_Hidden_State;
3429 ----------------------------------------
3430 -- Check_Nonvolatile_Function_Profile --
3431 ----------------------------------------
3433 procedure Check_Nonvolatile_Function_Profile (Func_Id : Entity_Id) is
3437 -- Inspect all formal parameters
3439 Formal := First_Formal (Func_Id);
3440 while Present (Formal) loop
3441 if Is_Effectively_Volatile (Etype (Formal)) then
3443 ("nonvolatile function & cannot have a volatile parameter",
3447 Next_Formal (Formal);
3450 -- Inspect the return type
3452 if Is_Effectively_Volatile (Etype (Func_Id)) then
3454 ("nonvolatile function & cannot have a volatile return type",
3455 Result_Definition (Parent (Func_Id)), Func_Id);
3457 end Check_Nonvolatile_Function_Profile;
3459 -----------------------------
3460 -- Check_Part_Of_Reference --
3461 -----------------------------
3463 procedure Check_Part_Of_Reference (Var_Id : Entity_Id; Ref : Node_Id) is
3464 function Is_Enclosing_Package_Body
3465 (Body_Decl : Node_Id;
3466 Obj_Id : Entity_Id) return Boolean;
3467 pragma Inline (Is_Enclosing_Package_Body);
3468 -- Determine whether package body Body_Decl or its corresponding spec
3469 -- immediately encloses the declaration of object Obj_Id.
3471 function Is_Internal_Declaration_Or_Body
3472 (Decl : Node_Id) return Boolean;
3473 pragma Inline (Is_Internal_Declaration_Or_Body);
3474 -- Determine whether declaration or body denoted by Decl is internal
3476 function Is_Single_Declaration_Or_Body
3478 Conc_Typ : Entity_Id) return Boolean;
3479 pragma Inline (Is_Single_Declaration_Or_Body);
3480 -- Determine whether protected/task declaration or body denoted by Decl
3481 -- belongs to single concurrent type Conc_Typ.
3483 function Is_Single_Task_Pragma
3485 Task_Typ : Entity_Id) return Boolean;
3486 pragma Inline (Is_Single_Task_Pragma);
3487 -- Determine whether pragma Prag belongs to single task type Task_Typ
3489 -------------------------------
3490 -- Is_Enclosing_Package_Body --
3491 -------------------------------
3493 function Is_Enclosing_Package_Body
3494 (Body_Decl : Node_Id;
3495 Obj_Id : Entity_Id) return Boolean
3497 Obj_Context : Node_Id;
3500 -- Find the context of the object declaration
3502 Obj_Context := Parent (Declaration_Node (Obj_Id));
3504 if Nkind (Obj_Context) = N_Package_Specification then
3505 Obj_Context := Parent (Obj_Context);
3508 -- The object appears immediately within the package body
3510 if Obj_Context = Body_Decl then
3513 -- The object appears immediately within the corresponding spec
3515 elsif Nkind (Obj_Context) = N_Package_Declaration
3516 and then Unit_Declaration_Node (Corresponding_Spec (Body_Decl)) =
3523 end Is_Enclosing_Package_Body;
3525 -------------------------------------
3526 -- Is_Internal_Declaration_Or_Body --
3527 -------------------------------------
3529 function Is_Internal_Declaration_Or_Body
3530 (Decl : Node_Id) return Boolean
3533 if Comes_From_Source (Decl) then
3536 -- A body generated for an expression function which has not been
3537 -- inserted into the tree yet (In_Spec_Expression is True) is not
3538 -- considered internal.
3540 elsif Nkind (Decl) = N_Subprogram_Body
3541 and then Was_Expression_Function (Decl)
3542 and then not In_Spec_Expression
3548 end Is_Internal_Declaration_Or_Body;
3550 -----------------------------------
3551 -- Is_Single_Declaration_Or_Body --
3552 -----------------------------------
3554 function Is_Single_Declaration_Or_Body
3556 Conc_Typ : Entity_Id) return Boolean
3558 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Decl);
3562 Present (Anonymous_Object (Spec_Id))
3563 and then Anonymous_Object (Spec_Id) = Conc_Typ;
3564 end Is_Single_Declaration_Or_Body;
3566 ---------------------------
3567 -- Is_Single_Task_Pragma --
3568 ---------------------------
3570 function Is_Single_Task_Pragma
3572 Task_Typ : Entity_Id) return Boolean
3574 Decl : constant Node_Id := Find_Related_Declaration_Or_Body (Prag);
3577 -- To qualify, the pragma must be associated with single task type
3581 Is_Single_Task_Object (Task_Typ)
3582 and then Nkind (Decl) = N_Object_Declaration
3583 and then Defining_Entity (Decl) = Task_Typ;
3584 end Is_Single_Task_Pragma;
3588 Conc_Obj : constant Entity_Id := Encapsulating_State (Var_Id);
3593 -- Start of processing for Check_Part_Of_Reference
3596 -- Nothing to do when the variable was recorded, but did not become a
3597 -- constituent of a single concurrent type.
3599 if No (Conc_Obj) then
3603 -- Traverse the parent chain looking for a suitable context for the
3604 -- reference to the concurrent constituent.
3607 Par := Parent (Prev);
3608 while Present (Par) loop
3609 if Nkind (Par) = N_Pragma then
3610 Prag_Nam := Pragma_Name (Par);
3612 -- A concurrent constituent is allowed to appear in pragmas
3613 -- Initial_Condition and Initializes as this is part of the
3614 -- elaboration checks for the constituent (SPARK RM 9(3)).
3616 if Nam_In (Prag_Nam, Name_Initial_Condition, Name_Initializes) then
3619 -- When the reference appears within pragma Depends or Global,
3620 -- check whether the pragma applies to a single task type. Note
3621 -- that the pragma may not encapsulated by the type definition,
3622 -- but this is still a valid context.
3624 elsif Nam_In (Prag_Nam, Name_Depends, Name_Global)
3625 and then Is_Single_Task_Pragma (Par, Conc_Obj)
3630 -- The reference appears somewhere in the definition of a single
3631 -- concurrent type (SPARK RM 9(3)).
3633 elsif Nkind_In (Par, N_Single_Protected_Declaration,
3634 N_Single_Task_Declaration)
3635 and then Defining_Entity (Par) = Conc_Obj
3639 -- The reference appears within the declaration or body of a single
3640 -- concurrent type (SPARK RM 9(3)).
3642 elsif Nkind_In (Par, N_Protected_Body,
3643 N_Protected_Type_Declaration,
3645 N_Task_Type_Declaration)
3646 and then Is_Single_Declaration_Or_Body (Par, Conc_Obj)
3650 -- The reference appears within the statement list of the object's
3651 -- immediately enclosing package (SPARK RM 9(3)).
3653 elsif Nkind (Par) = N_Package_Body
3654 and then Nkind (Prev) = N_Handled_Sequence_Of_Statements
3655 and then Is_Enclosing_Package_Body (Par, Var_Id)
3659 -- The reference has been relocated within an internally generated
3660 -- package or subprogram. Assume that the reference is legal as the
3661 -- real check was already performed in the original context of the
3664 elsif Nkind_In (Par, N_Package_Body,
3665 N_Package_Declaration,
3667 N_Subprogram_Declaration)
3668 and then Is_Internal_Declaration_Or_Body (Par)
3672 -- The reference has been relocated to an inlined body for GNATprove.
3673 -- Assume that the reference is legal as the real check was already
3674 -- performed in the original context of the reference.
3676 elsif GNATprove_Mode
3677 and then Nkind (Par) = N_Subprogram_Body
3678 and then Chars (Defining_Entity (Par)) = Name_uParent
3684 Par := Parent (Prev);
3687 -- At this point it is known that the reference does not appear within a
3691 ("reference to variable & cannot appear in this context", Ref, Var_Id);
3692 Error_Msg_Name_1 := Chars (Var_Id);
3694 if Is_Single_Protected_Object (Conc_Obj) then
3696 ("\% is constituent of single protected type &", Ref, Conc_Obj);
3700 ("\% is constituent of single task type &", Ref, Conc_Obj);
3702 end Check_Part_Of_Reference;
3704 ------------------------------------------
3705 -- Check_Potentially_Blocking_Operation --
3706 ------------------------------------------
3708 procedure Check_Potentially_Blocking_Operation (N : Node_Id) is
3712 -- N is one of the potentially blocking operations listed in 9.5.1(8).
3713 -- When pragma Detect_Blocking is active, the run time will raise
3714 -- Program_Error. Here we only issue a warning, since we generally
3715 -- support the use of potentially blocking operations in the absence
3718 -- Indirect blocking through a subprogram call cannot be diagnosed
3719 -- statically without interprocedural analysis, so we do not attempt
3722 S := Scope (Current_Scope);
3723 while Present (S) and then S /= Standard_Standard loop
3724 if Is_Protected_Type (S) then
3726 ("potentially blocking operation in protected operation??", N);
3732 end Check_Potentially_Blocking_Operation;
3734 ------------------------------------
3735 -- Check_Previous_Null_Procedure --
3736 ------------------------------------
3738 procedure Check_Previous_Null_Procedure
3743 if Ekind (Prev) = E_Procedure
3744 and then Nkind (Parent (Prev)) = N_Procedure_Specification
3745 and then Null_Present (Parent (Prev))
3747 Error_Msg_Sloc := Sloc (Prev);
3749 ("declaration cannot complete previous null procedure#", Decl);
3751 end Check_Previous_Null_Procedure;
3753 ---------------------------------
3754 -- Check_Result_And_Post_State --
3755 ---------------------------------
3757 procedure Check_Result_And_Post_State (Subp_Id : Entity_Id) is
3758 procedure Check_Result_And_Post_State_In_Pragma
3760 Result_Seen : in out Boolean);
3761 -- Determine whether pragma Prag mentions attribute 'Result and whether
3762 -- the pragma contains an expression that evaluates differently in pre-
3763 -- and post-state. Prag is a [refined] postcondition or a contract-cases
3764 -- pragma. Result_Seen is set when the pragma mentions attribute 'Result
3766 function Has_In_Out_Parameter (Subp_Id : Entity_Id) return Boolean;
3767 -- Determine whether subprogram Subp_Id contains at least one IN OUT
3768 -- formal parameter.
3770 -------------------------------------------
3771 -- Check_Result_And_Post_State_In_Pragma --
3772 -------------------------------------------
3774 procedure Check_Result_And_Post_State_In_Pragma
3776 Result_Seen : in out Boolean)
3778 procedure Check_Conjunct (Expr : Node_Id);
3779 -- Check an individual conjunct in a conjunction of Boolean
3780 -- expressions, connected by "and" or "and then" operators.
3782 procedure Check_Conjuncts (Expr : Node_Id);
3783 -- Apply the post-state check to every conjunct in an expression, in
3784 -- case this is a conjunction of Boolean expressions. Otherwise apply
3785 -- it to the expression as a whole.
3787 procedure Check_Expression (Expr : Node_Id);
3788 -- Perform the 'Result and post-state checks on a given expression
3790 function Is_Function_Result (N : Node_Id) return Traverse_Result;
3791 -- Attempt to find attribute 'Result in a subtree denoted by N
3793 function Is_Trivial_Boolean (N : Node_Id) return Boolean;
3794 -- Determine whether source node N denotes "True" or "False"
3796 function Mentions_Post_State (N : Node_Id) return Boolean;
3797 -- Determine whether a subtree denoted by N mentions any construct
3798 -- that denotes a post-state.
3800 procedure Check_Function_Result is
3801 new Traverse_Proc (Is_Function_Result);
3803 --------------------
3804 -- Check_Conjunct --
3805 --------------------
3807 procedure Check_Conjunct (Expr : Node_Id) is
3808 function Adjust_Message (Msg : String) return String;
3809 -- Prepend a prefix to the input message Msg denoting that the
3810 -- message applies to a conjunct in the expression, when this
3813 function Applied_On_Conjunct return Boolean;
3814 -- Returns True if the message applies to a conjunct in the
3815 -- expression, instead of the whole expression.
3817 function Has_Global_Output (Subp : Entity_Id) return Boolean;
3818 -- Returns True if Subp has an output in its Global contract
3820 function Has_No_Output (Subp : Entity_Id) return Boolean;
3821 -- Returns True if Subp has no declared output: no function
3822 -- result, no output parameter, and no output in its Global
3825 --------------------
3826 -- Adjust_Message --
3827 --------------------
3829 function Adjust_Message (Msg : String) return String is
3831 if Applied_On_Conjunct then
3832 return "conjunct in " & Msg;
3838 -------------------------
3839 -- Applied_On_Conjunct --
3840 -------------------------
3842 function Applied_On_Conjunct return Boolean is
3844 -- Expr is the conjunct of an enclosing "and" expression
3846 return Nkind (Parent (Expr)) in N_Subexpr
3848 -- or Expr is a conjunct of an enclosing "and then"
3849 -- expression in a postcondition aspect that was split into
3850 -- multiple pragmas. The first conjunct has the "and then"
3851 -- expression as Original_Node, and other conjuncts have
3852 -- Split_PCC set to True.
3854 or else Nkind (Original_Node (Expr)) = N_And_Then
3855 or else Split_PPC (Prag);
3856 end Applied_On_Conjunct;
3858 -----------------------
3859 -- Has_Global_Output --
3860 -----------------------
3862 function Has_Global_Output (Subp : Entity_Id) return Boolean is
3863 Global : constant Node_Id := Get_Pragma (Subp, Pragma_Global);
3872 List := Expression (Get_Argument (Global, Subp));
3874 -- Empty list (no global items) or single global item
3875 -- declaration (only input items).
3877 if Nkind_In (List, N_Null,
3880 N_Selected_Component)
3884 -- Simple global list (only input items) or moded global list
3887 elsif Nkind (List) = N_Aggregate then
3888 if Present (Expressions (List)) then
3892 Assoc := First (Component_Associations (List));
3893 while Present (Assoc) loop
3894 if Chars (First (Choices (Assoc))) /= Name_Input then
3904 -- To accommodate partial decoration of disabled SPARK
3905 -- features, this routine may be called with illegal input.
3906 -- If this is the case, do not raise Program_Error.
3911 end Has_Global_Output;
3917 function Has_No_Output (Subp : Entity_Id) return Boolean is
3921 -- A function has its result as output
3923 if Ekind (Subp) = E_Function then
3927 -- An OUT or IN OUT parameter is an output
3929 Param := First_Formal (Subp);
3930 while Present (Param) loop
3931 if Ekind_In (Param, E_Out_Parameter, E_In_Out_Parameter) then
3935 Next_Formal (Param);
3938 -- An item of mode Output or In_Out in the Global contract is
3941 if Has_Global_Output (Subp) then
3951 -- Error node when reporting a warning on a (refined)
3954 -- Start of processing for Check_Conjunct
3957 if Applied_On_Conjunct then
3963 -- Do not report missing reference to outcome in postcondition if
3964 -- either the postcondition is trivially True or False, or if the
3965 -- subprogram is ghost and has no declared output.
3967 if not Is_Trivial_Boolean (Expr)
3968 and then not Mentions_Post_State (Expr)
3969 and then not (Is_Ghost_Entity (Subp_Id)
3970 and then Has_No_Output (Subp_Id))
3972 if Pragma_Name (Prag) = Name_Contract_Cases then
3973 Error_Msg_NE (Adjust_Message
3974 ("contract case does not check the outcome of calling "
3975 & "&?T?"), Expr, Subp_Id);
3977 elsif Pragma_Name (Prag) = Name_Refined_Post then
3978 Error_Msg_NE (Adjust_Message
3979 ("refined postcondition does not check the outcome of "
3980 & "calling &?T?"), Err_Node, Subp_Id);
3983 Error_Msg_NE (Adjust_Message
3984 ("postcondition does not check the outcome of calling "
3985 & "&?T?"), Err_Node, Subp_Id);
3990 ---------------------
3991 -- Check_Conjuncts --
3992 ---------------------
3994 procedure Check_Conjuncts (Expr : Node_Id) is
3996 if Nkind_In (Expr, N_Op_And, N_And_Then) then
3997 Check_Conjuncts (Left_Opnd (Expr));
3998 Check_Conjuncts (Right_Opnd (Expr));
4000 Check_Conjunct (Expr);
4002 end Check_Conjuncts;
4004 ----------------------
4005 -- Check_Expression --
4006 ----------------------
4008 procedure Check_Expression (Expr : Node_Id) is
4010 if not Is_Trivial_Boolean (Expr) then
4011 Check_Function_Result (Expr);
4012 Check_Conjuncts (Expr);
4014 end Check_Expression;
4016 ------------------------
4017 -- Is_Function_Result --
4018 ------------------------
4020 function Is_Function_Result (N : Node_Id) return Traverse_Result is
4022 if Is_Attribute_Result (N) then
4023 Result_Seen := True;
4026 -- Warn on infinite recursion if call is to current function
4028 elsif Nkind (N) = N_Function_Call
4029 and then Is_Entity_Name (Name (N))
4030 and then Entity (Name (N)) = Subp_Id
4031 and then not Is_Potentially_Unevaluated (N)
4034 ("call to & within its postcondition will lead to infinite "
4035 & "recursion?", N, Subp_Id);
4038 -- Continue the traversal
4043 end Is_Function_Result;
4045 ------------------------
4046 -- Is_Trivial_Boolean --
4047 ------------------------
4049 function Is_Trivial_Boolean (N : Node_Id) return Boolean is
4052 Comes_From_Source (N)
4053 and then Is_Entity_Name (N)
4054 and then (Entity (N) = Standard_True
4056 Entity (N) = Standard_False);
4057 end Is_Trivial_Boolean;
4059 -------------------------
4060 -- Mentions_Post_State --
4061 -------------------------
4063 function Mentions_Post_State (N : Node_Id) return Boolean is
4064 Post_State_Seen : Boolean := False;
4066 function Is_Post_State (N : Node_Id) return Traverse_Result;
4067 -- Attempt to find a construct that denotes a post-state. If this
4068 -- is the case, set flag Post_State_Seen.
4074 function Is_Post_State (N : Node_Id) return Traverse_Result is
4078 if Nkind_In (N, N_Explicit_Dereference, N_Function_Call) then
4079 Post_State_Seen := True;
4082 elsif Nkind_In (N, N_Expanded_Name, N_Identifier) then
4085 -- Treat an undecorated reference as OK
4089 -- A reference to an assignable entity is considered a
4090 -- change in the post-state of a subprogram.
4092 or else Ekind_In (Ent, E_Generic_In_Out_Parameter,
4097 -- The reference may be modified through a dereference
4099 or else (Is_Access_Type (Etype (Ent))
4100 and then Nkind (Parent (N)) =
4101 N_Selected_Component)
4103 Post_State_Seen := True;
4107 elsif Nkind (N) = N_Attribute_Reference then
4108 if Attribute_Name (N) = Name_Old then
4111 elsif Attribute_Name (N) = Name_Result then
4112 Post_State_Seen := True;
4120 procedure Find_Post_State is new Traverse_Proc (Is_Post_State);
4122 -- Start of processing for Mentions_Post_State
4125 Find_Post_State (N);
4127 return Post_State_Seen;
4128 end Mentions_Post_State;
4132 Expr : constant Node_Id :=
4134 (First (Pragma_Argument_Associations (Prag)));
4135 Nam : constant Name_Id := Pragma_Name (Prag);
4138 -- Start of processing for Check_Result_And_Post_State_In_Pragma
4141 -- Examine all consequences
4143 if Nam = Name_Contract_Cases then
4144 CCase := First (Component_Associations (Expr));
4145 while Present (CCase) loop
4146 Check_Expression (Expression (CCase));
4151 -- Examine the expression of a postcondition
4153 else pragma Assert (Nam_In (Nam, Name_Postcondition,
4154 Name_Refined_Post));
4155 Check_Expression (Expr);
4157 end Check_Result_And_Post_State_In_Pragma;
4159 --------------------------
4160 -- Has_In_Out_Parameter --
4161 --------------------------
4163 function Has_In_Out_Parameter (Subp_Id : Entity_Id) return Boolean is
4167 -- Traverse the formals looking for an IN OUT parameter
4169 Formal := First_Formal (Subp_Id);
4170 while Present (Formal) loop
4171 if Ekind (Formal) = E_In_Out_Parameter then
4175 Next_Formal (Formal);
4179 end Has_In_Out_Parameter;
4183 Items : constant Node_Id := Contract (Subp_Id);
4184 Subp_Decl : constant Node_Id := Unit_Declaration_Node (Subp_Id);
4185 Case_Prag : Node_Id := Empty;
4186 Post_Prag : Node_Id := Empty;
4188 Seen_In_Case : Boolean := False;
4189 Seen_In_Post : Boolean := False;
4190 Spec_Id : Entity_Id;
4192 -- Start of processing for Check_Result_And_Post_State
4195 -- The lack of attribute 'Result or a post-state is classified as a
4196 -- suspicious contract. Do not perform the check if the corresponding
4197 -- swich is not set.
4199 if not Warn_On_Suspicious_Contract then
4202 -- Nothing to do if there is no contract
4204 elsif No (Items) then
4208 -- Retrieve the entity of the subprogram spec (if any)
4210 if Nkind (Subp_Decl) = N_Subprogram_Body
4211 and then Present (Corresponding_Spec (Subp_Decl))
4213 Spec_Id := Corresponding_Spec (Subp_Decl);
4215 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
4216 and then Present (Corresponding_Spec_Of_Stub (Subp_Decl))
4218 Spec_Id := Corresponding_Spec_Of_Stub (Subp_Decl);
4224 -- Examine all postconditions for attribute 'Result and a post-state
4226 Prag := Pre_Post_Conditions (Items);
4227 while Present (Prag) loop
4228 if Nam_In (Pragma_Name_Unmapped (Prag),
4229 Name_Postcondition, Name_Refined_Post)
4230 and then not Error_Posted (Prag)
4233 Check_Result_And_Post_State_In_Pragma (Prag, Seen_In_Post);
4236 Prag := Next_Pragma (Prag);
4239 -- Examine the contract cases of the subprogram for attribute 'Result
4240 -- and a post-state.
4242 Prag := Contract_Test_Cases (Items);
4243 while Present (Prag) loop
4244 if Pragma_Name (Prag) = Name_Contract_Cases
4245 and then not Error_Posted (Prag)
4248 Check_Result_And_Post_State_In_Pragma (Prag, Seen_In_Case);
4251 Prag := Next_Pragma (Prag);
4254 -- Do not emit any errors if the subprogram is not a function
4256 if not Ekind_In (Spec_Id, E_Function, E_Generic_Function) then
4259 -- Regardless of whether the function has postconditions or contract
4260 -- cases, or whether they mention attribute 'Result, an IN OUT formal
4261 -- parameter is always treated as a result.
4263 elsif Has_In_Out_Parameter (Spec_Id) then
4266 -- The function has both a postcondition and contract cases and they do
4267 -- not mention attribute 'Result.
4269 elsif Present (Case_Prag)
4270 and then not Seen_In_Case
4271 and then Present (Post_Prag)
4272 and then not Seen_In_Post
4275 ("neither postcondition nor contract cases mention function "
4276 & "result?T?", Post_Prag);
4278 -- The function has contract cases only and they do not mention
4279 -- attribute 'Result.
4281 elsif Present (Case_Prag) and then not Seen_In_Case then
4282 Error_Msg_N ("contract cases do not mention result?T?", Case_Prag);
4284 -- The function has postconditions only and they do not mention
4285 -- attribute 'Result.
4287 elsif Present (Post_Prag) and then not Seen_In_Post then
4289 ("postcondition does not mention function result?T?", Post_Prag);
4291 end Check_Result_And_Post_State;
4293 -----------------------------
4294 -- Check_State_Refinements --
4295 -----------------------------
4297 procedure Check_State_Refinements
4299 Is_Main_Unit : Boolean := False)
4301 procedure Check_Package (Pack : Node_Id);
4302 -- Verify that all abstract states of a [generic] package denoted by its
4303 -- declarative node Pack have proper refinement. Recursively verify the
4304 -- visible and private declarations of the [generic] package for other
4307 procedure Check_Packages_In (Decls : List_Id);
4308 -- Seek out [generic] package declarations within declarative list Decls
4309 -- and verify the status of their abstract state refinement.
4311 function SPARK_Mode_Is_Off (N : Node_Id) return Boolean;
4312 -- Determine whether construct N is subject to pragma SPARK_Mode Off
4318 procedure Check_Package (Pack : Node_Id) is
4319 Body_Id : constant Entity_Id := Corresponding_Body (Pack);
4320 Spec : constant Node_Id := Specification (Pack);
4321 States : constant Elist_Id :=
4322 Abstract_States (Defining_Entity (Pack));
4324 State_Elmt : Elmt_Id;
4325 State_Id : Entity_Id;
4328 -- Do not verify proper state refinement when the package is subject
4329 -- to pragma SPARK_Mode Off because this disables the requirement for
4330 -- state refinement.
4332 if SPARK_Mode_Is_Off (Pack) then
4335 -- State refinement can only occur in a completing package body. Do
4336 -- not verify proper state refinement when the body is subject to
4337 -- pragma SPARK_Mode Off because this disables the requirement for
4338 -- state refinement.
4340 elsif Present (Body_Id)
4341 and then SPARK_Mode_Is_Off (Unit_Declaration_Node (Body_Id))
4345 -- Do not verify proper state refinement when the package is an
4346 -- instance as this check was already performed in the generic.
4348 elsif Present (Generic_Parent (Spec)) then
4351 -- Otherwise examine the contents of the package
4354 if Present (States) then
4355 State_Elmt := First_Elmt (States);
4356 while Present (State_Elmt) loop
4357 State_Id := Node (State_Elmt);
4359 -- Emit an error when a non-null state lacks any form of
4362 if not Is_Null_State (State_Id)
4363 and then not Has_Null_Refinement (State_Id)
4364 and then not Has_Non_Null_Refinement (State_Id)
4366 Error_Msg_N ("state & requires refinement", State_Id);
4369 Next_Elmt (State_Elmt);
4373 Check_Packages_In (Visible_Declarations (Spec));
4374 Check_Packages_In (Private_Declarations (Spec));
4378 -----------------------
4379 -- Check_Packages_In --
4380 -----------------------
4382 procedure Check_Packages_In (Decls : List_Id) is
4386 if Present (Decls) then
4387 Decl := First (Decls);
4388 while Present (Decl) loop
4389 if Nkind_In (Decl, N_Generic_Package_Declaration,
4390 N_Package_Declaration)
4392 Check_Package (Decl);
4398 end Check_Packages_In;
4400 -----------------------
4401 -- SPARK_Mode_Is_Off --
4402 -----------------------
4404 function SPARK_Mode_Is_Off (N : Node_Id) return Boolean is
4405 Id : constant Entity_Id := Defining_Entity (N);
4406 Prag : constant Node_Id := SPARK_Pragma (Id);
4409 -- Default the mode to "off" when the context is an instance and all
4410 -- SPARK_Mode pragmas found within are to be ignored.
4412 if Ignore_SPARK_Mode_Pragmas (Id) then
4418 and then Get_SPARK_Mode_From_Annotation (Prag) = Off;
4420 end SPARK_Mode_Is_Off;
4422 -- Start of processing for Check_State_Refinements
4425 -- A block may declare a nested package
4427 if Nkind (Context) = N_Block_Statement then
4428 Check_Packages_In (Declarations (Context));
4430 -- An entry, protected, subprogram, or task body may declare a nested
4433 elsif Nkind_In (Context, N_Entry_Body,
4438 -- Do not verify proper state refinement when the body is subject to
4439 -- pragma SPARK_Mode Off because this disables the requirement for
4440 -- state refinement.
4442 if not SPARK_Mode_Is_Off (Context) then
4443 Check_Packages_In (Declarations (Context));
4446 -- A package body may declare a nested package
4448 elsif Nkind (Context) = N_Package_Body then
4449 Check_Package (Unit_Declaration_Node (Corresponding_Spec (Context)));
4451 -- Do not verify proper state refinement when the body is subject to
4452 -- pragma SPARK_Mode Off because this disables the requirement for
4453 -- state refinement.
4455 if not SPARK_Mode_Is_Off (Context) then
4456 Check_Packages_In (Declarations (Context));
4459 -- A library level [generic] package may declare a nested package
4461 elsif Nkind_In (Context, N_Generic_Package_Declaration,
4462 N_Package_Declaration)
4463 and then Is_Main_Unit
4465 Check_Package (Context);
4467 end Check_State_Refinements;
4469 ------------------------------
4470 -- Check_Unprotected_Access --
4471 ------------------------------
4473 procedure Check_Unprotected_Access
4477 Cont_Encl_Typ : Entity_Id;
4478 Pref_Encl_Typ : Entity_Id;
4480 function Enclosing_Protected_Type (Obj : Node_Id) return Entity_Id;
4481 -- Check whether Obj is a private component of a protected object.
4482 -- Return the protected type where the component resides, Empty
4485 function Is_Public_Operation return Boolean;
4486 -- Verify that the enclosing operation is callable from outside the
4487 -- protected object, to minimize false positives.
4489 ------------------------------
4490 -- Enclosing_Protected_Type --
4491 ------------------------------
4493 function Enclosing_Protected_Type (Obj : Node_Id) return Entity_Id is
4495 if Is_Entity_Name (Obj) then
4497 Ent : Entity_Id := Entity (Obj);
4500 -- The object can be a renaming of a private component, use
4501 -- the original record component.
4503 if Is_Prival (Ent) then
4504 Ent := Prival_Link (Ent);
4507 if Is_Protected_Type (Scope (Ent)) then
4513 -- For indexed and selected components, recursively check the prefix
4515 if Nkind_In (Obj, N_Indexed_Component, N_Selected_Component) then
4516 return Enclosing_Protected_Type (Prefix (Obj));
4518 -- The object does not denote a protected component
4523 end Enclosing_Protected_Type;
4525 -------------------------
4526 -- Is_Public_Operation --
4527 -------------------------
4529 function Is_Public_Operation return Boolean is
4535 while Present (S) and then S /= Pref_Encl_Typ loop
4536 if Scope (S) = Pref_Encl_Typ then
4537 E := First_Entity (Pref_Encl_Typ);
4539 and then E /= First_Private_Entity (Pref_Encl_Typ)
4553 end Is_Public_Operation;
4555 -- Start of processing for Check_Unprotected_Access
4558 if Nkind (Expr) = N_Attribute_Reference
4559 and then Attribute_Name (Expr) = Name_Unchecked_Access
4561 Cont_Encl_Typ := Enclosing_Protected_Type (Context);
4562 Pref_Encl_Typ := Enclosing_Protected_Type (Prefix (Expr));
4564 -- Check whether we are trying to export a protected component to a
4565 -- context with an equal or lower access level.
4567 if Present (Pref_Encl_Typ)
4568 and then No (Cont_Encl_Typ)
4569 and then Is_Public_Operation
4570 and then Scope_Depth (Pref_Encl_Typ) >=
4571 Object_Access_Level (Context)
4574 ("??possible unprotected access to protected data", Expr);
4577 end Check_Unprotected_Access;
4579 ------------------------------
4580 -- Check_Unused_Body_States --
4581 ------------------------------
4583 procedure Check_Unused_Body_States (Body_Id : Entity_Id) is
4584 procedure Process_Refinement_Clause
4587 -- Inspect all constituents of refinement clause Clause and remove any
4588 -- matches from body state list States.
4590 procedure Report_Unused_Body_States (States : Elist_Id);
4591 -- Emit errors for each abstract state or object found in list States
4593 -------------------------------
4594 -- Process_Refinement_Clause --
4595 -------------------------------
4597 procedure Process_Refinement_Clause
4601 procedure Process_Constituent (Constit : Node_Id);
4602 -- Remove constituent Constit from body state list States
4604 -------------------------
4605 -- Process_Constituent --
4606 -------------------------
4608 procedure Process_Constituent (Constit : Node_Id) is
4609 Constit_Id : Entity_Id;
4612 -- Guard against illegal constituents. Only abstract states and
4613 -- objects can appear on the right hand side of a refinement.
4615 if Is_Entity_Name (Constit) then
4616 Constit_Id := Entity_Of (Constit);
4618 if Present (Constit_Id)
4619 and then Ekind_In (Constit_Id, E_Abstract_State,
4623 Remove (States, Constit_Id);
4626 end Process_Constituent;
4632 -- Start of processing for Process_Refinement_Clause
4635 if Nkind (Clause) = N_Component_Association then
4636 Constit := Expression (Clause);
4638 -- Multiple constituents appear as an aggregate
4640 if Nkind (Constit) = N_Aggregate then
4641 Constit := First (Expressions (Constit));
4642 while Present (Constit) loop
4643 Process_Constituent (Constit);
4647 -- Various forms of a single constituent
4650 Process_Constituent (Constit);
4653 end Process_Refinement_Clause;
4655 -------------------------------
4656 -- Report_Unused_Body_States --
4657 -------------------------------
4659 procedure Report_Unused_Body_States (States : Elist_Id) is
4660 Posted : Boolean := False;
4661 State_Elmt : Elmt_Id;
4662 State_Id : Entity_Id;
4665 if Present (States) then
4666 State_Elmt := First_Elmt (States);
4667 while Present (State_Elmt) loop
4668 State_Id := Node (State_Elmt);
4670 -- Constants are part of the hidden state of a package, but the
4671 -- compiler cannot determine whether they have variable input
4672 -- (SPARK RM 7.1.1(2)) and cannot classify them properly as a
4673 -- hidden state. Do not emit an error when a constant does not
4674 -- participate in a state refinement, even though it acts as a
4677 if Ekind (State_Id) = E_Constant then
4680 -- Generate an error message of the form:
4682 -- body of package ... has unused hidden states
4683 -- abstract state ... defined at ...
4684 -- variable ... defined at ...
4690 ("body of package & has unused hidden states", Body_Id);
4693 Error_Msg_Sloc := Sloc (State_Id);
4695 if Ekind (State_Id) = E_Abstract_State then
4697 ("\abstract state & defined #", Body_Id, State_Id);
4700 SPARK_Msg_NE ("\variable & defined #", Body_Id, State_Id);
4704 Next_Elmt (State_Elmt);
4707 end Report_Unused_Body_States;
4711 Prag : constant Node_Id := Get_Pragma (Body_Id, Pragma_Refined_State);
4712 Spec_Id : constant Entity_Id := Spec_Entity (Body_Id);
4716 -- Start of processing for Check_Unused_Body_States
4719 -- Inspect the clauses of pragma Refined_State and determine whether all
4720 -- visible states declared within the package body participate in the
4723 if Present (Prag) then
4724 Clause := Expression (Get_Argument (Prag, Spec_Id));
4725 States := Collect_Body_States (Body_Id);
4727 -- Multiple non-null state refinements appear as an aggregate
4729 if Nkind (Clause) = N_Aggregate then
4730 Clause := First (Component_Associations (Clause));
4731 while Present (Clause) loop
4732 Process_Refinement_Clause (Clause, States);
4736 -- Various forms of a single state refinement
4739 Process_Refinement_Clause (Clause, States);
4742 -- Ensure that all abstract states and objects declared in the
4743 -- package body state space are utilized as constituents.
4745 Report_Unused_Body_States (States);
4747 end Check_Unused_Body_States;
4753 function Choice_List (N : Node_Id) return List_Id is
4755 if Nkind (N) = N_Iterated_Component_Association then
4756 return Discrete_Choices (N);
4762 -------------------------
4763 -- Collect_Body_States --
4764 -------------------------
4766 function Collect_Body_States (Body_Id : Entity_Id) return Elist_Id is
4767 function Is_Visible_Object (Obj_Id : Entity_Id) return Boolean;
4768 -- Determine whether object Obj_Id is a suitable visible state of a
4771 procedure Collect_Visible_States
4772 (Pack_Id : Entity_Id;
4773 States : in out Elist_Id);
4774 -- Gather the entities of all abstract states and objects declared in
4775 -- the visible state space of package Pack_Id.
4777 ----------------------------
4778 -- Collect_Visible_States --
4779 ----------------------------
4781 procedure Collect_Visible_States
4782 (Pack_Id : Entity_Id;
4783 States : in out Elist_Id)
4785 Item_Id : Entity_Id;
4788 -- Traverse the entity chain of the package and inspect all visible
4791 Item_Id := First_Entity (Pack_Id);
4792 while Present (Item_Id) and then not In_Private_Part (Item_Id) loop
4794 -- Do not consider internally generated items as those cannot be
4795 -- named and participate in refinement.
4797 if not Comes_From_Source (Item_Id) then
4800 elsif Ekind (Item_Id) = E_Abstract_State then
4801 Append_New_Elmt (Item_Id, States);
4803 elsif Ekind_In (Item_Id, E_Constant, E_Variable)
4804 and then Is_Visible_Object (Item_Id)
4806 Append_New_Elmt (Item_Id, States);
4808 -- Recursively gather the visible states of a nested package
4810 elsif Ekind (Item_Id) = E_Package then
4811 Collect_Visible_States (Item_Id, States);
4814 Next_Entity (Item_Id);
4816 end Collect_Visible_States;
4818 -----------------------
4819 -- Is_Visible_Object --
4820 -----------------------
4822 function Is_Visible_Object (Obj_Id : Entity_Id) return Boolean is
4824 -- Objects that map generic formals to their actuals are not visible
4825 -- from outside the generic instantiation.
4827 if Present (Corresponding_Generic_Association
4828 (Declaration_Node (Obj_Id)))
4832 -- Constituents of a single protected/task type act as components of
4833 -- the type and are not visible from outside the type.
4835 elsif Ekind (Obj_Id) = E_Variable
4836 and then Present (Encapsulating_State (Obj_Id))
4837 and then Is_Single_Concurrent_Object (Encapsulating_State (Obj_Id))
4844 end Is_Visible_Object;
4848 Body_Decl : constant Node_Id := Unit_Declaration_Node (Body_Id);
4850 Item_Id : Entity_Id;
4851 States : Elist_Id := No_Elist;
4853 -- Start of processing for Collect_Body_States
4856 -- Inspect the declarations of the body looking for source objects,
4857 -- packages and package instantiations. Note that even though this
4858 -- processing is very similar to Collect_Visible_States, a package
4859 -- body does not have a First/Next_Entity list.
4861 Decl := First (Declarations (Body_Decl));
4862 while Present (Decl) loop
4864 -- Capture source objects as internally generated temporaries cannot
4865 -- be named and participate in refinement.
4867 if Nkind (Decl) = N_Object_Declaration then
4868 Item_Id := Defining_Entity (Decl);
4870 if Comes_From_Source (Item_Id)
4871 and then Is_Visible_Object (Item_Id)
4873 Append_New_Elmt (Item_Id, States);
4876 -- Capture the visible abstract states and objects of a source
4877 -- package [instantiation].
4879 elsif Nkind (Decl) = N_Package_Declaration then
4880 Item_Id := Defining_Entity (Decl);
4882 if Comes_From_Source (Item_Id) then
4883 Collect_Visible_States (Item_Id, States);
4891 end Collect_Body_States;
4893 ------------------------
4894 -- Collect_Interfaces --
4895 ------------------------
4897 procedure Collect_Interfaces
4899 Ifaces_List : out Elist_Id;
4900 Exclude_Parents : Boolean := False;
4901 Use_Full_View : Boolean := True)
4903 procedure Collect (Typ : Entity_Id);
4904 -- Subsidiary subprogram used to traverse the whole list
4905 -- of directly and indirectly implemented interfaces
4911 procedure Collect (Typ : Entity_Id) is
4912 Ancestor : Entity_Id;
4920 -- Handle private types and subtypes
4923 and then Is_Private_Type (Typ)
4924 and then Present (Full_View (Typ))
4926 Full_T := Full_View (Typ);
4928 if Ekind (Full_T) = E_Record_Subtype then
4929 Full_T := Etype (Typ);
4931 if Present (Full_View (Full_T)) then
4932 Full_T := Full_View (Full_T);
4937 -- Include the ancestor if we are generating the whole list of
4938 -- abstract interfaces.
4940 if Etype (Full_T) /= Typ
4942 -- Protect the frontend against wrong sources. For example:
4945 -- type A is tagged null record;
4946 -- type B is new A with private;
4947 -- type C is new A with private;
4949 -- type B is new C with null record;
4950 -- type C is new B with null record;
4953 and then Etype (Full_T) /= T
4955 Ancestor := Etype (Full_T);
4958 if Is_Interface (Ancestor) and then not Exclude_Parents then
4959 Append_Unique_Elmt (Ancestor, Ifaces_List);
4963 -- Traverse the graph of ancestor interfaces
4965 if Is_Non_Empty_List (Abstract_Interface_List (Full_T)) then
4966 Id := First (Abstract_Interface_List (Full_T));
4967 while Present (Id) loop
4968 Iface := Etype (Id);
4970 -- Protect against wrong uses. For example:
4971 -- type I is interface;
4972 -- type O is tagged null record;
4973 -- type Wrong is new I and O with null record; -- ERROR
4975 if Is_Interface (Iface) then
4977 and then Etype (T) /= T
4978 and then Interface_Present_In_Ancestor (Etype (T), Iface)
4983 Append_Unique_Elmt (Iface, Ifaces_List);
4992 -- Start of processing for Collect_Interfaces
4995 pragma Assert (Is_Tagged_Type (T) or else Is_Concurrent_Type (T));
4996 Ifaces_List := New_Elmt_List;
4998 end Collect_Interfaces;
5000 ----------------------------------
5001 -- Collect_Interface_Components --
5002 ----------------------------------
5004 procedure Collect_Interface_Components
5005 (Tagged_Type : Entity_Id;
5006 Components_List : out Elist_Id)
5008 procedure Collect (Typ : Entity_Id);
5009 -- Subsidiary subprogram used to climb to the parents
5015 procedure Collect (Typ : Entity_Id) is
5016 Tag_Comp : Entity_Id;
5017 Parent_Typ : Entity_Id;
5020 -- Handle private types
5022 if Present (Full_View (Etype (Typ))) then
5023 Parent_Typ := Full_View (Etype (Typ));
5025 Parent_Typ := Etype (Typ);
5028 if Parent_Typ /= Typ
5030 -- Protect the frontend against wrong sources. For example:
5033 -- type A is tagged null record;
5034 -- type B is new A with private;
5035 -- type C is new A with private;
5037 -- type B is new C with null record;
5038 -- type C is new B with null record;
5041 and then Parent_Typ /= Tagged_Type
5043 Collect (Parent_Typ);
5046 -- Collect the components containing tags of secondary dispatch
5049 Tag_Comp := Next_Tag_Component (First_Tag_Component (Typ));
5050 while Present (Tag_Comp) loop
5051 pragma Assert (Present (Related_Type (Tag_Comp)));
5052 Append_Elmt (Tag_Comp, Components_List);
5054 Tag_Comp := Next_Tag_Component (Tag_Comp);
5058 -- Start of processing for Collect_Interface_Components
5061 pragma Assert (Ekind (Tagged_Type) = E_Record_Type
5062 and then Is_Tagged_Type (Tagged_Type));
5064 Components_List := New_Elmt_List;
5065 Collect (Tagged_Type);
5066 end Collect_Interface_Components;
5068 -----------------------------
5069 -- Collect_Interfaces_Info --
5070 -----------------------------
5072 procedure Collect_Interfaces_Info
5074 Ifaces_List : out Elist_Id;
5075 Components_List : out Elist_Id;
5076 Tags_List : out Elist_Id)
5078 Comps_List : Elist_Id;
5079 Comp_Elmt : Elmt_Id;
5080 Comp_Iface : Entity_Id;
5081 Iface_Elmt : Elmt_Id;
5084 function Search_Tag (Iface : Entity_Id) return Entity_Id;
5085 -- Search for the secondary tag associated with the interface type
5086 -- Iface that is implemented by T.
5092 function Search_Tag (Iface : Entity_Id) return Entity_Id is
5095 if not Is_CPP_Class (T) then
5096 ADT := Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (T))));
5098 ADT := Next_Elmt (First_Elmt (Access_Disp_Table (T)));
5102 and then Is_Tag (Node (ADT))
5103 and then Related_Type (Node (ADT)) /= Iface
5105 -- Skip secondary dispatch table referencing thunks to user
5106 -- defined primitives covered by this interface.
5108 pragma Assert (Has_Suffix (Node (ADT), 'P'));
5111 -- Skip secondary dispatch tables of Ada types
5113 if not Is_CPP_Class (T) then
5115 -- Skip secondary dispatch table referencing thunks to
5116 -- predefined primitives.
5118 pragma Assert (Has_Suffix (Node (ADT), 'Y'));
5121 -- Skip secondary dispatch table referencing user-defined
5122 -- primitives covered by this interface.
5124 pragma Assert (Has_Suffix (Node (ADT), 'D'));
5127 -- Skip secondary dispatch table referencing predefined
5130 pragma Assert (Has_Suffix (Node (ADT), 'Z'));
5135 pragma Assert (Is_Tag (Node (ADT)));
5139 -- Start of processing for Collect_Interfaces_Info
5142 Collect_Interfaces (T, Ifaces_List);
5143 Collect_Interface_Components (T, Comps_List);
5145 -- Search for the record component and tag associated with each
5146 -- interface type of T.
5148 Components_List := New_Elmt_List;
5149 Tags_List := New_Elmt_List;
5151 Iface_Elmt := First_Elmt (Ifaces_List);
5152 while Present (Iface_Elmt) loop
5153 Iface := Node (Iface_Elmt);
5155 -- Associate the primary tag component and the primary dispatch table
5156 -- with all the interfaces that are parents of T
5158 if Is_Ancestor (Iface, T, Use_Full_View => True) then
5159 Append_Elmt (First_Tag_Component (T), Components_List);
5160 Append_Elmt (Node (First_Elmt (Access_Disp_Table (T))), Tags_List);
5162 -- Otherwise search for the tag component and secondary dispatch
5166 Comp_Elmt := First_Elmt (Comps_List);
5167 while Present (Comp_Elmt) loop
5168 Comp_Iface := Related_Type (Node (Comp_Elmt));
5170 if Comp_Iface = Iface
5171 or else Is_Ancestor (Iface, Comp_Iface, Use_Full_View => True)
5173 Append_Elmt (Node (Comp_Elmt), Components_List);
5174 Append_Elmt (Search_Tag (Comp_Iface), Tags_List);
5178 Next_Elmt (Comp_Elmt);
5180 pragma Assert (Present (Comp_Elmt));
5183 Next_Elmt (Iface_Elmt);
5185 end Collect_Interfaces_Info;
5187 ---------------------
5188 -- Collect_Parents --
5189 ---------------------
5191 procedure Collect_Parents
5193 List : out Elist_Id;
5194 Use_Full_View : Boolean := True)
5196 Current_Typ : Entity_Id := T;
5197 Parent_Typ : Entity_Id;
5200 List := New_Elmt_List;
5202 -- No action if the if the type has no parents
5204 if T = Etype (T) then
5209 Parent_Typ := Etype (Current_Typ);
5211 if Is_Private_Type (Parent_Typ)
5212 and then Present (Full_View (Parent_Typ))
5213 and then Use_Full_View
5215 Parent_Typ := Full_View (Base_Type (Parent_Typ));
5218 Append_Elmt (Parent_Typ, List);
5220 exit when Parent_Typ = Current_Typ;
5221 Current_Typ := Parent_Typ;
5223 end Collect_Parents;
5225 ----------------------------------
5226 -- Collect_Primitive_Operations --
5227 ----------------------------------
5229 function Collect_Primitive_Operations (T : Entity_Id) return Elist_Id is
5230 B_Type : constant Entity_Id := Base_Type (T);
5232 function Match (E : Entity_Id) return Boolean;
5233 -- True if E's base type is B_Type, or E is of an anonymous access type
5234 -- and the base type of its designated type is B_Type.
5240 function Match (E : Entity_Id) return Boolean is
5241 Etyp : Entity_Id := Etype (E);
5244 if Ekind (Etyp) = E_Anonymous_Access_Type then
5245 Etyp := Designated_Type (Etyp);
5248 -- In Ada 2012 a primitive operation may have a formal of an
5249 -- incomplete view of the parent type.
5251 return Base_Type (Etyp) = B_Type
5253 (Ada_Version >= Ada_2012
5254 and then Ekind (Etyp) = E_Incomplete_Type
5255 and then Full_View (Etyp) = B_Type);
5260 B_Decl : constant Node_Id := Original_Node (Parent (B_Type));
5261 B_Scope : Entity_Id := Scope (B_Type);
5263 Eq_Prims_List : Elist_Id := No_Elist;
5266 Is_Type_In_Pkg : Boolean;
5267 Formal_Derived : Boolean := False;
5270 -- Start of processing for Collect_Primitive_Operations
5273 -- For tagged types, the primitive operations are collected as they
5274 -- are declared, and held in an explicit list which is simply returned.
5276 if Is_Tagged_Type (B_Type) then
5277 return Primitive_Operations (B_Type);
5279 -- An untagged generic type that is a derived type inherits the
5280 -- primitive operations of its parent type. Other formal types only
5281 -- have predefined operators, which are not explicitly represented.
5283 elsif Is_Generic_Type (B_Type) then
5284 if Nkind (B_Decl) = N_Formal_Type_Declaration
5285 and then Nkind (Formal_Type_Definition (B_Decl)) =
5286 N_Formal_Derived_Type_Definition
5288 Formal_Derived := True;
5290 return New_Elmt_List;
5294 Op_List := New_Elmt_List;
5296 if B_Scope = Standard_Standard then
5297 if B_Type = Standard_String then
5298 Append_Elmt (Standard_Op_Concat, Op_List);
5300 elsif B_Type = Standard_Wide_String then
5301 Append_Elmt (Standard_Op_Concatw, Op_List);
5307 -- Locate the primitive subprograms of the type
5310 -- The primitive operations appear after the base type, except if the
5311 -- derivation happens within the private part of B_Scope and the type
5312 -- is a private type, in which case both the type and some primitive
5313 -- operations may appear before the base type, and the list of
5314 -- candidates starts after the type.
5316 if In_Open_Scopes (B_Scope)
5317 and then Scope (T) = B_Scope
5318 and then In_Private_Part (B_Scope)
5320 Id := Next_Entity (T);
5322 -- In Ada 2012, If the type has an incomplete partial view, there may
5323 -- be primitive operations declared before the full view, so we need
5324 -- to start scanning from the incomplete view, which is earlier on
5325 -- the entity chain.
5327 elsif Nkind (Parent (B_Type)) = N_Full_Type_Declaration
5328 and then Present (Incomplete_View (Parent (B_Type)))
5330 Id := Defining_Entity (Incomplete_View (Parent (B_Type)));
5332 -- If T is a derived from a type with an incomplete view declared
5333 -- elsewhere, that incomplete view is irrelevant, we want the
5334 -- operations in the scope of T.
5336 if Scope (Id) /= Scope (B_Type) then
5337 Id := Next_Entity (B_Type);
5341 Id := Next_Entity (B_Type);
5344 -- Set flag if this is a type in a package spec
5347 Is_Package_Or_Generic_Package (B_Scope)
5349 Nkind (Parent (Declaration_Node (First_Subtype (T)))) /=
5352 while Present (Id) loop
5354 -- Test whether the result type or any of the parameter types of
5355 -- each subprogram following the type match that type when the
5356 -- type is declared in a package spec, is a derived type, or the
5357 -- subprogram is marked as primitive. (The Is_Primitive test is
5358 -- needed to find primitives of nonderived types in declarative
5359 -- parts that happen to override the predefined "=" operator.)
5361 -- Note that generic formal subprograms are not considered to be
5362 -- primitive operations and thus are never inherited.
5364 if Is_Overloadable (Id)
5365 and then (Is_Type_In_Pkg
5366 or else Is_Derived_Type (B_Type)
5367 or else Is_Primitive (Id))
5368 and then Nkind (Parent (Parent (Id)))
5369 not in N_Formal_Subprogram_Declaration
5377 Formal := First_Formal (Id);
5378 while Present (Formal) loop
5379 if Match (Formal) then
5384 Next_Formal (Formal);
5388 -- For a formal derived type, the only primitives are the ones
5389 -- inherited from the parent type. Operations appearing in the
5390 -- package declaration are not primitive for it.
5393 and then (not Formal_Derived or else Present (Alias (Id)))
5395 -- In the special case of an equality operator aliased to
5396 -- an overriding dispatching equality belonging to the same
5397 -- type, we don't include it in the list of primitives.
5398 -- This avoids inheriting multiple equality operators when
5399 -- deriving from untagged private types whose full type is
5400 -- tagged, which can otherwise cause ambiguities. Note that
5401 -- this should only happen for this kind of untagged parent
5402 -- type, since normally dispatching operations are inherited
5403 -- using the type's Primitive_Operations list.
5405 if Chars (Id) = Name_Op_Eq
5406 and then Is_Dispatching_Operation (Id)
5407 and then Present (Alias (Id))
5408 and then Present (Overridden_Operation (Alias (Id)))
5409 and then Base_Type (Etype (First_Entity (Id))) =
5410 Base_Type (Etype (First_Entity (Alias (Id))))
5414 -- Include the subprogram in the list of primitives
5417 Append_Elmt (Id, Op_List);
5419 -- Save collected equality primitives for later filtering
5420 -- (if we are processing a private type for which we can
5421 -- collect several candidates).
5423 if Inherits_From_Tagged_Full_View (T)
5424 and then Chars (Id) = Name_Op_Eq
5425 and then Etype (First_Formal (Id)) =
5426 Etype (Next_Formal (First_Formal (Id)))
5428 if No (Eq_Prims_List) then
5429 Eq_Prims_List := New_Elmt_List;
5432 Append_Elmt (Id, Eq_Prims_List);
5440 -- For a type declared in System, some of its operations may
5441 -- appear in the target-specific extension to System.
5444 and then B_Scope = RTU_Entity (System)
5445 and then Present_System_Aux
5447 B_Scope := System_Aux_Id;
5448 Id := First_Entity (System_Aux_Id);
5452 -- Filter collected equality primitives
5454 if Inherits_From_Tagged_Full_View (T)
5455 and then Present (Eq_Prims_List)
5458 First : constant Elmt_Id := First_Elmt (Eq_Prims_List);
5462 pragma Assert (No (Next_Elmt (First))
5463 or else No (Next_Elmt (Next_Elmt (First))));
5465 -- No action needed if we have collected a single equality
5468 if Present (Next_Elmt (First)) then
5469 Second := Next_Elmt (First);
5471 if Is_Dispatching_Operation
5472 (Ultimate_Alias (Node (First)))
5474 Remove (Op_List, Node (First));
5476 elsif Is_Dispatching_Operation
5477 (Ultimate_Alias (Node (Second)))
5479 Remove (Op_List, Node (Second));
5482 pragma Assert (False);
5483 raise Program_Error;
5491 end Collect_Primitive_Operations;
5493 -----------------------------------
5494 -- Compile_Time_Constraint_Error --
5495 -----------------------------------
5497 function Compile_Time_Constraint_Error
5500 Ent : Entity_Id := Empty;
5501 Loc : Source_Ptr := No_Location;
5502 Warn : Boolean := False;
5503 Extra_Msg : String := "") return Node_Id
5505 Msgc : String (1 .. Msg'Length + 3);
5506 -- Copy of message, with room for possible ?? or << and ! at end
5512 -- Start of processing for Compile_Time_Constraint_Error
5515 -- If this is a warning, convert it into an error if we are in code
5516 -- subject to SPARK_Mode being set On, unless Warn is True to force a
5517 -- warning. The rationale is that a compile-time constraint error should
5518 -- lead to an error instead of a warning when SPARK_Mode is On, but in
5519 -- a few cases we prefer to issue a warning and generate both a suitable
5520 -- run-time error in GNAT and a suitable check message in GNATprove.
5521 -- Those cases are those that likely correspond to deactivated SPARK
5522 -- code, so that this kind of code can be compiled and analyzed instead
5523 -- of being rejected.
5525 Error_Msg_Warn := Warn or SPARK_Mode /= On;
5527 -- A static constraint error in an instance body is not a fatal error.
5528 -- we choose to inhibit the message altogether, because there is no
5529 -- obvious node (for now) on which to post it. On the other hand the
5530 -- offending node must be replaced with a constraint_error in any case.
5532 -- No messages are generated if we already posted an error on this node
5534 if not Error_Posted (N) then
5535 if Loc /= No_Location then
5541 -- Copy message to Msgc, converting any ? in the message into <
5542 -- instead, so that we have an error in GNATprove mode.
5546 for J in 1 .. Msgl loop
5547 if Msg (J) = '?' and then (J = 1 or else Msg (J - 1) /= ''') then
5550 Msgc (J) := Msg (J);
5554 -- Message is a warning, even in Ada 95 case
5556 if Msg (Msg'Last) = '?' or else Msg (Msg'Last) = '<' then
5559 -- In Ada 83, all messages are warnings. In the private part and the
5560 -- body of an instance, constraint_checks are only warnings. We also
5561 -- make this a warning if the Warn parameter is set.
5564 or else (Ada_Version = Ada_83 and then Comes_From_Source (N))
5565 or else In_Instance_Not_Visible
5573 -- Otherwise we have a real error message (Ada 95 static case) and we
5574 -- make this an unconditional message. Note that in the warning case
5575 -- we do not make the message unconditional, it seems reasonable to
5576 -- delete messages like this (about exceptions that will be raised)
5585 -- One more test, skip the warning if the related expression is
5586 -- statically unevaluated, since we don't want to warn about what
5587 -- will happen when something is evaluated if it never will be
5590 if not Is_Statically_Unevaluated (N) then
5591 if Present (Ent) then
5592 Error_Msg_NEL (Msgc (1 .. Msgl), N, Ent, Eloc);
5594 Error_Msg_NEL (Msgc (1 .. Msgl), N, Etype (N), Eloc);
5597 -- Emit any extra message as a continuation
5599 if Extra_Msg /= "" then
5600 Error_Msg_N ('\' & Extra_Msg, N);
5605 -- Check whether the context is an Init_Proc
5607 if Inside_Init_Proc then
5609 Conc_Typ : constant Entity_Id :=
5610 Corresponding_Concurrent_Type
5611 (Entity (Parameter_Type (First
5612 (Parameter_Specifications
5613 (Parent (Current_Scope))))));
5616 -- Don't complain if the corresponding concurrent type
5617 -- doesn't come from source (i.e. a single task/protected
5620 if Present (Conc_Typ)
5621 and then not Comes_From_Source (Conc_Typ)
5624 ("\& [<<", N, Standard_Constraint_Error, Eloc);
5627 if GNATprove_Mode then
5629 ("\& would have been raised for objects of this "
5630 & "type", N, Standard_Constraint_Error, Eloc);
5633 ("\& will be raised for objects of this type??",
5634 N, Standard_Constraint_Error, Eloc);
5640 Error_Msg_NEL ("\& [<<", N, Standard_Constraint_Error, Eloc);
5644 Error_Msg ("\static expression fails Constraint_Check", Eloc);
5645 Set_Error_Posted (N);
5651 end Compile_Time_Constraint_Error;
5653 -----------------------
5654 -- Conditional_Delay --
5655 -----------------------
5657 procedure Conditional_Delay (New_Ent, Old_Ent : Entity_Id) is
5659 if Has_Delayed_Freeze (Old_Ent) and then not Is_Frozen (Old_Ent) then
5660 Set_Has_Delayed_Freeze (New_Ent);
5662 end Conditional_Delay;
5664 -------------------------
5665 -- Copy_Component_List --
5666 -------------------------
5668 function Copy_Component_List
5670 Loc : Source_Ptr) return List_Id
5673 Comps : constant List_Id := New_List;
5676 Comp := First_Component (Underlying_Type (R_Typ));
5677 while Present (Comp) loop
5678 if Comes_From_Source (Comp) then
5680 Comp_Decl : constant Node_Id := Declaration_Node (Comp);
5683 Make_Component_Declaration (Loc,
5684 Defining_Identifier =>
5685 Make_Defining_Identifier (Loc, Chars (Comp)),
5686 Component_Definition =>
5688 (Component_Definition (Comp_Decl), New_Sloc => Loc)));
5692 Next_Component (Comp);
5696 end Copy_Component_List;
5698 -------------------------
5699 -- Copy_Parameter_List --
5700 -------------------------
5702 function Copy_Parameter_List (Subp_Id : Entity_Id) return List_Id is
5703 Loc : constant Source_Ptr := Sloc (Subp_Id);
5708 if No (First_Formal (Subp_Id)) then
5712 Formal := First_Formal (Subp_Id);
5713 while Present (Formal) loop
5715 Make_Parameter_Specification (Loc,
5716 Defining_Identifier =>
5717 Make_Defining_Identifier (Sloc (Formal), Chars (Formal)),
5718 In_Present => In_Present (Parent (Formal)),
5719 Out_Present => Out_Present (Parent (Formal)),
5721 New_Occurrence_Of (Etype (Formal), Loc),
5723 New_Copy_Tree (Expression (Parent (Formal)))));
5725 Next_Formal (Formal);
5730 end Copy_Parameter_List;
5732 ----------------------------
5733 -- Copy_SPARK_Mode_Aspect --
5734 ----------------------------
5736 procedure Copy_SPARK_Mode_Aspect (From : Node_Id; To : Node_Id) is
5737 pragma Assert (not Has_Aspects (To));
5741 if Has_Aspects (From) then
5742 Asp := Find_Aspect (Defining_Entity (From), Aspect_SPARK_Mode);
5744 if Present (Asp) then
5745 Set_Aspect_Specifications (To, New_List (New_Copy_Tree (Asp)));
5746 Set_Has_Aspects (To, True);
5749 end Copy_SPARK_Mode_Aspect;
5751 --------------------------
5752 -- Copy_Subprogram_Spec --
5753 --------------------------
5755 function Copy_Subprogram_Spec (Spec : Node_Id) return Node_Id is
5757 Formal_Spec : Node_Id;
5761 -- The structure of the original tree must be replicated without any
5762 -- alterations. Use New_Copy_Tree for this purpose.
5764 Result := New_Copy_Tree (Spec);
5766 -- However, the spec of a null procedure carries the corresponding null
5767 -- statement of the body (created by the parser), and this cannot be
5768 -- shared with the new subprogram spec.
5770 if Nkind (Result) = N_Procedure_Specification then
5771 Set_Null_Statement (Result, Empty);
5774 -- Create a new entity for the defining unit name
5776 Def_Id := Defining_Unit_Name (Result);
5777 Set_Defining_Unit_Name (Result,
5778 Make_Defining_Identifier (Sloc (Def_Id), Chars (Def_Id)));
5780 -- Create new entities for the formal parameters
5782 if Present (Parameter_Specifications (Result)) then
5783 Formal_Spec := First (Parameter_Specifications (Result));
5784 while Present (Formal_Spec) loop
5785 Def_Id := Defining_Identifier (Formal_Spec);
5786 Set_Defining_Identifier (Formal_Spec,
5787 Make_Defining_Identifier (Sloc (Def_Id), Chars (Def_Id)));
5794 end Copy_Subprogram_Spec;
5796 --------------------------------
5797 -- Corresponding_Generic_Type --
5798 --------------------------------
5800 function Corresponding_Generic_Type (T : Entity_Id) return Entity_Id is
5806 if not Is_Generic_Actual_Type (T) then
5809 -- If the actual is the actual of an enclosing instance, resolution
5810 -- was correct in the generic.
5812 elsif Nkind (Parent (T)) = N_Subtype_Declaration
5813 and then Is_Entity_Name (Subtype_Indication (Parent (T)))
5815 Is_Generic_Actual_Type (Entity (Subtype_Indication (Parent (T))))
5822 if Is_Wrapper_Package (Inst) then
5823 Inst := Related_Instance (Inst);
5828 (Specification (Unit_Declaration_Node (Inst)));
5830 -- Generic actual has the same name as the corresponding formal
5832 Typ := First_Entity (Gen);
5833 while Present (Typ) loop
5834 if Chars (Typ) = Chars (T) then
5843 end Corresponding_Generic_Type;
5845 --------------------
5846 -- Current_Entity --
5847 --------------------
5849 -- The currently visible definition for a given identifier is the
5850 -- one most chained at the start of the visibility chain, i.e. the
5851 -- one that is referenced by the Node_Id value of the name of the
5852 -- given identifier.
5854 function Current_Entity (N : Node_Id) return Entity_Id is
5856 return Get_Name_Entity_Id (Chars (N));
5859 -----------------------------
5860 -- Current_Entity_In_Scope --
5861 -----------------------------
5863 function Current_Entity_In_Scope (N : Node_Id) return Entity_Id is
5865 CS : constant Entity_Id := Current_Scope;
5867 Transient_Case : constant Boolean := Scope_Is_Transient;
5870 E := Get_Name_Entity_Id (Chars (N));
5872 and then Scope (E) /= CS
5873 and then (not Transient_Case or else Scope (E) /= Scope (CS))
5879 end Current_Entity_In_Scope;
5885 function Current_Scope return Entity_Id is
5887 if Scope_Stack.Last = -1 then
5888 return Standard_Standard;
5891 C : constant Entity_Id :=
5892 Scope_Stack.Table (Scope_Stack.Last).Entity;
5897 return Standard_Standard;
5903 ----------------------------
5904 -- Current_Scope_No_Loops --
5905 ----------------------------
5907 function Current_Scope_No_Loops return Entity_Id is
5911 -- Examine the scope stack starting from the current scope and skip any
5912 -- internally generated loops.
5915 while Present (S) and then S /= Standard_Standard loop
5916 if Ekind (S) = E_Loop and then not Comes_From_Source (S) then
5924 end Current_Scope_No_Loops;
5926 ------------------------
5927 -- Current_Subprogram --
5928 ------------------------
5930 function Current_Subprogram return Entity_Id is
5931 Scop : constant Entity_Id := Current_Scope;
5933 if Is_Subprogram_Or_Generic_Subprogram (Scop) then
5936 return Enclosing_Subprogram (Scop);
5938 end Current_Subprogram;
5940 ----------------------------------
5941 -- Deepest_Type_Access_Level --
5942 ----------------------------------
5944 function Deepest_Type_Access_Level (Typ : Entity_Id) return Uint is
5946 if Ekind (Typ) = E_Anonymous_Access_Type
5947 and then not Is_Local_Anonymous_Access (Typ)
5948 and then Nkind (Associated_Node_For_Itype (Typ)) = N_Object_Declaration
5950 -- Typ is the type of an Ada 2012 stand-alone object of an anonymous
5954 Scope_Depth (Enclosing_Dynamic_Scope
5955 (Defining_Identifier
5956 (Associated_Node_For_Itype (Typ))));
5958 -- For generic formal type, return Int'Last (infinite).
5959 -- See comment preceding Is_Generic_Type call in Type_Access_Level.
5961 elsif Is_Generic_Type (Root_Type (Typ)) then
5962 return UI_From_Int (Int'Last);
5965 return Type_Access_Level (Typ);
5967 end Deepest_Type_Access_Level;
5969 ---------------------
5970 -- Defining_Entity --
5971 ---------------------
5973 function Defining_Entity (N : Node_Id) return Entity_Id is
5976 when N_Abstract_Subprogram_Declaration
5977 | N_Expression_Function
5978 | N_Formal_Subprogram_Declaration
5979 | N_Generic_Package_Declaration
5980 | N_Generic_Subprogram_Declaration
5981 | N_Package_Declaration
5983 | N_Subprogram_Body_Stub
5984 | N_Subprogram_Declaration
5985 | N_Subprogram_Renaming_Declaration
5987 return Defining_Entity (Specification (N));
5989 when N_Component_Declaration
5990 | N_Defining_Program_Unit_Name
5991 | N_Discriminant_Specification
5993 | N_Entry_Declaration
5994 | N_Entry_Index_Specification
5995 | N_Exception_Declaration
5996 | N_Exception_Renaming_Declaration
5997 | N_Formal_Object_Declaration
5998 | N_Formal_Package_Declaration
5999 | N_Formal_Type_Declaration
6000 | N_Full_Type_Declaration
6001 | N_Implicit_Label_Declaration
6002 | N_Incomplete_Type_Declaration
6003 | N_Iterator_Specification
6004 | N_Loop_Parameter_Specification
6005 | N_Number_Declaration
6006 | N_Object_Declaration
6007 | N_Object_Renaming_Declaration
6008 | N_Package_Body_Stub
6009 | N_Parameter_Specification
6010 | N_Private_Extension_Declaration
6011 | N_Private_Type_Declaration
6013 | N_Protected_Body_Stub
6014 | N_Protected_Type_Declaration
6015 | N_Single_Protected_Declaration
6016 | N_Single_Task_Declaration
6017 | N_Subtype_Declaration
6020 | N_Task_Type_Declaration
6022 return Defining_Identifier (N);
6024 when N_Compilation_Unit =>
6025 return Defining_Entity (Unit (N));
6028 return Defining_Entity (Proper_Body (N));
6030 when N_Function_Instantiation
6031 | N_Function_Specification
6032 | N_Generic_Function_Renaming_Declaration
6033 | N_Generic_Package_Renaming_Declaration
6034 | N_Generic_Procedure_Renaming_Declaration
6036 | N_Package_Instantiation
6037 | N_Package_Renaming_Declaration
6038 | N_Package_Specification
6039 | N_Procedure_Instantiation
6040 | N_Procedure_Specification
6043 Nam : constant Node_Id := Defining_Unit_Name (N);
6044 Err : Entity_Id := Empty;
6047 if Nkind (Nam) in N_Entity then
6050 -- For Error, make up a name and attach to declaration so we
6051 -- can continue semantic analysis.
6053 elsif Nam = Error then
6054 Err := Make_Temporary (Sloc (N), 'T');
6055 Set_Defining_Unit_Name (N, Err);
6059 -- If not an entity, get defining identifier
6062 return Defining_Identifier (Nam);
6066 when N_Block_Statement
6069 return Entity (Identifier (N));
6072 raise Program_Error;
6074 end Defining_Entity;
6076 --------------------------
6077 -- Denotes_Discriminant --
6078 --------------------------
6080 function Denotes_Discriminant
6082 Check_Concurrent : Boolean := False) return Boolean
6087 if not Is_Entity_Name (N) or else No (Entity (N)) then
6093 -- If we are checking for a protected type, the discriminant may have
6094 -- been rewritten as the corresponding discriminal of the original type
6095 -- or of the corresponding concurrent record, depending on whether we
6096 -- are in the spec or body of the protected type.
6098 return Ekind (E) = E_Discriminant
6101 and then Ekind (E) = E_In_Parameter
6102 and then Present (Discriminal_Link (E))
6104 (Is_Concurrent_Type (Scope (Discriminal_Link (E)))
6106 Is_Concurrent_Record_Type (Scope (Discriminal_Link (E)))));
6107 end Denotes_Discriminant;
6109 -------------------------
6110 -- Denotes_Same_Object --
6111 -------------------------
6113 function Denotes_Same_Object (A1, A2 : Node_Id) return Boolean is
6114 function Is_Renaming (N : Node_Id) return Boolean;
6115 -- Return true if N names a renaming entity
6117 function Is_Valid_Renaming (N : Node_Id) return Boolean;
6118 -- For renamings, return False if the prefix of any dereference within
6119 -- the renamed object_name is a variable, or any expression within the
6120 -- renamed object_name contains references to variables or calls on
6121 -- nonstatic functions; otherwise return True (RM 6.4.1(6.10/3))
6127 function Is_Renaming (N : Node_Id) return Boolean is
6130 Is_Entity_Name (N) and then Present (Renamed_Entity (Entity (N)));
6133 -----------------------
6134 -- Is_Valid_Renaming --
6135 -----------------------
6137 function Is_Valid_Renaming (N : Node_Id) return Boolean is
6138 function Check_Renaming (N : Node_Id) return Boolean;
6139 -- Recursive function used to traverse all the prefixes of N
6141 --------------------
6142 -- Check_Renaming --
6143 --------------------
6145 function Check_Renaming (N : Node_Id) return Boolean is
6148 and then not Check_Renaming (Renamed_Entity (Entity (N)))
6153 if Nkind (N) = N_Indexed_Component then
6158 Indx := First (Expressions (N));
6159 while Present (Indx) loop
6160 if not Is_OK_Static_Expression (Indx) then
6169 if Has_Prefix (N) then
6171 P : constant Node_Id := Prefix (N);
6174 if Nkind (N) = N_Explicit_Dereference
6175 and then Is_Variable (P)
6179 elsif Is_Entity_Name (P)
6180 and then Ekind (Entity (P)) = E_Function
6184 elsif Nkind (P) = N_Function_Call then
6188 -- Recursion to continue traversing the prefix of the
6189 -- renaming expression
6191 return Check_Renaming (P);
6198 -- Start of processing for Is_Valid_Renaming
6201 return Check_Renaming (N);
6202 end Is_Valid_Renaming;
6206 Obj1 : Node_Id := A1;
6207 Obj2 : Node_Id := A2;
6209 -- Start of processing for Denotes_Same_Object
6212 -- Both names statically denote the same stand-alone object or parameter
6213 -- (RM 6.4.1(6.5/3))
6215 if Is_Entity_Name (Obj1)
6216 and then Is_Entity_Name (Obj2)
6217 and then Entity (Obj1) = Entity (Obj2)
6222 -- For renamings, the prefix of any dereference within the renamed
6223 -- object_name is not a variable, and any expression within the
6224 -- renamed object_name contains no references to variables nor
6225 -- calls on nonstatic functions (RM 6.4.1(6.10/3)).
6227 if Is_Renaming (Obj1) then
6228 if Is_Valid_Renaming (Obj1) then
6229 Obj1 := Renamed_Entity (Entity (Obj1));
6235 if Is_Renaming (Obj2) then
6236 if Is_Valid_Renaming (Obj2) then
6237 Obj2 := Renamed_Entity (Entity (Obj2));
6243 -- No match if not same node kind (such cases are handled by
6244 -- Denotes_Same_Prefix)
6246 if Nkind (Obj1) /= Nkind (Obj2) then
6249 -- After handling valid renamings, one of the two names statically
6250 -- denoted a renaming declaration whose renamed object_name is known
6251 -- to denote the same object as the other (RM 6.4.1(6.10/3))
6253 elsif Is_Entity_Name (Obj1) then
6254 if Is_Entity_Name (Obj2) then
6255 return Entity (Obj1) = Entity (Obj2);
6260 -- Both names are selected_components, their prefixes are known to
6261 -- denote the same object, and their selector_names denote the same
6262 -- component (RM 6.4.1(6.6/3)).
6264 elsif Nkind (Obj1) = N_Selected_Component then
6265 return Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2))
6267 Entity (Selector_Name (Obj1)) = Entity (Selector_Name (Obj2));
6269 -- Both names are dereferences and the dereferenced names are known to
6270 -- denote the same object (RM 6.4.1(6.7/3))
6272 elsif Nkind (Obj1) = N_Explicit_Dereference then
6273 return Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2));
6275 -- Both names are indexed_components, their prefixes are known to denote
6276 -- the same object, and each of the pairs of corresponding index values
6277 -- are either both static expressions with the same static value or both
6278 -- names that are known to denote the same object (RM 6.4.1(6.8/3))
6280 elsif Nkind (Obj1) = N_Indexed_Component then
6281 if not Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2)) then
6289 Indx1 := First (Expressions (Obj1));
6290 Indx2 := First (Expressions (Obj2));
6291 while Present (Indx1) loop
6293 -- Indexes must denote the same static value or same object
6295 if Is_OK_Static_Expression (Indx1) then
6296 if not Is_OK_Static_Expression (Indx2) then
6299 elsif Expr_Value (Indx1) /= Expr_Value (Indx2) then
6303 elsif not Denotes_Same_Object (Indx1, Indx2) then
6315 -- Both names are slices, their prefixes are known to denote the same
6316 -- object, and the two slices have statically matching index constraints
6317 -- (RM 6.4.1(6.9/3))
6319 elsif Nkind (Obj1) = N_Slice
6320 and then Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2))
6323 Lo1, Lo2, Hi1, Hi2 : Node_Id;
6326 Get_Index_Bounds (Etype (Obj1), Lo1, Hi1);
6327 Get_Index_Bounds (Etype (Obj2), Lo2, Hi2);
6329 -- Check whether bounds are statically identical. There is no
6330 -- attempt to detect partial overlap of slices.
6332 return Denotes_Same_Object (Lo1, Lo2)
6334 Denotes_Same_Object (Hi1, Hi2);
6337 -- In the recursion, literals appear as indexes
6339 elsif Nkind (Obj1) = N_Integer_Literal
6341 Nkind (Obj2) = N_Integer_Literal
6343 return Intval (Obj1) = Intval (Obj2);
6348 end Denotes_Same_Object;
6350 -------------------------
6351 -- Denotes_Same_Prefix --
6352 -------------------------
6354 function Denotes_Same_Prefix (A1, A2 : Node_Id) return Boolean is
6356 if Is_Entity_Name (A1) then
6357 if Nkind_In (A2, N_Selected_Component, N_Indexed_Component)
6358 and then not Is_Access_Type (Etype (A1))
6360 return Denotes_Same_Object (A1, Prefix (A2))
6361 or else Denotes_Same_Prefix (A1, Prefix (A2));
6366 elsif Is_Entity_Name (A2) then
6367 return Denotes_Same_Prefix (A1 => A2, A2 => A1);
6369 elsif Nkind_In (A1, N_Selected_Component, N_Indexed_Component, N_Slice)
6371 Nkind_In (A2, N_Selected_Component, N_Indexed_Component, N_Slice)
6374 Root1, Root2 : Node_Id;
6375 Depth1, Depth2 : Nat := 0;
6378 Root1 := Prefix (A1);
6379 while not Is_Entity_Name (Root1) loop
6381 (Root1, N_Selected_Component, N_Indexed_Component)
6385 Root1 := Prefix (Root1);
6388 Depth1 := Depth1 + 1;
6391 Root2 := Prefix (A2);
6392 while not Is_Entity_Name (Root2) loop
6393 if not Nkind_In (Root2, N_Selected_Component,
6394 N_Indexed_Component)
6398 Root2 := Prefix (Root2);
6401 Depth2 := Depth2 + 1;
6404 -- If both have the same depth and they do not denote the same
6405 -- object, they are disjoint and no warning is needed.
6407 if Depth1 = Depth2 then
6410 elsif Depth1 > Depth2 then
6411 Root1 := Prefix (A1);
6412 for J in 1 .. Depth1 - Depth2 - 1 loop
6413 Root1 := Prefix (Root1);
6416 return Denotes_Same_Object (Root1, A2);
6419 Root2 := Prefix (A2);
6420 for J in 1 .. Depth2 - Depth1 - 1 loop
6421 Root2 := Prefix (Root2);
6424 return Denotes_Same_Object (A1, Root2);
6431 end Denotes_Same_Prefix;
6433 ----------------------
6434 -- Denotes_Variable --
6435 ----------------------
6437 function Denotes_Variable (N : Node_Id) return Boolean is
6439 return Is_Variable (N) and then Paren_Count (N) = 0;
6440 end Denotes_Variable;
6442 -----------------------------
6443 -- Depends_On_Discriminant --
6444 -----------------------------
6446 function Depends_On_Discriminant (N : Node_Id) return Boolean is
6451 Get_Index_Bounds (N, L, H);
6452 return Denotes_Discriminant (L) or else Denotes_Discriminant (H);
6453 end Depends_On_Discriminant;
6455 -------------------------
6456 -- Designate_Same_Unit --
6457 -------------------------
6459 function Designate_Same_Unit
6461 Name2 : Node_Id) return Boolean
6463 K1 : constant Node_Kind := Nkind (Name1);
6464 K2 : constant Node_Kind := Nkind (Name2);
6466 function Prefix_Node (N : Node_Id) return Node_Id;
6467 -- Returns the parent unit name node of a defining program unit name
6468 -- or the prefix if N is a selected component or an expanded name.
6470 function Select_Node (N : Node_Id) return Node_Id;
6471 -- Returns the defining identifier node of a defining program unit
6472 -- name or the selector node if N is a selected component or an
6479 function Prefix_Node (N : Node_Id) return Node_Id is
6481 if Nkind (N) = N_Defining_Program_Unit_Name then
6492 function Select_Node (N : Node_Id) return Node_Id is
6494 if Nkind (N) = N_Defining_Program_Unit_Name then
6495 return Defining_Identifier (N);
6497 return Selector_Name (N);
6501 -- Start of processing for Designate_Same_Unit
6504 if Nkind_In (K1, N_Identifier, N_Defining_Identifier)
6506 Nkind_In (K2, N_Identifier, N_Defining_Identifier)
6508 return Chars (Name1) = Chars (Name2);
6510 elsif Nkind_In (K1, N_Expanded_Name,
6511 N_Selected_Component,
6512 N_Defining_Program_Unit_Name)
6514 Nkind_In (K2, N_Expanded_Name,
6515 N_Selected_Component,
6516 N_Defining_Program_Unit_Name)
6519 (Chars (Select_Node (Name1)) = Chars (Select_Node (Name2)))
6521 Designate_Same_Unit (Prefix_Node (Name1), Prefix_Node (Name2));
6526 end Designate_Same_Unit;
6528 ---------------------------------------------
6529 -- Diagnose_Iterated_Component_Association --
6530 ---------------------------------------------
6532 procedure Diagnose_Iterated_Component_Association (N : Node_Id) is
6533 Def_Id : constant Entity_Id := Defining_Identifier (N);
6537 -- Determine whether the iterated component association appears within
6538 -- an aggregate. If this is the case, raise Program_Error because the
6539 -- iterated component association cannot be left in the tree as is and
6540 -- must always be processed by the related aggregate.
6543 while Present (Aggr) loop
6544 if Nkind (Aggr) = N_Aggregate then
6545 raise Program_Error;
6547 -- Prevent the search from going too far
6549 elsif Is_Body_Or_Package_Declaration (Aggr) then
6553 Aggr := Parent (Aggr);
6556 -- At this point it is known that the iterated component association is
6557 -- not within an aggregate. This is really a quantified expression with
6558 -- a missing "all" or "some" quantifier.
6560 Error_Msg_N ("missing quantifier", Def_Id);
6562 -- Rewrite the iterated component association as True to prevent any
6565 Rewrite (N, New_Occurrence_Of (Standard_True, Sloc (N)));
6567 end Diagnose_Iterated_Component_Association;
6569 ---------------------------------
6570 -- Dynamic_Accessibility_Level --
6571 ---------------------------------
6573 function Dynamic_Accessibility_Level (N : Node_Id) return Node_Id is
6574 Loc : constant Source_Ptr := Sloc (N);
6576 function Make_Level_Literal (Level : Uint) return Node_Id;
6577 -- Construct an integer literal representing an accessibility level
6578 -- with its type set to Natural.
6580 ------------------------
6581 -- Make_Level_Literal --
6582 ------------------------
6584 function Make_Level_Literal (Level : Uint) return Node_Id is
6585 Result : constant Node_Id := Make_Integer_Literal (Loc, Level);
6588 Set_Etype (Result, Standard_Natural);
6590 end Make_Level_Literal;
6594 Expr : Node_Id := Original_Node (N);
6595 -- Expr references the original node because at this stage N may be the
6596 -- reference to a variable internally created by the frontend to remove
6597 -- side effects of an expression.
6601 -- Start of processing for Dynamic_Accessibility_Level
6604 if Is_Entity_Name (Expr) then
6607 if Present (Renamed_Object (E)) then
6608 return Dynamic_Accessibility_Level (Renamed_Object (E));
6612 or else Ekind_In (E, E_Variable, E_Constant))
6613 and then Present (Get_Accessibility (E))
6615 return New_Occurrence_Of (Get_Accessibility (E), Loc);
6619 -- Handle a constant-folded conditional expression by avoiding use of
6620 -- the original node.
6622 if Nkind_In (Expr, N_Case_Expression, N_If_Expression) then
6626 -- Unimplemented: Ptr.all'Access, where Ptr has Extra_Accessibility ???
6628 case Nkind (Expr) is
6629 -- It may be possible that we have an access object denoted by an
6630 -- attribute reference for 'Loop_Entry which may, in turn, have an
6631 -- indexed component representing a loop identifier.
6633 -- In this case we must climb up the indexed component and set expr
6634 -- to the attribute reference so the rest of the machinery can
6635 -- operate as expected.
6637 when N_Indexed_Component =>
6638 if Nkind (Prefix (Expr)) = N_Attribute_Reference
6639 and then Get_Attribute_Id (Attribute_Name (Prefix (Expr)))
6640 = Attribute_Loop_Entry
6642 Expr := Prefix (Expr);
6645 -- For access discriminant, the level of the enclosing object
6647 when N_Selected_Component =>
6648 if Ekind (Entity (Selector_Name (Expr))) = E_Discriminant
6649 and then Ekind (Etype (Entity (Selector_Name (Expr)))) =
6650 E_Anonymous_Access_Type
6652 return Make_Level_Literal (Object_Access_Level (Expr));
6655 when N_Attribute_Reference =>
6656 case Get_Attribute_Id (Attribute_Name (Expr)) is
6658 -- Ignore 'Loop_Entry, 'Result, and 'Old as they can be used to
6659 -- identify access objects and do not have an effect on
6660 -- accessibility level.
6662 when Attribute_Loop_Entry | Attribute_Old | Attribute_Result =>
6665 -- For X'Access, the level of the prefix X
6667 when Attribute_Access =>
6668 return Make_Level_Literal
6669 (Object_Access_Level (Prefix (Expr)));
6671 -- Treat the unchecked attributes as library-level
6673 when Attribute_Unchecked_Access
6674 | Attribute_Unrestricted_Access
6676 return Make_Level_Literal (Scope_Depth (Standard_Standard));
6678 -- No other access-valued attributes
6681 raise Program_Error;
6686 -- This is not fully implemented since it depends on context (see
6687 -- 3.10.2(14/3-14.2/3). More work is needed in the following cases
6689 -- 1) For an anonymous allocator defining the value of an access
6690 -- parameter, the accessibility level is that of the innermost
6691 -- master of the call; however currently we pass the level of
6692 -- execution of the called subprogram, which is one greater
6693 -- than the current scope level (see Expand_Call_Helper).
6695 -- For example, a statement is a master and a declaration is
6696 -- not a master; so we should not pass in the same level for
6697 -- the following cases:
6699 -- function F (X : access Integer) return T is ... ;
6700 -- Decl : T := F (new Integer); -- level is off by one
6702 -- Decl := F (new Integer); -- we get this case right
6704 -- 2) For an anonymous allocator that defines the result of a
6705 -- function with an access result, the accessibility level is
6706 -- determined as though the allocator were in place of the call
6707 -- of the function. In the special case of a call that is the
6708 -- operand of a type conversion the level is that of the target
6709 -- access type of the conversion.
6711 -- 3) For an anonymous allocator defining an access discriminant
6712 -- the accessibility level is determined as follows:
6713 -- * for an allocator used to define the discriminant of an
6714 -- object, the level of the object
6715 -- * for an allocator used to define the constraint in a
6716 -- subtype_indication in any other context, the level of
6717 -- the master that elaborates the subtype_indication.
6719 case Nkind (Parent (N)) is
6720 when N_Object_Declaration =>
6722 -- For an anonymous allocator whose type is that of a
6723 -- stand-alone object of an anonymous access-to-object type,
6724 -- the accessibility level is that of the declaration of the
6725 -- stand-alone object.
6729 (Object_Access_Level
6730 (Defining_Identifier (Parent (N))));
6732 when N_Assignment_Statement =>
6735 (Object_Access_Level (Name (Parent (N))));
6739 S : constant String :=
6740 Node_Kind'Image (Nkind (Parent (N)));
6742 Error_Msg_Strlen := S'Length;
6743 Error_Msg_String (1 .. Error_Msg_Strlen) := S;
6745 ("unsupported context for anonymous allocator (~)",
6750 when N_Type_Conversion =>
6751 if not Is_Local_Anonymous_Access (Etype (Expr)) then
6753 -- Handle type conversions introduced for a rename of an
6754 -- Ada 2012 stand-alone object of an anonymous access type.
6756 return Dynamic_Accessibility_Level (Expression (Expr));
6763 return Make_Level_Literal (Type_Access_Level (Etype (Expr)));
6764 end Dynamic_Accessibility_Level;
6766 ------------------------
6767 -- Discriminated_Size --
6768 ------------------------
6770 function Discriminated_Size (Comp : Entity_Id) return Boolean is
6771 function Non_Static_Bound (Bound : Node_Id) return Boolean;
6772 -- Check whether the bound of an index is non-static and does denote
6773 -- a discriminant, in which case any object of the type (protected or
6774 -- otherwise) will have a non-static size.
6776 ----------------------
6777 -- Non_Static_Bound --
6778 ----------------------
6780 function Non_Static_Bound (Bound : Node_Id) return Boolean is
6782 if Is_OK_Static_Expression (Bound) then
6785 -- If the bound is given by a discriminant it is non-static
6786 -- (A static constraint replaces the reference with the value).
6787 -- In an protected object the discriminant has been replaced by
6788 -- the corresponding discriminal within the protected operation.
6790 elsif Is_Entity_Name (Bound)
6792 (Ekind (Entity (Bound)) = E_Discriminant
6793 or else Present (Discriminal_Link (Entity (Bound))))
6800 end Non_Static_Bound;
6804 Typ : constant Entity_Id := Etype (Comp);
6807 -- Start of processing for Discriminated_Size
6810 if not Is_Array_Type (Typ) then
6814 if Ekind (Typ) = E_Array_Subtype then
6815 Index := First_Index (Typ);
6816 while Present (Index) loop
6817 if Non_Static_Bound (Low_Bound (Index))
6818 or else Non_Static_Bound (High_Bound (Index))
6830 end Discriminated_Size;
6832 -----------------------------------
6833 -- Effective_Extra_Accessibility --
6834 -----------------------------------
6836 function Effective_Extra_Accessibility (Id : Entity_Id) return Entity_Id is
6838 if Present (Renamed_Object (Id))
6839 and then Is_Entity_Name (Renamed_Object (Id))
6841 return Effective_Extra_Accessibility (Entity (Renamed_Object (Id)));
6843 return Extra_Accessibility (Id);
6845 end Effective_Extra_Accessibility;
6847 -----------------------------
6848 -- Effective_Reads_Enabled --
6849 -----------------------------
6851 function Effective_Reads_Enabled (Id : Entity_Id) return Boolean is
6853 return Has_Enabled_Property (Id, Name_Effective_Reads);
6854 end Effective_Reads_Enabled;
6856 ------------------------------
6857 -- Effective_Writes_Enabled --
6858 ------------------------------
6860 function Effective_Writes_Enabled (Id : Entity_Id) return Boolean is
6862 return Has_Enabled_Property (Id, Name_Effective_Writes);
6863 end Effective_Writes_Enabled;
6865 ------------------------------
6866 -- Enclosing_Comp_Unit_Node --
6867 ------------------------------
6869 function Enclosing_Comp_Unit_Node (N : Node_Id) return Node_Id is
6870 Current_Node : Node_Id;
6874 while Present (Current_Node)
6875 and then Nkind (Current_Node) /= N_Compilation_Unit
6877 Current_Node := Parent (Current_Node);
6880 if Nkind (Current_Node) /= N_Compilation_Unit then
6883 return Current_Node;
6885 end Enclosing_Comp_Unit_Node;
6887 --------------------------
6888 -- Enclosing_CPP_Parent --
6889 --------------------------
6891 function Enclosing_CPP_Parent (Typ : Entity_Id) return Entity_Id is
6892 Parent_Typ : Entity_Id := Typ;
6895 while not Is_CPP_Class (Parent_Typ)
6896 and then Etype (Parent_Typ) /= Parent_Typ
6898 Parent_Typ := Etype (Parent_Typ);
6900 if Is_Private_Type (Parent_Typ) then
6901 Parent_Typ := Full_View (Base_Type (Parent_Typ));
6905 pragma Assert (Is_CPP_Class (Parent_Typ));
6907 end Enclosing_CPP_Parent;
6909 ---------------------------
6910 -- Enclosing_Declaration --
6911 ---------------------------
6913 function Enclosing_Declaration (N : Node_Id) return Node_Id is
6914 Decl : Node_Id := N;
6917 while Present (Decl)
6918 and then not (Nkind (Decl) in N_Declaration
6920 Nkind (Decl) in N_Later_Decl_Item
6922 Nkind (Decl) = N_Number_Declaration)
6924 Decl := Parent (Decl);
6928 end Enclosing_Declaration;
6930 ----------------------------
6931 -- Enclosing_Generic_Body --
6932 ----------------------------
6934 function Enclosing_Generic_Body (N : Node_Id) return Node_Id is
6936 Spec_Id : Entity_Id;
6940 while Present (Par) loop
6941 if Nkind_In (Par, N_Package_Body, N_Subprogram_Body) then
6942 Spec_Id := Corresponding_Spec (Par);
6944 if Present (Spec_Id)
6945 and then Nkind_In (Unit_Declaration_Node (Spec_Id),
6946 N_Generic_Package_Declaration,
6947 N_Generic_Subprogram_Declaration)
6953 Par := Parent (Par);
6957 end Enclosing_Generic_Body;
6959 ----------------------------
6960 -- Enclosing_Generic_Unit --
6961 ----------------------------
6963 function Enclosing_Generic_Unit (N : Node_Id) return Node_Id is
6965 Spec_Decl : Node_Id;
6966 Spec_Id : Entity_Id;
6970 while Present (Par) loop
6971 if Nkind_In (Par, N_Generic_Package_Declaration,
6972 N_Generic_Subprogram_Declaration)
6976 elsif Nkind_In (Par, N_Package_Body, N_Subprogram_Body) then
6977 Spec_Id := Corresponding_Spec (Par);
6979 if Present (Spec_Id) then
6980 Spec_Decl := Unit_Declaration_Node (Spec_Id);
6982 if Nkind_In (Spec_Decl, N_Generic_Package_Declaration,
6983 N_Generic_Subprogram_Declaration)
6990 Par := Parent (Par);
6994 end Enclosing_Generic_Unit;
6996 -------------------------------
6997 -- Enclosing_Lib_Unit_Entity --
6998 -------------------------------
7000 function Enclosing_Lib_Unit_Entity
7001 (E : Entity_Id := Current_Scope) return Entity_Id
7003 Unit_Entity : Entity_Id;
7006 -- Look for enclosing library unit entity by following scope links.
7007 -- Equivalent to, but faster than indexing through the scope stack.
7010 while (Present (Scope (Unit_Entity))
7011 and then Scope (Unit_Entity) /= Standard_Standard)
7012 and not Is_Child_Unit (Unit_Entity)
7014 Unit_Entity := Scope (Unit_Entity);
7018 end Enclosing_Lib_Unit_Entity;
7020 -----------------------------
7021 -- Enclosing_Lib_Unit_Node --
7022 -----------------------------
7024 function Enclosing_Lib_Unit_Node (N : Node_Id) return Node_Id is
7025 Encl_Unit : Node_Id;
7028 Encl_Unit := Enclosing_Comp_Unit_Node (N);
7029 while Present (Encl_Unit)
7030 and then Nkind (Unit (Encl_Unit)) = N_Subunit
7032 Encl_Unit := Library_Unit (Encl_Unit);
7035 pragma Assert (Nkind (Encl_Unit) = N_Compilation_Unit);
7037 end Enclosing_Lib_Unit_Node;
7039 -----------------------
7040 -- Enclosing_Package --
7041 -----------------------
7043 function Enclosing_Package (E : Entity_Id) return Entity_Id is
7044 Dynamic_Scope : constant Entity_Id := Enclosing_Dynamic_Scope (E);
7047 if Dynamic_Scope = Standard_Standard then
7048 return Standard_Standard;
7050 elsif Dynamic_Scope = Empty then
7053 elsif Ekind_In (Dynamic_Scope, E_Generic_Package,
7057 return Dynamic_Scope;
7060 return Enclosing_Package (Dynamic_Scope);
7062 end Enclosing_Package;
7064 -------------------------------------
7065 -- Enclosing_Package_Or_Subprogram --
7066 -------------------------------------
7068 function Enclosing_Package_Or_Subprogram (E : Entity_Id) return Entity_Id is
7073 while Present (S) loop
7074 if Is_Package_Or_Generic_Package (S)
7075 or else Is_Subprogram_Or_Generic_Subprogram (S)
7085 end Enclosing_Package_Or_Subprogram;
7087 --------------------------
7088 -- Enclosing_Subprogram --
7089 --------------------------
7091 function Enclosing_Subprogram (E : Entity_Id) return Entity_Id is
7092 Dyn_Scop : constant Entity_Id := Enclosing_Dynamic_Scope (E);
7095 if Dyn_Scop = Standard_Standard then
7098 elsif Dyn_Scop = Empty then
7101 elsif Ekind (Dyn_Scop) = E_Subprogram_Body then
7102 return Corresponding_Spec (Parent (Parent (Dyn_Scop)));
7104 elsif Ekind_In (Dyn_Scop, E_Block, E_Loop, E_Return_Statement) then
7105 return Enclosing_Subprogram (Dyn_Scop);
7107 elsif Ekind_In (Dyn_Scop, E_Entry, E_Entry_Family) then
7109 -- For a task entry or entry family, return the enclosing subprogram
7110 -- of the task itself.
7112 if Ekind (Scope (Dyn_Scop)) = E_Task_Type then
7113 return Enclosing_Subprogram (Dyn_Scop);
7115 -- A protected entry or entry family is rewritten as a protected
7116 -- procedure which is the desired enclosing subprogram. This is
7117 -- relevant when unnesting a procedure local to an entry body.
7120 return Protected_Body_Subprogram (Dyn_Scop);
7123 elsif Ekind (Dyn_Scop) = E_Task_Type then
7124 return Get_Task_Body_Procedure (Dyn_Scop);
7126 -- The scope may appear as a private type or as a private extension
7127 -- whose completion is a task or protected type.
7129 elsif Ekind_In (Dyn_Scop, E_Limited_Private_Type,
7130 E_Record_Type_With_Private)
7131 and then Present (Full_View (Dyn_Scop))
7132 and then Ekind_In (Full_View (Dyn_Scop), E_Task_Type, E_Protected_Type)
7134 return Get_Task_Body_Procedure (Full_View (Dyn_Scop));
7136 -- No body is generated if the protected operation is eliminated
7138 elsif Convention (Dyn_Scop) = Convention_Protected
7139 and then not Is_Eliminated (Dyn_Scop)
7140 and then Present (Protected_Body_Subprogram (Dyn_Scop))
7142 return Protected_Body_Subprogram (Dyn_Scop);
7147 end Enclosing_Subprogram;
7149 --------------------------
7150 -- End_Keyword_Location --
7151 --------------------------
7153 function End_Keyword_Location (N : Node_Id) return Source_Ptr is
7154 function End_Label_Loc (Nod : Node_Id) return Source_Ptr;
7155 -- Return the source location of Nod's end label according to the
7156 -- following precedence rules:
7158 -- 1) If the end label exists, return its location
7159 -- 2) If Nod exists, return its location
7160 -- 3) Return the location of N
7166 function End_Label_Loc (Nod : Node_Id) return Source_Ptr is
7170 if Present (Nod) then
7171 Label := End_Label (Nod);
7173 if Present (Label) then
7174 return Sloc (Label);
7188 -- Start of processing for End_Keyword_Location
7191 if Nkind_In (N, N_Block_Statement,
7197 Owner := Handled_Statement_Sequence (N);
7199 elsif Nkind (N) = N_Package_Declaration then
7200 Owner := Specification (N);
7202 elsif Nkind (N) = N_Protected_Body then
7205 elsif Nkind_In (N, N_Protected_Type_Declaration,
7206 N_Single_Protected_Declaration)
7208 Owner := Protected_Definition (N);
7210 elsif Nkind_In (N, N_Single_Task_Declaration,
7211 N_Task_Type_Declaration)
7213 Owner := Task_Definition (N);
7215 -- This routine should not be called with other contexts
7218 pragma Assert (False);
7222 return End_Label_Loc (Owner);
7223 end End_Keyword_Location;
7225 ------------------------
7226 -- Ensure_Freeze_Node --
7227 ------------------------
7229 procedure Ensure_Freeze_Node (E : Entity_Id) is
7232 if No (Freeze_Node (E)) then
7233 FN := Make_Freeze_Entity (Sloc (E));
7234 Set_Has_Delayed_Freeze (E);
7235 Set_Freeze_Node (E, FN);
7236 Set_Access_Types_To_Process (FN, No_Elist);
7237 Set_TSS_Elist (FN, No_Elist);
7240 end Ensure_Freeze_Node;
7246 procedure Enter_Name (Def_Id : Entity_Id) is
7247 C : constant Entity_Id := Current_Entity (Def_Id);
7248 E : constant Entity_Id := Current_Entity_In_Scope (Def_Id);
7249 S : constant Entity_Id := Current_Scope;
7252 Generate_Definition (Def_Id);
7254 -- Add new name to current scope declarations. Check for duplicate
7255 -- declaration, which may or may not be a genuine error.
7259 -- Case of previous entity entered because of a missing declaration
7260 -- or else a bad subtype indication. Best is to use the new entity,
7261 -- and make the previous one invisible.
7263 if Etype (E) = Any_Type then
7264 Set_Is_Immediately_Visible (E, False);
7266 -- Case of renaming declaration constructed for package instances.
7267 -- if there is an explicit declaration with the same identifier,
7268 -- the renaming is not immediately visible any longer, but remains
7269 -- visible through selected component notation.
7271 elsif Nkind (Parent (E)) = N_Package_Renaming_Declaration
7272 and then not Comes_From_Source (E)
7274 Set_Is_Immediately_Visible (E, False);
7276 -- The new entity may be the package renaming, which has the same
7277 -- same name as a generic formal which has been seen already.
7279 elsif Nkind (Parent (Def_Id)) = N_Package_Renaming_Declaration
7280 and then not Comes_From_Source (Def_Id)
7282 Set_Is_Immediately_Visible (E, False);
7284 -- For a fat pointer corresponding to a remote access to subprogram,
7285 -- we use the same identifier as the RAS type, so that the proper
7286 -- name appears in the stub. This type is only retrieved through
7287 -- the RAS type and never by visibility, and is not added to the
7288 -- visibility list (see below).
7290 elsif Nkind (Parent (Def_Id)) = N_Full_Type_Declaration
7291 and then Ekind (Def_Id) = E_Record_Type
7292 and then Present (Corresponding_Remote_Type (Def_Id))
7296 -- Case of an implicit operation or derived literal. The new entity
7297 -- hides the implicit one, which is removed from all visibility,
7298 -- i.e. the entity list of its scope, and homonym chain of its name.
7300 elsif (Is_Overloadable (E) and then Is_Inherited_Operation (E))
7301 or else Is_Internal (E)
7304 Decl : constant Node_Id := Parent (E);
7306 Prev_Vis : Entity_Id;
7309 -- If E is an implicit declaration, it cannot be the first
7310 -- entity in the scope.
7312 Prev := First_Entity (Current_Scope);
7313 while Present (Prev) and then Next_Entity (Prev) /= E loop
7319 -- If E is not on the entity chain of the current scope,
7320 -- it is an implicit declaration in the generic formal
7321 -- part of a generic subprogram. When analyzing the body,
7322 -- the generic formals are visible but not on the entity
7323 -- chain of the subprogram. The new entity will become
7324 -- the visible one in the body.
7327 (Nkind (Parent (Decl)) = N_Generic_Subprogram_Declaration);
7331 Link_Entities (Prev, Next_Entity (E));
7333 if No (Next_Entity (Prev)) then
7334 Set_Last_Entity (Current_Scope, Prev);
7337 if E = Current_Entity (E) then
7341 Prev_Vis := Current_Entity (E);
7342 while Homonym (Prev_Vis) /= E loop
7343 Prev_Vis := Homonym (Prev_Vis);
7347 if Present (Prev_Vis) then
7349 -- Skip E in the visibility chain
7351 Set_Homonym (Prev_Vis, Homonym (E));
7354 Set_Name_Entity_Id (Chars (E), Homonym (E));
7359 -- This section of code could use a comment ???
7361 elsif Present (Etype (E))
7362 and then Is_Concurrent_Type (Etype (E))
7367 -- If the homograph is a protected component renaming, it should not
7368 -- be hiding the current entity. Such renamings are treated as weak
7371 elsif Is_Prival (E) then
7372 Set_Is_Immediately_Visible (E, False);
7374 -- In this case the current entity is a protected component renaming.
7375 -- Perform minimal decoration by setting the scope and return since
7376 -- the prival should not be hiding other visible entities.
7378 elsif Is_Prival (Def_Id) then
7379 Set_Scope (Def_Id, Current_Scope);
7382 -- Analogous to privals, the discriminal generated for an entry index
7383 -- parameter acts as a weak declaration. Perform minimal decoration
7384 -- to avoid bogus errors.
7386 elsif Is_Discriminal (Def_Id)
7387 and then Ekind (Discriminal_Link (Def_Id)) = E_Entry_Index_Parameter
7389 Set_Scope (Def_Id, Current_Scope);
7392 -- In the body or private part of an instance, a type extension may
7393 -- introduce a component with the same name as that of an actual. The
7394 -- legality rule is not enforced, but the semantics of the full type
7395 -- with two components of same name are not clear at this point???
7397 elsif In_Instance_Not_Visible then
7400 -- When compiling a package body, some child units may have become
7401 -- visible. They cannot conflict with local entities that hide them.
7403 elsif Is_Child_Unit (E)
7404 and then In_Open_Scopes (Scope (E))
7405 and then not Is_Immediately_Visible (E)
7409 -- Conversely, with front-end inlining we may compile the parent body
7410 -- first, and a child unit subsequently. The context is now the
7411 -- parent spec, and body entities are not visible.
7413 elsif Is_Child_Unit (Def_Id)
7414 and then Is_Package_Body_Entity (E)
7415 and then not In_Package_Body (Current_Scope)
7419 -- Case of genuine duplicate declaration
7422 Error_Msg_Sloc := Sloc (E);
7424 -- If the previous declaration is an incomplete type declaration
7425 -- this may be an attempt to complete it with a private type. The
7426 -- following avoids confusing cascaded errors.
7428 if Nkind (Parent (E)) = N_Incomplete_Type_Declaration
7429 and then Nkind (Parent (Def_Id)) = N_Private_Type_Declaration
7432 ("incomplete type cannot be completed with a private " &
7433 "declaration", Parent (Def_Id));
7434 Set_Is_Immediately_Visible (E, False);
7435 Set_Full_View (E, Def_Id);
7437 -- An inherited component of a record conflicts with a new
7438 -- discriminant. The discriminant is inserted first in the scope,
7439 -- but the error should be posted on it, not on the component.
7441 elsif Ekind (E) = E_Discriminant
7442 and then Present (Scope (Def_Id))
7443 and then Scope (Def_Id) /= Current_Scope
7445 Error_Msg_Sloc := Sloc (Def_Id);
7446 Error_Msg_N ("& conflicts with declaration#", E);
7449 -- If the name of the unit appears in its own context clause, a
7450 -- dummy package with the name has already been created, and the
7451 -- error emitted. Try to continue quietly.
7453 elsif Error_Posted (E)
7454 and then Sloc (E) = No_Location
7455 and then Nkind (Parent (E)) = N_Package_Specification
7456 and then Current_Scope = Standard_Standard
7458 Set_Scope (Def_Id, Current_Scope);
7462 Error_Msg_N ("& conflicts with declaration#", Def_Id);
7464 -- Avoid cascaded messages with duplicate components in
7467 if Ekind_In (E, E_Component, E_Discriminant) then
7472 if Nkind (Parent (Parent (Def_Id))) =
7473 N_Generic_Subprogram_Declaration
7475 Defining_Entity (Specification (Parent (Parent (Def_Id))))
7477 Error_Msg_N ("\generic units cannot be overloaded", Def_Id);
7480 -- If entity is in standard, then we are in trouble, because it
7481 -- means that we have a library package with a duplicated name.
7482 -- That's hard to recover from, so abort.
7484 if S = Standard_Standard then
7485 raise Unrecoverable_Error;
7487 -- Otherwise we continue with the declaration. Having two
7488 -- identical declarations should not cause us too much trouble.
7496 -- If we fall through, declaration is OK, at least OK enough to continue
7498 -- If Def_Id is a discriminant or a record component we are in the midst
7499 -- of inheriting components in a derived record definition. Preserve
7500 -- their Ekind and Etype.
7502 if Ekind_In (Def_Id, E_Discriminant, E_Component) then
7505 -- If a type is already set, leave it alone (happens when a type
7506 -- declaration is reanalyzed following a call to the optimizer).
7508 elsif Present (Etype (Def_Id)) then
7511 -- Otherwise, the kind E_Void insures that premature uses of the entity
7512 -- will be detected. Any_Type insures that no cascaded errors will occur
7515 Set_Ekind (Def_Id, E_Void);
7516 Set_Etype (Def_Id, Any_Type);
7519 -- Inherited discriminants and components in derived record types are
7520 -- immediately visible. Itypes are not.
7522 -- Unless the Itype is for a record type with a corresponding remote
7523 -- type (what is that about, it was not commented ???)
7525 if Ekind_In (Def_Id, E_Discriminant, E_Component)
7527 ((not Is_Record_Type (Def_Id)
7528 or else No (Corresponding_Remote_Type (Def_Id)))
7529 and then not Is_Itype (Def_Id))
7531 Set_Is_Immediately_Visible (Def_Id);
7532 Set_Current_Entity (Def_Id);
7535 Set_Homonym (Def_Id, C);
7536 Append_Entity (Def_Id, S);
7537 Set_Public_Status (Def_Id);
7539 -- Declaring a homonym is not allowed in SPARK ...
7541 if Present (C) and then Restriction_Check_Required (SPARK_05) then
7543 Enclosing_Subp : constant Node_Id := Enclosing_Subprogram (Def_Id);
7544 Enclosing_Pack : constant Node_Id := Enclosing_Package (Def_Id);
7545 Other_Scope : constant Node_Id := Enclosing_Dynamic_Scope (C);
7548 -- ... unless the new declaration is in a subprogram, and the
7549 -- visible declaration is a variable declaration or a parameter
7550 -- specification outside that subprogram.
7552 if Present (Enclosing_Subp)
7553 and then Nkind_In (Parent (C), N_Object_Declaration,
7554 N_Parameter_Specification)
7555 and then not Scope_Within_Or_Same (Other_Scope, Enclosing_Subp)
7559 -- ... or the new declaration is in a package, and the visible
7560 -- declaration occurs outside that package.
7562 elsif Present (Enclosing_Pack)
7563 and then not Scope_Within_Or_Same (Other_Scope, Enclosing_Pack)
7567 -- ... or the new declaration is a component declaration in a
7568 -- record type definition.
7570 elsif Nkind (Parent (Def_Id)) = N_Component_Declaration then
7573 -- Don't issue error for non-source entities
7575 elsif Comes_From_Source (Def_Id)
7576 and then Comes_From_Source (C)
7578 Error_Msg_Sloc := Sloc (C);
7579 Check_SPARK_05_Restriction
7580 ("redeclaration of identifier &#", Def_Id);
7585 -- Warn if new entity hides an old one
7587 if Warn_On_Hiding and then Present (C)
7589 -- Don't warn for record components since they always have a well
7590 -- defined scope which does not confuse other uses. Note that in
7591 -- some cases, Ekind has not been set yet.
7593 and then Ekind (C) /= E_Component
7594 and then Ekind (C) /= E_Discriminant
7595 and then Nkind (Parent (C)) /= N_Component_Declaration
7596 and then Ekind (Def_Id) /= E_Component
7597 and then Ekind (Def_Id) /= E_Discriminant
7598 and then Nkind (Parent (Def_Id)) /= N_Component_Declaration
7600 -- Don't warn for one character variables. It is too common to use
7601 -- such variables as locals and will just cause too many false hits.
7603 and then Length_Of_Name (Chars (C)) /= 1
7605 -- Don't warn for non-source entities
7607 and then Comes_From_Source (C)
7608 and then Comes_From_Source (Def_Id)
7610 -- Don't warn unless entity in question is in extended main source
7612 and then In_Extended_Main_Source_Unit (Def_Id)
7614 -- Finally, the hidden entity must be either immediately visible or
7615 -- use visible (i.e. from a used package).
7618 (Is_Immediately_Visible (C)
7620 Is_Potentially_Use_Visible (C))
7622 Error_Msg_Sloc := Sloc (C);
7623 Error_Msg_N ("declaration hides &#?h?", Def_Id);
7631 function Entity_Of (N : Node_Id) return Entity_Id is
7636 -- Assume that the arbitrary node does not have an entity
7640 if Is_Entity_Name (N) then
7643 -- Follow a possible chain of renamings to reach the earliest renamed
7647 and then Is_Object (Id)
7648 and then Present (Renamed_Object (Id))
7650 Ren := Renamed_Object (Id);
7652 -- The reference renames an abstract state or a whole object
7655 -- Ren : ... renames Obj;
7657 if Is_Entity_Name (Ren) then
7659 -- Do not follow a renaming that goes through a generic formal,
7660 -- because these entities are hidden and must not be referenced
7661 -- from outside the generic.
7663 if Is_Hidden (Entity (Ren)) then
7670 -- The reference renames a function result. Check the original
7671 -- node in case expansion relocates the function call.
7673 -- Ren : ... renames Func_Call;
7675 elsif Nkind (Original_Node (Ren)) = N_Function_Call then
7678 -- Otherwise the reference renames something which does not yield
7679 -- an abstract state or a whole object. Treat the reference as not
7680 -- having a proper entity for SPARK legality purposes.
7692 --------------------------
7693 -- Examine_Array_Bounds --
7694 --------------------------
7696 procedure Examine_Array_Bounds
7698 All_Static : out Boolean;
7699 Has_Empty : out Boolean)
7701 function Is_OK_Static_Bound (Bound : Node_Id) return Boolean;
7702 -- Determine whether bound Bound is a suitable static bound
7704 ------------------------
7705 -- Is_OK_Static_Bound --
7706 ------------------------
7708 function Is_OK_Static_Bound (Bound : Node_Id) return Boolean is
7711 not Error_Posted (Bound)
7712 and then Is_OK_Static_Expression (Bound);
7713 end Is_OK_Static_Bound;
7721 -- Start of processing for Examine_Array_Bounds
7724 -- An unconstrained array type does not have static bounds, and it is
7725 -- not known whether they are empty or not.
7727 if not Is_Constrained (Typ) then
7728 All_Static := False;
7731 -- A string literal has static bounds, and is not empty as long as it
7732 -- contains at least one character.
7734 elsif Ekind (Typ) = E_String_Literal_Subtype then
7736 Has_Empty := String_Literal_Length (Typ) > 0;
7739 -- Assume that all bounds are static and not empty
7744 -- Examine each index
7746 Index := First_Index (Typ);
7747 while Present (Index) loop
7748 if Is_Discrete_Type (Etype (Index)) then
7749 Get_Index_Bounds (Index, Lo_Bound, Hi_Bound);
7751 if Is_OK_Static_Bound (Lo_Bound)
7753 Is_OK_Static_Bound (Hi_Bound)
7755 -- The static bounds produce an empty range
7757 if Is_Null_Range (Lo_Bound, Hi_Bound) then
7761 -- Otherwise at least one of the bounds is not static
7764 All_Static := False;
7767 -- Otherwise the index is non-discrete, therefore not static
7770 All_Static := False;
7775 end Examine_Array_Bounds;
7781 function Exceptions_OK return Boolean is
7784 not (Restriction_Active (No_Exception_Handlers) or else
7785 Restriction_Active (No_Exception_Propagation) or else
7786 Restriction_Active (No_Exceptions));
7789 --------------------------
7790 -- Explain_Limited_Type --
7791 --------------------------
7793 procedure Explain_Limited_Type (T : Entity_Id; N : Node_Id) is
7797 -- For array, component type must be limited
7799 if Is_Array_Type (T) then
7800 Error_Msg_Node_2 := T;
7802 ("\component type& of type& is limited", N, Component_Type (T));
7803 Explain_Limited_Type (Component_Type (T), N);
7805 elsif Is_Record_Type (T) then
7807 -- No need for extra messages if explicit limited record
7809 if Is_Limited_Record (Base_Type (T)) then
7813 -- Otherwise find a limited component. Check only components that
7814 -- come from source, or inherited components that appear in the
7815 -- source of the ancestor.
7817 C := First_Component (T);
7818 while Present (C) loop
7819 if Is_Limited_Type (Etype (C))
7821 (Comes_From_Source (C)
7823 (Present (Original_Record_Component (C))
7825 Comes_From_Source (Original_Record_Component (C))))
7827 Error_Msg_Node_2 := T;
7828 Error_Msg_NE ("\component& of type& has limited type", N, C);
7829 Explain_Limited_Type (Etype (C), N);
7836 -- The type may be declared explicitly limited, even if no component
7837 -- of it is limited, in which case we fall out of the loop.
7840 end Explain_Limited_Type;
7842 ---------------------------------------
7843 -- Expression_Of_Expression_Function --
7844 ---------------------------------------
7846 function Expression_Of_Expression_Function
7847 (Subp : Entity_Id) return Node_Id
7849 Expr_Func : Node_Id;
7852 pragma Assert (Is_Expression_Function_Or_Completion (Subp));
7854 if Nkind (Original_Node (Subprogram_Spec (Subp))) =
7855 N_Expression_Function
7857 Expr_Func := Original_Node (Subprogram_Spec (Subp));
7859 elsif Nkind (Original_Node (Subprogram_Body (Subp))) =
7860 N_Expression_Function
7862 Expr_Func := Original_Node (Subprogram_Body (Subp));
7865 pragma Assert (False);
7869 return Original_Node (Expression (Expr_Func));
7870 end Expression_Of_Expression_Function;
7872 -------------------------------
7873 -- Extensions_Visible_Status --
7874 -------------------------------
7876 function Extensions_Visible_Status
7877 (Id : Entity_Id) return Extensions_Visible_Mode
7886 -- When a formal parameter is subject to Extensions_Visible, the pragma
7887 -- is stored in the contract of related subprogram.
7889 if Is_Formal (Id) then
7892 elsif Is_Subprogram_Or_Generic_Subprogram (Id) then
7895 -- No other construct carries this pragma
7898 return Extensions_Visible_None;
7901 Prag := Get_Pragma (Subp, Pragma_Extensions_Visible);
7903 -- In certain cases analysis may request the Extensions_Visible status
7904 -- of an expression function before the pragma has been analyzed yet.
7905 -- Inspect the declarative items after the expression function looking
7906 -- for the pragma (if any).
7908 if No (Prag) and then Is_Expression_Function (Subp) then
7909 Decl := Next (Unit_Declaration_Node (Subp));
7910 while Present (Decl) loop
7911 if Nkind (Decl) = N_Pragma
7912 and then Pragma_Name (Decl) = Name_Extensions_Visible
7917 -- A source construct ends the region where Extensions_Visible may
7918 -- appear, stop the traversal. An expanded expression function is
7919 -- no longer a source construct, but it must still be recognized.
7921 elsif Comes_From_Source (Decl)
7923 (Nkind_In (Decl, N_Subprogram_Body,
7924 N_Subprogram_Declaration)
7925 and then Is_Expression_Function (Defining_Entity (Decl)))
7934 -- Extract the value from the Boolean expression (if any)
7936 if Present (Prag) then
7937 Arg := First (Pragma_Argument_Associations (Prag));
7939 if Present (Arg) then
7940 Expr := Get_Pragma_Arg (Arg);
7942 -- When the associated subprogram is an expression function, the
7943 -- argument of the pragma may not have been analyzed.
7945 if not Analyzed (Expr) then
7946 Preanalyze_And_Resolve (Expr, Standard_Boolean);
7949 -- Guard against cascading errors when the argument of pragma
7950 -- Extensions_Visible is not a valid static Boolean expression.
7952 if Error_Posted (Expr) then
7953 return Extensions_Visible_None;
7955 elsif Is_True (Expr_Value (Expr)) then
7956 return Extensions_Visible_True;
7959 return Extensions_Visible_False;
7962 -- Otherwise the aspect or pragma defaults to True
7965 return Extensions_Visible_True;
7968 -- Otherwise aspect or pragma Extensions_Visible is not inherited or
7969 -- directly specified. In SPARK code, its value defaults to "False".
7971 elsif SPARK_Mode = On then
7972 return Extensions_Visible_False;
7974 -- In non-SPARK code, aspect or pragma Extensions_Visible defaults to
7978 return Extensions_Visible_True;
7980 end Extensions_Visible_Status;
7986 procedure Find_Actual
7988 Formal : out Entity_Id;
7991 Context : constant Node_Id := Parent (N);
7996 if Nkind_In (Context, N_Indexed_Component, N_Selected_Component)
7997 and then N = Prefix (Context)
7999 Find_Actual (Context, Formal, Call);
8002 elsif Nkind (Context) = N_Parameter_Association
8003 and then N = Explicit_Actual_Parameter (Context)
8005 Call := Parent (Context);
8007 elsif Nkind_In (Context, N_Entry_Call_Statement,
8009 N_Procedure_Call_Statement)
8019 -- If we have a call to a subprogram look for the parameter. Note that
8020 -- we exclude overloaded calls, since we don't know enough to be sure
8021 -- of giving the right answer in this case.
8023 if Nkind_In (Call, N_Entry_Call_Statement,
8025 N_Procedure_Call_Statement)
8027 Call_Nam := Name (Call);
8029 -- A call to a protected or task entry appears as a selected
8030 -- component rather than an expanded name.
8032 if Nkind (Call_Nam) = N_Selected_Component then
8033 Call_Nam := Selector_Name (Call_Nam);
8036 if Is_Entity_Name (Call_Nam)
8037 and then Present (Entity (Call_Nam))
8038 and then Is_Overloadable (Entity (Call_Nam))
8039 and then not Is_Overloaded (Call_Nam)
8041 -- If node is name in call it is not an actual
8043 if N = Call_Nam then
8049 -- Fall here if we are definitely a parameter
8051 Actual := First_Actual (Call);
8052 Formal := First_Formal (Entity (Call_Nam));
8053 while Present (Formal) and then Present (Actual) loop
8057 -- An actual that is the prefix in a prefixed call may have
8058 -- been rewritten in the call, after the deferred reference
8059 -- was collected. Check if sloc and kinds and names match.
8061 elsif Sloc (Actual) = Sloc (N)
8062 and then Nkind (Actual) = N_Identifier
8063 and then Nkind (Actual) = Nkind (N)
8064 and then Chars (Actual) = Chars (N)
8069 Actual := Next_Actual (Actual);
8070 Formal := Next_Formal (Formal);
8076 -- Fall through here if we did not find matching actual
8082 ---------------------------
8083 -- Find_Body_Discriminal --
8084 ---------------------------
8086 function Find_Body_Discriminal
8087 (Spec_Discriminant : Entity_Id) return Entity_Id
8093 -- If expansion is suppressed, then the scope can be the concurrent type
8094 -- itself rather than a corresponding concurrent record type.
8096 if Is_Concurrent_Type (Scope (Spec_Discriminant)) then
8097 Tsk := Scope (Spec_Discriminant);
8100 pragma Assert (Is_Concurrent_Record_Type (Scope (Spec_Discriminant)));
8102 Tsk := Corresponding_Concurrent_Type (Scope (Spec_Discriminant));
8105 -- Find discriminant of original concurrent type, and use its current
8106 -- discriminal, which is the renaming within the task/protected body.
8108 Disc := First_Discriminant (Tsk);
8109 while Present (Disc) loop
8110 if Chars (Disc) = Chars (Spec_Discriminant) then
8111 return Discriminal (Disc);
8114 Next_Discriminant (Disc);
8117 -- That loop should always succeed in finding a matching entry and
8118 -- returning. Fatal error if not.
8120 raise Program_Error;
8121 end Find_Body_Discriminal;
8123 -------------------------------------
8124 -- Find_Corresponding_Discriminant --
8125 -------------------------------------
8127 function Find_Corresponding_Discriminant
8129 Typ : Entity_Id) return Entity_Id
8131 Par_Disc : Entity_Id;
8132 Old_Disc : Entity_Id;
8133 New_Disc : Entity_Id;
8136 Par_Disc := Original_Record_Component (Original_Discriminant (Id));
8138 -- The original type may currently be private, and the discriminant
8139 -- only appear on its full view.
8141 if Is_Private_Type (Scope (Par_Disc))
8142 and then not Has_Discriminants (Scope (Par_Disc))
8143 and then Present (Full_View (Scope (Par_Disc)))
8145 Old_Disc := First_Discriminant (Full_View (Scope (Par_Disc)));
8147 Old_Disc := First_Discriminant (Scope (Par_Disc));
8150 if Is_Class_Wide_Type (Typ) then
8151 New_Disc := First_Discriminant (Root_Type (Typ));
8153 New_Disc := First_Discriminant (Typ);
8156 while Present (Old_Disc) and then Present (New_Disc) loop
8157 if Old_Disc = Par_Disc then
8161 Next_Discriminant (Old_Disc);
8162 Next_Discriminant (New_Disc);
8165 -- Should always find it
8167 raise Program_Error;
8168 end Find_Corresponding_Discriminant;
8174 function Find_DIC_Type (Typ : Entity_Id) return Entity_Id is
8175 Curr_Typ : Entity_Id;
8176 -- The current type being examined in the parent hierarchy traversal
8178 DIC_Typ : Entity_Id;
8179 -- The type which carries the DIC pragma. This variable denotes the
8180 -- partial view when private types are involved.
8182 Par_Typ : Entity_Id;
8183 -- The parent type of the current type. This variable denotes the full
8184 -- view when private types are involved.
8187 -- The input type defines its own DIC pragma, therefore it is the owner
8189 if Has_Own_DIC (Typ) then
8192 -- Otherwise the DIC pragma is inherited from a parent type
8195 pragma Assert (Has_Inherited_DIC (Typ));
8197 -- Climb the parent chain
8201 -- Inspect the parent type. Do not consider subtypes as they
8202 -- inherit the DIC attributes from their base types.
8204 DIC_Typ := Base_Type (Etype (Curr_Typ));
8206 -- Look at the full view of a private type because the type may
8207 -- have a hidden parent introduced in the full view.
8211 if Is_Private_Type (Par_Typ)
8212 and then Present (Full_View (Par_Typ))
8214 Par_Typ := Full_View (Par_Typ);
8217 -- Stop the climb once the nearest parent type which defines a DIC
8218 -- pragma of its own is encountered or when the root of the parent
8219 -- chain is reached.
8221 exit when Has_Own_DIC (DIC_Typ) or else Curr_Typ = Par_Typ;
8223 Curr_Typ := Par_Typ;
8230 ----------------------------------
8231 -- Find_Enclosing_Iterator_Loop --
8232 ----------------------------------
8234 function Find_Enclosing_Iterator_Loop (Id : Entity_Id) return Entity_Id is
8239 -- Traverse the scope chain looking for an iterator loop. Such loops are
8240 -- usually transformed into blocks, hence the use of Original_Node.
8243 while Present (S) and then S /= Standard_Standard loop
8244 if Ekind (S) = E_Loop
8245 and then Nkind (Parent (S)) = N_Implicit_Label_Declaration
8247 Constr := Original_Node (Label_Construct (Parent (S)));
8249 if Nkind (Constr) = N_Loop_Statement
8250 and then Present (Iteration_Scheme (Constr))
8251 and then Nkind (Iterator_Specification
8252 (Iteration_Scheme (Constr))) =
8253 N_Iterator_Specification
8263 end Find_Enclosing_Iterator_Loop;
8265 --------------------------
8266 -- Find_Enclosing_Scope --
8267 --------------------------
8269 function Find_Enclosing_Scope (N : Node_Id) return Entity_Id is
8273 -- Examine the parent chain looking for a construct which defines a
8277 while Present (Par) loop
8280 -- The construct denotes a declaration, the proper scope is its
8283 when N_Entry_Declaration
8284 | N_Expression_Function
8285 | N_Full_Type_Declaration
8286 | N_Generic_Package_Declaration
8287 | N_Generic_Subprogram_Declaration
8288 | N_Package_Declaration
8289 | N_Private_Extension_Declaration
8290 | N_Protected_Type_Declaration
8291 | N_Single_Protected_Declaration
8292 | N_Single_Task_Declaration
8293 | N_Subprogram_Declaration
8294 | N_Task_Type_Declaration
8296 return Defining_Entity (Par);
8298 -- The construct denotes a body, the proper scope is the entity of
8299 -- the corresponding spec or that of the body if the body does not
8300 -- complete a previous declaration.
8308 return Unique_Defining_Entity (Par);
8312 -- Blocks carry either a source or an internally-generated scope,
8313 -- unless the block is a byproduct of exception handling.
8315 when N_Block_Statement =>
8316 if not Exception_Junk (Par) then
8317 return Entity (Identifier (Par));
8320 -- Loops carry an internally-generated scope
8322 when N_Loop_Statement =>
8323 return Entity (Identifier (Par));
8325 -- Extended return statements carry an internally-generated scope
8327 when N_Extended_Return_Statement =>
8328 return Return_Statement_Entity (Par);
8330 -- A traversal from a subunit continues via the corresponding stub
8333 Par := Corresponding_Stub (Par);
8339 Par := Parent (Par);
8342 return Standard_Standard;
8343 end Find_Enclosing_Scope;
8345 ------------------------------------
8346 -- Find_Loop_In_Conditional_Block --
8347 ------------------------------------
8349 function Find_Loop_In_Conditional_Block (N : Node_Id) return Node_Id is
8355 if Nkind (Stmt) = N_If_Statement then
8356 Stmt := First (Then_Statements (Stmt));
8359 pragma Assert (Nkind (Stmt) = N_Block_Statement);
8361 -- Inspect the statements of the conditional block. In general the loop
8362 -- should be the first statement in the statement sequence of the block,
8363 -- but the finalization machinery may have introduced extra object
8366 Stmt := First (Statements (Handled_Statement_Sequence (Stmt)));
8367 while Present (Stmt) loop
8368 if Nkind (Stmt) = N_Loop_Statement then
8375 -- The expansion of attribute 'Loop_Entry produced a malformed block
8377 raise Program_Error;
8378 end Find_Loop_In_Conditional_Block;
8380 --------------------------
8381 -- Find_Overlaid_Entity --
8382 --------------------------
8384 procedure Find_Overlaid_Entity
8386 Ent : out Entity_Id;
8392 -- We are looking for one of the two following forms:
8394 -- for X'Address use Y'Address
8398 -- Const : constant Address := expr;
8400 -- for X'Address use Const;
8402 -- In the second case, the expr is either Y'Address, or recursively a
8403 -- constant that eventually references Y'Address.
8408 if Nkind (N) = N_Attribute_Definition_Clause
8409 and then Chars (N) = Name_Address
8411 Expr := Expression (N);
8413 -- This loop checks the form of the expression for Y'Address,
8414 -- using recursion to deal with intermediate constants.
8417 -- Check for Y'Address
8419 if Nkind (Expr) = N_Attribute_Reference
8420 and then Attribute_Name (Expr) = Name_Address
8422 Expr := Prefix (Expr);
8425 -- Check for Const where Const is a constant entity
8427 elsif Is_Entity_Name (Expr)
8428 and then Ekind (Entity (Expr)) = E_Constant
8430 Expr := Constant_Value (Entity (Expr));
8432 -- Anything else does not need checking
8439 -- This loop checks the form of the prefix for an entity, using
8440 -- recursion to deal with intermediate components.
8443 -- Check for Y where Y is an entity
8445 if Is_Entity_Name (Expr) then
8446 Ent := Entity (Expr);
8449 -- Check for components
8452 Nkind_In (Expr, N_Selected_Component, N_Indexed_Component)
8454 Expr := Prefix (Expr);
8457 -- Anything else does not need checking
8464 end Find_Overlaid_Entity;
8466 -------------------------
8467 -- Find_Parameter_Type --
8468 -------------------------
8470 function Find_Parameter_Type (Param : Node_Id) return Entity_Id is
8472 if Nkind (Param) /= N_Parameter_Specification then
8475 -- For an access parameter, obtain the type from the formal entity
8476 -- itself, because access to subprogram nodes do not carry a type.
8477 -- Shouldn't we always use the formal entity ???
8479 elsif Nkind (Parameter_Type (Param)) = N_Access_Definition then
8480 return Etype (Defining_Identifier (Param));
8483 return Etype (Parameter_Type (Param));
8485 end Find_Parameter_Type;
8487 -----------------------------------
8488 -- Find_Placement_In_State_Space --
8489 -----------------------------------
8491 procedure Find_Placement_In_State_Space
8492 (Item_Id : Entity_Id;
8493 Placement : out State_Space_Kind;
8494 Pack_Id : out Entity_Id)
8496 Context : Entity_Id;
8499 -- Assume that the item does not appear in the state space of a package
8501 Placement := Not_In_Package;
8504 -- Climb the scope stack and examine the enclosing context
8506 Context := Scope (Item_Id);
8507 while Present (Context) and then Context /= Standard_Standard loop
8508 if Is_Package_Or_Generic_Package (Context) then
8511 -- A package body is a cut off point for the traversal as the item
8512 -- cannot be visible to the outside from this point on. Note that
8513 -- this test must be done first as a body is also classified as a
8516 if In_Package_Body (Context) then
8517 Placement := Body_State_Space;
8520 -- The private part of a package is a cut off point for the
8521 -- traversal as the item cannot be visible to the outside from
8524 elsif In_Private_Part (Context) then
8525 Placement := Private_State_Space;
8528 -- When the item appears in the visible state space of a package,
8529 -- continue to climb the scope stack as this may not be the final
8533 Placement := Visible_State_Space;
8535 -- The visible state space of a child unit acts as the proper
8536 -- placement of an item.
8538 if Is_Child_Unit (Context) then
8543 -- The item or its enclosing package appear in a construct that has
8547 Placement := Not_In_Package;
8551 Context := Scope (Context);
8553 end Find_Placement_In_State_Space;
8555 -----------------------
8556 -- Find_Primitive_Eq --
8557 -----------------------
8559 function Find_Primitive_Eq (Typ : Entity_Id) return Entity_Id is
8560 function Find_Eq_Prim (Prims_List : Elist_Id) return Entity_Id;
8561 -- Search for the equality primitive; return Empty if the primitive is
8568 function Find_Eq_Prim (Prims_List : Elist_Id) return Entity_Id is
8570 Prim_Elmt : Elmt_Id;
8573 Prim_Elmt := First_Elmt (Prims_List);
8574 while Present (Prim_Elmt) loop
8575 Prim := Node (Prim_Elmt);
8577 -- Locate primitive equality with the right signature
8579 if Chars (Prim) = Name_Op_Eq
8580 and then Etype (First_Formal (Prim)) =
8581 Etype (Next_Formal (First_Formal (Prim)))
8582 and then Base_Type (Etype (Prim)) = Standard_Boolean
8587 Next_Elmt (Prim_Elmt);
8595 Eq_Prim : Entity_Id;
8596 Full_Type : Entity_Id;
8598 -- Start of processing for Find_Primitive_Eq
8601 if Is_Private_Type (Typ) then
8602 Full_Type := Underlying_Type (Typ);
8607 if No (Full_Type) then
8611 Full_Type := Base_Type (Full_Type);
8613 -- When the base type itself is private, use the full view
8615 if Is_Private_Type (Full_Type) then
8616 Full_Type := Underlying_Type (Full_Type);
8619 if Is_Class_Wide_Type (Full_Type) then
8620 Full_Type := Root_Type (Full_Type);
8623 if not Is_Tagged_Type (Full_Type) then
8624 Eq_Prim := Find_Eq_Prim (Collect_Primitive_Operations (Typ));
8626 -- If this is an untagged private type completed with a derivation of
8627 -- an untagged private type whose full view is a tagged type, we use
8628 -- the primitive operations of the private parent type (since it does
8629 -- not have a full view, and also because its equality primitive may
8630 -- have been overridden in its untagged full view). If no equality was
8631 -- defined for it then take its dispatching equality primitive.
8633 elsif Inherits_From_Tagged_Full_View (Typ) then
8634 Eq_Prim := Find_Eq_Prim (Collect_Primitive_Operations (Typ));
8636 if No (Eq_Prim) then
8637 Eq_Prim := Find_Eq_Prim (Primitive_Operations (Full_Type));
8641 Eq_Prim := Find_Eq_Prim (Primitive_Operations (Full_Type));
8645 end Find_Primitive_Eq;
8647 ------------------------
8648 -- Find_Specific_Type --
8649 ------------------------
8651 function Find_Specific_Type (CW : Entity_Id) return Entity_Id is
8652 Typ : Entity_Id := Root_Type (CW);
8655 if Ekind (Typ) = E_Incomplete_Type then
8656 if From_Limited_With (Typ) then
8657 Typ := Non_Limited_View (Typ);
8659 Typ := Full_View (Typ);
8663 if Is_Private_Type (Typ)
8664 and then not Is_Tagged_Type (Typ)
8665 and then Present (Full_View (Typ))
8667 return Full_View (Typ);
8671 end Find_Specific_Type;
8673 -----------------------------
8674 -- Find_Static_Alternative --
8675 -----------------------------
8677 function Find_Static_Alternative (N : Node_Id) return Node_Id is
8678 Expr : constant Node_Id := Expression (N);
8679 Val : constant Uint := Expr_Value (Expr);
8684 Alt := First (Alternatives (N));
8687 if Nkind (Alt) /= N_Pragma then
8688 Choice := First (Discrete_Choices (Alt));
8689 while Present (Choice) loop
8691 -- Others choice, always matches
8693 if Nkind (Choice) = N_Others_Choice then
8696 -- Range, check if value is in the range
8698 elsif Nkind (Choice) = N_Range then
8700 Val >= Expr_Value (Low_Bound (Choice))
8702 Val <= Expr_Value (High_Bound (Choice));
8704 -- Choice is a subtype name. Note that we know it must
8705 -- be a static subtype, since otherwise it would have
8706 -- been diagnosed as illegal.
8708 elsif Is_Entity_Name (Choice)
8709 and then Is_Type (Entity (Choice))
8711 exit Search when Is_In_Range (Expr, Etype (Choice),
8712 Assume_Valid => False);
8714 -- Choice is a subtype indication
8716 elsif Nkind (Choice) = N_Subtype_Indication then
8718 C : constant Node_Id := Constraint (Choice);
8719 R : constant Node_Id := Range_Expression (C);
8723 Val >= Expr_Value (Low_Bound (R))
8725 Val <= Expr_Value (High_Bound (R));
8728 -- Choice is a simple expression
8731 exit Search when Val = Expr_Value (Choice);
8739 pragma Assert (Present (Alt));
8742 -- The above loop *must* terminate by finding a match, since we know the
8743 -- case statement is valid, and the value of the expression is known at
8744 -- compile time. When we fall out of the loop, Alt points to the
8745 -- alternative that we know will be selected at run time.
8748 end Find_Static_Alternative;
8754 function First_Actual (Node : Node_Id) return Node_Id is
8758 if No (Parameter_Associations (Node)) then
8762 N := First (Parameter_Associations (Node));
8764 if Nkind (N) = N_Parameter_Association then
8765 return First_Named_Actual (Node);
8775 function First_Global
8777 Global_Mode : Name_Id;
8778 Refined : Boolean := False) return Node_Id
8780 function First_From_Global_List
8782 Global_Mode : Name_Id := Name_Input) return Entity_Id;
8783 -- Get the first item with suitable mode from List
8785 ----------------------------
8786 -- First_From_Global_List --
8787 ----------------------------
8789 function First_From_Global_List
8791 Global_Mode : Name_Id := Name_Input) return Entity_Id
8796 -- Empty list (no global items)
8798 if Nkind (List) = N_Null then
8801 -- Single global item declaration (only input items)
8803 elsif Nkind_In (List, N_Expanded_Name, N_Identifier) then
8804 if Global_Mode = Name_Input then
8810 -- Simple global list (only input items) or moded global list
8813 elsif Nkind (List) = N_Aggregate then
8814 if Present (Expressions (List)) then
8815 if Global_Mode = Name_Input then
8816 return First (Expressions (List));
8822 Assoc := First (Component_Associations (List));
8823 while Present (Assoc) loop
8825 -- When we find the desired mode in an association, call
8826 -- recursively First_From_Global_List as if the mode was
8827 -- Name_Input, in order to reuse the existing machinery
8828 -- for the other cases.
8830 if Chars (First (Choices (Assoc))) = Global_Mode then
8831 return First_From_Global_List (Expression (Assoc));
8840 -- To accommodate partial decoration of disabled SPARK features,
8841 -- this routine may be called with illegal input. If this is the
8842 -- case, do not raise Program_Error.
8847 end First_From_Global_List;
8851 Global : Node_Id := Empty;
8852 Body_Id : Entity_Id;
8854 -- Start of processing for First_Global
8857 pragma Assert (Nam_In (Global_Mode, Name_In_Out,
8862 -- Retrieve the suitable pragma Global or Refined_Global. In the second
8863 -- case, it can only be located on the body entity.
8866 if Is_Subprogram_Or_Generic_Subprogram (Subp) then
8867 Body_Id := Subprogram_Body_Entity (Subp);
8869 elsif Is_Entry (Subp) or else Is_Task_Type (Subp) then
8870 Body_Id := Corresponding_Body (Parent (Subp));
8872 -- ??? It should be possible to retrieve the Refined_Global on the
8873 -- task body associated to the task object. This is not yet possible.
8875 elsif Is_Single_Task_Object (Subp) then
8882 if Present (Body_Id) then
8883 Global := Get_Pragma (Body_Id, Pragma_Refined_Global);
8886 Global := Get_Pragma (Subp, Pragma_Global);
8889 -- No corresponding global if pragma is not present
8894 -- Otherwise retrieve the corresponding list of items depending on the
8898 return First_From_Global_List
8899 (Expression (Get_Argument (Global, Subp)), Global_Mode);
8907 function Fix_Msg (Id : Entity_Id; Msg : String) return String is
8908 Is_Task : constant Boolean :=
8909 Ekind_In (Id, E_Task_Body, E_Task_Type)
8910 or else Is_Single_Task_Object (Id);
8911 Msg_Last : constant Natural := Msg'Last;
8912 Msg_Index : Natural;
8913 Res : String (Msg'Range) := (others => ' ');
8914 Res_Index : Natural;
8917 -- Copy all characters from the input message Msg to result Res with
8918 -- suitable replacements.
8920 Msg_Index := Msg'First;
8921 Res_Index := Res'First;
8922 while Msg_Index <= Msg_Last loop
8924 -- Replace "subprogram" with a different word
8926 if Msg_Index <= Msg_Last - 10
8927 and then Msg (Msg_Index .. Msg_Index + 9) = "subprogram"
8929 if Ekind_In (Id, E_Entry, E_Entry_Family) then
8930 Res (Res_Index .. Res_Index + 4) := "entry";
8931 Res_Index := Res_Index + 5;
8934 Res (Res_Index .. Res_Index + 8) := "task type";
8935 Res_Index := Res_Index + 9;
8938 Res (Res_Index .. Res_Index + 9) := "subprogram";
8939 Res_Index := Res_Index + 10;
8942 Msg_Index := Msg_Index + 10;
8944 -- Replace "protected" with a different word
8946 elsif Msg_Index <= Msg_Last - 9
8947 and then Msg (Msg_Index .. Msg_Index + 8) = "protected"
8950 Res (Res_Index .. Res_Index + 3) := "task";
8951 Res_Index := Res_Index + 4;
8952 Msg_Index := Msg_Index + 9;
8954 -- Otherwise copy the character
8957 Res (Res_Index) := Msg (Msg_Index);
8958 Msg_Index := Msg_Index + 1;
8959 Res_Index := Res_Index + 1;
8963 return Res (Res'First .. Res_Index - 1);
8966 -------------------------
8967 -- From_Nested_Package --
8968 -------------------------
8970 function From_Nested_Package (T : Entity_Id) return Boolean is
8971 Pack : constant Entity_Id := Scope (T);
8975 Ekind (Pack) = E_Package
8976 and then not Is_Frozen (Pack)
8977 and then not Scope_Within_Or_Same (Current_Scope, Pack)
8978 and then In_Open_Scopes (Scope (Pack));
8979 end From_Nested_Package;
8981 -----------------------
8982 -- Gather_Components --
8983 -----------------------
8985 procedure Gather_Components
8987 Comp_List : Node_Id;
8988 Governed_By : List_Id;
8990 Report_Errors : out Boolean)
8994 Discrete_Choice : Node_Id;
8995 Comp_Item : Node_Id;
8996 Discrim : Entity_Id;
8997 Discrim_Name : Node_Id;
8999 type Discriminant_Value_Status is
9000 (Static_Expr, Static_Subtype, Bad);
9001 subtype Good_Discrim_Value_Status is Discriminant_Value_Status
9002 range Static_Expr .. Static_Subtype; -- range excludes Bad
9004 Discrim_Value : Node_Id;
9005 Discrim_Value_Subtype : Node_Id;
9006 Discrim_Value_Status : Discriminant_Value_Status := Bad;
9008 Report_Errors := False;
9010 if No (Comp_List) or else Null_Present (Comp_List) then
9013 elsif Present (Component_Items (Comp_List)) then
9014 Comp_Item := First (Component_Items (Comp_List));
9020 while Present (Comp_Item) loop
9022 -- Skip the tag of a tagged record, the interface tags, as well
9023 -- as all items that are not user components (anonymous types,
9024 -- rep clauses, Parent field, controller field).
9026 if Nkind (Comp_Item) = N_Component_Declaration then
9028 Comp : constant Entity_Id := Defining_Identifier (Comp_Item);
9030 if not Is_Tag (Comp) and then Chars (Comp) /= Name_uParent then
9031 Append_Elmt (Comp, Into);
9039 if No (Variant_Part (Comp_List)) then
9042 Discrim_Name := Name (Variant_Part (Comp_List));
9043 Variant := First_Non_Pragma (Variants (Variant_Part (Comp_List)));
9046 -- Look for the discriminant that governs this variant part.
9047 -- The discriminant *must* be in the Governed_By List
9049 Assoc := First (Governed_By);
9050 Find_Constraint : loop
9051 Discrim := First (Choices (Assoc));
9052 exit Find_Constraint when
9053 Chars (Discrim_Name) = Chars (Discrim)
9055 (Present (Corresponding_Discriminant (Entity (Discrim)))
9056 and then Chars (Corresponding_Discriminant
9057 (Entity (Discrim))) = Chars (Discrim_Name))
9059 Chars (Original_Record_Component (Entity (Discrim))) =
9060 Chars (Discrim_Name);
9062 if No (Next (Assoc)) then
9063 if not Is_Constrained (Typ) and then Is_Derived_Type (Typ) then
9065 -- If the type is a tagged type with inherited discriminants,
9066 -- use the stored constraint on the parent in order to find
9067 -- the values of discriminants that are otherwise hidden by an
9068 -- explicit constraint. Renamed discriminants are handled in
9071 -- If several parent discriminants are renamed by a single
9072 -- discriminant of the derived type, the call to obtain the
9073 -- Corresponding_Discriminant field only retrieves the last
9074 -- of them. We recover the constraint on the others from the
9075 -- Stored_Constraint as well.
9077 -- An inherited discriminant may have been constrained in a
9078 -- later ancestor (not the immediate parent) so we must examine
9079 -- the stored constraint of all of them to locate the inherited
9085 T : Entity_Id := Typ;
9088 while Is_Derived_Type (T) loop
9089 if Present (Stored_Constraint (T)) then
9090 D := First_Discriminant (Etype (T));
9091 C := First_Elmt (Stored_Constraint (T));
9092 while Present (D) and then Present (C) loop
9093 if Chars (Discrim_Name) = Chars (D) then
9094 if Is_Entity_Name (Node (C))
9095 and then Entity (Node (C)) = Entity (Discrim)
9097 -- D is renamed by Discrim, whose value is
9104 Make_Component_Association (Sloc (Typ),
9106 (New_Occurrence_Of (D, Sloc (Typ))),
9107 Duplicate_Subexpr_No_Checks (Node (C)));
9110 exit Find_Constraint;
9113 Next_Discriminant (D);
9118 -- Discriminant may be inherited from ancestor
9126 if No (Next (Assoc)) then
9128 (" missing value for discriminant&",
9129 First (Governed_By), Discrim_Name);
9131 Report_Errors := True;
9136 end loop Find_Constraint;
9138 Discrim_Value := Expression (Assoc);
9139 if Is_OK_Static_Expression (Discrim_Value) then
9140 Discrim_Value_Status := Static_Expr;
9142 if Ada_Version >= Ada_2020 then
9143 if Original_Node (Discrim_Value) /= Discrim_Value
9144 and then Nkind (Discrim_Value) = N_Type_Conversion
9145 and then Etype (Original_Node (Discrim_Value))
9146 = Etype (Expression (Discrim_Value))
9148 Discrim_Value_Subtype := Etype (Original_Node (Discrim_Value));
9149 -- An unhelpful (for this code) type conversion may be
9150 -- introduced in some cases; deal with it.
9152 Discrim_Value_Subtype := Etype (Discrim_Value);
9155 if Is_OK_Static_Subtype (Discrim_Value_Subtype) and then
9156 not Is_Null_Range (Type_Low_Bound (Discrim_Value_Subtype),
9157 Type_High_Bound (Discrim_Value_Subtype))
9159 -- Is_Null_Range test doesn't account for predicates, as in
9160 -- subtype Null_By_Predicate is Natural
9161 -- with Static_Predicate => Null_By_Predicate < 0;
9162 -- so test for that null case separately.
9164 if (not Has_Static_Predicate (Discrim_Value_Subtype))
9165 or else Present (First (Static_Discrete_Predicate
9166 (Discrim_Value_Subtype)))
9168 Discrim_Value_Status := Static_Subtype;
9173 if Discrim_Value_Status = Bad then
9175 -- If the variant part is governed by a discriminant of the type
9176 -- this is an error. If the variant part and the discriminant are
9177 -- inherited from an ancestor this is legal (AI05-220) unless the
9178 -- components are being gathered for an aggregate, in which case
9179 -- the caller must check Report_Errors.
9181 -- In Ada 2020 the above rules are relaxed. A nonstatic governing
9182 -- discriminant is OK as long as it has a static subtype and
9183 -- every value of that subtype (and there must be at least one)
9184 -- selects the same variant.
9186 if Scope (Original_Record_Component
9187 ((Entity (First (Choices (Assoc)))))) = Typ
9189 if Ada_Version >= Ada_2020 then
9191 ("value for discriminant & must be static or " &
9192 "discriminant's nominal subtype must be static " &
9194 Discrim_Value, Discrim);
9197 ("value for discriminant & must be static!",
9198 Discrim_Value, Discrim);
9200 Why_Not_Static (Discrim_Value);
9203 Report_Errors := True;
9208 Search_For_Discriminant_Value : declare
9214 UI_Discrim_Value : Uint;
9217 case Good_Discrim_Value_Status'(Discrim_Value_Status) is
9219 UI_Discrim_Value := Expr_Value (Discrim_Value);
9220 when Static_Subtype =>
9221 -- Arbitrarily pick one value of the subtype and look
9222 -- for the variant associated with that value; we will
9223 -- check later that the same variant is associated with
9224 -- all of the other values of the subtype.
9225 if Has_Static_Predicate (Discrim_Value_Subtype) then
9227 Range_Or_Expr : constant Node_Id :=
9228 First (Static_Discrete_Predicate
9229 (Discrim_Value_Subtype));
9231 if Nkind (Range_Or_Expr) = N_Range then
9233 Expr_Value (Low_Bound (Range_Or_Expr));
9235 UI_Discrim_Value := Expr_Value (Range_Or_Expr);
9240 := Expr_Value (Type_Low_Bound (Discrim_Value_Subtype));
9244 Find_Discrete_Value : while Present (Variant) loop
9246 -- If a choice is a subtype with a static predicate, it must
9247 -- be rewritten as an explicit list of non-predicated choices.
9249 Expand_Static_Predicates_In_Choices (Variant);
9251 Discrete_Choice := First (Discrete_Choices (Variant));
9252 while Present (Discrete_Choice) loop
9253 exit Find_Discrete_Value when
9254 Nkind (Discrete_Choice) = N_Others_Choice;
9256 Get_Index_Bounds (Discrete_Choice, Low, High);
9258 UI_Low := Expr_Value (Low);
9259 UI_High := Expr_Value (High);
9261 exit Find_Discrete_Value when
9262 UI_Low <= UI_Discrim_Value
9264 UI_High >= UI_Discrim_Value;
9266 Next (Discrete_Choice);
9269 Next_Non_Pragma (Variant);
9270 end loop Find_Discrete_Value;
9271 end Search_For_Discriminant_Value;
9273 -- The case statement must include a variant that corresponds to the
9274 -- value of the discriminant, unless the discriminant type has a
9275 -- static predicate. In that case the absence of an others_choice that
9276 -- would cover this value becomes a run-time error (3.8.1 (21.1/2)).
9279 and then not Has_Static_Predicate (Etype (Discrim_Name))
9282 ("value of discriminant & is out of range", Discrim_Value, Discrim);
9283 Report_Errors := True;
9287 -- If we have found the corresponding choice, recursively add its
9288 -- components to the Into list. The nested components are part of
9289 -- the same record type.
9291 if Present (Variant) then
9292 if Discrim_Value_Status = Static_Subtype then
9294 Discrim_Value_Subtype_Intervals
9295 : constant Interval_Lists.Discrete_Interval_List
9296 := Interval_Lists.Type_Intervals (Discrim_Value_Subtype);
9299 : constant Interval_Lists.Discrete_Interval_List
9300 := Interval_Lists.Choice_List_Intervals
9301 (Discrete_Choices => Discrete_Choices (Variant));
9303 if not Interval_Lists.Is_Subset
9304 (Subset => Discrim_Value_Subtype_Intervals,
9305 Of_Set => Variant_Intervals)
9308 ("no single variant is associated with all values of " &
9309 "the subtype of discriminant value &",
9310 Discrim_Value, Discrim);
9311 Report_Errors := True;
9318 (Typ, Component_List (Variant), Governed_By, Into, Report_Errors);
9320 end Gather_Components;
9322 -----------------------
9323 -- Get_Accessibility --
9324 -----------------------
9326 function Get_Accessibility (E : Entity_Id) return Node_Id is
9328 -- When minimum accessibility is set for E then we utilize it - except
9329 -- in a few edge cases like the expansion of select statements where
9330 -- generated subprogram may attempt to unnecessarily use a minimum
9331 -- accessibility object declared outside of scope.
9333 -- To avoid these situations where expansion may get complex we verify
9334 -- that the minimum accessibility object is within scope.
9336 if Ekind (E) in Formal_Kind
9337 and then Present (Minimum_Accessibility (E))
9338 and then In_Open_Scopes (Scope (Minimum_Accessibility (E)))
9340 return Minimum_Accessibility (E);
9343 return Extra_Accessibility (E);
9344 end Get_Accessibility;
9346 ------------------------
9347 -- Get_Actual_Subtype --
9348 ------------------------
9350 function Get_Actual_Subtype (N : Node_Id) return Entity_Id is
9351 Typ : constant Entity_Id := Etype (N);
9352 Utyp : Entity_Id := Underlying_Type (Typ);
9361 -- If what we have is an identifier that references a subprogram
9362 -- formal, or a variable or constant object, then we get the actual
9363 -- subtype from the referenced entity if one has been built.
9365 if Nkind (N) = N_Identifier
9367 (Is_Formal (Entity (N))
9368 or else Ekind (Entity (N)) = E_Constant
9369 or else Ekind (Entity (N)) = E_Variable)
9370 and then Present (Actual_Subtype (Entity (N)))
9372 return Actual_Subtype (Entity (N));
9374 -- Actual subtype of unchecked union is always itself. We never need
9375 -- the "real" actual subtype. If we did, we couldn't get it anyway
9376 -- because the discriminant is not available. The restrictions on
9377 -- Unchecked_Union are designed to make sure that this is OK.
9379 elsif Is_Unchecked_Union (Base_Type (Utyp)) then
9382 -- Here for the unconstrained case, we must find actual subtype
9383 -- No actual subtype is available, so we must build it on the fly.
9385 -- Checking the type, not the underlying type, for constrainedness
9386 -- seems to be necessary. Maybe all the tests should be on the type???
9388 elsif (not Is_Constrained (Typ))
9389 and then (Is_Array_Type (Utyp)
9390 or else (Is_Record_Type (Utyp)
9391 and then Has_Discriminants (Utyp)))
9392 and then not Has_Unknown_Discriminants (Utyp)
9393 and then not (Ekind (Utyp) = E_String_Literal_Subtype)
9395 -- Nothing to do if in spec expression (why not???)
9397 if In_Spec_Expression then
9400 elsif Is_Private_Type (Typ) and then not Has_Discriminants (Typ) then
9402 -- If the type has no discriminants, there is no subtype to
9403 -- build, even if the underlying type is discriminated.
9407 -- Else build the actual subtype
9410 Decl := Build_Actual_Subtype (Typ, N);
9412 -- The call may yield a declaration, or just return the entity
9418 Atyp := Defining_Identifier (Decl);
9420 -- If Build_Actual_Subtype generated a new declaration then use it
9424 -- The actual subtype is an Itype, so analyze the declaration,
9425 -- but do not attach it to the tree, to get the type defined.
9427 Set_Parent (Decl, N);
9428 Set_Is_Itype (Atyp);
9429 Analyze (Decl, Suppress => All_Checks);
9430 Set_Associated_Node_For_Itype (Atyp, N);
9431 Set_Has_Delayed_Freeze (Atyp, False);
9433 -- We need to freeze the actual subtype immediately. This is
9434 -- needed, because otherwise this Itype will not get frozen
9435 -- at all, and it is always safe to freeze on creation because
9436 -- any associated types must be frozen at this point.
9438 Freeze_Itype (Atyp, N);
9441 -- Otherwise we did not build a declaration, so return original
9448 -- For all remaining cases, the actual subtype is the same as
9449 -- the nominal type.
9454 end Get_Actual_Subtype;
9456 -------------------------------------
9457 -- Get_Actual_Subtype_If_Available --
9458 -------------------------------------
9460 function Get_Actual_Subtype_If_Available (N : Node_Id) return Entity_Id is
9461 Typ : constant Entity_Id := Etype (N);
9464 -- If what we have is an identifier that references a subprogram
9465 -- formal, or a variable or constant object, then we get the actual
9466 -- subtype from the referenced entity if one has been built.
9468 if Nkind (N) = N_Identifier
9470 (Is_Formal (Entity (N))
9471 or else Ekind (Entity (N)) = E_Constant
9472 or else Ekind (Entity (N)) = E_Variable)
9473 and then Present (Actual_Subtype (Entity (N)))
9475 return Actual_Subtype (Entity (N));
9477 -- Otherwise the Etype of N is returned unchanged
9482 end Get_Actual_Subtype_If_Available;
9484 ------------------------
9485 -- Get_Body_From_Stub --
9486 ------------------------
9488 function Get_Body_From_Stub (N : Node_Id) return Node_Id is
9490 return Proper_Body (Unit (Library_Unit (N)));
9491 end Get_Body_From_Stub;
9493 ---------------------
9494 -- Get_Cursor_Type --
9495 ---------------------
9497 function Get_Cursor_Type
9499 Typ : Entity_Id) return Entity_Id
9503 First_Op : Entity_Id;
9507 -- If error already detected, return
9509 if Error_Posted (Aspect) then
9513 -- The cursor type for an Iterable aspect is the return type of a
9514 -- non-overloaded First primitive operation. Locate association for
9517 Assoc := First (Component_Associations (Expression (Aspect)));
9519 while Present (Assoc) loop
9520 if Chars (First (Choices (Assoc))) = Name_First then
9521 First_Op := Expression (Assoc);
9528 if First_Op = Any_Id then
9529 Error_Msg_N ("aspect Iterable must specify First operation", Aspect);
9532 elsif not Analyzed (First_Op) then
9538 -- Locate function with desired name and profile in scope of type
9539 -- In the rare case where the type is an integer type, a base type
9540 -- is created for it, check that the base type of the first formal
9541 -- of First matches the base type of the domain.
9543 Func := First_Entity (Scope (Typ));
9544 while Present (Func) loop
9545 if Chars (Func) = Chars (First_Op)
9546 and then Ekind (Func) = E_Function
9547 and then Present (First_Formal (Func))
9548 and then Base_Type (Etype (First_Formal (Func))) = Base_Type (Typ)
9549 and then No (Next_Formal (First_Formal (Func)))
9551 if Cursor /= Any_Type then
9553 ("Operation First for iterable type must be unique", Aspect);
9556 Cursor := Etype (Func);
9563 -- If not found, no way to resolve remaining primitives
9565 if Cursor = Any_Type then
9567 ("primitive operation for Iterable type must appear in the same "
9568 & "list of declarations as the type", Aspect);
9572 end Get_Cursor_Type;
9574 function Get_Cursor_Type (Typ : Entity_Id) return Entity_Id is
9576 return Etype (Get_Iterable_Type_Primitive (Typ, Name_First));
9577 end Get_Cursor_Type;
9579 -------------------------------
9580 -- Get_Default_External_Name --
9581 -------------------------------
9583 function Get_Default_External_Name (E : Node_Or_Entity_Id) return Node_Id is
9585 Get_Decoded_Name_String (Chars (E));
9587 if Opt.External_Name_Imp_Casing = Uppercase then
9588 Set_Casing (All_Upper_Case);
9590 Set_Casing (All_Lower_Case);
9594 Make_String_Literal (Sloc (E),
9595 Strval => String_From_Name_Buffer);
9596 end Get_Default_External_Name;
9598 --------------------------
9599 -- Get_Enclosing_Object --
9600 --------------------------
9602 function Get_Enclosing_Object (N : Node_Id) return Entity_Id is
9604 if Is_Entity_Name (N) then
9608 when N_Indexed_Component
9609 | N_Selected_Component
9612 -- If not generating code, a dereference may be left implicit.
9613 -- In thoses cases, return Empty.
9615 if Is_Access_Type (Etype (Prefix (N))) then
9618 return Get_Enclosing_Object (Prefix (N));
9621 when N_Type_Conversion =>
9622 return Get_Enclosing_Object (Expression (N));
9628 end Get_Enclosing_Object;
9630 ---------------------------
9631 -- Get_Enum_Lit_From_Pos --
9632 ---------------------------
9634 function Get_Enum_Lit_From_Pos
9637 Loc : Source_Ptr) return Node_Id
9639 Btyp : Entity_Id := Base_Type (T);
9644 -- In the case where the literal is of type Character, Wide_Character
9645 -- or Wide_Wide_Character or of a type derived from them, there needs
9646 -- to be some special handling since there is no explicit chain of
9647 -- literals to search. Instead, an N_Character_Literal node is created
9648 -- with the appropriate Char_Code and Chars fields.
9650 if Is_Standard_Character_Type (T) then
9651 Set_Character_Literal_Name (UI_To_CC (Pos));
9654 Make_Character_Literal (Loc,
9656 Char_Literal_Value => Pos);
9658 -- For all other cases, we have a complete table of literals, and
9659 -- we simply iterate through the chain of literal until the one
9660 -- with the desired position value is found.
9663 if Is_Private_Type (Btyp) and then Present (Full_View (Btyp)) then
9664 Btyp := Full_View (Btyp);
9667 Lit := First_Literal (Btyp);
9669 -- Position in the enumeration type starts at 0
9671 if UI_To_Int (Pos) < 0 then
9672 raise Constraint_Error;
9675 for J in 1 .. UI_To_Int (Pos) loop
9678 -- If Lit is Empty, Pos is not in range, so raise Constraint_Error
9679 -- inside the loop to avoid calling Next_Literal on Empty.
9682 raise Constraint_Error;
9686 -- Create a new node from Lit, with source location provided by Loc
9687 -- if not equal to No_Location, or by copying the source location of
9692 if LLoc = No_Location then
9696 return New_Occurrence_Of (Lit, LLoc);
9698 end Get_Enum_Lit_From_Pos;
9700 ------------------------
9701 -- Get_Generic_Entity --
9702 ------------------------
9704 function Get_Generic_Entity (N : Node_Id) return Entity_Id is
9705 Ent : constant Entity_Id := Entity (Name (N));
9707 if Present (Renamed_Object (Ent)) then
9708 return Renamed_Object (Ent);
9712 end Get_Generic_Entity;
9714 -------------------------------------
9715 -- Get_Incomplete_View_Of_Ancestor --
9716 -------------------------------------
9718 function Get_Incomplete_View_Of_Ancestor (E : Entity_Id) return Entity_Id is
9719 Cur_Unit : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
9720 Par_Scope : Entity_Id;
9721 Par_Type : Entity_Id;
9724 -- The incomplete view of an ancestor is only relevant for private
9725 -- derived types in child units.
9727 if not Is_Derived_Type (E)
9728 or else not Is_Child_Unit (Cur_Unit)
9733 Par_Scope := Scope (Cur_Unit);
9734 if No (Par_Scope) then
9738 Par_Type := Etype (Base_Type (E));
9740 -- Traverse list of ancestor types until we find one declared in
9741 -- a parent or grandparent unit (two levels seem sufficient).
9743 while Present (Par_Type) loop
9744 if Scope (Par_Type) = Par_Scope
9745 or else Scope (Par_Type) = Scope (Par_Scope)
9749 elsif not Is_Derived_Type (Par_Type) then
9753 Par_Type := Etype (Base_Type (Par_Type));
9757 -- If none found, there is no relevant ancestor type.
9761 end Get_Incomplete_View_Of_Ancestor;
9763 ----------------------
9764 -- Get_Index_Bounds --
9765 ----------------------
9767 procedure Get_Index_Bounds
9771 Use_Full_View : Boolean := False)
9773 function Scalar_Range_Of_Type (Typ : Entity_Id) return Node_Id;
9774 -- Obtain the scalar range of type Typ. If flag Use_Full_View is set and
9775 -- Typ qualifies, the scalar range is obtained from the full view of the
9778 --------------------------
9779 -- Scalar_Range_Of_Type --
9780 --------------------------
9782 function Scalar_Range_Of_Type (Typ : Entity_Id) return Node_Id is
9783 T : Entity_Id := Typ;
9786 if Use_Full_View and then Present (Full_View (T)) then
9790 return Scalar_Range (T);
9791 end Scalar_Range_Of_Type;
9795 Kind : constant Node_Kind := Nkind (N);
9798 -- Start of processing for Get_Index_Bounds
9801 if Kind = N_Range then
9803 H := High_Bound (N);
9805 elsif Kind = N_Subtype_Indication then
9806 Rng := Range_Expression (Constraint (N));
9814 L := Low_Bound (Range_Expression (Constraint (N)));
9815 H := High_Bound (Range_Expression (Constraint (N)));
9818 elsif Is_Entity_Name (N) and then Is_Type (Entity (N)) then
9819 Rng := Scalar_Range_Of_Type (Entity (N));
9821 if Error_Posted (Rng) then
9825 elsif Nkind (Rng) = N_Subtype_Indication then
9826 Get_Index_Bounds (Rng, L, H);
9829 L := Low_Bound (Rng);
9830 H := High_Bound (Rng);
9834 -- N is an expression, indicating a range with one value
9839 end Get_Index_Bounds;
9841 -----------------------------
9842 -- Get_Interfacing_Aspects --
9843 -----------------------------
9845 procedure Get_Interfacing_Aspects
9846 (Iface_Asp : Node_Id;
9847 Conv_Asp : out Node_Id;
9848 EN_Asp : out Node_Id;
9849 Expo_Asp : out Node_Id;
9850 Imp_Asp : out Node_Id;
9851 LN_Asp : out Node_Id;
9852 Do_Checks : Boolean := False)
9854 procedure Save_Or_Duplication_Error
9856 To : in out Node_Id);
9857 -- Save the value of aspect Asp in node To. If To already has a value,
9858 -- then this is considered a duplicate use of aspect. Emit an error if
9859 -- flag Do_Checks is set.
9861 -------------------------------
9862 -- Save_Or_Duplication_Error --
9863 -------------------------------
9865 procedure Save_Or_Duplication_Error
9867 To : in out Node_Id)
9870 -- Detect an extra aspect and issue an error
9872 if Present (To) then
9874 Error_Msg_Name_1 := Chars (Identifier (Asp));
9875 Error_Msg_Sloc := Sloc (To);
9876 Error_Msg_N ("aspect % previously given #", Asp);
9879 -- Otherwise capture the aspect
9884 end Save_Or_Duplication_Error;
9891 -- The following variables capture each individual aspect
9893 Conv : Node_Id := Empty;
9894 EN : Node_Id := Empty;
9895 Expo : Node_Id := Empty;
9896 Imp : Node_Id := Empty;
9897 LN : Node_Id := Empty;
9899 -- Start of processing for Get_Interfacing_Aspects
9902 -- The input interfacing aspect should reside in an aspect specification
9905 pragma Assert (Is_List_Member (Iface_Asp));
9907 -- Examine the aspect specifications of the related entity. Find and
9908 -- capture all interfacing aspects. Detect duplicates and emit errors
9911 Asp := First (List_Containing (Iface_Asp));
9912 while Present (Asp) loop
9913 Asp_Id := Get_Aspect_Id (Asp);
9915 if Asp_Id = Aspect_Convention then
9916 Save_Or_Duplication_Error (Asp, Conv);
9918 elsif Asp_Id = Aspect_External_Name then
9919 Save_Or_Duplication_Error (Asp, EN);
9921 elsif Asp_Id = Aspect_Export then
9922 Save_Or_Duplication_Error (Asp, Expo);
9924 elsif Asp_Id = Aspect_Import then
9925 Save_Or_Duplication_Error (Asp, Imp);
9927 elsif Asp_Id = Aspect_Link_Name then
9928 Save_Or_Duplication_Error (Asp, LN);
9939 end Get_Interfacing_Aspects;
9941 ---------------------------------
9942 -- Get_Iterable_Type_Primitive --
9943 ---------------------------------
9945 function Get_Iterable_Type_Primitive
9947 Nam : Name_Id) return Entity_Id
9949 Funcs : constant Node_Id := Find_Value_Of_Aspect (Typ, Aspect_Iterable);
9957 Assoc := First (Component_Associations (Funcs));
9958 while Present (Assoc) loop
9959 if Chars (First (Choices (Assoc))) = Nam then
9960 return Entity (Expression (Assoc));
9963 Assoc := Next (Assoc);
9968 end Get_Iterable_Type_Primitive;
9970 ----------------------------------
9971 -- Get_Library_Unit_Name_String --
9972 ----------------------------------
9974 procedure Get_Library_Unit_Name_String (Decl_Node : Node_Id) is
9975 Unit_Name_Id : constant Unit_Name_Type := Get_Unit_Name (Decl_Node);
9978 Get_Unit_Name_String (Unit_Name_Id);
9980 -- Remove seven last character (" (spec)" or " (body)")
9982 Name_Len := Name_Len - 7;
9983 pragma Assert (Name_Buffer (Name_Len + 1) = ' ');
9984 end Get_Library_Unit_Name_String;
9986 --------------------------
9987 -- Get_Max_Queue_Length --
9988 --------------------------
9990 function Get_Max_Queue_Length (Id : Entity_Id) return Uint is
9991 pragma Assert (Is_Entry (Id));
9992 Prag : constant Entity_Id := Get_Pragma (Id, Pragma_Max_Queue_Length);
9996 -- A value of 0 or -1 represents no maximum specified, and entries and
9997 -- entry families with no Max_Queue_Length aspect or pragma default to
10000 if not Present (Prag) then
10005 (Expression (First (Pragma_Argument_Associations (Prag))));
10007 -- Since -1 and 0 are equivalent, return 0 for instances of -1 for
10015 end Get_Max_Queue_Length;
10017 ------------------------
10018 -- Get_Name_Entity_Id --
10019 ------------------------
10021 function Get_Name_Entity_Id (Id : Name_Id) return Entity_Id is
10023 return Entity_Id (Get_Name_Table_Int (Id));
10024 end Get_Name_Entity_Id;
10026 ------------------------------
10027 -- Get_Name_From_CTC_Pragma --
10028 ------------------------------
10030 function Get_Name_From_CTC_Pragma (N : Node_Id) return String_Id is
10031 Arg : constant Node_Id :=
10032 Get_Pragma_Arg (First (Pragma_Argument_Associations (N)));
10034 return Strval (Expr_Value_S (Arg));
10035 end Get_Name_From_CTC_Pragma;
10037 -----------------------
10038 -- Get_Parent_Entity --
10039 -----------------------
10041 function Get_Parent_Entity (Unit : Node_Id) return Entity_Id is
10043 if Nkind (Unit) = N_Package_Body
10044 and then Nkind (Original_Node (Unit)) = N_Package_Instantiation
10046 return Defining_Entity
10047 (Specification (Instance_Spec (Original_Node (Unit))));
10048 elsif Nkind (Unit) = N_Package_Instantiation then
10049 return Defining_Entity (Specification (Instance_Spec (Unit)));
10051 return Defining_Entity (Unit);
10053 end Get_Parent_Entity;
10055 -------------------
10056 -- Get_Pragma_Id --
10057 -------------------
10059 function Get_Pragma_Id (N : Node_Id) return Pragma_Id is
10061 return Get_Pragma_Id (Pragma_Name_Unmapped (N));
10064 ------------------------
10065 -- Get_Qualified_Name --
10066 ------------------------
10068 function Get_Qualified_Name
10070 Suffix : Entity_Id := Empty) return Name_Id
10072 Suffix_Nam : Name_Id := No_Name;
10075 if Present (Suffix) then
10076 Suffix_Nam := Chars (Suffix);
10079 return Get_Qualified_Name (Chars (Id), Suffix_Nam, Scope (Id));
10080 end Get_Qualified_Name;
10082 function Get_Qualified_Name
10084 Suffix : Name_Id := No_Name;
10085 Scop : Entity_Id := Current_Scope) return Name_Id
10087 procedure Add_Scope (S : Entity_Id);
10088 -- Add the fully qualified form of scope S to the name buffer. The
10096 procedure Add_Scope (S : Entity_Id) is
10101 elsif S = Standard_Standard then
10105 Add_Scope (Scope (S));
10106 Get_Name_String_And_Append (Chars (S));
10107 Add_Str_To_Name_Buffer ("__");
10111 -- Start of processing for Get_Qualified_Name
10117 -- Append the base name after all scopes have been chained
10119 Get_Name_String_And_Append (Nam);
10121 -- Append the suffix (if present)
10123 if Suffix /= No_Name then
10124 Add_Str_To_Name_Buffer ("__");
10125 Get_Name_String_And_Append (Suffix);
10129 end Get_Qualified_Name;
10131 -----------------------
10132 -- Get_Reason_String --
10133 -----------------------
10135 procedure Get_Reason_String (N : Node_Id) is
10137 if Nkind (N) = N_String_Literal then
10138 Store_String_Chars (Strval (N));
10140 elsif Nkind (N) = N_Op_Concat then
10141 Get_Reason_String (Left_Opnd (N));
10142 Get_Reason_String (Right_Opnd (N));
10144 -- If not of required form, error
10148 ("Reason for pragma Warnings has wrong form", N);
10150 ("\must be string literal or concatenation of string literals", N);
10153 end Get_Reason_String;
10155 --------------------------------
10156 -- Get_Reference_Discriminant --
10157 --------------------------------
10159 function Get_Reference_Discriminant (Typ : Entity_Id) return Entity_Id is
10163 D := First_Discriminant (Typ);
10164 while Present (D) loop
10165 if Has_Implicit_Dereference (D) then
10168 Next_Discriminant (D);
10172 end Get_Reference_Discriminant;
10174 ---------------------------
10175 -- Get_Referenced_Object --
10176 ---------------------------
10178 function Get_Referenced_Object (N : Node_Id) return Node_Id is
10183 while Is_Entity_Name (R)
10184 and then Is_Object (Entity (R))
10185 and then Present (Renamed_Object (Entity (R)))
10187 R := Renamed_Object (Entity (R));
10191 end Get_Referenced_Object;
10193 ------------------------
10194 -- Get_Renamed_Entity --
10195 ------------------------
10197 function Get_Renamed_Entity (E : Entity_Id) return Entity_Id is
10202 while Present (Renamed_Entity (R)) loop
10203 R := Renamed_Entity (R);
10207 end Get_Renamed_Entity;
10209 -----------------------
10210 -- Get_Return_Object --
10211 -----------------------
10213 function Get_Return_Object (N : Node_Id) return Entity_Id is
10217 Decl := First (Return_Object_Declarations (N));
10218 while Present (Decl) loop
10219 exit when Nkind (Decl) = N_Object_Declaration
10220 and then Is_Return_Object (Defining_Identifier (Decl));
10224 pragma Assert (Present (Decl));
10225 return Defining_Identifier (Decl);
10226 end Get_Return_Object;
10228 ---------------------------
10229 -- Get_Subprogram_Entity --
10230 ---------------------------
10232 function Get_Subprogram_Entity (Nod : Node_Id) return Entity_Id is
10234 Subp_Id : Entity_Id;
10237 if Nkind (Nod) = N_Accept_Statement then
10238 Subp := Entry_Direct_Name (Nod);
10240 elsif Nkind (Nod) = N_Slice then
10241 Subp := Prefix (Nod);
10244 Subp := Name (Nod);
10247 -- Strip the subprogram call
10250 if Nkind_In (Subp, N_Explicit_Dereference,
10251 N_Indexed_Component,
10252 N_Selected_Component)
10254 Subp := Prefix (Subp);
10256 elsif Nkind_In (Subp, N_Type_Conversion,
10257 N_Unchecked_Type_Conversion)
10259 Subp := Expression (Subp);
10266 -- Extract the entity of the subprogram call
10268 if Is_Entity_Name (Subp) then
10269 Subp_Id := Entity (Subp);
10271 if Ekind (Subp_Id) = E_Access_Subprogram_Type then
10272 Subp_Id := Directly_Designated_Type (Subp_Id);
10275 if Is_Subprogram (Subp_Id) then
10281 -- The search did not find a construct that denotes a subprogram
10286 end Get_Subprogram_Entity;
10288 -----------------------------
10289 -- Get_Task_Body_Procedure --
10290 -----------------------------
10292 function Get_Task_Body_Procedure (E : Entity_Id) return Entity_Id is
10294 -- Note: A task type may be the completion of a private type with
10295 -- discriminants. When performing elaboration checks on a task
10296 -- declaration, the current view of the type may be the private one,
10297 -- and the procedure that holds the body of the task is held in its
10298 -- underlying type.
10300 -- This is an odd function, why not have Task_Body_Procedure do
10301 -- the following digging???
10303 return Task_Body_Procedure (Underlying_Type (Root_Type (E)));
10304 end Get_Task_Body_Procedure;
10306 -------------------------
10307 -- Get_User_Defined_Eq --
10308 -------------------------
10310 function Get_User_Defined_Eq (E : Entity_Id) return Entity_Id is
10315 Prim := First_Elmt (Collect_Primitive_Operations (E));
10316 while Present (Prim) loop
10319 if Chars (Op) = Name_Op_Eq
10320 and then Etype (Op) = Standard_Boolean
10321 and then Etype (First_Formal (Op)) = E
10322 and then Etype (Next_Formal (First_Formal (Op))) = E
10331 end Get_User_Defined_Eq;
10337 procedure Get_Views
10339 Priv_Typ : out Entity_Id;
10340 Full_Typ : out Entity_Id;
10341 Full_Base : out Entity_Id;
10342 CRec_Typ : out Entity_Id)
10344 IP_View : Entity_Id;
10347 -- Assume that none of the views can be recovered
10351 Full_Base := Empty;
10354 -- The input type is the corresponding record type of a protected or a
10357 if Ekind (Typ) = E_Record_Type
10358 and then Is_Concurrent_Record_Type (Typ)
10361 Full_Typ := Corresponding_Concurrent_Type (CRec_Typ);
10362 Full_Base := Base_Type (Full_Typ);
10363 Priv_Typ := Incomplete_Or_Partial_View (Full_Typ);
10365 -- Otherwise the input type denotes an arbitrary type
10368 IP_View := Incomplete_Or_Partial_View (Typ);
10370 -- The input type denotes the full view of a private type
10372 if Present (IP_View) then
10373 Priv_Typ := IP_View;
10376 -- The input type is a private type
10378 elsif Is_Private_Type (Typ) then
10380 Full_Typ := Full_View (Priv_Typ);
10382 -- Otherwise the input type does not have any views
10388 if Present (Full_Typ) then
10389 Full_Base := Base_Type (Full_Typ);
10391 if Ekind_In (Full_Typ, E_Protected_Type, E_Task_Type) then
10392 CRec_Typ := Corresponding_Record_Type (Full_Typ);
10398 -----------------------
10399 -- Has_Access_Values --
10400 -----------------------
10402 function Has_Access_Values (T : Entity_Id) return Boolean is
10403 Typ : constant Entity_Id := Underlying_Type (T);
10406 -- Case of a private type which is not completed yet. This can only
10407 -- happen in the case of a generic format type appearing directly, or
10408 -- as a component of the type to which this function is being applied
10409 -- at the top level. Return False in this case, since we certainly do
10410 -- not know that the type contains access types.
10415 elsif Is_Access_Type (Typ) then
10418 elsif Is_Array_Type (Typ) then
10419 return Has_Access_Values (Component_Type (Typ));
10421 elsif Is_Record_Type (Typ) then
10426 -- Loop to Check components
10428 Comp := First_Component_Or_Discriminant (Typ);
10429 while Present (Comp) loop
10431 -- Check for access component, tag field does not count, even
10432 -- though it is implemented internally using an access type.
10434 if Has_Access_Values (Etype (Comp))
10435 and then Chars (Comp) /= Name_uTag
10440 Next_Component_Or_Discriminant (Comp);
10449 end Has_Access_Values;
10451 ------------------------------
10452 -- Has_Compatible_Alignment --
10453 ------------------------------
10455 function Has_Compatible_Alignment
10458 Layout_Done : Boolean) return Alignment_Result
10460 function Has_Compatible_Alignment_Internal
10463 Layout_Done : Boolean;
10464 Default : Alignment_Result) return Alignment_Result;
10465 -- This is the internal recursive function that actually does the work.
10466 -- There is one additional parameter, which says what the result should
10467 -- be if no alignment information is found, and there is no definite
10468 -- indication of compatible alignments. At the outer level, this is set
10469 -- to Unknown, but for internal recursive calls in the case where types
10470 -- are known to be correct, it is set to Known_Compatible.
10472 ---------------------------------------
10473 -- Has_Compatible_Alignment_Internal --
10474 ---------------------------------------
10476 function Has_Compatible_Alignment_Internal
10479 Layout_Done : Boolean;
10480 Default : Alignment_Result) return Alignment_Result
10482 Result : Alignment_Result := Known_Compatible;
10483 -- Holds the current status of the result. Note that once a value of
10484 -- Known_Incompatible is set, it is sticky and does not get changed
10485 -- to Unknown (the value in Result only gets worse as we go along,
10488 Offs : Uint := No_Uint;
10489 -- Set to a factor of the offset from the base object when Expr is a
10490 -- selected or indexed component, based on Component_Bit_Offset and
10491 -- Component_Size respectively. A negative value is used to represent
10492 -- a value which is not known at compile time.
10494 procedure Check_Prefix;
10495 -- Checks the prefix recursively in the case where the expression
10496 -- is an indexed or selected component.
10498 procedure Set_Result (R : Alignment_Result);
10499 -- If R represents a worse outcome (unknown instead of known
10500 -- compatible, or known incompatible), then set Result to R.
10506 procedure Check_Prefix is
10508 -- The subtlety here is that in doing a recursive call to check
10509 -- the prefix, we have to decide what to do in the case where we
10510 -- don't find any specific indication of an alignment problem.
10512 -- At the outer level, we normally set Unknown as the result in
10513 -- this case, since we can only set Known_Compatible if we really
10514 -- know that the alignment value is OK, but for the recursive
10515 -- call, in the case where the types match, and we have not
10516 -- specified a peculiar alignment for the object, we are only
10517 -- concerned about suspicious rep clauses, the default case does
10518 -- not affect us, since the compiler will, in the absence of such
10519 -- rep clauses, ensure that the alignment is correct.
10521 if Default = Known_Compatible
10523 (Etype (Obj) = Etype (Expr)
10524 and then (Unknown_Alignment (Obj)
10526 Alignment (Obj) = Alignment (Etype (Obj))))
10529 (Has_Compatible_Alignment_Internal
10530 (Obj, Prefix (Expr), Layout_Done, Known_Compatible));
10532 -- In all other cases, we need a full check on the prefix
10536 (Has_Compatible_Alignment_Internal
10537 (Obj, Prefix (Expr), Layout_Done, Unknown));
10545 procedure Set_Result (R : Alignment_Result) is
10552 -- Start of processing for Has_Compatible_Alignment_Internal
10555 -- If Expr is a selected component, we must make sure there is no
10556 -- potentially troublesome component clause and that the record is
10557 -- not packed if the layout is not done.
10559 if Nkind (Expr) = N_Selected_Component then
10561 -- Packing generates unknown alignment if layout is not done
10563 if Is_Packed (Etype (Prefix (Expr))) and then not Layout_Done then
10564 Set_Result (Unknown);
10567 -- Check prefix and component offset
10570 Offs := Component_Bit_Offset (Entity (Selector_Name (Expr)));
10572 -- If Expr is an indexed component, we must make sure there is no
10573 -- potentially troublesome Component_Size clause and that the array
10574 -- is not bit-packed if the layout is not done.
10576 elsif Nkind (Expr) = N_Indexed_Component then
10578 Typ : constant Entity_Id := Etype (Prefix (Expr));
10581 -- Packing generates unknown alignment if layout is not done
10583 if Is_Bit_Packed_Array (Typ) and then not Layout_Done then
10584 Set_Result (Unknown);
10587 -- Check prefix and component offset (or at least size)
10590 Offs := Indexed_Component_Bit_Offset (Expr);
10591 if Offs = No_Uint then
10592 Offs := Component_Size (Typ);
10597 -- If we have a null offset, the result is entirely determined by
10598 -- the base object and has already been computed recursively.
10600 if Offs = Uint_0 then
10603 -- Case where we know the alignment of the object
10605 elsif Known_Alignment (Obj) then
10607 ObjA : constant Uint := Alignment (Obj);
10608 ExpA : Uint := No_Uint;
10609 SizA : Uint := No_Uint;
10612 -- If alignment of Obj is 1, then we are always OK
10615 Set_Result (Known_Compatible);
10617 -- Alignment of Obj is greater than 1, so we need to check
10620 -- If we have an offset, see if it is compatible
10622 if Offs /= No_Uint and Offs > Uint_0 then
10623 if Offs mod (System_Storage_Unit * ObjA) /= 0 then
10624 Set_Result (Known_Incompatible);
10627 -- See if Expr is an object with known alignment
10629 elsif Is_Entity_Name (Expr)
10630 and then Known_Alignment (Entity (Expr))
10632 ExpA := Alignment (Entity (Expr));
10634 -- Otherwise, we can use the alignment of the type of
10635 -- Expr given that we already checked for
10636 -- discombobulating rep clauses for the cases of indexed
10637 -- and selected components above.
10639 elsif Known_Alignment (Etype (Expr)) then
10640 ExpA := Alignment (Etype (Expr));
10642 -- Otherwise the alignment is unknown
10645 Set_Result (Default);
10648 -- If we got an alignment, see if it is acceptable
10650 if ExpA /= No_Uint and then ExpA < ObjA then
10651 Set_Result (Known_Incompatible);
10654 -- If Expr is not a piece of a larger object, see if size
10655 -- is given. If so, check that it is not too small for the
10656 -- required alignment.
10658 if Offs /= No_Uint then
10661 -- See if Expr is an object with known size
10663 elsif Is_Entity_Name (Expr)
10664 and then Known_Static_Esize (Entity (Expr))
10666 SizA := Esize (Entity (Expr));
10668 -- Otherwise, we check the object size of the Expr type
10670 elsif Known_Static_Esize (Etype (Expr)) then
10671 SizA := Esize (Etype (Expr));
10674 -- If we got a size, see if it is a multiple of the Obj
10675 -- alignment, if not, then the alignment cannot be
10676 -- acceptable, since the size is always a multiple of the
10679 if SizA /= No_Uint then
10680 if SizA mod (ObjA * Ttypes.System_Storage_Unit) /= 0 then
10681 Set_Result (Known_Incompatible);
10687 -- If we do not know required alignment, any non-zero offset is a
10688 -- potential problem (but certainly may be OK, so result is unknown).
10690 elsif Offs /= No_Uint then
10691 Set_Result (Unknown);
10693 -- If we can't find the result by direct comparison of alignment
10694 -- values, then there is still one case that we can determine known
10695 -- result, and that is when we can determine that the types are the
10696 -- same, and no alignments are specified. Then we known that the
10697 -- alignments are compatible, even if we don't know the alignment
10698 -- value in the front end.
10700 elsif Etype (Obj) = Etype (Expr) then
10702 -- Types are the same, but we have to check for possible size
10703 -- and alignments on the Expr object that may make the alignment
10704 -- different, even though the types are the same.
10706 if Is_Entity_Name (Expr) then
10708 -- First check alignment of the Expr object. Any alignment less
10709 -- than Maximum_Alignment is worrisome since this is the case
10710 -- where we do not know the alignment of Obj.
10712 if Known_Alignment (Entity (Expr))
10713 and then UI_To_Int (Alignment (Entity (Expr))) <
10714 Ttypes.Maximum_Alignment
10716 Set_Result (Unknown);
10718 -- Now check size of Expr object. Any size that is not an
10719 -- even multiple of Maximum_Alignment is also worrisome
10720 -- since it may cause the alignment of the object to be less
10721 -- than the alignment of the type.
10723 elsif Known_Static_Esize (Entity (Expr))
10725 (UI_To_Int (Esize (Entity (Expr))) mod
10726 (Ttypes.Maximum_Alignment * Ttypes.System_Storage_Unit))
10729 Set_Result (Unknown);
10731 -- Otherwise same type is decisive
10734 Set_Result (Known_Compatible);
10738 -- Another case to deal with is when there is an explicit size or
10739 -- alignment clause when the types are not the same. If so, then the
10740 -- result is Unknown. We don't need to do this test if the Default is
10741 -- Unknown, since that result will be set in any case.
10743 elsif Default /= Unknown
10744 and then (Has_Size_Clause (Etype (Expr))
10746 Has_Alignment_Clause (Etype (Expr)))
10748 Set_Result (Unknown);
10750 -- If no indication found, set default
10753 Set_Result (Default);
10756 -- Return worst result found
10759 end Has_Compatible_Alignment_Internal;
10761 -- Start of processing for Has_Compatible_Alignment
10764 -- If Obj has no specified alignment, then set alignment from the type
10765 -- alignment. Perhaps we should always do this, but for sure we should
10766 -- do it when there is an address clause since we can do more if the
10767 -- alignment is known.
10769 if Unknown_Alignment (Obj) then
10770 Set_Alignment (Obj, Alignment (Etype (Obj)));
10773 -- Now do the internal call that does all the work
10776 Has_Compatible_Alignment_Internal (Obj, Expr, Layout_Done, Unknown);
10777 end Has_Compatible_Alignment;
10779 ----------------------
10780 -- Has_Declarations --
10781 ----------------------
10783 function Has_Declarations (N : Node_Id) return Boolean is
10785 return Nkind_In (Nkind (N), N_Accept_Statement,
10787 N_Compilation_Unit_Aux,
10793 N_Package_Specification);
10794 end Has_Declarations;
10796 ---------------------------------
10797 -- Has_Defaulted_Discriminants --
10798 ---------------------------------
10800 function Has_Defaulted_Discriminants (Typ : Entity_Id) return Boolean is
10802 return Has_Discriminants (Typ)
10803 and then Present (First_Discriminant (Typ))
10804 and then Present (Discriminant_Default_Value
10805 (First_Discriminant (Typ)));
10806 end Has_Defaulted_Discriminants;
10808 -------------------
10809 -- Has_Denormals --
10810 -------------------
10812 function Has_Denormals (E : Entity_Id) return Boolean is
10814 return Is_Floating_Point_Type (E) and then Denorm_On_Target;
10817 -------------------------------------------
10818 -- Has_Discriminant_Dependent_Constraint --
10819 -------------------------------------------
10821 function Has_Discriminant_Dependent_Constraint
10822 (Comp : Entity_Id) return Boolean
10824 Comp_Decl : constant Node_Id := Parent (Comp);
10825 Subt_Indic : Node_Id;
10830 -- Discriminants can't depend on discriminants
10832 if Ekind (Comp) = E_Discriminant then
10836 Subt_Indic := Subtype_Indication (Component_Definition (Comp_Decl));
10838 if Nkind (Subt_Indic) = N_Subtype_Indication then
10839 Constr := Constraint (Subt_Indic);
10841 if Nkind (Constr) = N_Index_Or_Discriminant_Constraint then
10842 Assn := First (Constraints (Constr));
10843 while Present (Assn) loop
10844 case Nkind (Assn) is
10847 | N_Subtype_Indication
10849 if Depends_On_Discriminant (Assn) then
10853 when N_Discriminant_Association =>
10854 if Depends_On_Discriminant (Expression (Assn)) then
10869 end Has_Discriminant_Dependent_Constraint;
10871 --------------------------------------
10872 -- Has_Effectively_Volatile_Profile --
10873 --------------------------------------
10875 function Has_Effectively_Volatile_Profile
10876 (Subp_Id : Entity_Id) return Boolean
10878 Formal : Entity_Id;
10881 -- Inspect the formal parameters looking for an effectively volatile
10884 Formal := First_Formal (Subp_Id);
10885 while Present (Formal) loop
10886 if Is_Effectively_Volatile (Etype (Formal)) then
10890 Next_Formal (Formal);
10893 -- Inspect the return type of functions
10895 if Ekind_In (Subp_Id, E_Function, E_Generic_Function)
10896 and then Is_Effectively_Volatile (Etype (Subp_Id))
10902 end Has_Effectively_Volatile_Profile;
10904 --------------------------
10905 -- Has_Enabled_Property --
10906 --------------------------
10908 function Has_Enabled_Property
10909 (Item_Id : Entity_Id;
10910 Property : Name_Id) return Boolean
10912 function Protected_Object_Has_Enabled_Property return Boolean;
10913 -- Determine whether a protected object denoted by Item_Id has the
10914 -- property enabled.
10916 function State_Has_Enabled_Property return Boolean;
10917 -- Determine whether a state denoted by Item_Id has the property enabled
10919 function Variable_Has_Enabled_Property return Boolean;
10920 -- Determine whether a variable denoted by Item_Id has the property
10923 -------------------------------------------
10924 -- Protected_Object_Has_Enabled_Property --
10925 -------------------------------------------
10927 function Protected_Object_Has_Enabled_Property return Boolean is
10928 Constits : constant Elist_Id := Part_Of_Constituents (Item_Id);
10929 Constit_Elmt : Elmt_Id;
10930 Constit_Id : Entity_Id;
10933 -- Protected objects always have the properties Async_Readers and
10934 -- Async_Writers (SPARK RM 7.1.2(16)).
10936 if Property = Name_Async_Readers
10937 or else Property = Name_Async_Writers
10941 -- Protected objects that have Part_Of components also inherit their
10942 -- properties Effective_Reads and Effective_Writes
10943 -- (SPARK RM 7.1.2(16)).
10945 elsif Present (Constits) then
10946 Constit_Elmt := First_Elmt (Constits);
10947 while Present (Constit_Elmt) loop
10948 Constit_Id := Node (Constit_Elmt);
10950 if Has_Enabled_Property (Constit_Id, Property) then
10954 Next_Elmt (Constit_Elmt);
10959 end Protected_Object_Has_Enabled_Property;
10961 --------------------------------
10962 -- State_Has_Enabled_Property --
10963 --------------------------------
10965 function State_Has_Enabled_Property return Boolean is
10966 Decl : constant Node_Id := Parent (Item_Id);
10968 procedure Find_Simple_Properties
10969 (Has_External : out Boolean;
10970 Has_Synchronous : out Boolean);
10971 -- Extract the simple properties associated with declaration Decl
10973 function Is_Enabled_External_Property return Boolean;
10974 -- Determine whether property Property appears within the external
10975 -- property list of declaration Decl, and return its status.
10977 ----------------------------
10978 -- Find_Simple_Properties --
10979 ----------------------------
10981 procedure Find_Simple_Properties
10982 (Has_External : out Boolean;
10983 Has_Synchronous : out Boolean)
10988 -- Assume that none of the properties are available
10990 Has_External := False;
10991 Has_Synchronous := False;
10993 Opt := First (Expressions (Decl));
10994 while Present (Opt) loop
10995 if Nkind (Opt) = N_Identifier then
10996 if Chars (Opt) = Name_External then
10997 Has_External := True;
10999 elsif Chars (Opt) = Name_Synchronous then
11000 Has_Synchronous := True;
11006 end Find_Simple_Properties;
11008 ----------------------------------
11009 -- Is_Enabled_External_Property --
11010 ----------------------------------
11012 function Is_Enabled_External_Property return Boolean is
11016 Prop_Nam : Node_Id;
11020 Opt := First (Component_Associations (Decl));
11021 while Present (Opt) loop
11022 Opt_Nam := First (Choices (Opt));
11024 if Nkind (Opt_Nam) = N_Identifier
11025 and then Chars (Opt_Nam) = Name_External
11027 Props := Expression (Opt);
11029 -- Multiple properties appear as an aggregate
11031 if Nkind (Props) = N_Aggregate then
11033 -- Simple property form
11035 Prop := First (Expressions (Props));
11036 while Present (Prop) loop
11037 if Chars (Prop) = Property then
11044 -- Property with expression form
11046 Prop := First (Component_Associations (Props));
11047 while Present (Prop) loop
11048 Prop_Nam := First (Choices (Prop));
11050 -- The property can be represented in two ways:
11051 -- others => <value>
11052 -- <property> => <value>
11054 if Nkind (Prop_Nam) = N_Others_Choice
11055 or else (Nkind (Prop_Nam) = N_Identifier
11056 and then Chars (Prop_Nam) = Property)
11058 return Is_True (Expr_Value (Expression (Prop)));
11067 return Chars (Props) = Property;
11075 end Is_Enabled_External_Property;
11079 Has_External : Boolean;
11080 Has_Synchronous : Boolean;
11082 -- Start of processing for State_Has_Enabled_Property
11085 -- The declaration of an external abstract state appears as an
11086 -- extension aggregate. If this is not the case, properties can
11089 if Nkind (Decl) /= N_Extension_Aggregate then
11093 Find_Simple_Properties (Has_External, Has_Synchronous);
11095 -- Simple option External enables all properties (SPARK RM 7.1.2(2))
11097 if Has_External then
11100 -- Option External may enable or disable specific properties
11102 elsif Is_Enabled_External_Property then
11105 -- Simple option Synchronous
11107 -- enables disables
11108 -- Async_Readers Effective_Reads
11109 -- Async_Writers Effective_Writes
11111 -- Note that both forms of External have higher precedence than
11112 -- Synchronous (SPARK RM 7.1.4(9)).
11114 elsif Has_Synchronous then
11115 return Nam_In (Property, Name_Async_Readers, Name_Async_Writers);
11119 end State_Has_Enabled_Property;
11121 -----------------------------------
11122 -- Variable_Has_Enabled_Property --
11123 -----------------------------------
11125 function Variable_Has_Enabled_Property return Boolean is
11126 function Is_Enabled (Prag : Node_Id) return Boolean;
11127 -- Determine whether property pragma Prag (if present) denotes an
11128 -- enabled property.
11134 function Is_Enabled (Prag : Node_Id) return Boolean is
11138 if Present (Prag) then
11139 Arg1 := First (Pragma_Argument_Associations (Prag));
11141 -- The pragma has an optional Boolean expression, the related
11142 -- property is enabled only when the expression evaluates to
11145 if Present (Arg1) then
11146 return Is_True (Expr_Value (Get_Pragma_Arg (Arg1)));
11148 -- Otherwise the lack of expression enables the property by
11155 -- The property was never set in the first place
11164 AR : constant Node_Id :=
11165 Get_Pragma (Item_Id, Pragma_Async_Readers);
11166 AW : constant Node_Id :=
11167 Get_Pragma (Item_Id, Pragma_Async_Writers);
11168 ER : constant Node_Id :=
11169 Get_Pragma (Item_Id, Pragma_Effective_Reads);
11170 EW : constant Node_Id :=
11171 Get_Pragma (Item_Id, Pragma_Effective_Writes);
11173 -- Start of processing for Variable_Has_Enabled_Property
11176 -- A non-effectively volatile object can never possess external
11179 if not Is_Effectively_Volatile (Item_Id) then
11182 -- External properties related to variables come in two flavors -
11183 -- explicit and implicit. The explicit case is characterized by the
11184 -- presence of a property pragma with an optional Boolean flag. The
11185 -- property is enabled when the flag evaluates to True or the flag is
11186 -- missing altogether.
11188 elsif Property = Name_Async_Readers and then Is_Enabled (AR) then
11191 elsif Property = Name_Async_Writers and then Is_Enabled (AW) then
11194 elsif Property = Name_Effective_Reads and then Is_Enabled (ER) then
11197 elsif Property = Name_Effective_Writes and then Is_Enabled (EW) then
11200 -- The implicit case lacks all property pragmas
11202 elsif No (AR) and then No (AW) and then No (ER) and then No (EW) then
11203 if Is_Protected_Type (Etype (Item_Id)) then
11204 return Protected_Object_Has_Enabled_Property;
11212 end Variable_Has_Enabled_Property;
11214 -- Start of processing for Has_Enabled_Property
11217 -- Abstract states and variables have a flexible scheme of specifying
11218 -- external properties.
11220 if Ekind (Item_Id) = E_Abstract_State then
11221 return State_Has_Enabled_Property;
11223 elsif Ekind (Item_Id) = E_Variable then
11224 return Variable_Has_Enabled_Property;
11226 -- By default, protected objects only have the properties Async_Readers
11227 -- and Async_Writers. If they have Part_Of components, they also inherit
11228 -- their properties Effective_Reads and Effective_Writes
11229 -- (SPARK RM 7.1.2(16)).
11231 elsif Ekind (Item_Id) = E_Protected_Object then
11232 return Protected_Object_Has_Enabled_Property;
11234 -- Otherwise a property is enabled when the related item is effectively
11238 return Is_Effectively_Volatile (Item_Id);
11240 end Has_Enabled_Property;
11242 -------------------------------------
11243 -- Has_Full_Default_Initialization --
11244 -------------------------------------
11246 function Has_Full_Default_Initialization (Typ : Entity_Id) return Boolean is
11250 -- A type subject to pragma Default_Initial_Condition may be fully
11251 -- default initialized depending on inheritance and the argument of
11252 -- the pragma. Since any type may act as the full view of a private
11253 -- type, this check must be performed prior to the specialized tests
11256 if Has_Fully_Default_Initializing_DIC_Pragma (Typ) then
11260 -- A scalar type is fully default initialized if it is subject to aspect
11263 if Is_Scalar_Type (Typ) then
11264 return Has_Default_Aspect (Typ);
11266 -- An access type is fully default initialized by default
11268 elsif Is_Access_Type (Typ) then
11271 -- An array type is fully default initialized if its element type is
11272 -- scalar and the array type carries aspect Default_Component_Value or
11273 -- the element type is fully default initialized.
11275 elsif Is_Array_Type (Typ) then
11277 Has_Default_Aspect (Typ)
11278 or else Has_Full_Default_Initialization (Component_Type (Typ));
11280 -- A protected type, record type, or type extension is fully default
11281 -- initialized if all its components either carry an initialization
11282 -- expression or have a type that is fully default initialized. The
11283 -- parent type of a type extension must be fully default initialized.
11285 elsif Is_Record_Type (Typ) or else Is_Protected_Type (Typ) then
11287 -- Inspect all entities defined in the scope of the type, looking for
11288 -- uninitialized components.
11290 Comp := First_Entity (Typ);
11291 while Present (Comp) loop
11292 if Ekind (Comp) = E_Component
11293 and then Comes_From_Source (Comp)
11294 and then No (Expression (Parent (Comp)))
11295 and then not Has_Full_Default_Initialization (Etype (Comp))
11300 Next_Entity (Comp);
11303 -- Ensure that the parent type of a type extension is fully default
11306 if Etype (Typ) /= Typ
11307 and then not Has_Full_Default_Initialization (Etype (Typ))
11312 -- If we get here, then all components and parent portion are fully
11313 -- default initialized.
11317 -- A task type is fully default initialized by default
11319 elsif Is_Task_Type (Typ) then
11322 -- Otherwise the type is not fully default initialized
11327 end Has_Full_Default_Initialization;
11329 -----------------------------------------------
11330 -- Has_Fully_Default_Initializing_DIC_Pragma --
11331 -----------------------------------------------
11333 function Has_Fully_Default_Initializing_DIC_Pragma
11334 (Typ : Entity_Id) return Boolean
11340 -- A type that inherits pragma Default_Initial_Condition from a parent
11341 -- type is automatically fully default initialized.
11343 if Has_Inherited_DIC (Typ) then
11346 -- Otherwise the type is fully default initialized only when the pragma
11347 -- appears without an argument, or the argument is non-null.
11349 elsif Has_Own_DIC (Typ) then
11350 Prag := Get_Pragma (Typ, Pragma_Default_Initial_Condition);
11351 pragma Assert (Present (Prag));
11352 Args := Pragma_Argument_Associations (Prag);
11354 -- The pragma appears without an argument in which case it defaults
11360 -- The pragma appears with a non-null expression
11362 elsif Nkind (Get_Pragma_Arg (First (Args))) /= N_Null then
11368 end Has_Fully_Default_Initializing_DIC_Pragma;
11370 --------------------
11371 -- Has_Infinities --
11372 --------------------
11374 function Has_Infinities (E : Entity_Id) return Boolean is
11377 Is_Floating_Point_Type (E)
11378 and then Nkind (Scalar_Range (E)) = N_Range
11379 and then Includes_Infinities (Scalar_Range (E));
11380 end Has_Infinities;
11382 --------------------
11383 -- Has_Interfaces --
11384 --------------------
11386 function Has_Interfaces
11388 Use_Full_View : Boolean := True) return Boolean
11390 Typ : Entity_Id := Base_Type (T);
11393 -- Handle concurrent types
11395 if Is_Concurrent_Type (Typ) then
11396 Typ := Corresponding_Record_Type (Typ);
11399 if not Present (Typ)
11400 or else not Is_Record_Type (Typ)
11401 or else not Is_Tagged_Type (Typ)
11406 -- Handle private types
11408 if Use_Full_View and then Present (Full_View (Typ)) then
11409 Typ := Full_View (Typ);
11412 -- Handle concurrent record types
11414 if Is_Concurrent_Record_Type (Typ)
11415 and then Is_Non_Empty_List (Abstract_Interface_List (Typ))
11421 if Is_Interface (Typ)
11423 (Is_Record_Type (Typ)
11424 and then Present (Interfaces (Typ))
11425 and then not Is_Empty_Elmt_List (Interfaces (Typ)))
11430 exit when Etype (Typ) = Typ
11432 -- Handle private types
11434 or else (Present (Full_View (Etype (Typ)))
11435 and then Full_View (Etype (Typ)) = Typ)
11437 -- Protect frontend against wrong sources with cyclic derivations
11439 or else Etype (Typ) = T;
11441 -- Climb to the ancestor type handling private types
11443 if Present (Full_View (Etype (Typ))) then
11444 Typ := Full_View (Etype (Typ));
11446 Typ := Etype (Typ);
11451 end Has_Interfaces;
11453 --------------------------
11454 -- Has_Max_Queue_Length --
11455 --------------------------
11457 function Has_Max_Queue_Length (Id : Entity_Id) return Boolean is
11460 Ekind (Id) = E_Entry
11461 and then Present (Get_Pragma (Id, Pragma_Max_Queue_Length));
11462 end Has_Max_Queue_Length;
11464 ---------------------------------
11465 -- Has_No_Obvious_Side_Effects --
11466 ---------------------------------
11468 function Has_No_Obvious_Side_Effects (N : Node_Id) return Boolean is
11470 -- For now handle literals, constants, and non-volatile variables and
11471 -- expressions combining these with operators or short circuit forms.
11473 if Nkind (N) in N_Numeric_Or_String_Literal then
11476 elsif Nkind (N) = N_Character_Literal then
11479 elsif Nkind (N) in N_Unary_Op then
11480 return Has_No_Obvious_Side_Effects (Right_Opnd (N));
11482 elsif Nkind (N) in N_Binary_Op or else Nkind (N) in N_Short_Circuit then
11483 return Has_No_Obvious_Side_Effects (Left_Opnd (N))
11485 Has_No_Obvious_Side_Effects (Right_Opnd (N));
11487 elsif Nkind (N) = N_Expression_With_Actions
11488 and then Is_Empty_List (Actions (N))
11490 return Has_No_Obvious_Side_Effects (Expression (N));
11492 elsif Nkind (N) in N_Has_Entity then
11493 return Present (Entity (N))
11494 and then Ekind_In (Entity (N), E_Variable,
11496 E_Enumeration_Literal,
11499 E_In_Out_Parameter)
11500 and then not Is_Volatile (Entity (N));
11505 end Has_No_Obvious_Side_Effects;
11507 -----------------------------
11508 -- Has_Non_Null_Refinement --
11509 -----------------------------
11511 function Has_Non_Null_Refinement (Id : Entity_Id) return Boolean is
11512 Constits : Elist_Id;
11515 pragma Assert (Ekind (Id) = E_Abstract_State);
11516 Constits := Refinement_Constituents (Id);
11518 -- For a refinement to be non-null, the first constituent must be
11519 -- anything other than null.
11523 and then Nkind (Node (First_Elmt (Constits))) /= N_Null;
11524 end Has_Non_Null_Refinement;
11526 -----------------------------
11527 -- Has_Non_Null_Statements --
11528 -----------------------------
11530 function Has_Non_Null_Statements (L : List_Id) return Boolean is
11534 if Is_Non_Empty_List (L) then
11538 if Nkind (Node) /= N_Null_Statement then
11543 exit when Node = Empty;
11548 end Has_Non_Null_Statements;
11550 ----------------------------------
11551 -- Has_Non_Trivial_Precondition --
11552 ----------------------------------
11554 function Has_Non_Trivial_Precondition (Subp : Entity_Id) return Boolean is
11555 Pre : constant Node_Id := Find_Aspect (Subp, Aspect_Pre);
11560 and then Class_Present (Pre)
11561 and then not Is_Entity_Name (Expression (Pre));
11562 end Has_Non_Trivial_Precondition;
11564 -------------------
11565 -- Has_Null_Body --
11566 -------------------
11568 function Has_Null_Body (Proc_Id : Entity_Id) return Boolean is
11569 Body_Id : Entity_Id;
11576 Spec := Parent (Proc_Id);
11577 Decl := Parent (Spec);
11579 -- Retrieve the entity of the procedure body (e.g. invariant proc).
11581 if Nkind (Spec) = N_Procedure_Specification
11582 and then Nkind (Decl) = N_Subprogram_Declaration
11584 Body_Id := Corresponding_Body (Decl);
11586 -- The body acts as a spec
11589 Body_Id := Proc_Id;
11592 -- The body will be generated later
11594 if No (Body_Id) then
11598 Spec := Parent (Body_Id);
11599 Decl := Parent (Spec);
11602 (Nkind (Spec) = N_Procedure_Specification
11603 and then Nkind (Decl) = N_Subprogram_Body);
11605 Stmt1 := First (Statements (Handled_Statement_Sequence (Decl)));
11607 -- Look for a null statement followed by an optional return
11610 if Nkind (Stmt1) = N_Null_Statement then
11611 Stmt2 := Next (Stmt1);
11613 if Present (Stmt2) then
11614 return Nkind (Stmt2) = N_Simple_Return_Statement;
11623 ------------------------
11624 -- Has_Null_Exclusion --
11625 ------------------------
11627 function Has_Null_Exclusion (N : Node_Id) return Boolean is
11630 when N_Access_Definition
11631 | N_Access_Function_Definition
11632 | N_Access_Procedure_Definition
11633 | N_Access_To_Object_Definition
11635 | N_Derived_Type_Definition
11636 | N_Function_Specification
11637 | N_Subtype_Declaration
11639 return Null_Exclusion_Present (N);
11641 when N_Component_Definition
11642 | N_Formal_Object_Declaration
11643 | N_Object_Renaming_Declaration
11645 if Present (Subtype_Mark (N)) then
11646 return Null_Exclusion_Present (N);
11647 else pragma Assert (Present (Access_Definition (N)));
11648 return Null_Exclusion_Present (Access_Definition (N));
11651 when N_Discriminant_Specification =>
11652 if Nkind (Discriminant_Type (N)) = N_Access_Definition then
11653 return Null_Exclusion_Present (Discriminant_Type (N));
11655 return Null_Exclusion_Present (N);
11658 when N_Object_Declaration =>
11659 if Nkind (Object_Definition (N)) = N_Access_Definition then
11660 return Null_Exclusion_Present (Object_Definition (N));
11662 return Null_Exclusion_Present (N);
11665 when N_Parameter_Specification =>
11666 if Nkind (Parameter_Type (N)) = N_Access_Definition then
11667 return Null_Exclusion_Present (Parameter_Type (N));
11669 return Null_Exclusion_Present (N);
11675 end Has_Null_Exclusion;
11677 ------------------------
11678 -- Has_Null_Extension --
11679 ------------------------
11681 function Has_Null_Extension (T : Entity_Id) return Boolean is
11682 B : constant Entity_Id := Base_Type (T);
11687 if Nkind (Parent (B)) = N_Full_Type_Declaration
11688 and then Present (Record_Extension_Part (Type_Definition (Parent (B))))
11690 Ext := Record_Extension_Part (Type_Definition (Parent (B)));
11692 if Present (Ext) then
11693 if Null_Present (Ext) then
11696 Comps := Component_List (Ext);
11698 -- The null component list is rewritten during analysis to
11699 -- include the parent component. Any other component indicates
11700 -- that the extension was not originally null.
11702 return Null_Present (Comps)
11703 or else No (Next (First (Component_Items (Comps))));
11712 end Has_Null_Extension;
11714 -------------------------
11715 -- Has_Null_Refinement --
11716 -------------------------
11718 function Has_Null_Refinement (Id : Entity_Id) return Boolean is
11719 Constits : Elist_Id;
11722 pragma Assert (Ekind (Id) = E_Abstract_State);
11723 Constits := Refinement_Constituents (Id);
11725 -- For a refinement to be null, the state's sole constituent must be a
11730 and then Nkind (Node (First_Elmt (Constits))) = N_Null;
11731 end Has_Null_Refinement;
11733 -------------------------------
11734 -- Has_Overriding_Initialize --
11735 -------------------------------
11737 function Has_Overriding_Initialize (T : Entity_Id) return Boolean is
11738 BT : constant Entity_Id := Base_Type (T);
11742 if Is_Controlled (BT) then
11743 if Is_RTU (Scope (BT), Ada_Finalization) then
11746 elsif Present (Primitive_Operations (BT)) then
11747 P := First_Elmt (Primitive_Operations (BT));
11748 while Present (P) loop
11750 Init : constant Entity_Id := Node (P);
11751 Formal : constant Entity_Id := First_Formal (Init);
11753 if Ekind (Init) = E_Procedure
11754 and then Chars (Init) = Name_Initialize
11755 and then Comes_From_Source (Init)
11756 and then Present (Formal)
11757 and then Etype (Formal) = BT
11758 and then No (Next_Formal (Formal))
11759 and then (Ada_Version < Ada_2012
11760 or else not Null_Present (Parent (Init)))
11770 -- Here if type itself does not have a non-null Initialize operation:
11771 -- check immediate ancestor.
11773 if Is_Derived_Type (BT)
11774 and then Has_Overriding_Initialize (Etype (BT))
11781 end Has_Overriding_Initialize;
11783 --------------------------------------
11784 -- Has_Preelaborable_Initialization --
11785 --------------------------------------
11787 function Has_Preelaborable_Initialization (E : Entity_Id) return Boolean is
11790 procedure Check_Components (E : Entity_Id);
11791 -- Check component/discriminant chain, sets Has_PE False if a component
11792 -- or discriminant does not meet the preelaborable initialization rules.
11794 ----------------------
11795 -- Check_Components --
11796 ----------------------
11798 procedure Check_Components (E : Entity_Id) is
11803 -- Loop through entities of record or protected type
11806 while Present (Ent) loop
11808 -- We are interested only in components and discriminants
11812 case Ekind (Ent) is
11813 when E_Component =>
11815 -- Get default expression if any. If there is no declaration
11816 -- node, it means we have an internal entity. The parent and
11817 -- tag fields are examples of such entities. For such cases,
11818 -- we just test the type of the entity.
11820 if Present (Declaration_Node (Ent)) then
11821 Exp := Expression (Declaration_Node (Ent));
11824 when E_Discriminant =>
11826 -- Note: for a renamed discriminant, the Declaration_Node
11827 -- may point to the one from the ancestor, and have a
11828 -- different expression, so use the proper attribute to
11829 -- retrieve the expression from the derived constraint.
11831 Exp := Discriminant_Default_Value (Ent);
11834 goto Check_Next_Entity;
11837 -- A component has PI if it has no default expression and the
11838 -- component type has PI.
11841 if not Has_Preelaborable_Initialization (Etype (Ent)) then
11846 -- Require the default expression to be preelaborable
11848 elsif not Is_Preelaborable_Construct (Exp) then
11853 <<Check_Next_Entity>>
11856 end Check_Components;
11858 -- Start of processing for Has_Preelaborable_Initialization
11861 -- Immediate return if already marked as known preelaborable init. This
11862 -- covers types for which this function has already been called once
11863 -- and returned True (in which case the result is cached), and also
11864 -- types to which a pragma Preelaborable_Initialization applies.
11866 if Known_To_Have_Preelab_Init (E) then
11870 -- If the type is a subtype representing a generic actual type, then
11871 -- test whether its base type has preelaborable initialization since
11872 -- the subtype representing the actual does not inherit this attribute
11873 -- from the actual or formal. (but maybe it should???)
11875 if Is_Generic_Actual_Type (E) then
11876 return Has_Preelaborable_Initialization (Base_Type (E));
11879 -- All elementary types have preelaborable initialization
11881 if Is_Elementary_Type (E) then
11884 -- Array types have PI if the component type has PI
11886 elsif Is_Array_Type (E) then
11887 Has_PE := Has_Preelaborable_Initialization (Component_Type (E));
11889 -- A derived type has preelaborable initialization if its parent type
11890 -- has preelaborable initialization and (in the case of a derived record
11891 -- extension) if the non-inherited components all have preelaborable
11892 -- initialization. However, a user-defined controlled type with an
11893 -- overriding Initialize procedure does not have preelaborable
11896 elsif Is_Derived_Type (E) then
11898 -- If the derived type is a private extension then it doesn't have
11899 -- preelaborable initialization.
11901 if Ekind (Base_Type (E)) = E_Record_Type_With_Private then
11905 -- First check whether ancestor type has preelaborable initialization
11907 Has_PE := Has_Preelaborable_Initialization (Etype (Base_Type (E)));
11909 -- If OK, check extension components (if any)
11911 if Has_PE and then Is_Record_Type (E) then
11912 Check_Components (First_Entity (E));
11915 -- Check specifically for 10.2.1(11.4/2) exception: a controlled type
11916 -- with a user defined Initialize procedure does not have PI. If
11917 -- the type is untagged, the control primitives come from a component
11918 -- that has already been checked.
11921 and then Is_Controlled (E)
11922 and then Is_Tagged_Type (E)
11923 and then Has_Overriding_Initialize (E)
11928 -- Private types not derived from a type having preelaborable init and
11929 -- that are not marked with pragma Preelaborable_Initialization do not
11930 -- have preelaborable initialization.
11932 elsif Is_Private_Type (E) then
11935 -- Record type has PI if it is non private and all components have PI
11937 elsif Is_Record_Type (E) then
11939 Check_Components (First_Entity (E));
11941 -- Protected types must not have entries, and components must meet
11942 -- same set of rules as for record components.
11944 elsif Is_Protected_Type (E) then
11945 if Has_Entries (E) then
11949 Check_Components (First_Entity (E));
11950 Check_Components (First_Private_Entity (E));
11953 -- Type System.Address always has preelaborable initialization
11955 elsif Is_RTE (E, RE_Address) then
11958 -- In all other cases, type does not have preelaborable initialization
11964 -- If type has preelaborable initialization, cache result
11967 Set_Known_To_Have_Preelab_Init (E);
11971 end Has_Preelaborable_Initialization;
11977 function Has_Prefix (N : Node_Id) return Boolean is
11980 Nkind_In (N, N_Attribute_Reference,
11982 N_Explicit_Dereference,
11983 N_Indexed_Component,
11985 N_Selected_Component,
11989 ---------------------------
11990 -- Has_Private_Component --
11991 ---------------------------
11993 function Has_Private_Component (Type_Id : Entity_Id) return Boolean is
11994 Btype : Entity_Id := Base_Type (Type_Id);
11995 Component : Entity_Id;
11998 if Error_Posted (Type_Id)
11999 or else Error_Posted (Btype)
12004 if Is_Class_Wide_Type (Btype) then
12005 Btype := Root_Type (Btype);
12008 if Is_Private_Type (Btype) then
12010 UT : constant Entity_Id := Underlying_Type (Btype);
12013 if No (Full_View (Btype)) then
12014 return not Is_Generic_Type (Btype)
12016 not Is_Generic_Type (Root_Type (Btype));
12018 return not Is_Generic_Type (Root_Type (Full_View (Btype)));
12021 return not Is_Frozen (UT) and then Has_Private_Component (UT);
12025 elsif Is_Array_Type (Btype) then
12026 return Has_Private_Component (Component_Type (Btype));
12028 elsif Is_Record_Type (Btype) then
12029 Component := First_Component (Btype);
12030 while Present (Component) loop
12031 if Has_Private_Component (Etype (Component)) then
12035 Next_Component (Component);
12040 elsif Is_Protected_Type (Btype)
12041 and then Present (Corresponding_Record_Type (Btype))
12043 return Has_Private_Component (Corresponding_Record_Type (Btype));
12048 end Has_Private_Component;
12050 ----------------------
12051 -- Has_Signed_Zeros --
12052 ----------------------
12054 function Has_Signed_Zeros (E : Entity_Id) return Boolean is
12056 return Is_Floating_Point_Type (E) and then Signed_Zeros_On_Target;
12057 end Has_Signed_Zeros;
12059 ------------------------------
12060 -- Has_Significant_Contract --
12061 ------------------------------
12063 function Has_Significant_Contract (Subp_Id : Entity_Id) return Boolean is
12064 Subp_Nam : constant Name_Id := Chars (Subp_Id);
12067 -- _Finalizer procedure
12069 if Subp_Nam = Name_uFinalizer then
12072 -- _Postconditions procedure
12074 elsif Subp_Nam = Name_uPostconditions then
12077 -- Predicate function
12079 elsif Ekind (Subp_Id) = E_Function
12080 and then Is_Predicate_Function (Subp_Id)
12086 elsif Get_TSS_Name (Subp_Id) /= TSS_Null then
12092 end Has_Significant_Contract;
12094 -----------------------------
12095 -- Has_Static_Array_Bounds --
12096 -----------------------------
12098 function Has_Static_Array_Bounds (Typ : Node_Id) return Boolean is
12099 All_Static : Boolean;
12103 Examine_Array_Bounds (Typ, All_Static, Dummy);
12106 end Has_Static_Array_Bounds;
12108 ---------------------------------------
12109 -- Has_Static_Non_Empty_Array_Bounds --
12110 ---------------------------------------
12112 function Has_Static_Non_Empty_Array_Bounds (Typ : Node_Id) return Boolean is
12113 All_Static : Boolean;
12114 Has_Empty : Boolean;
12117 Examine_Array_Bounds (Typ, All_Static, Has_Empty);
12119 return All_Static and not Has_Empty;
12120 end Has_Static_Non_Empty_Array_Bounds;
12126 function Has_Stream (T : Entity_Id) return Boolean is
12133 elsif Is_RTE (Root_Type (T), RE_Root_Stream_Type) then
12136 elsif Is_Array_Type (T) then
12137 return Has_Stream (Component_Type (T));
12139 elsif Is_Record_Type (T) then
12140 E := First_Component (T);
12141 while Present (E) loop
12142 if Has_Stream (Etype (E)) then
12145 Next_Component (E);
12151 elsif Is_Private_Type (T) then
12152 return Has_Stream (Underlying_Type (T));
12163 function Has_Suffix (E : Entity_Id; Suffix : Character) return Boolean is
12165 Get_Name_String (Chars (E));
12166 return Name_Buffer (Name_Len) = Suffix;
12173 function Add_Suffix (E : Entity_Id; Suffix : Character) return Name_Id is
12175 Get_Name_String (Chars (E));
12176 Add_Char_To_Name_Buffer (Suffix);
12180 -------------------
12181 -- Remove_Suffix --
12182 -------------------
12184 function Remove_Suffix (E : Entity_Id; Suffix : Character) return Name_Id is
12186 pragma Assert (Has_Suffix (E, Suffix));
12187 Get_Name_String (Chars (E));
12188 Name_Len := Name_Len - 1;
12192 ----------------------------------
12193 -- Replace_Null_By_Null_Address --
12194 ----------------------------------
12196 procedure Replace_Null_By_Null_Address (N : Node_Id) is
12197 procedure Replace_Null_Operand (Op : Node_Id; Other_Op : Node_Id);
12198 -- Replace operand Op with a reference to Null_Address when the operand
12199 -- denotes a null Address. Other_Op denotes the other operand.
12201 --------------------------
12202 -- Replace_Null_Operand --
12203 --------------------------
12205 procedure Replace_Null_Operand (Op : Node_Id; Other_Op : Node_Id) is
12207 -- Check the type of the complementary operand since the N_Null node
12208 -- has not been decorated yet.
12210 if Nkind (Op) = N_Null
12211 and then Is_Descendant_Of_Address (Etype (Other_Op))
12213 Rewrite (Op, New_Occurrence_Of (RTE (RE_Null_Address), Sloc (Op)));
12215 end Replace_Null_Operand;
12217 -- Start of processing for Replace_Null_By_Null_Address
12220 pragma Assert (Relaxed_RM_Semantics);
12221 pragma Assert (Nkind_In (N, N_Null,
12229 if Nkind (N) = N_Null then
12230 Rewrite (N, New_Occurrence_Of (RTE (RE_Null_Address), Sloc (N)));
12234 L : constant Node_Id := Left_Opnd (N);
12235 R : constant Node_Id := Right_Opnd (N);
12238 Replace_Null_Operand (L, Other_Op => R);
12239 Replace_Null_Operand (R, Other_Op => L);
12242 end Replace_Null_By_Null_Address;
12244 --------------------------
12245 -- Has_Tagged_Component --
12246 --------------------------
12248 function Has_Tagged_Component (Typ : Entity_Id) return Boolean is
12252 if Is_Private_Type (Typ) and then Present (Underlying_Type (Typ)) then
12253 return Has_Tagged_Component (Underlying_Type (Typ));
12255 elsif Is_Array_Type (Typ) then
12256 return Has_Tagged_Component (Component_Type (Typ));
12258 elsif Is_Tagged_Type (Typ) then
12261 elsif Is_Record_Type (Typ) then
12262 Comp := First_Component (Typ);
12263 while Present (Comp) loop
12264 if Has_Tagged_Component (Etype (Comp)) then
12268 Next_Component (Comp);
12276 end Has_Tagged_Component;
12278 -----------------------------
12279 -- Has_Undefined_Reference --
12280 -----------------------------
12282 function Has_Undefined_Reference (Expr : Node_Id) return Boolean is
12283 Has_Undef_Ref : Boolean := False;
12284 -- Flag set when expression Expr contains at least one undefined
12287 function Is_Undefined_Reference (N : Node_Id) return Traverse_Result;
12288 -- Determine whether N denotes a reference and if it does, whether it is
12291 ----------------------------
12292 -- Is_Undefined_Reference --
12293 ----------------------------
12295 function Is_Undefined_Reference (N : Node_Id) return Traverse_Result is
12297 if Is_Entity_Name (N)
12298 and then Present (Entity (N))
12299 and then Entity (N) = Any_Id
12301 Has_Undef_Ref := True;
12306 end Is_Undefined_Reference;
12308 procedure Find_Undefined_References is
12309 new Traverse_Proc (Is_Undefined_Reference);
12311 -- Start of processing for Has_Undefined_Reference
12314 Find_Undefined_References (Expr);
12316 return Has_Undef_Ref;
12317 end Has_Undefined_Reference;
12319 ----------------------------
12320 -- Has_Volatile_Component --
12321 ----------------------------
12323 function Has_Volatile_Component (Typ : Entity_Id) return Boolean is
12327 if Has_Volatile_Components (Typ) then
12330 elsif Is_Array_Type (Typ) then
12331 return Is_Volatile (Component_Type (Typ));
12333 elsif Is_Record_Type (Typ) then
12334 Comp := First_Component (Typ);
12335 while Present (Comp) loop
12336 if Is_Volatile_Object (Comp) then
12340 Comp := Next_Component (Comp);
12345 end Has_Volatile_Component;
12347 -------------------------
12348 -- Implementation_Kind --
12349 -------------------------
12351 function Implementation_Kind (Subp : Entity_Id) return Name_Id is
12352 Impl_Prag : constant Node_Id := Get_Rep_Pragma (Subp, Name_Implemented);
12355 pragma Assert (Present (Impl_Prag));
12356 Arg := Last (Pragma_Argument_Associations (Impl_Prag));
12357 return Chars (Get_Pragma_Arg (Arg));
12358 end Implementation_Kind;
12360 --------------------------
12361 -- Implements_Interface --
12362 --------------------------
12364 function Implements_Interface
12365 (Typ_Ent : Entity_Id;
12366 Iface_Ent : Entity_Id;
12367 Exclude_Parents : Boolean := False) return Boolean
12369 Ifaces_List : Elist_Id;
12371 Iface : Entity_Id := Base_Type (Iface_Ent);
12372 Typ : Entity_Id := Base_Type (Typ_Ent);
12375 if Is_Class_Wide_Type (Typ) then
12376 Typ := Root_Type (Typ);
12379 if not Has_Interfaces (Typ) then
12383 if Is_Class_Wide_Type (Iface) then
12384 Iface := Root_Type (Iface);
12387 Collect_Interfaces (Typ, Ifaces_List);
12389 Elmt := First_Elmt (Ifaces_List);
12390 while Present (Elmt) loop
12391 if Is_Ancestor (Node (Elmt), Typ, Use_Full_View => True)
12392 and then Exclude_Parents
12396 elsif Node (Elmt) = Iface then
12404 end Implements_Interface;
12406 ------------------------------------
12407 -- In_Assertion_Expression_Pragma --
12408 ------------------------------------
12410 function In_Assertion_Expression_Pragma (N : Node_Id) return Boolean is
12412 Prag : Node_Id := Empty;
12415 -- Climb the parent chain looking for an enclosing pragma
12418 while Present (Par) loop
12419 if Nkind (Par) = N_Pragma then
12423 -- Precondition-like pragmas are expanded into if statements, check
12424 -- the original node instead.
12426 elsif Nkind (Original_Node (Par)) = N_Pragma then
12427 Prag := Original_Node (Par);
12430 -- The expansion of attribute 'Old generates a constant to capture
12431 -- the result of the prefix. If the parent traversal reaches
12432 -- one of these constants, then the node technically came from a
12433 -- postcondition-like pragma. Note that the Ekind is not tested here
12434 -- because N may be the expression of an object declaration which is
12435 -- currently being analyzed. Such objects carry Ekind of E_Void.
12437 elsif Nkind (Par) = N_Object_Declaration
12438 and then Constant_Present (Par)
12439 and then Stores_Attribute_Old_Prefix (Defining_Entity (Par))
12443 -- Prevent the search from going too far
12445 elsif Is_Body_Or_Package_Declaration (Par) then
12449 Par := Parent (Par);
12454 and then Assertion_Expression_Pragma (Get_Pragma_Id (Prag));
12455 end In_Assertion_Expression_Pragma;
12457 ----------------------
12458 -- In_Generic_Scope --
12459 ----------------------
12461 function In_Generic_Scope (E : Entity_Id) return Boolean is
12466 while Present (S) and then S /= Standard_Standard loop
12467 if Is_Generic_Unit (S) then
12475 end In_Generic_Scope;
12481 function In_Instance return Boolean is
12482 Curr_Unit : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
12486 S := Current_Scope;
12487 while Present (S) and then S /= Standard_Standard loop
12488 if Is_Generic_Instance (S) then
12490 -- A child instance is always compiled in the context of a parent
12491 -- instance. Nevertheless, its actuals must not be analyzed in an
12492 -- instance context. We detect this case by examining the current
12493 -- compilation unit, which must be a child instance, and checking
12494 -- that it has not been analyzed yet.
12496 if Is_Child_Unit (Curr_Unit)
12497 and then Nkind (Unit (Cunit (Current_Sem_Unit))) =
12498 N_Package_Instantiation
12499 and then Ekind (Curr_Unit) = E_Void
12513 ----------------------
12514 -- In_Instance_Body --
12515 ----------------------
12517 function In_Instance_Body return Boolean is
12521 S := Current_Scope;
12522 while Present (S) and then S /= Standard_Standard loop
12523 if Ekind_In (S, E_Function, E_Procedure)
12524 and then Is_Generic_Instance (S)
12528 elsif Ekind (S) = E_Package
12529 and then In_Package_Body (S)
12530 and then Is_Generic_Instance (S)
12539 end In_Instance_Body;
12541 -----------------------------
12542 -- In_Instance_Not_Visible --
12543 -----------------------------
12545 function In_Instance_Not_Visible return Boolean is
12549 S := Current_Scope;
12550 while Present (S) and then S /= Standard_Standard loop
12551 if Ekind_In (S, E_Function, E_Procedure)
12552 and then Is_Generic_Instance (S)
12556 elsif Ekind (S) = E_Package
12557 and then (In_Package_Body (S) or else In_Private_Part (S))
12558 and then Is_Generic_Instance (S)
12567 end In_Instance_Not_Visible;
12569 ------------------------------
12570 -- In_Instance_Visible_Part --
12571 ------------------------------
12573 function In_Instance_Visible_Part
12574 (Id : Entity_Id := Current_Scope) return Boolean
12580 while Present (Inst) and then Inst /= Standard_Standard loop
12581 if Ekind (Inst) = E_Package
12582 and then Is_Generic_Instance (Inst)
12583 and then not In_Package_Body (Inst)
12584 and then not In_Private_Part (Inst)
12589 Inst := Scope (Inst);
12593 end In_Instance_Visible_Part;
12595 ---------------------
12596 -- In_Package_Body --
12597 ---------------------
12599 function In_Package_Body return Boolean is
12603 S := Current_Scope;
12604 while Present (S) and then S /= Standard_Standard loop
12605 if Ekind (S) = E_Package and then In_Package_Body (S) then
12613 end In_Package_Body;
12615 --------------------------
12616 -- In_Pragma_Expression --
12617 --------------------------
12619 function In_Pragma_Expression (N : Node_Id; Nam : Name_Id) return Boolean is
12626 elsif Nkind (P) = N_Pragma and then Pragma_Name (P) = Nam then
12632 end In_Pragma_Expression;
12634 ---------------------------
12635 -- In_Pre_Post_Condition --
12636 ---------------------------
12638 function In_Pre_Post_Condition (N : Node_Id) return Boolean is
12640 Prag : Node_Id := Empty;
12641 Prag_Id : Pragma_Id;
12644 -- Climb the parent chain looking for an enclosing pragma
12647 while Present (Par) loop
12648 if Nkind (Par) = N_Pragma then
12652 -- Prevent the search from going too far
12654 elsif Is_Body_Or_Package_Declaration (Par) then
12658 Par := Parent (Par);
12661 if Present (Prag) then
12662 Prag_Id := Get_Pragma_Id (Prag);
12665 Prag_Id = Pragma_Post
12666 or else Prag_Id = Pragma_Post_Class
12667 or else Prag_Id = Pragma_Postcondition
12668 or else Prag_Id = Pragma_Pre
12669 or else Prag_Id = Pragma_Pre_Class
12670 or else Prag_Id = Pragma_Precondition;
12672 -- Otherwise the node is not enclosed by a pre/postcondition pragma
12677 end In_Pre_Post_Condition;
12679 ------------------------------
12680 -- In_Quantified_Expression --
12681 ------------------------------
12683 function In_Quantified_Expression (N : Node_Id) return Boolean is
12690 elsif Nkind (P) = N_Quantified_Expression then
12696 end In_Quantified_Expression;
12698 -------------------------------------
12699 -- In_Reverse_Storage_Order_Object --
12700 -------------------------------------
12702 function In_Reverse_Storage_Order_Object (N : Node_Id) return Boolean is
12704 Btyp : Entity_Id := Empty;
12707 -- Climb up indexed components
12711 case Nkind (Pref) is
12712 when N_Selected_Component =>
12713 Pref := Prefix (Pref);
12716 when N_Indexed_Component =>
12717 Pref := Prefix (Pref);
12725 if Present (Pref) then
12726 Btyp := Base_Type (Etype (Pref));
12729 return Present (Btyp)
12730 and then (Is_Record_Type (Btyp) or else Is_Array_Type (Btyp))
12731 and then Reverse_Storage_Order (Btyp);
12732 end In_Reverse_Storage_Order_Object;
12734 ------------------------------
12735 -- In_Same_Declarative_Part --
12736 ------------------------------
12738 function In_Same_Declarative_Part
12739 (Context : Node_Id;
12740 N : Node_Id) return Boolean
12742 Cont : Node_Id := Context;
12746 if Nkind (Cont) = N_Compilation_Unit_Aux then
12747 Cont := Parent (Cont);
12751 while Present (Nod) loop
12755 elsif Nkind_In (Nod, N_Accept_Statement,
12757 N_Compilation_Unit,
12760 N_Package_Declaration,
12767 elsif Nkind (Nod) = N_Subunit then
12768 Nod := Corresponding_Stub (Nod);
12771 Nod := Parent (Nod);
12776 end In_Same_Declarative_Part;
12778 --------------------------------------
12779 -- In_Subprogram_Or_Concurrent_Unit --
12780 --------------------------------------
12782 function In_Subprogram_Or_Concurrent_Unit return Boolean is
12787 -- Use scope chain to check successively outer scopes
12789 E := Current_Scope;
12793 if K in Subprogram_Kind
12794 or else K in Concurrent_Kind
12795 or else K in Generic_Subprogram_Kind
12799 elsif E = Standard_Standard then
12805 end In_Subprogram_Or_Concurrent_Unit;
12811 function In_Subtree (N : Node_Id; Root : Node_Id) return Boolean is
12816 while Present (Curr) loop
12817 if Curr = Root then
12821 Curr := Parent (Curr);
12831 function In_Subtree
12834 Root2 : Node_Id) return Boolean
12840 while Present (Curr) loop
12841 if Curr = Root1 or else Curr = Root2 then
12845 Curr := Parent (Curr);
12851 ---------------------
12852 -- In_Visible_Part --
12853 ---------------------
12855 function In_Visible_Part (Scope_Id : Entity_Id) return Boolean is
12857 return Is_Package_Or_Generic_Package (Scope_Id)
12858 and then In_Open_Scopes (Scope_Id)
12859 and then not In_Package_Body (Scope_Id)
12860 and then not In_Private_Part (Scope_Id);
12861 end In_Visible_Part;
12863 -----------------------------
12864 -- In_While_Loop_Condition --
12865 -----------------------------
12867 function In_While_Loop_Condition (N : Node_Id) return Boolean is
12868 Prev : Node_Id := N;
12869 P : Node_Id := Parent (N);
12870 -- P and Prev will be used for traversing the AST, while maintaining an
12871 -- invariant that P = Parent (Prev).
12876 elsif Nkind (P) = N_Iteration_Scheme
12877 and then Prev = Condition (P)
12885 end In_While_Loop_Condition;
12887 --------------------------------
12888 -- Incomplete_Or_Partial_View --
12889 --------------------------------
12891 function Incomplete_Or_Partial_View (Id : Entity_Id) return Entity_Id is
12892 function Inspect_Decls
12894 Taft : Boolean := False) return Entity_Id;
12895 -- Check whether a declarative region contains the incomplete or partial
12898 -------------------
12899 -- Inspect_Decls --
12900 -------------------
12902 function Inspect_Decls
12904 Taft : Boolean := False) return Entity_Id
12910 Decl := First (Decls);
12911 while Present (Decl) loop
12914 -- The partial view of a Taft-amendment type is an incomplete
12918 if Nkind (Decl) = N_Incomplete_Type_Declaration then
12919 Match := Defining_Identifier (Decl);
12922 -- Otherwise look for a private type whose full view matches the
12923 -- input type. Note that this checks full_type_declaration nodes
12924 -- to account for derivations from a private type where the type
12925 -- declaration hold the partial view and the full view is an
12928 elsif Nkind_In (Decl, N_Full_Type_Declaration,
12929 N_Private_Extension_Declaration,
12930 N_Private_Type_Declaration)
12932 Match := Defining_Identifier (Decl);
12935 -- Guard against unanalyzed entities
12938 and then Is_Type (Match)
12939 and then Present (Full_View (Match))
12940 and then Full_View (Match) = Id
12955 -- Start of processing for Incomplete_Or_Partial_View
12958 -- Deferred constant or incomplete type case
12960 Prev := Current_Entity_In_Scope (Id);
12963 and then (Is_Incomplete_Type (Prev) or else Ekind (Prev) = E_Constant)
12964 and then Present (Full_View (Prev))
12965 and then Full_View (Prev) = Id
12970 -- Private or Taft amendment type case
12973 Pkg : constant Entity_Id := Scope (Id);
12974 Pkg_Decl : Node_Id := Pkg;
12978 and then Is_Package_Or_Generic_Package (Pkg)
12980 while Nkind (Pkg_Decl) /= N_Package_Specification loop
12981 Pkg_Decl := Parent (Pkg_Decl);
12984 -- It is knows that Typ has a private view, look for it in the
12985 -- visible declarations of the enclosing scope. A special case
12986 -- of this is when the two views have been exchanged - the full
12987 -- appears earlier than the private.
12989 if Has_Private_Declaration (Id) then
12990 Prev := Inspect_Decls (Visible_Declarations (Pkg_Decl));
12992 -- Exchanged view case, look in the private declarations
12995 Prev := Inspect_Decls (Private_Declarations (Pkg_Decl));
13000 -- Otherwise if this is the package body, then Typ is a potential
13001 -- Taft amendment type. The incomplete view should be located in
13002 -- the private declarations of the enclosing scope.
13004 elsif In_Package_Body (Pkg) then
13005 return Inspect_Decls (Private_Declarations (Pkg_Decl), True);
13010 -- The type has no incomplete or private view
13013 end Incomplete_Or_Partial_View;
13015 ---------------------------------------
13016 -- Incomplete_View_From_Limited_With --
13017 ---------------------------------------
13019 function Incomplete_View_From_Limited_With
13020 (Typ : Entity_Id) return Entity_Id
13023 -- It might make sense to make this an attribute in Einfo, and set it
13024 -- in Sem_Ch10 in Build_Shadow_Entity. However, we're running short on
13025 -- slots for new attributes, and it seems a bit simpler to just search
13026 -- the Limited_View (if it exists) for an incomplete type whose
13027 -- Non_Limited_View is Typ.
13029 if Ekind (Scope (Typ)) = E_Package
13030 and then Present (Limited_View (Scope (Typ)))
13033 Ent : Entity_Id := First_Entity (Limited_View (Scope (Typ)));
13035 while Present (Ent) loop
13036 if Ekind (Ent) in Incomplete_Kind
13037 and then Non_Limited_View (Ent) = Typ
13042 Ent := Next_Entity (Ent);
13048 end Incomplete_View_From_Limited_With;
13050 ----------------------------------
13051 -- Indexed_Component_Bit_Offset --
13052 ----------------------------------
13054 function Indexed_Component_Bit_Offset (N : Node_Id) return Uint is
13055 Exp : constant Node_Id := First (Expressions (N));
13056 Typ : constant Entity_Id := Etype (Prefix (N));
13057 Off : constant Uint := Component_Size (Typ);
13061 -- Return early if the component size is not known or variable
13063 if Off = No_Uint or else Off < Uint_0 then
13067 -- Deal with the degenerate case of an empty component
13069 if Off = Uint_0 then
13073 -- Check that both the index value and the low bound are known
13075 if not Compile_Time_Known_Value (Exp) then
13079 Ind := First_Index (Typ);
13084 if Nkind (Ind) = N_Subtype_Indication then
13085 Ind := Constraint (Ind);
13087 if Nkind (Ind) = N_Range_Constraint then
13088 Ind := Range_Expression (Ind);
13092 if Nkind (Ind) /= N_Range
13093 or else not Compile_Time_Known_Value (Low_Bound (Ind))
13098 -- Return the scaled offset
13100 return Off * (Expr_Value (Exp) - Expr_Value (Low_Bound ((Ind))));
13101 end Indexed_Component_Bit_Offset;
13103 ----------------------------
13104 -- Inherit_Rep_Item_Chain --
13105 ----------------------------
13107 procedure Inherit_Rep_Item_Chain (Typ : Entity_Id; From_Typ : Entity_Id) is
13109 Next_Item : Node_Id;
13112 -- There are several inheritance scenarios to consider depending on
13113 -- whether both types have rep item chains and whether the destination
13114 -- type already inherits part of the source type's rep item chain.
13116 -- 1) The source type lacks a rep item chain
13117 -- From_Typ ---> Empty
13119 -- Typ --------> Item (or Empty)
13121 -- In this case inheritance cannot take place because there are no items
13124 -- 2) The destination type lacks a rep item chain
13125 -- From_Typ ---> Item ---> ...
13127 -- Typ --------> Empty
13129 -- Inheritance takes place by setting the First_Rep_Item of the
13130 -- destination type to the First_Rep_Item of the source type.
13131 -- From_Typ ---> Item ---> ...
13133 -- Typ -----------+
13135 -- 3.1) Both source and destination types have at least one rep item.
13136 -- The destination type does NOT inherit a rep item from the source
13138 -- From_Typ ---> Item ---> Item
13140 -- Typ --------> Item ---> Item
13142 -- Inheritance takes place by setting the Next_Rep_Item of the last item
13143 -- of the destination type to the First_Rep_Item of the source type.
13144 -- From_Typ -------------------> Item ---> Item
13146 -- Typ --------> Item ---> Item --+
13148 -- 3.2) Both source and destination types have at least one rep item.
13149 -- The destination type DOES inherit part of the rep item chain of the
13151 -- From_Typ ---> Item ---> Item ---> Item
13153 -- Typ --------> Item ------+
13155 -- This rare case arises when the full view of a private extension must
13156 -- inherit the rep item chain from the full view of its parent type and
13157 -- the full view of the parent type contains extra rep items. Currently
13158 -- only invariants may lead to such form of inheritance.
13160 -- type From_Typ is tagged private
13161 -- with Type_Invariant'Class => Item_2;
13163 -- type Typ is new From_Typ with private
13164 -- with Type_Invariant => Item_4;
13166 -- At this point the rep item chains contain the following items
13168 -- From_Typ -----------> Item_2 ---> Item_3
13170 -- Typ --------> Item_4 --+
13172 -- The full views of both types may introduce extra invariants
13174 -- type From_Typ is tagged null record
13175 -- with Type_Invariant => Item_1;
13177 -- type Typ is new From_Typ with null record;
13179 -- The full view of Typ would have to inherit any new rep items added to
13180 -- the full view of From_Typ.
13182 -- From_Typ -----------> Item_1 ---> Item_2 ---> Item_3
13184 -- Typ --------> Item_4 --+
13186 -- To achieve this form of inheritance, the destination type must first
13187 -- sever the link between its own rep chain and that of the source type,
13188 -- then inheritance 3.1 takes place.
13190 -- Case 1: The source type lacks a rep item chain
13192 if No (First_Rep_Item (From_Typ)) then
13195 -- Case 2: The destination type lacks a rep item chain
13197 elsif No (First_Rep_Item (Typ)) then
13198 Set_First_Rep_Item (Typ, First_Rep_Item (From_Typ));
13200 -- Case 3: Both the source and destination types have at least one rep
13201 -- item. Traverse the rep item chain of the destination type to find the
13206 Next_Item := First_Rep_Item (Typ);
13207 while Present (Next_Item) loop
13209 -- Detect a link between the destination type's rep chain and that
13210 -- of the source type. There are two possibilities:
13215 -- From_Typ ---> Item_1 --->
13217 -- Typ -----------+
13224 -- From_Typ ---> Item_1 ---> Item_2 --->
13226 -- Typ --------> Item_3 ------+
13230 if Has_Rep_Item (From_Typ, Next_Item) then
13235 Next_Item := Next_Rep_Item (Next_Item);
13238 -- Inherit the source type's rep item chain
13240 if Present (Item) then
13241 Set_Next_Rep_Item (Item, First_Rep_Item (From_Typ));
13243 Set_First_Rep_Item (Typ, First_Rep_Item (From_Typ));
13246 end Inherit_Rep_Item_Chain;
13248 ------------------------------------
13249 -- Inherits_From_Tagged_Full_View --
13250 ------------------------------------
13252 function Inherits_From_Tagged_Full_View (Typ : Entity_Id) return Boolean is
13254 return Is_Private_Type (Typ)
13255 and then Present (Full_View (Typ))
13256 and then Is_Private_Type (Full_View (Typ))
13257 and then not Is_Tagged_Type (Full_View (Typ))
13258 and then Present (Underlying_Type (Full_View (Typ)))
13259 and then Is_Tagged_Type (Underlying_Type (Full_View (Typ)));
13260 end Inherits_From_Tagged_Full_View;
13262 ---------------------------------
13263 -- Insert_Explicit_Dereference --
13264 ---------------------------------
13266 procedure Insert_Explicit_Dereference (N : Node_Id) is
13267 New_Prefix : constant Node_Id := Relocate_Node (N);
13268 Ent : Entity_Id := Empty;
13269 Pref : Node_Id := Empty;
13275 Save_Interps (N, New_Prefix);
13278 Make_Explicit_Dereference (Sloc (Parent (N)),
13279 Prefix => New_Prefix));
13281 Set_Etype (N, Designated_Type (Etype (New_Prefix)));
13283 if Is_Overloaded (New_Prefix) then
13285 -- The dereference is also overloaded, and its interpretations are
13286 -- the designated types of the interpretations of the original node.
13288 Set_Etype (N, Any_Type);
13290 Get_First_Interp (New_Prefix, I, It);
13291 while Present (It.Nam) loop
13294 if Is_Access_Type (T) then
13295 Add_One_Interp (N, Designated_Type (T), Designated_Type (T));
13298 Get_Next_Interp (I, It);
13304 -- Prefix is unambiguous: mark the original prefix (which might
13305 -- Come_From_Source) as a reference, since the new (relocated) one
13306 -- won't be taken into account.
13308 if Is_Entity_Name (New_Prefix) then
13309 Ent := Entity (New_Prefix);
13310 Pref := New_Prefix;
13312 -- For a retrieval of a subcomponent of some composite object,
13313 -- retrieve the ultimate entity if there is one.
13315 elsif Nkind_In (New_Prefix, N_Selected_Component,
13316 N_Indexed_Component)
13318 Pref := Prefix (New_Prefix);
13319 while Present (Pref)
13320 and then Nkind_In (Pref, N_Selected_Component,
13321 N_Indexed_Component)
13323 Pref := Prefix (Pref);
13326 if Present (Pref) and then Is_Entity_Name (Pref) then
13327 Ent := Entity (Pref);
13331 -- Place the reference on the entity node
13333 if Present (Ent) then
13334 Generate_Reference (Ent, Pref);
13337 end Insert_Explicit_Dereference;
13339 ------------------------------------------
13340 -- Inspect_Deferred_Constant_Completion --
13341 ------------------------------------------
13343 procedure Inspect_Deferred_Constant_Completion (Decls : List_Id) is
13347 Decl := First (Decls);
13348 while Present (Decl) loop
13350 -- Deferred constant signature
13352 if Nkind (Decl) = N_Object_Declaration
13353 and then Constant_Present (Decl)
13354 and then No (Expression (Decl))
13356 -- No need to check internally generated constants
13358 and then Comes_From_Source (Decl)
13360 -- The constant is not completed. A full object declaration or a
13361 -- pragma Import complete a deferred constant.
13363 and then not Has_Completion (Defining_Identifier (Decl))
13366 ("constant declaration requires initialization expression",
13367 Defining_Identifier (Decl));
13370 Decl := Next (Decl);
13372 end Inspect_Deferred_Constant_Completion;
13374 -------------------------------
13375 -- Install_Elaboration_Model --
13376 -------------------------------
13378 procedure Install_Elaboration_Model (Unit_Id : Entity_Id) is
13379 function Find_Elaboration_Checks_Pragma (L : List_Id) return Node_Id;
13380 -- Try to find pragma Elaboration_Checks in arbitrary list L. Return
13381 -- Empty if there is no such pragma.
13383 ------------------------------------
13384 -- Find_Elaboration_Checks_Pragma --
13385 ------------------------------------
13387 function Find_Elaboration_Checks_Pragma (L : List_Id) return Node_Id is
13392 while Present (Item) loop
13393 if Nkind (Item) = N_Pragma
13394 and then Pragma_Name (Item) = Name_Elaboration_Checks
13403 end Find_Elaboration_Checks_Pragma;
13412 -- Start of processing for Install_Elaboration_Model
13415 -- Nothing to do when the unit does not exist
13417 if No (Unit_Id) then
13421 Unit := Parent (Unit_Declaration_Node (Unit_Id));
13423 -- Nothing to do when the unit is not a library unit
13425 if Nkind (Unit) /= N_Compilation_Unit then
13429 Prag := Find_Elaboration_Checks_Pragma (Context_Items (Unit));
13431 -- The compilation unit is subject to pragma Elaboration_Checks. Set the
13432 -- elaboration model as specified by the pragma.
13434 if Present (Prag) then
13435 Args := Pragma_Argument_Associations (Prag);
13437 -- Guard against an illegal pragma. The sole argument must be an
13438 -- identifier which specifies either Dynamic or Static model.
13440 if Present (Args) then
13441 Model := Get_Pragma_Arg (First (Args));
13443 if Nkind (Model) = N_Identifier then
13444 Dynamic_Elaboration_Checks := Chars (Model) = Name_Dynamic;
13448 end Install_Elaboration_Model;
13450 -----------------------------
13451 -- Install_Generic_Formals --
13452 -----------------------------
13454 procedure Install_Generic_Formals (Subp_Id : Entity_Id) is
13458 pragma Assert (Is_Generic_Subprogram (Subp_Id));
13460 E := First_Entity (Subp_Id);
13461 while Present (E) loop
13462 Install_Entity (E);
13465 end Install_Generic_Formals;
13467 ------------------------
13468 -- Install_SPARK_Mode --
13469 ------------------------
13471 procedure Install_SPARK_Mode (Mode : SPARK_Mode_Type; Prag : Node_Id) is
13473 SPARK_Mode := Mode;
13474 SPARK_Mode_Pragma := Prag;
13475 end Install_SPARK_Mode;
13477 --------------------------
13478 -- Invalid_Scalar_Value --
13479 --------------------------
13481 function Invalid_Scalar_Value
13483 Scal_Typ : Scalar_Id) return Node_Id
13485 function Invalid_Binder_Value return Node_Id;
13486 -- Return a reference to the corresponding invalid value for type
13487 -- Scal_Typ as defined in unit System.Scalar_Values.
13489 function Invalid_Float_Value return Node_Id;
13490 -- Return the invalid value of float type Scal_Typ
13492 function Invalid_Integer_Value return Node_Id;
13493 -- Return the invalid value of integer type Scal_Typ
13495 procedure Set_Invalid_Binder_Values;
13496 -- Set the contents of collection Invalid_Binder_Values
13498 --------------------------
13499 -- Invalid_Binder_Value --
13500 --------------------------
13502 function Invalid_Binder_Value return Node_Id is
13503 Val_Id : Entity_Id;
13506 -- Initialize the collection of invalid binder values the first time
13509 Set_Invalid_Binder_Values;
13511 -- Obtain the corresponding variable from System.Scalar_Values which
13512 -- holds the invalid value for this type.
13514 Val_Id := Invalid_Binder_Values (Scal_Typ);
13515 pragma Assert (Present (Val_Id));
13517 return New_Occurrence_Of (Val_Id, Loc);
13518 end Invalid_Binder_Value;
13520 -------------------------
13521 -- Invalid_Float_Value --
13522 -------------------------
13524 function Invalid_Float_Value return Node_Id is
13525 Value : constant Ureal := Invalid_Floats (Scal_Typ);
13528 -- Pragma Invalid_Scalars did not specify an invalid value for this
13529 -- type. Fall back to the value provided by the binder.
13531 if Value = No_Ureal then
13532 return Invalid_Binder_Value;
13534 return Make_Real_Literal (Loc, Realval => Value);
13536 end Invalid_Float_Value;
13538 ---------------------------
13539 -- Invalid_Integer_Value --
13540 ---------------------------
13542 function Invalid_Integer_Value return Node_Id is
13543 Value : constant Uint := Invalid_Integers (Scal_Typ);
13546 -- Pragma Invalid_Scalars did not specify an invalid value for this
13547 -- type. Fall back to the value provided by the binder.
13549 if Value = No_Uint then
13550 return Invalid_Binder_Value;
13552 return Make_Integer_Literal (Loc, Intval => Value);
13554 end Invalid_Integer_Value;
13556 -------------------------------
13557 -- Set_Invalid_Binder_Values --
13558 -------------------------------
13560 procedure Set_Invalid_Binder_Values is
13562 if not Invalid_Binder_Values_Set then
13563 Invalid_Binder_Values_Set := True;
13565 -- Initialize the contents of the collection once since RTE calls
13568 Invalid_Binder_Values :=
13569 (Name_Short_Float => RTE (RE_IS_Isf),
13570 Name_Float => RTE (RE_IS_Ifl),
13571 Name_Long_Float => RTE (RE_IS_Ilf),
13572 Name_Long_Long_Float => RTE (RE_IS_Ill),
13573 Name_Signed_8 => RTE (RE_IS_Is1),
13574 Name_Signed_16 => RTE (RE_IS_Is2),
13575 Name_Signed_32 => RTE (RE_IS_Is4),
13576 Name_Signed_64 => RTE (RE_IS_Is8),
13577 Name_Unsigned_8 => RTE (RE_IS_Iu1),
13578 Name_Unsigned_16 => RTE (RE_IS_Iu2),
13579 Name_Unsigned_32 => RTE (RE_IS_Iu4),
13580 Name_Unsigned_64 => RTE (RE_IS_Iu8));
13582 end Set_Invalid_Binder_Values;
13584 -- Start of processing for Invalid_Scalar_Value
13587 if Scal_Typ in Float_Scalar_Id then
13588 return Invalid_Float_Value;
13590 else pragma Assert (Scal_Typ in Integer_Scalar_Id);
13591 return Invalid_Integer_Value;
13593 end Invalid_Scalar_Value;
13595 -----------------------------
13596 -- Is_Actual_Out_Parameter --
13597 -----------------------------
13599 function Is_Actual_Out_Parameter (N : Node_Id) return Boolean is
13600 Formal : Entity_Id;
13603 Find_Actual (N, Formal, Call);
13604 return Present (Formal) and then Ekind (Formal) = E_Out_Parameter;
13605 end Is_Actual_Out_Parameter;
13607 -------------------------
13608 -- Is_Actual_Parameter --
13609 -------------------------
13611 function Is_Actual_Parameter (N : Node_Id) return Boolean is
13612 PK : constant Node_Kind := Nkind (Parent (N));
13616 when N_Parameter_Association =>
13617 return N = Explicit_Actual_Parameter (Parent (N));
13619 when N_Subprogram_Call =>
13620 return Is_List_Member (N)
13622 List_Containing (N) = Parameter_Associations (Parent (N));
13627 end Is_Actual_Parameter;
13629 --------------------------------
13630 -- Is_Actual_Tagged_Parameter --
13631 --------------------------------
13633 function Is_Actual_Tagged_Parameter (N : Node_Id) return Boolean is
13634 Formal : Entity_Id;
13637 Find_Actual (N, Formal, Call);
13638 return Present (Formal) and then Is_Tagged_Type (Etype (Formal));
13639 end Is_Actual_Tagged_Parameter;
13641 ---------------------
13642 -- Is_Aliased_View --
13643 ---------------------
13645 function Is_Aliased_View (Obj : Node_Id) return Boolean is
13649 if Is_Entity_Name (Obj) then
13656 or else (Present (Renamed_Object (E))
13657 and then Is_Aliased_View (Renamed_Object (E)))))
13659 or else ((Is_Formal (E) or else Is_Formal_Object (E))
13660 and then Is_Tagged_Type (Etype (E)))
13662 or else (Is_Concurrent_Type (E) and then In_Open_Scopes (E))
13664 -- Current instance of type, either directly or as rewritten
13665 -- reference to the current object.
13667 or else (Is_Entity_Name (Original_Node (Obj))
13668 and then Present (Entity (Original_Node (Obj)))
13669 and then Is_Type (Entity (Original_Node (Obj))))
13671 or else (Is_Type (E) and then E = Current_Scope)
13673 or else (Is_Incomplete_Or_Private_Type (E)
13674 and then Full_View (E) = Current_Scope)
13676 -- Ada 2012 AI05-0053: the return object of an extended return
13677 -- statement is aliased if its type is immutably limited.
13679 or else (Is_Return_Object (E)
13680 and then Is_Limited_View (Etype (E)));
13682 elsif Nkind (Obj) = N_Selected_Component then
13683 return Is_Aliased (Entity (Selector_Name (Obj)));
13685 elsif Nkind (Obj) = N_Indexed_Component then
13686 return Has_Aliased_Components (Etype (Prefix (Obj)))
13688 (Is_Access_Type (Etype (Prefix (Obj)))
13689 and then Has_Aliased_Components
13690 (Designated_Type (Etype (Prefix (Obj)))));
13692 elsif Nkind_In (Obj, N_Unchecked_Type_Conversion, N_Type_Conversion) then
13693 return Is_Tagged_Type (Etype (Obj))
13694 and then Is_Aliased_View (Expression (Obj));
13696 elsif Nkind (Obj) = N_Explicit_Dereference then
13697 return Nkind (Original_Node (Obj)) /= N_Function_Call;
13702 end Is_Aliased_View;
13704 -------------------------
13705 -- Is_Ancestor_Package --
13706 -------------------------
13708 function Is_Ancestor_Package
13710 E2 : Entity_Id) return Boolean
13716 while Present (Par) and then Par /= Standard_Standard loop
13721 Par := Scope (Par);
13725 end Is_Ancestor_Package;
13727 ----------------------
13728 -- Is_Atomic_Object --
13729 ----------------------
13731 function Is_Atomic_Object (N : Node_Id) return Boolean is
13732 function Prefix_Has_Atomic_Components (P : Node_Id) return Boolean;
13733 -- Determine whether prefix P has atomic components. This requires the
13734 -- presence of an Atomic_Components aspect/pragma.
13736 ---------------------------------
13737 -- Prefix_Has_Atomic_Components --
13738 ---------------------------------
13740 function Prefix_Has_Atomic_Components (P : Node_Id) return Boolean is
13741 Typ : constant Entity_Id := Etype (P);
13744 if Is_Access_Type (Typ) then
13745 return Has_Atomic_Components (Designated_Type (Typ));
13747 elsif Has_Atomic_Components (Typ) then
13750 elsif Is_Entity_Name (P)
13751 and then Has_Atomic_Components (Entity (P))
13758 end Prefix_Has_Atomic_Components;
13760 -- Start of processing for Is_Atomic_Object
13763 if Is_Entity_Name (N) then
13764 return Is_Atomic_Object_Entity (Entity (N));
13766 elsif Is_Atomic (Etype (N)) then
13769 elsif Nkind (N) = N_Indexed_Component then
13770 return Prefix_Has_Atomic_Components (Prefix (N));
13772 elsif Nkind (N) = N_Selected_Component then
13773 return Is_Atomic (Entity (Selector_Name (N)));
13778 end Is_Atomic_Object;
13780 -----------------------------
13781 -- Is_Atomic_Object_Entity --
13782 -----------------------------
13784 function Is_Atomic_Object_Entity (Id : Entity_Id) return Boolean is
13788 and then (Is_Atomic (Id) or else Is_Atomic (Etype (Id)));
13789 end Is_Atomic_Object_Entity;
13791 -----------------------------
13792 -- Is_Atomic_Or_VFA_Object --
13793 -----------------------------
13795 function Is_Atomic_Or_VFA_Object (N : Node_Id) return Boolean is
13797 return Is_Atomic_Object (N) or else Is_Volatile_Full_Access_Object (N);
13798 end Is_Atomic_Or_VFA_Object;
13800 ----------------------
13801 -- Is_Attribute_Old --
13802 ----------------------
13804 function Is_Attribute_Old (N : Node_Id) return Boolean is
13806 return Nkind (N) = N_Attribute_Reference
13807 and then Attribute_Name (N) = Name_Old;
13808 end Is_Attribute_Old;
13810 -------------------------
13811 -- Is_Attribute_Result --
13812 -------------------------
13814 function Is_Attribute_Result (N : Node_Id) return Boolean is
13816 return Nkind (N) = N_Attribute_Reference
13817 and then Attribute_Name (N) = Name_Result;
13818 end Is_Attribute_Result;
13820 -------------------------
13821 -- Is_Attribute_Update --
13822 -------------------------
13824 function Is_Attribute_Update (N : Node_Id) return Boolean is
13826 return Nkind (N) = N_Attribute_Reference
13827 and then Attribute_Name (N) = Name_Update;
13828 end Is_Attribute_Update;
13830 ------------------------------------
13831 -- Is_Body_Or_Package_Declaration --
13832 ------------------------------------
13834 function Is_Body_Or_Package_Declaration (N : Node_Id) return Boolean is
13836 return Is_Body (N) or else Nkind (N) = N_Package_Declaration;
13837 end Is_Body_Or_Package_Declaration;
13839 -----------------------
13840 -- Is_Bounded_String --
13841 -----------------------
13843 function Is_Bounded_String (T : Entity_Id) return Boolean is
13844 Under : constant Entity_Id := Underlying_Type (Root_Type (T));
13847 -- Check whether T is ultimately derived from Ada.Strings.Superbounded.
13848 -- Super_String, or one of the [Wide_]Wide_ versions. This will
13849 -- be True for all the Bounded_String types in instances of the
13850 -- Generic_Bounded_Length generics, and for types derived from those.
13852 return Present (Under)
13853 and then (Is_RTE (Root_Type (Under), RO_SU_Super_String) or else
13854 Is_RTE (Root_Type (Under), RO_WI_Super_String) or else
13855 Is_RTE (Root_Type (Under), RO_WW_Super_String));
13856 end Is_Bounded_String;
13858 ---------------------
13859 -- Is_CCT_Instance --
13860 ---------------------
13862 function Is_CCT_Instance
13863 (Ref_Id : Entity_Id;
13864 Context_Id : Entity_Id) return Boolean
13867 pragma Assert (Ekind_In (Ref_Id, E_Protected_Type, E_Task_Type));
13869 if Is_Single_Task_Object (Context_Id) then
13870 return Scope_Within_Or_Same (Etype (Context_Id), Ref_Id);
13873 pragma Assert (Ekind_In (Context_Id, E_Entry,
13881 Is_Record_Type (Context_Id));
13882 return Scope_Within_Or_Same (Context_Id, Ref_Id);
13884 end Is_CCT_Instance;
13886 -------------------------
13887 -- Is_Child_Or_Sibling --
13888 -------------------------
13890 function Is_Child_Or_Sibling
13891 (Pack_1 : Entity_Id;
13892 Pack_2 : Entity_Id) return Boolean
13894 function Distance_From_Standard (Pack : Entity_Id) return Nat;
13895 -- Given an arbitrary package, return the number of "climbs" necessary
13896 -- to reach scope Standard_Standard.
13898 procedure Equalize_Depths
13899 (Pack : in out Entity_Id;
13900 Depth : in out Nat;
13901 Depth_To_Reach : Nat);
13902 -- Given an arbitrary package, its depth and a target depth to reach,
13903 -- climb the scope chain until the said depth is reached. The pointer
13904 -- to the package and its depth a modified during the climb.
13906 ----------------------------
13907 -- Distance_From_Standard --
13908 ----------------------------
13910 function Distance_From_Standard (Pack : Entity_Id) return Nat is
13917 while Present (Scop) and then Scop /= Standard_Standard loop
13919 Scop := Scope (Scop);
13923 end Distance_From_Standard;
13925 ---------------------
13926 -- Equalize_Depths --
13927 ---------------------
13929 procedure Equalize_Depths
13930 (Pack : in out Entity_Id;
13931 Depth : in out Nat;
13932 Depth_To_Reach : Nat)
13935 -- The package must be at a greater or equal depth
13937 if Depth < Depth_To_Reach then
13938 raise Program_Error;
13941 -- Climb the scope chain until the desired depth is reached
13943 while Present (Pack) and then Depth /= Depth_To_Reach loop
13944 Pack := Scope (Pack);
13945 Depth := Depth - 1;
13947 end Equalize_Depths;
13951 P_1 : Entity_Id := Pack_1;
13952 P_1_Child : Boolean := False;
13953 P_1_Depth : Nat := Distance_From_Standard (P_1);
13954 P_2 : Entity_Id := Pack_2;
13955 P_2_Child : Boolean := False;
13956 P_2_Depth : Nat := Distance_From_Standard (P_2);
13958 -- Start of processing for Is_Child_Or_Sibling
13962 (Ekind (Pack_1) = E_Package and then Ekind (Pack_2) = E_Package);
13964 -- Both packages denote the same entity, therefore they cannot be
13965 -- children or siblings.
13970 -- One of the packages is at a deeper level than the other. Note that
13971 -- both may still come from different hierarchies.
13979 elsif P_1_Depth > P_2_Depth then
13982 Depth => P_1_Depth,
13983 Depth_To_Reach => P_2_Depth);
13992 elsif P_2_Depth > P_1_Depth then
13995 Depth => P_2_Depth,
13996 Depth_To_Reach => P_1_Depth);
14000 -- At this stage the package pointers have been elevated to the same
14001 -- depth. If the related entities are the same, then one package is a
14002 -- potential child of the other:
14006 -- X became P_1 P_2 or vice versa
14012 return Is_Child_Unit (Pack_1);
14014 else pragma Assert (P_2_Child);
14015 return Is_Child_Unit (Pack_2);
14018 -- The packages may come from the same package chain or from entirely
14019 -- different hierarcies. To determine this, climb the scope stack until
14020 -- a common root is found.
14022 -- (root) (root 1) (root 2)
14027 while Present (P_1) and then Present (P_2) loop
14029 -- The two packages may be siblings
14032 return Is_Child_Unit (Pack_1) and then Is_Child_Unit (Pack_2);
14035 P_1 := Scope (P_1);
14036 P_2 := Scope (P_2);
14041 end Is_Child_Or_Sibling;
14043 -----------------------------
14044 -- Is_Concurrent_Interface --
14045 -----------------------------
14047 function Is_Concurrent_Interface (T : Entity_Id) return Boolean is
14049 return Is_Interface (T)
14051 (Is_Protected_Interface (T)
14052 or else Is_Synchronized_Interface (T)
14053 or else Is_Task_Interface (T));
14054 end Is_Concurrent_Interface;
14056 -----------------------
14057 -- Is_Constant_Bound --
14058 -----------------------
14060 function Is_Constant_Bound (Exp : Node_Id) return Boolean is
14062 if Compile_Time_Known_Value (Exp) then
14065 elsif Is_Entity_Name (Exp) and then Present (Entity (Exp)) then
14066 return Is_Constant_Object (Entity (Exp))
14067 or else Ekind (Entity (Exp)) = E_Enumeration_Literal;
14069 elsif Nkind (Exp) in N_Binary_Op then
14070 return Is_Constant_Bound (Left_Opnd (Exp))
14071 and then Is_Constant_Bound (Right_Opnd (Exp))
14072 and then Scope (Entity (Exp)) = Standard_Standard;
14077 end Is_Constant_Bound;
14079 ---------------------------
14080 -- Is_Container_Element --
14081 ---------------------------
14083 function Is_Container_Element (Exp : Node_Id) return Boolean is
14084 Loc : constant Source_Ptr := Sloc (Exp);
14085 Pref : constant Node_Id := Prefix (Exp);
14088 -- Call to an indexing aspect
14090 Cont_Typ : Entity_Id;
14091 -- The type of the container being accessed
14093 Elem_Typ : Entity_Id;
14094 -- Its element type
14096 Indexing : Entity_Id;
14097 Is_Const : Boolean;
14098 -- Indicates that constant indexing is used, and the element is thus
14101 Ref_Typ : Entity_Id;
14102 -- The reference type returned by the indexing operation
14105 -- If C is a container, in a context that imposes the element type of
14106 -- that container, the indexing notation C (X) is rewritten as:
14108 -- Indexing (C, X).Discr.all
14110 -- where Indexing is one of the indexing aspects of the container.
14111 -- If the context does not require a reference, the construct can be
14116 -- First, verify that the construct has the proper form
14118 if not Expander_Active then
14121 elsif Nkind (Pref) /= N_Selected_Component then
14124 elsif Nkind (Prefix (Pref)) /= N_Function_Call then
14128 Call := Prefix (Pref);
14129 Ref_Typ := Etype (Call);
14132 if not Has_Implicit_Dereference (Ref_Typ)
14133 or else No (First (Parameter_Associations (Call)))
14134 or else not Is_Entity_Name (Name (Call))
14139 -- Retrieve type of container object, and its iterator aspects
14141 Cont_Typ := Etype (First (Parameter_Associations (Call)));
14142 Indexing := Find_Value_Of_Aspect (Cont_Typ, Aspect_Constant_Indexing);
14145 if No (Indexing) then
14147 -- Container should have at least one indexing operation
14151 elsif Entity (Name (Call)) /= Entity (Indexing) then
14153 -- This may be a variable indexing operation
14155 Indexing := Find_Value_Of_Aspect (Cont_Typ, Aspect_Variable_Indexing);
14158 or else Entity (Name (Call)) /= Entity (Indexing)
14167 Elem_Typ := Find_Value_Of_Aspect (Cont_Typ, Aspect_Iterator_Element);
14169 if No (Elem_Typ) or else Entity (Elem_Typ) /= Etype (Exp) then
14173 -- Check that the expression is not the target of an assignment, in
14174 -- which case the rewriting is not possible.
14176 if not Is_Const then
14182 while Present (Par)
14184 if Nkind (Parent (Par)) = N_Assignment_Statement
14185 and then Par = Name (Parent (Par))
14189 -- A renaming produces a reference, and the transformation
14192 elsif Nkind (Parent (Par)) = N_Object_Renaming_Declaration then
14196 (Nkind (Parent (Par)), N_Function_Call,
14197 N_Procedure_Call_Statement,
14198 N_Entry_Call_Statement)
14200 -- Check that the element is not part of an actual for an
14201 -- in-out parameter.
14208 F := First_Formal (Entity (Name (Parent (Par))));
14209 A := First (Parameter_Associations (Parent (Par)));
14210 while Present (F) loop
14211 if A = Par and then Ekind (F) /= E_In_Parameter then
14220 -- E_In_Parameter in a call: element is not modified.
14225 Par := Parent (Par);
14230 -- The expression has the proper form and the context requires the
14231 -- element type. Retrieve the Element function of the container and
14232 -- rewrite the construct as a call to it.
14238 Op := First_Elmt (Primitive_Operations (Cont_Typ));
14239 while Present (Op) loop
14240 exit when Chars (Node (Op)) = Name_Element;
14249 Make_Function_Call (Loc,
14250 Name => New_Occurrence_Of (Node (Op), Loc),
14251 Parameter_Associations => Parameter_Associations (Call)));
14252 Analyze_And_Resolve (Exp, Entity (Elem_Typ));
14256 end Is_Container_Element;
14258 ----------------------------
14259 -- Is_Contract_Annotation --
14260 ----------------------------
14262 function Is_Contract_Annotation (Item : Node_Id) return Boolean is
14264 return Is_Package_Contract_Annotation (Item)
14266 Is_Subprogram_Contract_Annotation (Item);
14267 end Is_Contract_Annotation;
14269 --------------------------------------
14270 -- Is_Controlling_Limited_Procedure --
14271 --------------------------------------
14273 function Is_Controlling_Limited_Procedure
14274 (Proc_Nam : Entity_Id) return Boolean
14277 Param_Typ : Entity_Id := Empty;
14280 if Ekind (Proc_Nam) = E_Procedure
14281 and then Present (Parameter_Specifications (Parent (Proc_Nam)))
14285 (First (Parameter_Specifications (Parent (Proc_Nam))));
14287 -- The formal may be an anonymous access type
14289 if Nkind (Param) = N_Access_Definition then
14290 Param_Typ := Entity (Subtype_Mark (Param));
14292 Param_Typ := Etype (Param);
14295 -- In the case where an Itype was created for a dispatchin call, the
14296 -- procedure call has been rewritten. The actual may be an access to
14297 -- interface type in which case it is the designated type that is the
14298 -- controlling type.
14300 elsif Present (Associated_Node_For_Itype (Proc_Nam))
14301 and then Present (Original_Node (Associated_Node_For_Itype (Proc_Nam)))
14303 Present (Parameter_Associations
14304 (Associated_Node_For_Itype (Proc_Nam)))
14307 Etype (First (Parameter_Associations
14308 (Associated_Node_For_Itype (Proc_Nam))));
14310 if Ekind (Param_Typ) = E_Anonymous_Access_Type then
14311 Param_Typ := Directly_Designated_Type (Param_Typ);
14315 if Present (Param_Typ) then
14317 Is_Interface (Param_Typ)
14318 and then Is_Limited_Record (Param_Typ);
14322 end Is_Controlling_Limited_Procedure;
14324 -----------------------------
14325 -- Is_CPP_Constructor_Call --
14326 -----------------------------
14328 function Is_CPP_Constructor_Call (N : Node_Id) return Boolean is
14330 return Nkind (N) = N_Function_Call
14331 and then Is_CPP_Class (Etype (Etype (N)))
14332 and then Is_Constructor (Entity (Name (N)))
14333 and then Is_Imported (Entity (Name (N)));
14334 end Is_CPP_Constructor_Call;
14336 -------------------------
14337 -- Is_Current_Instance --
14338 -------------------------
14340 function Is_Current_Instance (N : Node_Id) return Boolean is
14341 Typ : constant Entity_Id := Entity (N);
14345 -- Simplest case: entity is a concurrent type and we are currently
14346 -- inside the body. This will eventually be expanded into a call to
14347 -- Self (for tasks) or _object (for protected objects).
14349 if Is_Concurrent_Type (Typ) and then In_Open_Scopes (Typ) then
14353 -- Check whether the context is a (sub)type declaration for the
14357 while Present (P) loop
14358 if Nkind_In (P, N_Full_Type_Declaration,
14359 N_Private_Type_Declaration,
14360 N_Subtype_Declaration)
14361 and then Comes_From_Source (P)
14362 and then Defining_Entity (P) = Typ
14366 -- A subtype name may appear in an aspect specification for a
14367 -- Predicate_Failure aspect, for which we do not construct a
14368 -- wrapper procedure. The subtype will be replaced by the
14369 -- expression being tested when the corresponding predicate
14370 -- check is expanded.
14372 elsif Nkind (P) = N_Aspect_Specification
14373 and then Nkind (Parent (P)) = N_Subtype_Declaration
14377 elsif Nkind (P) = N_Pragma
14378 and then Get_Pragma_Id (P) = Pragma_Predicate_Failure
14387 -- In any other context this is not a current occurrence
14390 end Is_Current_Instance;
14392 --------------------
14393 -- Is_Declaration --
14394 --------------------
14396 function Is_Declaration
14398 Body_OK : Boolean := True;
14399 Concurrent_OK : Boolean := True;
14400 Formal_OK : Boolean := True;
14401 Generic_OK : Boolean := True;
14402 Instantiation_OK : Boolean := True;
14403 Renaming_OK : Boolean := True;
14404 Stub_OK : Boolean := True;
14405 Subprogram_OK : Boolean := True;
14406 Type_OK : Boolean := True) return Boolean
14411 -- Body declarations
14413 when N_Proper_Body =>
14416 -- Concurrent type declarations
14418 when N_Protected_Type_Declaration
14419 | N_Single_Protected_Declaration
14420 | N_Single_Task_Declaration
14421 | N_Task_Type_Declaration
14423 return Concurrent_OK or Type_OK;
14425 -- Formal declarations
14427 when N_Formal_Abstract_Subprogram_Declaration
14428 | N_Formal_Concrete_Subprogram_Declaration
14429 | N_Formal_Object_Declaration
14430 | N_Formal_Package_Declaration
14431 | N_Formal_Type_Declaration
14435 -- Generic declarations
14437 when N_Generic_Package_Declaration
14438 | N_Generic_Subprogram_Declaration
14442 -- Generic instantiations
14444 when N_Function_Instantiation
14445 | N_Package_Instantiation
14446 | N_Procedure_Instantiation
14448 return Instantiation_OK;
14450 -- Generic renaming declarations
14452 when N_Generic_Renaming_Declaration =>
14453 return Generic_OK or Renaming_OK;
14455 -- Renaming declarations
14457 when N_Exception_Renaming_Declaration
14458 | N_Object_Renaming_Declaration
14459 | N_Package_Renaming_Declaration
14460 | N_Subprogram_Renaming_Declaration
14462 return Renaming_OK;
14464 -- Stub declarations
14466 when N_Body_Stub =>
14469 -- Subprogram declarations
14471 when N_Abstract_Subprogram_Declaration
14472 | N_Entry_Declaration
14473 | N_Expression_Function
14474 | N_Subprogram_Declaration
14476 return Subprogram_OK;
14478 -- Type declarations
14480 when N_Full_Type_Declaration
14481 | N_Incomplete_Type_Declaration
14482 | N_Private_Extension_Declaration
14483 | N_Private_Type_Declaration
14484 | N_Subtype_Declaration
14490 when N_Component_Declaration
14491 | N_Exception_Declaration
14492 | N_Implicit_Label_Declaration
14493 | N_Number_Declaration
14494 | N_Object_Declaration
14495 | N_Package_Declaration
14502 end Is_Declaration;
14504 --------------------------------
14505 -- Is_Declared_Within_Variant --
14506 --------------------------------
14508 function Is_Declared_Within_Variant (Comp : Entity_Id) return Boolean is
14509 Comp_Decl : constant Node_Id := Parent (Comp);
14510 Comp_List : constant Node_Id := Parent (Comp_Decl);
14512 return Nkind (Parent (Comp_List)) = N_Variant;
14513 end Is_Declared_Within_Variant;
14515 ----------------------------------------------
14516 -- Is_Dependent_Component_Of_Mutable_Object --
14517 ----------------------------------------------
14519 function Is_Dependent_Component_Of_Mutable_Object
14520 (Object : Node_Id) return Boolean
14523 Prefix_Type : Entity_Id;
14524 P_Aliased : Boolean := False;
14527 Deref : Node_Id := Object;
14528 -- Dereference node, in something like X.all.Y(2)
14530 -- Start of processing for Is_Dependent_Component_Of_Mutable_Object
14533 -- Find the dereference node if any
14535 while Nkind_In (Deref, N_Indexed_Component,
14536 N_Selected_Component,
14539 Deref := Prefix (Deref);
14542 -- If the prefix is a qualified expression of a variable, then function
14543 -- Is_Variable will return False for that because a qualified expression
14544 -- denotes a constant view, so we need to get the name being qualified
14545 -- so we can test below whether that's a variable (or a dereference).
14547 if Nkind (Deref) = N_Qualified_Expression then
14548 Deref := Expression (Deref);
14551 -- Ada 2005: If we have a component or slice of a dereference, something
14552 -- like X.all.Y (2) and the type of X is access-to-constant, Is_Variable
14553 -- will return False, because it is indeed a constant view. But it might
14554 -- be a view of a variable object, so we want the following condition to
14555 -- be True in that case.
14557 if Is_Variable (Object)
14558 or else Is_Variable (Deref)
14559 or else (Ada_Version >= Ada_2005
14560 and then (Nkind (Deref) = N_Explicit_Dereference
14561 or else Is_Access_Type (Etype (Deref))))
14563 if Nkind (Object) = N_Selected_Component then
14565 -- If the selector is not a component, then we definitely return
14566 -- False (it could be a function selector in a prefix form call
14567 -- occurring in an iterator specification).
14569 if not Ekind_In (Entity (Selector_Name (Object)), E_Component,
14575 -- Get the original node of the prefix in case it has been
14576 -- rewritten, which can occur, for example, in qualified
14577 -- expression cases. Also, a discriminant check on a selected
14578 -- component may be expanded into a dereference when removing
14579 -- side effects, and the subtype of the original node may be
14582 P := Original_Node (Prefix (Object));
14583 Prefix_Type := Etype (P);
14585 -- If the prefix is a qualified expression, we want to look at its
14588 if Nkind (P) = N_Qualified_Expression then
14589 P := Expression (P);
14590 Prefix_Type := Etype (P);
14593 if Is_Entity_Name (P) then
14594 if Ekind (Entity (P)) = E_Generic_In_Out_Parameter then
14595 Prefix_Type := Base_Type (Prefix_Type);
14598 if Is_Aliased (Entity (P)) then
14602 -- For explicit dereferences we get the access prefix so we can
14603 -- treat this similarly to implicit dereferences and examine the
14604 -- kind of the access type and its designated subtype further
14607 elsif Nkind (P) = N_Explicit_Dereference then
14609 Prefix_Type := Etype (P);
14612 -- Check for prefix being an aliased component???
14617 -- A heap object is constrained by its initial value
14619 -- Ada 2005 (AI-363): Always assume the object could be mutable in
14620 -- the dereferenced case, since the access value might denote an
14621 -- unconstrained aliased object, whereas in Ada 95 the designated
14622 -- object is guaranteed to be constrained. A worst-case assumption
14623 -- has to apply in Ada 2005 because we can't tell at compile
14624 -- time whether the object is "constrained by its initial value",
14625 -- despite the fact that 3.10.2(26/2) and 8.5.1(5/2) are semantic
14626 -- rules (these rules are acknowledged to need fixing). We don't
14627 -- impose this more stringent checking for earlier Ada versions or
14628 -- when Relaxed_RM_Semantics applies (the latter for CodePeer's
14629 -- benefit, though it's unclear on why using -gnat95 would not be
14632 if Ada_Version < Ada_2005 or else Relaxed_RM_Semantics then
14633 if Is_Access_Type (Prefix_Type)
14634 or else Nkind (P) = N_Explicit_Dereference
14639 else pragma Assert (Ada_Version >= Ada_2005);
14640 if Is_Access_Type (Prefix_Type) then
14641 -- We need to make sure we have the base subtype, in case
14642 -- this is actually an access subtype (whose Ekind will be
14643 -- E_Access_Subtype).
14645 Prefix_Type := Etype (Prefix_Type);
14647 -- If the access type is pool-specific, and there is no
14648 -- constrained partial view of the designated type, then the
14649 -- designated object is known to be constrained. If it's a
14650 -- formal access type and the renaming is in the generic
14651 -- spec, we also treat it as pool-specific (known to be
14652 -- constrained), but assume the worst if in the generic body
14653 -- (see RM 3.3(23.3/3)).
14655 if Ekind (Prefix_Type) = E_Access_Type
14656 and then (not Is_Generic_Type (Prefix_Type)
14657 or else not In_Generic_Body (Current_Scope))
14658 and then not Object_Type_Has_Constrained_Partial_View
14659 (Typ => Designated_Type (Prefix_Type),
14660 Scop => Current_Scope)
14664 -- Otherwise (general access type, or there is a constrained
14665 -- partial view of the designated type), we need to check
14666 -- based on the designated type.
14669 Prefix_Type := Designated_Type (Prefix_Type);
14675 Original_Record_Component (Entity (Selector_Name (Object)));
14677 -- As per AI-0017, the renaming is illegal in a generic body, even
14678 -- if the subtype is indefinite (only applies to prefixes of an
14679 -- untagged formal type, see RM 3.3 (23.11/3)).
14681 -- Ada 2005 (AI-363): In Ada 2005 an aliased object can be mutable
14683 if not Is_Constrained (Prefix_Type)
14684 and then (Is_Definite_Subtype (Prefix_Type)
14686 (not Is_Tagged_Type (Prefix_Type)
14687 and then Is_Generic_Type (Prefix_Type)
14688 and then In_Generic_Body (Current_Scope)))
14690 and then (Is_Declared_Within_Variant (Comp)
14691 or else Has_Discriminant_Dependent_Constraint (Comp))
14692 and then (not P_Aliased or else Ada_Version >= Ada_2005)
14696 -- If the prefix is of an access type at this point, then we want
14697 -- to return False, rather than calling this function recursively
14698 -- on the access object (which itself might be a discriminant-
14699 -- dependent component of some other object, but that isn't
14700 -- relevant to checking the object passed to us). This avoids
14701 -- issuing wrong errors when compiling with -gnatc, where there
14702 -- can be implicit dereferences that have not been expanded.
14704 elsif Is_Access_Type (Etype (Prefix (Object))) then
14709 Is_Dependent_Component_Of_Mutable_Object (Prefix (Object));
14712 elsif Nkind (Object) = N_Indexed_Component
14713 or else Nkind (Object) = N_Slice
14715 return Is_Dependent_Component_Of_Mutable_Object (Prefix (Object));
14717 -- A type conversion that Is_Variable is a view conversion:
14718 -- go back to the denoted object.
14720 elsif Nkind (Object) = N_Type_Conversion then
14722 Is_Dependent_Component_Of_Mutable_Object (Expression (Object));
14727 end Is_Dependent_Component_Of_Mutable_Object;
14729 ---------------------
14730 -- Is_Dereferenced --
14731 ---------------------
14733 function Is_Dereferenced (N : Node_Id) return Boolean is
14734 P : constant Node_Id := Parent (N);
14736 return Nkind_In (P, N_Selected_Component,
14737 N_Explicit_Dereference,
14738 N_Indexed_Component,
14740 and then Prefix (P) = N;
14741 end Is_Dereferenced;
14743 ----------------------
14744 -- Is_Descendant_Of --
14745 ----------------------
14747 function Is_Descendant_Of (T1 : Entity_Id; T2 : Entity_Id) return Boolean is
14752 pragma Assert (Nkind (T1) in N_Entity);
14753 pragma Assert (Nkind (T2) in N_Entity);
14755 T := Base_Type (T1);
14757 -- Immediate return if the types match
14762 -- Comment needed here ???
14764 elsif Ekind (T) = E_Class_Wide_Type then
14765 return Etype (T) = T2;
14773 -- Done if we found the type we are looking for
14778 -- Done if no more derivations to check
14785 -- Following test catches error cases resulting from prev errors
14787 elsif No (Etyp) then
14790 elsif Is_Private_Type (T) and then Etyp = Full_View (T) then
14793 elsif Is_Private_Type (Etyp) and then Full_View (Etyp) = T then
14797 T := Base_Type (Etyp);
14800 end Is_Descendant_Of;
14802 ----------------------------------------
14803 -- Is_Descendant_Of_Suspension_Object --
14804 ----------------------------------------
14806 function Is_Descendant_Of_Suspension_Object
14807 (Typ : Entity_Id) return Boolean
14809 Cur_Typ : Entity_Id;
14810 Par_Typ : Entity_Id;
14813 -- Climb the type derivation chain checking each parent type against
14814 -- Suspension_Object.
14816 Cur_Typ := Base_Type (Typ);
14817 while Present (Cur_Typ) loop
14818 Par_Typ := Etype (Cur_Typ);
14820 -- The current type is a match
14822 if Is_Suspension_Object (Cur_Typ) then
14825 -- Stop the traversal once the root of the derivation chain has been
14826 -- reached. In that case the current type is its own base type.
14828 elsif Cur_Typ = Par_Typ then
14832 Cur_Typ := Base_Type (Par_Typ);
14836 end Is_Descendant_Of_Suspension_Object;
14838 ---------------------------------------------
14839 -- Is_Double_Precision_Floating_Point_Type --
14840 ---------------------------------------------
14842 function Is_Double_Precision_Floating_Point_Type
14843 (E : Entity_Id) return Boolean is
14845 return Is_Floating_Point_Type (E)
14846 and then Machine_Radix_Value (E) = Uint_2
14847 and then Machine_Mantissa_Value (E) = UI_From_Int (53)
14848 and then Machine_Emax_Value (E) = Uint_2 ** Uint_10
14849 and then Machine_Emin_Value (E) = Uint_3 - (Uint_2 ** Uint_10);
14850 end Is_Double_Precision_Floating_Point_Type;
14852 -----------------------------
14853 -- Is_Effectively_Volatile --
14854 -----------------------------
14856 function Is_Effectively_Volatile (Id : Entity_Id) return Boolean is
14858 if Is_Type (Id) then
14860 -- An arbitrary type is effectively volatile when it is subject to
14861 -- pragma Atomic or Volatile.
14863 if Is_Volatile (Id) then
14866 -- An array type is effectively volatile when it is subject to pragma
14867 -- Atomic_Components or Volatile_Components or its component type is
14868 -- effectively volatile.
14870 elsif Is_Array_Type (Id) then
14872 Anc : Entity_Id := Base_Type (Id);
14874 if Is_Private_Type (Anc) then
14875 Anc := Full_View (Anc);
14878 -- Test for presence of ancestor, as the full view of a private
14879 -- type may be missing in case of error.
14882 Has_Volatile_Components (Id)
14885 and then Is_Effectively_Volatile (Component_Type (Anc)));
14888 -- A protected type is always volatile
14890 elsif Is_Protected_Type (Id) then
14893 -- A descendant of Ada.Synchronous_Task_Control.Suspension_Object is
14894 -- automatically volatile.
14896 elsif Is_Descendant_Of_Suspension_Object (Id) then
14899 -- Otherwise the type is not effectively volatile
14905 -- Otherwise Id denotes an object
14908 -- A volatile object for which No_Caching is enabled is not
14909 -- effectively volatile.
14912 (Is_Volatile (Id) and then not No_Caching_Enabled (Id))
14913 or else Has_Volatile_Components (Id)
14914 or else Is_Effectively_Volatile (Etype (Id));
14916 end Is_Effectively_Volatile;
14918 ------------------------------------
14919 -- Is_Effectively_Volatile_Object --
14920 ------------------------------------
14922 function Is_Effectively_Volatile_Object (N : Node_Id) return Boolean is
14924 if Is_Entity_Name (N) then
14925 return Is_Effectively_Volatile (Entity (N));
14927 elsif Nkind (N) = N_Indexed_Component then
14928 return Is_Effectively_Volatile_Object (Prefix (N));
14930 elsif Nkind (N) = N_Selected_Component then
14932 Is_Effectively_Volatile_Object (Prefix (N))
14934 Is_Effectively_Volatile_Object (Selector_Name (N));
14939 end Is_Effectively_Volatile_Object;
14941 -------------------
14942 -- Is_Entry_Body --
14943 -------------------
14945 function Is_Entry_Body (Id : Entity_Id) return Boolean is
14948 Ekind_In (Id, E_Entry, E_Entry_Family)
14949 and then Nkind (Unit_Declaration_Node (Id)) = N_Entry_Body;
14952 --------------------------
14953 -- Is_Entry_Declaration --
14954 --------------------------
14956 function Is_Entry_Declaration (Id : Entity_Id) return Boolean is
14959 Ekind_In (Id, E_Entry, E_Entry_Family)
14960 and then Nkind (Unit_Declaration_Node (Id)) = N_Entry_Declaration;
14961 end Is_Entry_Declaration;
14963 ------------------------------------
14964 -- Is_Expanded_Priority_Attribute --
14965 ------------------------------------
14967 function Is_Expanded_Priority_Attribute (E : Entity_Id) return Boolean is
14970 Nkind (E) = N_Function_Call
14971 and then not Configurable_Run_Time_Mode
14972 and then Nkind (Original_Node (E)) = N_Attribute_Reference
14973 and then (Entity (Name (E)) = RTE (RE_Get_Ceiling)
14974 or else Entity (Name (E)) = RTE (RO_PE_Get_Ceiling));
14975 end Is_Expanded_Priority_Attribute;
14977 ----------------------------
14978 -- Is_Expression_Function --
14979 ----------------------------
14981 function Is_Expression_Function (Subp : Entity_Id) return Boolean is
14983 if Ekind_In (Subp, E_Function, E_Subprogram_Body) then
14985 Nkind (Original_Node (Unit_Declaration_Node (Subp))) =
14986 N_Expression_Function;
14990 end Is_Expression_Function;
14992 ------------------------------------------
14993 -- Is_Expression_Function_Or_Completion --
14994 ------------------------------------------
14996 function Is_Expression_Function_Or_Completion
14997 (Subp : Entity_Id) return Boolean
14999 Subp_Decl : Node_Id;
15002 if Ekind (Subp) = E_Function then
15003 Subp_Decl := Unit_Declaration_Node (Subp);
15005 -- The function declaration is either an expression function or is
15006 -- completed by an expression function body.
15009 Is_Expression_Function (Subp)
15010 or else (Nkind (Subp_Decl) = N_Subprogram_Declaration
15011 and then Present (Corresponding_Body (Subp_Decl))
15012 and then Is_Expression_Function
15013 (Corresponding_Body (Subp_Decl)));
15015 elsif Ekind (Subp) = E_Subprogram_Body then
15016 return Is_Expression_Function (Subp);
15021 end Is_Expression_Function_Or_Completion;
15023 -----------------------
15024 -- Is_EVF_Expression --
15025 -----------------------
15027 function Is_EVF_Expression (N : Node_Id) return Boolean is
15028 Orig_N : constant Node_Id := Original_Node (N);
15034 -- Detect a reference to a formal parameter of a specific tagged type
15035 -- whose related subprogram is subject to pragma Expresions_Visible with
15038 if Is_Entity_Name (N) and then Present (Entity (N)) then
15043 and then Is_Specific_Tagged_Type (Etype (Id))
15044 and then Extensions_Visible_Status (Id) =
15045 Extensions_Visible_False;
15047 -- A case expression is an EVF expression when it contains at least one
15048 -- EVF dependent_expression. Note that a case expression may have been
15049 -- expanded, hence the use of Original_Node.
15051 elsif Nkind (Orig_N) = N_Case_Expression then
15052 Alt := First (Alternatives (Orig_N));
15053 while Present (Alt) loop
15054 if Is_EVF_Expression (Expression (Alt)) then
15061 -- An if expression is an EVF expression when it contains at least one
15062 -- EVF dependent_expression. Note that an if expression may have been
15063 -- expanded, hence the use of Original_Node.
15065 elsif Nkind (Orig_N) = N_If_Expression then
15066 Expr := Next (First (Expressions (Orig_N)));
15067 while Present (Expr) loop
15068 if Is_EVF_Expression (Expr) then
15075 -- A qualified expression or a type conversion is an EVF expression when
15076 -- its operand is an EVF expression.
15078 elsif Nkind_In (N, N_Qualified_Expression,
15079 N_Unchecked_Type_Conversion,
15082 return Is_EVF_Expression (Expression (N));
15084 -- Attributes 'Loop_Entry, 'Old, and 'Update are EVF expressions when
15085 -- their prefix denotes an EVF expression.
15087 elsif Nkind (N) = N_Attribute_Reference
15088 and then Nam_In (Attribute_Name (N), Name_Loop_Entry,
15092 return Is_EVF_Expression (Prefix (N));
15096 end Is_EVF_Expression;
15102 function Is_False (U : Uint) return Boolean is
15107 ---------------------------
15108 -- Is_Fixed_Model_Number --
15109 ---------------------------
15111 function Is_Fixed_Model_Number (U : Ureal; T : Entity_Id) return Boolean is
15112 S : constant Ureal := Small_Value (T);
15113 M : Urealp.Save_Mark;
15118 R := (U = UR_Trunc (U / S) * S);
15119 Urealp.Release (M);
15121 end Is_Fixed_Model_Number;
15123 -------------------------------
15124 -- Is_Fully_Initialized_Type --
15125 -------------------------------
15127 function Is_Fully_Initialized_Type (Typ : Entity_Id) return Boolean is
15131 if Is_Scalar_Type (Typ) then
15133 -- A scalar type with an aspect Default_Value is fully initialized
15135 -- Note: Iniitalize/Normalize_Scalars also ensure full initialization
15136 -- of a scalar type, but we don't take that into account here, since
15137 -- we don't want these to affect warnings.
15139 return Has_Default_Aspect (Typ);
15141 elsif Is_Access_Type (Typ) then
15144 elsif Is_Array_Type (Typ) then
15145 if Is_Fully_Initialized_Type (Component_Type (Typ))
15146 or else (Ada_Version >= Ada_2012 and then Has_Default_Aspect (Typ))
15151 -- An interesting case, if we have a constrained type one of whose
15152 -- bounds is known to be null, then there are no elements to be
15153 -- initialized, so all the elements are initialized.
15155 if Is_Constrained (Typ) then
15158 Indx_Typ : Entity_Id;
15159 Lbd, Hbd : Node_Id;
15162 Indx := First_Index (Typ);
15163 while Present (Indx) loop
15164 if Etype (Indx) = Any_Type then
15167 -- If index is a range, use directly
15169 elsif Nkind (Indx) = N_Range then
15170 Lbd := Low_Bound (Indx);
15171 Hbd := High_Bound (Indx);
15174 Indx_Typ := Etype (Indx);
15176 if Is_Private_Type (Indx_Typ) then
15177 Indx_Typ := Full_View (Indx_Typ);
15180 if No (Indx_Typ) or else Etype (Indx_Typ) = Any_Type then
15183 Lbd := Type_Low_Bound (Indx_Typ);
15184 Hbd := Type_High_Bound (Indx_Typ);
15188 if Compile_Time_Known_Value (Lbd)
15190 Compile_Time_Known_Value (Hbd)
15192 if Expr_Value (Hbd) < Expr_Value (Lbd) then
15202 -- If no null indexes, then type is not fully initialized
15208 elsif Is_Record_Type (Typ) then
15209 if Has_Discriminants (Typ)
15211 Present (Discriminant_Default_Value (First_Discriminant (Typ)))
15212 and then Is_Fully_Initialized_Variant (Typ)
15217 -- We consider bounded string types to be fully initialized, because
15218 -- otherwise we get false alarms when the Data component is not
15219 -- default-initialized.
15221 if Is_Bounded_String (Typ) then
15225 -- Controlled records are considered to be fully initialized if
15226 -- there is a user defined Initialize routine. This may not be
15227 -- entirely correct, but as the spec notes, we are guessing here
15228 -- what is best from the point of view of issuing warnings.
15230 if Is_Controlled (Typ) then
15232 Utyp : constant Entity_Id := Underlying_Type (Typ);
15235 if Present (Utyp) then
15237 Init : constant Entity_Id :=
15238 (Find_Optional_Prim_Op
15239 (Underlying_Type (Typ), Name_Initialize));
15243 and then Comes_From_Source (Init)
15244 and then not In_Predefined_Unit (Init)
15248 elsif Has_Null_Extension (Typ)
15250 Is_Fully_Initialized_Type
15251 (Etype (Base_Type (Typ)))
15260 -- Otherwise see if all record components are initialized
15266 Ent := First_Entity (Typ);
15267 while Present (Ent) loop
15268 if Ekind (Ent) = E_Component
15269 and then (No (Parent (Ent))
15270 or else No (Expression (Parent (Ent))))
15271 and then not Is_Fully_Initialized_Type (Etype (Ent))
15273 -- Special VM case for tag components, which need to be
15274 -- defined in this case, but are never initialized as VMs
15275 -- are using other dispatching mechanisms. Ignore this
15276 -- uninitialized case. Note that this applies both to the
15277 -- uTag entry and the main vtable pointer (CPP_Class case).
15279 and then (Tagged_Type_Expansion or else not Is_Tag (Ent))
15288 -- No uninitialized components, so type is fully initialized.
15289 -- Note that this catches the case of no components as well.
15293 elsif Is_Concurrent_Type (Typ) then
15296 elsif Is_Private_Type (Typ) then
15298 U : constant Entity_Id := Underlying_Type (Typ);
15304 return Is_Fully_Initialized_Type (U);
15311 end Is_Fully_Initialized_Type;
15313 ----------------------------------
15314 -- Is_Fully_Initialized_Variant --
15315 ----------------------------------
15317 function Is_Fully_Initialized_Variant (Typ : Entity_Id) return Boolean is
15318 Loc : constant Source_Ptr := Sloc (Typ);
15319 Constraints : constant List_Id := New_List;
15320 Components : constant Elist_Id := New_Elmt_List;
15321 Comp_Elmt : Elmt_Id;
15323 Comp_List : Node_Id;
15325 Discr_Val : Node_Id;
15327 Report_Errors : Boolean;
15328 pragma Warnings (Off, Report_Errors);
15331 if Serious_Errors_Detected > 0 then
15335 if Is_Record_Type (Typ)
15336 and then Nkind (Parent (Typ)) = N_Full_Type_Declaration
15337 and then Nkind (Type_Definition (Parent (Typ))) = N_Record_Definition
15339 Comp_List := Component_List (Type_Definition (Parent (Typ)));
15341 Discr := First_Discriminant (Typ);
15342 while Present (Discr) loop
15343 if Nkind (Parent (Discr)) = N_Discriminant_Specification then
15344 Discr_Val := Expression (Parent (Discr));
15346 if Present (Discr_Val)
15347 and then Is_OK_Static_Expression (Discr_Val)
15349 Append_To (Constraints,
15350 Make_Component_Association (Loc,
15351 Choices => New_List (New_Occurrence_Of (Discr, Loc)),
15352 Expression => New_Copy (Discr_Val)));
15360 Next_Discriminant (Discr);
15365 Comp_List => Comp_List,
15366 Governed_By => Constraints,
15367 Into => Components,
15368 Report_Errors => Report_Errors);
15370 -- Check that each component present is fully initialized
15372 Comp_Elmt := First_Elmt (Components);
15373 while Present (Comp_Elmt) loop
15374 Comp_Id := Node (Comp_Elmt);
15376 if Ekind (Comp_Id) = E_Component
15377 and then (No (Parent (Comp_Id))
15378 or else No (Expression (Parent (Comp_Id))))
15379 and then not Is_Fully_Initialized_Type (Etype (Comp_Id))
15384 Next_Elmt (Comp_Elmt);
15389 elsif Is_Private_Type (Typ) then
15391 U : constant Entity_Id := Underlying_Type (Typ);
15397 return Is_Fully_Initialized_Variant (U);
15404 end Is_Fully_Initialized_Variant;
15406 ------------------------------------
15407 -- Is_Generic_Declaration_Or_Body --
15408 ------------------------------------
15410 function Is_Generic_Declaration_Or_Body (Decl : Node_Id) return Boolean is
15411 Spec_Decl : Node_Id;
15414 -- Package/subprogram body
15416 if Nkind_In (Decl, N_Package_Body, N_Subprogram_Body)
15417 and then Present (Corresponding_Spec (Decl))
15419 Spec_Decl := Unit_Declaration_Node (Corresponding_Spec (Decl));
15421 -- Package/subprogram body stub
15423 elsif Nkind_In (Decl, N_Package_Body_Stub, N_Subprogram_Body_Stub)
15424 and then Present (Corresponding_Spec_Of_Stub (Decl))
15427 Unit_Declaration_Node (Corresponding_Spec_Of_Stub (Decl));
15435 -- Rather than inspecting the defining entity of the spec declaration,
15436 -- look at its Nkind. This takes care of the case where the analysis of
15437 -- a generic body modifies the Ekind of its spec to allow for recursive
15441 Nkind_In (Spec_Decl, N_Generic_Package_Declaration,
15442 N_Generic_Subprogram_Declaration);
15443 end Is_Generic_Declaration_Or_Body;
15445 ---------------------------
15446 -- Is_Independent_Object --
15447 ---------------------------
15449 function Is_Independent_Object (N : Node_Id) return Boolean is
15450 function Is_Independent_Object_Entity (Id : Entity_Id) return Boolean;
15451 -- Determine whether arbitrary entity Id denotes an object that is
15454 function Prefix_Has_Independent_Components (P : Node_Id) return Boolean;
15455 -- Determine whether prefix P has independent components. This requires
15456 -- the presence of an Independent_Components aspect/pragma.
15458 ------------------------------------
15459 -- Is_Independent_Object_Entity --
15460 ------------------------------------
15462 function Is_Independent_Object_Entity (Id : Entity_Id) return Boolean is
15466 and then (Is_Independent (Id)
15468 Is_Independent (Etype (Id)));
15469 end Is_Independent_Object_Entity;
15471 -------------------------------------
15472 -- Prefix_Has_Independent_Components --
15473 -------------------------------------
15475 function Prefix_Has_Independent_Components (P : Node_Id) return Boolean
15477 Typ : constant Entity_Id := Etype (P);
15480 if Is_Access_Type (Typ) then
15481 return Has_Independent_Components (Designated_Type (Typ));
15483 elsif Has_Independent_Components (Typ) then
15486 elsif Is_Entity_Name (P)
15487 and then Has_Independent_Components (Entity (P))
15494 end Prefix_Has_Independent_Components;
15496 -- Start of processing for Is_Independent_Object
15499 if Is_Entity_Name (N) then
15500 return Is_Independent_Object_Entity (Entity (N));
15502 elsif Is_Independent (Etype (N)) then
15505 elsif Nkind (N) = N_Indexed_Component then
15506 return Prefix_Has_Independent_Components (Prefix (N));
15508 elsif Nkind (N) = N_Selected_Component then
15509 return Prefix_Has_Independent_Components (Prefix (N))
15510 or else Is_Independent (Entity (Selector_Name (N)));
15515 end Is_Independent_Object;
15517 ----------------------------
15518 -- Is_Inherited_Operation --
15519 ----------------------------
15521 function Is_Inherited_Operation (E : Entity_Id) return Boolean is
15522 pragma Assert (Is_Overloadable (E));
15523 Kind : constant Node_Kind := Nkind (Parent (E));
15525 return Kind = N_Full_Type_Declaration
15526 or else Kind = N_Private_Extension_Declaration
15527 or else Kind = N_Subtype_Declaration
15528 or else (Ekind (E) = E_Enumeration_Literal
15529 and then Is_Derived_Type (Etype (E)));
15530 end Is_Inherited_Operation;
15532 -------------------------------------
15533 -- Is_Inherited_Operation_For_Type --
15534 -------------------------------------
15536 function Is_Inherited_Operation_For_Type
15538 Typ : Entity_Id) return Boolean
15541 -- Check that the operation has been created by the type declaration
15543 return Is_Inherited_Operation (E)
15544 and then Defining_Identifier (Parent (E)) = Typ;
15545 end Is_Inherited_Operation_For_Type;
15547 --------------------------------------
15548 -- Is_Inlinable_Expression_Function --
15549 --------------------------------------
15551 function Is_Inlinable_Expression_Function
15552 (Subp : Entity_Id) return Boolean
15554 Return_Expr : Node_Id;
15557 if Is_Expression_Function_Or_Completion (Subp)
15558 and then Has_Pragma_Inline_Always (Subp)
15559 and then Needs_No_Actuals (Subp)
15560 and then No (Contract (Subp))
15561 and then not Is_Dispatching_Operation (Subp)
15562 and then Needs_Finalization (Etype (Subp))
15563 and then not Is_Class_Wide_Type (Etype (Subp))
15564 and then not (Has_Invariants (Etype (Subp)))
15565 and then Present (Subprogram_Body (Subp))
15566 and then Was_Expression_Function (Subprogram_Body (Subp))
15568 Return_Expr := Expression_Of_Expression_Function (Subp);
15570 -- The returned object must not have a qualified expression and its
15571 -- nominal subtype must be statically compatible with the result
15572 -- subtype of the expression function.
15575 Nkind (Return_Expr) = N_Identifier
15576 and then Etype (Return_Expr) = Etype (Subp);
15580 end Is_Inlinable_Expression_Function;
15586 function Is_Iterator (Typ : Entity_Id) return Boolean is
15587 function Denotes_Iterator (Iter_Typ : Entity_Id) return Boolean;
15588 -- Determine whether type Iter_Typ is a predefined forward or reversible
15591 ----------------------
15592 -- Denotes_Iterator --
15593 ----------------------
15595 function Denotes_Iterator (Iter_Typ : Entity_Id) return Boolean is
15597 -- Check that the name matches, and that the ultimate ancestor is in
15598 -- a predefined unit, i.e the one that declares iterator interfaces.
15601 Nam_In (Chars (Iter_Typ), Name_Forward_Iterator,
15602 Name_Reversible_Iterator)
15603 and then In_Predefined_Unit (Root_Type (Iter_Typ));
15604 end Denotes_Iterator;
15608 Iface_Elmt : Elmt_Id;
15611 -- Start of processing for Is_Iterator
15614 -- The type may be a subtype of a descendant of the proper instance of
15615 -- the predefined interface type, so we must use the root type of the
15616 -- given type. The same is done for Is_Reversible_Iterator.
15618 if Is_Class_Wide_Type (Typ)
15619 and then Denotes_Iterator (Root_Type (Typ))
15623 elsif not Is_Tagged_Type (Typ) or else not Is_Derived_Type (Typ) then
15626 elsif Present (Find_Value_Of_Aspect (Typ, Aspect_Iterable)) then
15630 Collect_Interfaces (Typ, Ifaces);
15632 Iface_Elmt := First_Elmt (Ifaces);
15633 while Present (Iface_Elmt) loop
15634 if Denotes_Iterator (Node (Iface_Elmt)) then
15638 Next_Elmt (Iface_Elmt);
15645 ----------------------------
15646 -- Is_Iterator_Over_Array --
15647 ----------------------------
15649 function Is_Iterator_Over_Array (N : Node_Id) return Boolean is
15650 Container : constant Node_Id := Name (N);
15651 Container_Typ : constant Entity_Id := Base_Type (Etype (Container));
15653 return Is_Array_Type (Container_Typ);
15654 end Is_Iterator_Over_Array;
15660 -- We seem to have a lot of overlapping functions that do similar things
15661 -- (testing for left hand sides or lvalues???).
15663 function Is_LHS (N : Node_Id) return Is_LHS_Result is
15664 P : constant Node_Id := Parent (N);
15667 -- Return True if we are the left hand side of an assignment statement
15669 if Nkind (P) = N_Assignment_Statement then
15670 if Name (P) = N then
15676 -- Case of prefix of indexed or selected component or slice
15678 elsif Nkind_In (P, N_Indexed_Component, N_Selected_Component, N_Slice)
15679 and then N = Prefix (P)
15681 -- Here we have the case where the parent P is N.Q or N(Q .. R).
15682 -- If P is an LHS, then N is also effectively an LHS, but there
15683 -- is an important exception. If N is of an access type, then
15684 -- what we really have is N.all.Q (or N.all(Q .. R)). In either
15685 -- case this makes N.all a left hand side but not N itself.
15687 -- If we don't know the type yet, this is the case where we return
15688 -- Unknown, since the answer depends on the type which is unknown.
15690 if No (Etype (N)) then
15693 -- We have an Etype set, so we can check it
15695 elsif Is_Access_Type (Etype (N)) then
15698 -- OK, not access type case, so just test whole expression
15704 -- All other cases are not left hand sides
15711 -----------------------------
15712 -- Is_Library_Level_Entity --
15713 -----------------------------
15715 function Is_Library_Level_Entity (E : Entity_Id) return Boolean is
15717 -- The following is a small optimization, and it also properly handles
15718 -- discriminals, which in task bodies might appear in expressions before
15719 -- the corresponding procedure has been created, and which therefore do
15720 -- not have an assigned scope.
15722 if Is_Formal (E) then
15726 -- Normal test is simply that the enclosing dynamic scope is Standard
15728 return Enclosing_Dynamic_Scope (E) = Standard_Standard;
15729 end Is_Library_Level_Entity;
15731 --------------------------------
15732 -- Is_Limited_Class_Wide_Type --
15733 --------------------------------
15735 function Is_Limited_Class_Wide_Type (Typ : Entity_Id) return Boolean is
15738 Is_Class_Wide_Type (Typ)
15739 and then (Is_Limited_Type (Typ) or else From_Limited_With (Typ));
15740 end Is_Limited_Class_Wide_Type;
15742 ---------------------------------
15743 -- Is_Local_Variable_Reference --
15744 ---------------------------------
15746 function Is_Local_Variable_Reference (Expr : Node_Id) return Boolean is
15748 if not Is_Entity_Name (Expr) then
15753 Ent : constant Entity_Id := Entity (Expr);
15754 Sub : constant Entity_Id := Enclosing_Subprogram (Ent);
15756 if not Ekind_In (Ent, E_Variable, E_In_Out_Parameter) then
15759 return Present (Sub) and then Sub = Current_Subprogram;
15763 end Is_Local_Variable_Reference;
15765 -----------------------
15766 -- Is_Name_Reference --
15767 -----------------------
15769 function Is_Name_Reference (N : Node_Id) return Boolean is
15771 if Is_Entity_Name (N) then
15772 return Present (Entity (N)) and then Is_Object (Entity (N));
15776 when N_Indexed_Component
15780 Is_Name_Reference (Prefix (N))
15781 or else Is_Access_Type (Etype (Prefix (N)));
15783 -- Attributes 'Input, 'Old and 'Result produce objects
15785 when N_Attribute_Reference =>
15787 Nam_In (Attribute_Name (N), Name_Input, Name_Old, Name_Result);
15789 when N_Selected_Component =>
15791 Is_Name_Reference (Selector_Name (N))
15793 (Is_Name_Reference (Prefix (N))
15794 or else Is_Access_Type (Etype (Prefix (N))));
15796 when N_Explicit_Dereference =>
15799 -- A view conversion of a tagged name is a name reference
15801 when N_Type_Conversion =>
15803 Is_Tagged_Type (Etype (Subtype_Mark (N)))
15804 and then Is_Tagged_Type (Etype (Expression (N)))
15805 and then Is_Name_Reference (Expression (N));
15807 -- An unchecked type conversion is considered to be a name if the
15808 -- operand is a name (this construction arises only as a result of
15809 -- expansion activities).
15811 when N_Unchecked_Type_Conversion =>
15812 return Is_Name_Reference (Expression (N));
15817 end Is_Name_Reference;
15819 ------------------------------------
15820 -- Is_Non_Preelaborable_Construct --
15821 ------------------------------------
15823 function Is_Non_Preelaborable_Construct (N : Node_Id) return Boolean is
15825 -- NOTE: the routines within Is_Non_Preelaborable_Construct are
15826 -- intentionally unnested to avoid deep indentation of code.
15828 Non_Preelaborable : exception;
15829 -- This exception is raised when the construct violates preelaborability
15830 -- to terminate the recursion.
15832 procedure Visit (Nod : Node_Id);
15833 -- Semantically inspect construct Nod to determine whether it violates
15834 -- preelaborability. This routine raises Non_Preelaborable.
15836 procedure Visit_List (List : List_Id);
15837 pragma Inline (Visit_List);
15838 -- Invoke Visit on each element of list List. This routine raises
15839 -- Non_Preelaborable.
15841 procedure Visit_Pragma (Prag : Node_Id);
15842 pragma Inline (Visit_Pragma);
15843 -- Semantically inspect pragma Prag to determine whether it violates
15844 -- preelaborability. This routine raises Non_Preelaborable.
15846 procedure Visit_Subexpression (Expr : Node_Id);
15847 pragma Inline (Visit_Subexpression);
15848 -- Semantically inspect expression Expr to determine whether it violates
15849 -- preelaborability. This routine raises Non_Preelaborable.
15855 procedure Visit (Nod : Node_Id) is
15857 case Nkind (Nod) is
15861 when N_Component_Declaration =>
15863 -- Defining_Identifier is left out because it is not relevant
15864 -- for preelaborability.
15866 Visit (Component_Definition (Nod));
15867 Visit (Expression (Nod));
15869 when N_Derived_Type_Definition =>
15871 -- Interface_List is left out because it is not relevant for
15872 -- preelaborability.
15874 Visit (Record_Extension_Part (Nod));
15875 Visit (Subtype_Indication (Nod));
15877 when N_Entry_Declaration =>
15879 -- A protected type with at leat one entry is not preelaborable
15880 -- while task types are never preelaborable. This renders entry
15881 -- declarations non-preelaborable.
15883 raise Non_Preelaborable;
15885 when N_Full_Type_Declaration =>
15887 -- Defining_Identifier and Discriminant_Specifications are left
15888 -- out because they are not relevant for preelaborability.
15890 Visit (Type_Definition (Nod));
15892 when N_Function_Instantiation
15893 | N_Package_Instantiation
15894 | N_Procedure_Instantiation
15896 -- Defining_Unit_Name and Name are left out because they are
15897 -- not relevant for preelaborability.
15899 Visit_List (Generic_Associations (Nod));
15901 when N_Object_Declaration =>
15903 -- Defining_Identifier is left out because it is not relevant
15904 -- for preelaborability.
15906 Visit (Object_Definition (Nod));
15908 if Has_Init_Expression (Nod) then
15909 Visit (Expression (Nod));
15911 elsif not Has_Preelaborable_Initialization
15912 (Etype (Defining_Entity (Nod)))
15914 raise Non_Preelaborable;
15917 when N_Private_Extension_Declaration
15918 | N_Subtype_Declaration
15920 -- Defining_Identifier, Discriminant_Specifications, and
15921 -- Interface_List are left out because they are not relevant
15922 -- for preelaborability.
15924 Visit (Subtype_Indication (Nod));
15926 when N_Protected_Type_Declaration
15927 | N_Single_Protected_Declaration
15929 -- Defining_Identifier, Discriminant_Specifications, and
15930 -- Interface_List are left out because they are not relevant
15931 -- for preelaborability.
15933 Visit (Protected_Definition (Nod));
15935 -- A [single] task type is never preelaborable
15937 when N_Single_Task_Declaration
15938 | N_Task_Type_Declaration
15940 raise Non_Preelaborable;
15945 Visit_Pragma (Nod);
15949 when N_Statement_Other_Than_Procedure_Call =>
15950 if Nkind (Nod) /= N_Null_Statement then
15951 raise Non_Preelaborable;
15957 Visit_Subexpression (Nod);
15961 when N_Access_To_Object_Definition =>
15962 Visit (Subtype_Indication (Nod));
15964 when N_Case_Expression_Alternative =>
15965 Visit (Expression (Nod));
15966 Visit_List (Discrete_Choices (Nod));
15968 when N_Component_Definition =>
15969 Visit (Access_Definition (Nod));
15970 Visit (Subtype_Indication (Nod));
15972 when N_Component_List =>
15973 Visit_List (Component_Items (Nod));
15974 Visit (Variant_Part (Nod));
15976 when N_Constrained_Array_Definition =>
15977 Visit_List (Discrete_Subtype_Definitions (Nod));
15978 Visit (Component_Definition (Nod));
15980 when N_Delta_Constraint
15981 | N_Digits_Constraint
15983 -- Delta_Expression and Digits_Expression are left out because
15984 -- they are not relevant for preelaborability.
15986 Visit (Range_Constraint (Nod));
15988 when N_Discriminant_Specification =>
15990 -- Defining_Identifier and Expression are left out because they
15991 -- are not relevant for preelaborability.
15993 Visit (Discriminant_Type (Nod));
15995 when N_Generic_Association =>
15997 -- Selector_Name is left out because it is not relevant for
15998 -- preelaborability.
16000 Visit (Explicit_Generic_Actual_Parameter (Nod));
16002 when N_Index_Or_Discriminant_Constraint =>
16003 Visit_List (Constraints (Nod));
16005 when N_Iterator_Specification =>
16007 -- Defining_Identifier is left out because it is not relevant
16008 -- for preelaborability.
16010 Visit (Name (Nod));
16011 Visit (Subtype_Indication (Nod));
16013 when N_Loop_Parameter_Specification =>
16015 -- Defining_Identifier is left out because it is not relevant
16016 -- for preelaborability.
16018 Visit (Discrete_Subtype_Definition (Nod));
16020 when N_Protected_Definition =>
16022 -- End_Label is left out because it is not relevant for
16023 -- preelaborability.
16025 Visit_List (Private_Declarations (Nod));
16026 Visit_List (Visible_Declarations (Nod));
16028 when N_Range_Constraint =>
16029 Visit (Range_Expression (Nod));
16031 when N_Record_Definition
16034 -- End_Label, Discrete_Choices, and Interface_List are left out
16035 -- because they are not relevant for preelaborability.
16037 Visit (Component_List (Nod));
16039 when N_Subtype_Indication =>
16041 -- Subtype_Mark is left out because it is not relevant for
16042 -- preelaborability.
16044 Visit (Constraint (Nod));
16046 when N_Unconstrained_Array_Definition =>
16048 -- Subtype_Marks is left out because it is not relevant for
16049 -- preelaborability.
16051 Visit (Component_Definition (Nod));
16053 when N_Variant_Part =>
16055 -- Name is left out because it is not relevant for
16056 -- preelaborability.
16058 Visit_List (Variants (Nod));
16071 procedure Visit_List (List : List_Id) is
16075 if Present (List) then
16076 Nod := First (List);
16077 while Present (Nod) loop
16088 procedure Visit_Pragma (Prag : Node_Id) is
16090 case Get_Pragma_Id (Prag) is
16092 | Pragma_Assert_And_Cut
16094 | Pragma_Async_Readers
16095 | Pragma_Async_Writers
16096 | Pragma_Attribute_Definition
16098 | Pragma_Constant_After_Elaboration
16100 | Pragma_Deadline_Floor
16101 | Pragma_Dispatching_Domain
16102 | Pragma_Effective_Reads
16103 | Pragma_Effective_Writes
16104 | Pragma_Extensions_Visible
16106 | Pragma_Secondary_Stack_Size
16108 | Pragma_Volatile_Function
16110 Visit_List (Pragma_Argument_Associations (Prag));
16119 -------------------------
16120 -- Visit_Subexpression --
16121 -------------------------
16123 procedure Visit_Subexpression (Expr : Node_Id) is
16124 procedure Visit_Aggregate (Aggr : Node_Id);
16125 pragma Inline (Visit_Aggregate);
16126 -- Semantically inspect aggregate Aggr to determine whether it
16127 -- violates preelaborability.
16129 ---------------------
16130 -- Visit_Aggregate --
16131 ---------------------
16133 procedure Visit_Aggregate (Aggr : Node_Id) is
16135 if not Is_Preelaborable_Aggregate (Aggr) then
16136 raise Non_Preelaborable;
16138 end Visit_Aggregate;
16140 -- Start of processing for Visit_Subexpression
16143 case Nkind (Expr) is
16145 | N_Qualified_Expression
16146 | N_Type_Conversion
16147 | N_Unchecked_Expression
16148 | N_Unchecked_Type_Conversion
16150 -- Subpool_Handle_Name and Subtype_Mark are left out because
16151 -- they are not relevant for preelaborability.
16153 Visit (Expression (Expr));
16156 | N_Extension_Aggregate
16158 Visit_Aggregate (Expr);
16160 when N_Attribute_Reference
16161 | N_Explicit_Dereference
16164 -- Attribute_Name and Expressions are left out because they are
16165 -- not relevant for preelaborability.
16167 Visit (Prefix (Expr));
16169 when N_Case_Expression =>
16171 -- End_Span is left out because it is not relevant for
16172 -- preelaborability.
16174 Visit_List (Alternatives (Expr));
16175 Visit (Expression (Expr));
16177 when N_Delta_Aggregate =>
16178 Visit_Aggregate (Expr);
16179 Visit (Expression (Expr));
16181 when N_Expression_With_Actions =>
16182 Visit_List (Actions (Expr));
16183 Visit (Expression (Expr));
16185 when N_If_Expression =>
16186 Visit_List (Expressions (Expr));
16188 when N_Quantified_Expression =>
16189 Visit (Condition (Expr));
16190 Visit (Iterator_Specification (Expr));
16191 Visit (Loop_Parameter_Specification (Expr));
16194 Visit (High_Bound (Expr));
16195 Visit (Low_Bound (Expr));
16198 Visit (Discrete_Range (Expr));
16199 Visit (Prefix (Expr));
16205 -- The evaluation of an object name is not preelaborable,
16206 -- unless the name is a static expression (checked further
16207 -- below), or statically denotes a discriminant.
16209 if Is_Entity_Name (Expr) then
16210 Object_Name : declare
16211 Id : constant Entity_Id := Entity (Expr);
16214 if Is_Object (Id) then
16215 if Ekind (Id) = E_Discriminant then
16218 elsif Ekind_In (Id, E_Constant, E_In_Parameter)
16219 and then Present (Discriminal_Link (Id))
16224 raise Non_Preelaborable;
16229 -- A non-static expression is not preelaborable
16231 elsif not Is_OK_Static_Expression (Expr) then
16232 raise Non_Preelaborable;
16235 end Visit_Subexpression;
16237 -- Start of processing for Is_Non_Preelaborable_Construct
16242 -- At this point it is known that the construct is preelaborable
16248 -- The elaboration of the construct performs an action which violates
16249 -- preelaborability.
16251 when Non_Preelaborable =>
16253 end Is_Non_Preelaborable_Construct;
16255 ---------------------------------
16256 -- Is_Nontrivial_DIC_Procedure --
16257 ---------------------------------
16259 function Is_Nontrivial_DIC_Procedure (Id : Entity_Id) return Boolean is
16260 Body_Decl : Node_Id;
16264 if Ekind (Id) = E_Procedure and then Is_DIC_Procedure (Id) then
16266 Unit_Declaration_Node
16267 (Corresponding_Body (Unit_Declaration_Node (Id)));
16269 -- The body of the Default_Initial_Condition procedure must contain
16270 -- at least one statement, otherwise the generation of the subprogram
16273 pragma Assert (Present (Handled_Statement_Sequence (Body_Decl)));
16275 -- To qualify as nontrivial, the first statement of the procedure
16276 -- must be a check in the form of an if statement. If the original
16277 -- Default_Initial_Condition expression was folded, then the first
16278 -- statement is not a check.
16280 Stmt := First (Statements (Handled_Statement_Sequence (Body_Decl)));
16283 Nkind (Stmt) = N_If_Statement
16284 and then Nkind (Original_Node (Stmt)) = N_Pragma;
16288 end Is_Nontrivial_DIC_Procedure;
16290 -------------------------
16291 -- Is_Null_Record_Type --
16292 -------------------------
16294 function Is_Null_Record_Type (T : Entity_Id) return Boolean is
16295 Decl : constant Node_Id := Parent (T);
16297 return Nkind (Decl) = N_Full_Type_Declaration
16298 and then Nkind (Type_Definition (Decl)) = N_Record_Definition
16300 (No (Component_List (Type_Definition (Decl)))
16301 or else Null_Present (Component_List (Type_Definition (Decl))));
16302 end Is_Null_Record_Type;
16304 ---------------------
16305 -- Is_Object_Image --
16306 ---------------------
16308 function Is_Object_Image (Prefix : Node_Id) return Boolean is
16310 -- When the type of the prefix is not scalar, then the prefix is not
16311 -- valid in any scenario.
16313 if not Is_Scalar_Type (Etype (Prefix)) then
16317 -- Here we test for the case that the prefix is not a type and assume
16318 -- if it is not then it must be a named value or an object reference.
16319 -- This is because the parser always checks that prefixes of attributes
16322 return not (Is_Entity_Name (Prefix) and then Is_Type (Entity (Prefix)));
16323 end Is_Object_Image;
16325 -------------------------
16326 -- Is_Object_Reference --
16327 -------------------------
16329 function Is_Object_Reference (N : Node_Id) return Boolean is
16330 function Is_Internally_Generated_Renaming (N : Node_Id) return Boolean;
16331 -- Determine whether N is the name of an internally-generated renaming
16333 --------------------------------------
16334 -- Is_Internally_Generated_Renaming --
16335 --------------------------------------
16337 function Is_Internally_Generated_Renaming (N : Node_Id) return Boolean is
16342 while Present (P) loop
16343 if Nkind (P) = N_Object_Renaming_Declaration then
16344 return not Comes_From_Source (P);
16345 elsif Is_List_Member (P) then
16353 end Is_Internally_Generated_Renaming;
16355 -- Start of processing for Is_Object_Reference
16358 if Is_Entity_Name (N) then
16359 return Present (Entity (N)) and then Is_Object (Entity (N));
16363 when N_Indexed_Component
16367 Is_Object_Reference (Prefix (N))
16368 or else Is_Access_Type (Etype (Prefix (N)));
16370 -- In Ada 95, a function call is a constant object; a procedure
16373 -- Note that predefined operators are functions as well, and so
16374 -- are attributes that are (can be renamed as) functions.
16380 return Etype (N) /= Standard_Void_Type;
16382 -- Attributes references 'Loop_Entry, 'Old, and 'Result yield
16383 -- objects, even though they are not functions.
16385 when N_Attribute_Reference =>
16387 Nam_In (Attribute_Name (N), Name_Loop_Entry,
16390 or else Is_Function_Attribute_Name (Attribute_Name (N));
16392 when N_Selected_Component =>
16394 Is_Object_Reference (Selector_Name (N))
16396 (Is_Object_Reference (Prefix (N))
16397 or else Is_Access_Type (Etype (Prefix (N))));
16399 -- An explicit dereference denotes an object, except that a
16400 -- conditional expression gets turned into an explicit dereference
16401 -- in some cases, and conditional expressions are not object
16404 when N_Explicit_Dereference =>
16405 return not Nkind_In (Original_Node (N), N_Case_Expression,
16408 -- A view conversion of a tagged object is an object reference
16410 when N_Type_Conversion =>
16411 return Is_Tagged_Type (Etype (Subtype_Mark (N)))
16412 and then Is_Tagged_Type (Etype (Expression (N)))
16413 and then Is_Object_Reference (Expression (N));
16415 -- An unchecked type conversion is considered to be an object if
16416 -- the operand is an object (this construction arises only as a
16417 -- result of expansion activities).
16419 when N_Unchecked_Type_Conversion =>
16422 -- Allow string literals to act as objects as long as they appear
16423 -- in internally-generated renamings. The expansion of iterators
16424 -- may generate such renamings when the range involves a string
16427 when N_String_Literal =>
16428 return Is_Internally_Generated_Renaming (Parent (N));
16430 -- AI05-0003: In Ada 2012 a qualified expression is a name.
16431 -- This allows disambiguation of function calls and the use
16432 -- of aggregates in more contexts.
16434 when N_Qualified_Expression =>
16435 if Ada_Version < Ada_2012 then
16438 return Is_Object_Reference (Expression (N))
16439 or else Nkind (Expression (N)) = N_Aggregate;
16446 end Is_Object_Reference;
16448 -----------------------------------
16449 -- Is_OK_Variable_For_Out_Formal --
16450 -----------------------------------
16452 function Is_OK_Variable_For_Out_Formal (AV : Node_Id) return Boolean is
16454 Note_Possible_Modification (AV, Sure => True);
16456 -- We must reject parenthesized variable names. Comes_From_Source is
16457 -- checked because there are currently cases where the compiler violates
16458 -- this rule (e.g. passing a task object to its controlled Initialize
16459 -- routine). This should be properly documented in sinfo???
16461 if Paren_Count (AV) > 0 and then Comes_From_Source (AV) then
16464 -- A variable is always allowed
16466 elsif Is_Variable (AV) then
16469 -- Generalized indexing operations are rewritten as explicit
16470 -- dereferences, and it is only during resolution that we can
16471 -- check whether the context requires an access_to_variable type.
16473 elsif Nkind (AV) = N_Explicit_Dereference
16474 and then Ada_Version >= Ada_2012
16475 and then Nkind (Original_Node (AV)) = N_Indexed_Component
16476 and then Present (Etype (Original_Node (AV)))
16477 and then Has_Implicit_Dereference (Etype (Original_Node (AV)))
16479 return not Is_Access_Constant (Etype (Prefix (AV)));
16481 -- Unchecked conversions are allowed only if they come from the
16482 -- generated code, which sometimes uses unchecked conversions for out
16483 -- parameters in cases where code generation is unaffected. We tell
16484 -- source unchecked conversions by seeing if they are rewrites of
16485 -- an original Unchecked_Conversion function call, or of an explicit
16486 -- conversion of a function call or an aggregate (as may happen in the
16487 -- expansion of a packed array aggregate).
16489 elsif Nkind (AV) = N_Unchecked_Type_Conversion then
16490 if Nkind_In (Original_Node (AV), N_Function_Call, N_Aggregate) then
16493 elsif Comes_From_Source (AV)
16494 and then Nkind (Original_Node (Expression (AV))) = N_Function_Call
16498 elsif Nkind (Original_Node (AV)) = N_Type_Conversion then
16499 return Is_OK_Variable_For_Out_Formal (Expression (AV));
16505 -- Normal type conversions are allowed if argument is a variable
16507 elsif Nkind (AV) = N_Type_Conversion then
16508 if Is_Variable (Expression (AV))
16509 and then Paren_Count (Expression (AV)) = 0
16511 Note_Possible_Modification (Expression (AV), Sure => True);
16514 -- We also allow a non-parenthesized expression that raises
16515 -- constraint error if it rewrites what used to be a variable
16517 elsif Raises_Constraint_Error (Expression (AV))
16518 and then Paren_Count (Expression (AV)) = 0
16519 and then Is_Variable (Original_Node (Expression (AV)))
16523 -- Type conversion of something other than a variable
16529 -- If this node is rewritten, then test the original form, if that is
16530 -- OK, then we consider the rewritten node OK (for example, if the
16531 -- original node is a conversion, then Is_Variable will not be true
16532 -- but we still want to allow the conversion if it converts a variable).
16534 elsif Is_Rewrite_Substitution (AV) then
16536 -- In Ada 2012, the explicit dereference may be a rewritten call to a
16537 -- Reference function.
16539 if Ada_Version >= Ada_2012
16540 and then Nkind (Original_Node (AV)) = N_Function_Call
16542 Has_Implicit_Dereference (Etype (Name (Original_Node (AV))))
16545 -- Check that this is not a constant reference.
16547 return not Is_Access_Constant (Etype (Prefix (AV)));
16549 elsif Has_Implicit_Dereference (Etype (Original_Node (AV))) then
16551 not Is_Access_Constant (Etype
16552 (Get_Reference_Discriminant (Etype (Original_Node (AV)))));
16555 return Is_OK_Variable_For_Out_Formal (Original_Node (AV));
16558 -- All other non-variables are rejected
16563 end Is_OK_Variable_For_Out_Formal;
16565 ----------------------------
16566 -- Is_OK_Volatile_Context --
16567 ----------------------------
16569 function Is_OK_Volatile_Context
16570 (Context : Node_Id;
16571 Obj_Ref : Node_Id) return Boolean
16573 function Is_Protected_Operation_Call (Nod : Node_Id) return Boolean;
16574 -- Determine whether an arbitrary node denotes a call to a protected
16575 -- entry, function, or procedure in prefixed form where the prefix is
16578 function Within_Check (Nod : Node_Id) return Boolean;
16579 -- Determine whether an arbitrary node appears in a check node
16581 function Within_Volatile_Function (Id : Entity_Id) return Boolean;
16582 -- Determine whether an arbitrary entity appears in a volatile function
16584 ---------------------------------
16585 -- Is_Protected_Operation_Call --
16586 ---------------------------------
16588 function Is_Protected_Operation_Call (Nod : Node_Id) return Boolean is
16593 -- A call to a protected operations retains its selected component
16594 -- form as opposed to other prefixed calls that are transformed in
16597 if Nkind (Nod) = N_Selected_Component then
16598 Pref := Prefix (Nod);
16599 Subp := Selector_Name (Nod);
16603 and then Present (Etype (Pref))
16604 and then Is_Protected_Type (Etype (Pref))
16605 and then Is_Entity_Name (Subp)
16606 and then Present (Entity (Subp))
16607 and then Ekind_In (Entity (Subp), E_Entry,
16614 end Is_Protected_Operation_Call;
16620 function Within_Check (Nod : Node_Id) return Boolean is
16624 -- Climb the parent chain looking for a check node
16627 while Present (Par) loop
16628 if Nkind (Par) in N_Raise_xxx_Error then
16631 -- Prevent the search from going too far
16633 elsif Is_Body_Or_Package_Declaration (Par) then
16637 Par := Parent (Par);
16643 ------------------------------
16644 -- Within_Volatile_Function --
16645 ------------------------------
16647 function Within_Volatile_Function (Id : Entity_Id) return Boolean is
16648 Func_Id : Entity_Id;
16651 -- Traverse the scope stack looking for a [generic] function
16654 while Present (Func_Id) and then Func_Id /= Standard_Standard loop
16655 if Ekind_In (Func_Id, E_Function, E_Generic_Function) then
16656 return Is_Volatile_Function (Func_Id);
16659 Func_Id := Scope (Func_Id);
16663 end Within_Volatile_Function;
16667 Obj_Id : Entity_Id;
16669 -- Start of processing for Is_OK_Volatile_Context
16672 -- The volatile object appears on either side of an assignment
16674 if Nkind (Context) = N_Assignment_Statement then
16677 -- The volatile object is part of the initialization expression of
16680 elsif Nkind (Context) = N_Object_Declaration
16681 and then Present (Expression (Context))
16682 and then Expression (Context) = Obj_Ref
16684 Obj_Id := Defining_Entity (Context);
16686 -- The volatile object acts as the initialization expression of an
16687 -- extended return statement. This is valid context as long as the
16688 -- function is volatile.
16690 if Is_Return_Object (Obj_Id) then
16691 return Within_Volatile_Function (Obj_Id);
16693 -- Otherwise this is a normal object initialization
16699 -- The volatile object acts as the name of a renaming declaration
16701 elsif Nkind (Context) = N_Object_Renaming_Declaration
16702 and then Name (Context) = Obj_Ref
16706 -- The volatile object appears as an actual parameter in a call to an
16707 -- instance of Unchecked_Conversion whose result is renamed.
16709 elsif Nkind (Context) = N_Function_Call
16710 and then Is_Entity_Name (Name (Context))
16711 and then Is_Unchecked_Conversion_Instance (Entity (Name (Context)))
16712 and then Nkind (Parent (Context)) = N_Object_Renaming_Declaration
16716 -- The volatile object is actually the prefix in a protected entry,
16717 -- function, or procedure call.
16719 elsif Is_Protected_Operation_Call (Context) then
16722 -- The volatile object appears as the expression of a simple return
16723 -- statement that applies to a volatile function.
16725 elsif Nkind (Context) = N_Simple_Return_Statement
16726 and then Expression (Context) = Obj_Ref
16729 Within_Volatile_Function (Return_Statement_Entity (Context));
16731 -- The volatile object appears as the prefix of a name occurring in a
16732 -- non-interfering context.
16734 elsif Nkind_In (Context, N_Attribute_Reference,
16735 N_Explicit_Dereference,
16736 N_Indexed_Component,
16737 N_Selected_Component,
16739 and then Prefix (Context) = Obj_Ref
16740 and then Is_OK_Volatile_Context
16741 (Context => Parent (Context),
16742 Obj_Ref => Context)
16746 -- The volatile object appears as the prefix of attributes Address,
16747 -- Alignment, Component_Size, First, First_Bit, Last, Last_Bit, Length,
16748 -- Position, Size, Storage_Size.
16750 elsif Nkind (Context) = N_Attribute_Reference
16751 and then Prefix (Context) = Obj_Ref
16752 and then Nam_In (Attribute_Name (Context), Name_Address,
16754 Name_Component_Size,
16766 -- The volatile object appears as the expression of a type conversion
16767 -- occurring in a non-interfering context.
16769 elsif Nkind_In (Context, N_Type_Conversion,
16770 N_Unchecked_Type_Conversion)
16771 and then Expression (Context) = Obj_Ref
16772 and then Is_OK_Volatile_Context
16773 (Context => Parent (Context),
16774 Obj_Ref => Context)
16778 -- The volatile object appears as the expression in a delay statement
16780 elsif Nkind (Context) in N_Delay_Statement then
16783 -- Allow references to volatile objects in various checks. This is not a
16784 -- direct SPARK 2014 requirement.
16786 elsif Within_Check (Context) then
16789 -- Assume that references to effectively volatile objects that appear
16790 -- as actual parameters in a subprogram call are always legal. A full
16791 -- legality check is done when the actuals are resolved (see routine
16792 -- Resolve_Actuals).
16794 elsif Within_Subprogram_Call (Context) then
16797 -- Otherwise the context is not suitable for an effectively volatile
16803 end Is_OK_Volatile_Context;
16805 ------------------------------------
16806 -- Is_Package_Contract_Annotation --
16807 ------------------------------------
16809 function Is_Package_Contract_Annotation (Item : Node_Id) return Boolean is
16813 if Nkind (Item) = N_Aspect_Specification then
16814 Nam := Chars (Identifier (Item));
16816 else pragma Assert (Nkind (Item) = N_Pragma);
16817 Nam := Pragma_Name (Item);
16820 return Nam = Name_Abstract_State
16821 or else Nam = Name_Initial_Condition
16822 or else Nam = Name_Initializes
16823 or else Nam = Name_Refined_State;
16824 end Is_Package_Contract_Annotation;
16826 -----------------------------------
16827 -- Is_Partially_Initialized_Type --
16828 -----------------------------------
16830 function Is_Partially_Initialized_Type
16832 Include_Implicit : Boolean := True) return Boolean
16835 if Is_Scalar_Type (Typ) then
16838 elsif Is_Access_Type (Typ) then
16839 return Include_Implicit;
16841 elsif Is_Array_Type (Typ) then
16843 -- If component type is partially initialized, so is array type
16845 if Is_Partially_Initialized_Type
16846 (Component_Type (Typ), Include_Implicit)
16850 -- Otherwise we are only partially initialized if we are fully
16851 -- initialized (this is the empty array case, no point in us
16852 -- duplicating that code here).
16855 return Is_Fully_Initialized_Type (Typ);
16858 elsif Is_Record_Type (Typ) then
16860 -- A discriminated type is always partially initialized if in
16863 if Has_Discriminants (Typ) and then Include_Implicit then
16866 -- A tagged type is always partially initialized
16868 elsif Is_Tagged_Type (Typ) then
16871 -- Case of non-discriminated record
16877 Component_Present : Boolean := False;
16878 -- Set True if at least one component is present. If no
16879 -- components are present, then record type is fully
16880 -- initialized (another odd case, like the null array).
16883 -- Loop through components
16885 Ent := First_Entity (Typ);
16886 while Present (Ent) loop
16887 if Ekind (Ent) = E_Component then
16888 Component_Present := True;
16890 -- If a component has an initialization expression then
16891 -- the enclosing record type is partially initialized
16893 if Present (Parent (Ent))
16894 and then Present (Expression (Parent (Ent)))
16898 -- If a component is of a type which is itself partially
16899 -- initialized, then the enclosing record type is also.
16901 elsif Is_Partially_Initialized_Type
16902 (Etype (Ent), Include_Implicit)
16911 -- No initialized components found. If we found any components
16912 -- they were all uninitialized so the result is false.
16914 if Component_Present then
16917 -- But if we found no components, then all the components are
16918 -- initialized so we consider the type to be initialized.
16926 -- Concurrent types are always fully initialized
16928 elsif Is_Concurrent_Type (Typ) then
16931 -- For a private type, go to underlying type. If there is no underlying
16932 -- type then just assume this partially initialized. Not clear if this
16933 -- can happen in a non-error case, but no harm in testing for this.
16935 elsif Is_Private_Type (Typ) then
16937 U : constant Entity_Id := Underlying_Type (Typ);
16942 return Is_Partially_Initialized_Type (U, Include_Implicit);
16946 -- For any other type (are there any?) assume partially initialized
16951 end Is_Partially_Initialized_Type;
16953 ------------------------------------
16954 -- Is_Potentially_Persistent_Type --
16955 ------------------------------------
16957 function Is_Potentially_Persistent_Type (T : Entity_Id) return Boolean is
16962 -- For private type, test corresponding full type
16964 if Is_Private_Type (T) then
16965 return Is_Potentially_Persistent_Type (Full_View (T));
16967 -- Scalar types are potentially persistent
16969 elsif Is_Scalar_Type (T) then
16972 -- Record type is potentially persistent if not tagged and the types of
16973 -- all it components are potentially persistent, and no component has
16974 -- an initialization expression.
16976 elsif Is_Record_Type (T)
16977 and then not Is_Tagged_Type (T)
16978 and then not Is_Partially_Initialized_Type (T)
16980 Comp := First_Component (T);
16981 while Present (Comp) loop
16982 if not Is_Potentially_Persistent_Type (Etype (Comp)) then
16985 Next_Entity (Comp);
16991 -- Array type is potentially persistent if its component type is
16992 -- potentially persistent and if all its constraints are static.
16994 elsif Is_Array_Type (T) then
16995 if not Is_Potentially_Persistent_Type (Component_Type (T)) then
16999 Indx := First_Index (T);
17000 while Present (Indx) loop
17001 if not Is_OK_Static_Subtype (Etype (Indx)) then
17010 -- All other types are not potentially persistent
17015 end Is_Potentially_Persistent_Type;
17017 --------------------------------
17018 -- Is_Potentially_Unevaluated --
17019 --------------------------------
17021 function Is_Potentially_Unevaluated (N : Node_Id) return Boolean is
17029 -- A postcondition whose expression is a short-circuit is broken down
17030 -- into individual aspects for better exception reporting. The original
17031 -- short-circuit expression is rewritten as the second operand, and an
17032 -- occurrence of 'Old in that operand is potentially unevaluated.
17033 -- See sem_ch13.adb for details of this transformation. The reference
17034 -- to 'Old may appear within an expression, so we must look for the
17035 -- enclosing pragma argument in the tree that contains the reference.
17037 while Present (Par)
17038 and then Nkind (Par) /= N_Pragma_Argument_Association
17040 if Is_Rewrite_Substitution (Par)
17041 and then Nkind (Original_Node (Par)) = N_And_Then
17046 Par := Parent (Par);
17049 -- Other cases; 'Old appears within other expression (not the top-level
17050 -- conjunct in a postcondition) with a potentially unevaluated operand.
17052 Par := Parent (Expr);
17053 while not Nkind_In (Par, N_And_Then,
17059 N_Quantified_Expression)
17062 Par := Parent (Par);
17064 -- If the context is not an expression, or if is the result of
17065 -- expansion of an enclosing construct (such as another attribute)
17066 -- the predicate does not apply.
17068 if Nkind (Par) = N_Case_Expression_Alternative then
17071 elsif Nkind (Par) not in N_Subexpr
17072 or else not Comes_From_Source (Par)
17078 if Nkind (Par) = N_If_Expression then
17079 return Is_Elsif (Par) or else Expr /= First (Expressions (Par));
17081 elsif Nkind (Par) = N_Case_Expression then
17082 return Expr /= Expression (Par);
17084 elsif Nkind_In (Par, N_And_Then, N_Or_Else) then
17085 return Expr = Right_Opnd (Par);
17087 elsif Nkind_In (Par, N_In, N_Not_In) then
17089 -- If the membership includes several alternatives, only the first is
17090 -- definitely evaluated.
17092 if Present (Alternatives (Par)) then
17093 return Expr /= First (Alternatives (Par));
17095 -- If this is a range membership both bounds are evaluated
17101 elsif Nkind (Par) = N_Quantified_Expression then
17102 return Expr = Condition (Par);
17107 end Is_Potentially_Unevaluated;
17109 -----------------------------------------
17110 -- Is_Predefined_Dispatching_Operation --
17111 -----------------------------------------
17113 function Is_Predefined_Dispatching_Operation
17114 (E : Entity_Id) return Boolean
17116 TSS_Name : TSS_Name_Type;
17119 if not Is_Dispatching_Operation (E) then
17123 Get_Name_String (Chars (E));
17125 -- Most predefined primitives have internally generated names. Equality
17126 -- must be treated differently; the predefined operation is recognized
17127 -- as a homogeneous binary operator that returns Boolean.
17129 if Name_Len > TSS_Name_Type'Last then
17132 (Name_Buffer (Name_Len - TSS_Name'Length + 1 .. Name_Len));
17134 if Nam_In (Chars (E), Name_uAssign, Name_uSize)
17136 (Chars (E) = Name_Op_Eq
17137 and then Etype (First_Formal (E)) = Etype (Last_Formal (E)))
17138 or else TSS_Name = TSS_Deep_Adjust
17139 or else TSS_Name = TSS_Deep_Finalize
17140 or else TSS_Name = TSS_Stream_Input
17141 or else TSS_Name = TSS_Stream_Output
17142 or else TSS_Name = TSS_Stream_Read
17143 or else TSS_Name = TSS_Stream_Write
17144 or else Is_Predefined_Interface_Primitive (E)
17151 end Is_Predefined_Dispatching_Operation;
17153 ---------------------------------------
17154 -- Is_Predefined_Interface_Primitive --
17155 ---------------------------------------
17157 function Is_Predefined_Interface_Primitive (E : Entity_Id) return Boolean is
17159 -- In VM targets we don't restrict the functionality of this test to
17160 -- compiling in Ada 2005 mode since in VM targets any tagged type has
17161 -- these primitives.
17163 return (Ada_Version >= Ada_2005 or else not Tagged_Type_Expansion)
17164 and then Nam_In (Chars (E), Name_uDisp_Asynchronous_Select,
17165 Name_uDisp_Conditional_Select,
17166 Name_uDisp_Get_Prim_Op_Kind,
17167 Name_uDisp_Get_Task_Id,
17168 Name_uDisp_Requeue,
17169 Name_uDisp_Timed_Select);
17170 end Is_Predefined_Interface_Primitive;
17172 ---------------------------------------
17173 -- Is_Predefined_Internal_Operation --
17174 ---------------------------------------
17176 function Is_Predefined_Internal_Operation
17177 (E : Entity_Id) return Boolean
17179 TSS_Name : TSS_Name_Type;
17182 if not Is_Dispatching_Operation (E) then
17186 Get_Name_String (Chars (E));
17188 -- Most predefined primitives have internally generated names. Equality
17189 -- must be treated differently; the predefined operation is recognized
17190 -- as a homogeneous binary operator that returns Boolean.
17192 if Name_Len > TSS_Name_Type'Last then
17195 (Name_Buffer (Name_Len - TSS_Name'Length + 1 .. Name_Len));
17197 if Nam_In (Chars (E), Name_uSize, Name_uAssign)
17199 (Chars (E) = Name_Op_Eq
17200 and then Etype (First_Formal (E)) = Etype (Last_Formal (E)))
17201 or else TSS_Name = TSS_Deep_Adjust
17202 or else TSS_Name = TSS_Deep_Finalize
17203 or else Is_Predefined_Interface_Primitive (E)
17210 end Is_Predefined_Internal_Operation;
17212 --------------------------------
17213 -- Is_Preelaborable_Aggregate --
17214 --------------------------------
17216 function Is_Preelaborable_Aggregate (Aggr : Node_Id) return Boolean is
17217 Aggr_Typ : constant Entity_Id := Etype (Aggr);
17218 Array_Aggr : constant Boolean := Is_Array_Type (Aggr_Typ);
17220 Anc_Part : Node_Id;
17223 Comp_Typ : Entity_Id := Empty; -- init to avoid warning
17228 Comp_Typ := Component_Type (Aggr_Typ);
17231 -- Inspect the ancestor part
17233 if Nkind (Aggr) = N_Extension_Aggregate then
17234 Anc_Part := Ancestor_Part (Aggr);
17236 -- The ancestor denotes a subtype mark
17238 if Is_Entity_Name (Anc_Part)
17239 and then Is_Type (Entity (Anc_Part))
17241 if not Has_Preelaborable_Initialization (Entity (Anc_Part)) then
17245 -- Otherwise the ancestor denotes an expression
17247 elsif not Is_Preelaborable_Construct (Anc_Part) then
17252 -- Inspect the positional associations
17254 Expr := First (Expressions (Aggr));
17255 while Present (Expr) loop
17256 if not Is_Preelaborable_Construct (Expr) then
17263 -- Inspect the named associations
17265 Assoc := First (Component_Associations (Aggr));
17266 while Present (Assoc) loop
17268 -- Inspect the choices of the current named association
17270 Choice := First (Choices (Assoc));
17271 while Present (Choice) loop
17274 -- For a choice to be preelaborable, it must denote either a
17275 -- static range or a static expression.
17277 if Nkind (Choice) = N_Others_Choice then
17280 elsif Nkind (Choice) = N_Range then
17281 if not Is_OK_Static_Range (Choice) then
17285 elsif not Is_OK_Static_Expression (Choice) then
17290 Comp_Typ := Etype (Choice);
17296 -- The type of the choice must have preelaborable initialization if
17297 -- the association carries a <>.
17299 pragma Assert (Present (Comp_Typ));
17300 if Box_Present (Assoc) then
17301 if not Has_Preelaborable_Initialization (Comp_Typ) then
17305 -- The type of the expression must have preelaborable initialization
17307 elsif not Is_Preelaborable_Construct (Expression (Assoc)) then
17314 -- At this point the aggregate is preelaborable
17317 end Is_Preelaborable_Aggregate;
17319 --------------------------------
17320 -- Is_Preelaborable_Construct --
17321 --------------------------------
17323 function Is_Preelaborable_Construct (N : Node_Id) return Boolean is
17327 if Nkind_In (N, N_Aggregate, N_Extension_Aggregate) then
17328 return Is_Preelaborable_Aggregate (N);
17330 -- Attributes are allowed in general, even if their prefix is a formal
17331 -- type. It seems that certain attributes known not to be static might
17332 -- not be allowed, but there are no rules to prevent them.
17334 elsif Nkind (N) = N_Attribute_Reference then
17339 elsif Nkind (N) in N_Subexpr and then Is_OK_Static_Expression (N) then
17342 elsif Nkind (N) = N_Qualified_Expression then
17343 return Is_Preelaborable_Construct (Expression (N));
17345 -- Names are preelaborable when they denote a discriminant of an
17346 -- enclosing type. Discriminals are also considered for this check.
17348 elsif Is_Entity_Name (N)
17349 and then Present (Entity (N))
17351 (Ekind (Entity (N)) = E_Discriminant
17352 or else (Ekind_In (Entity (N), E_Constant, E_In_Parameter)
17353 and then Present (Discriminal_Link (Entity (N)))))
17359 elsif Nkind (N) = N_Null then
17362 -- Otherwise the construct is not preelaborable
17367 end Is_Preelaborable_Construct;
17369 ---------------------------------
17370 -- Is_Protected_Self_Reference --
17371 ---------------------------------
17373 function Is_Protected_Self_Reference (N : Node_Id) return Boolean is
17375 function In_Access_Definition (N : Node_Id) return Boolean;
17376 -- Returns true if N belongs to an access definition
17378 --------------------------
17379 -- In_Access_Definition --
17380 --------------------------
17382 function In_Access_Definition (N : Node_Id) return Boolean is
17387 while Present (P) loop
17388 if Nkind (P) = N_Access_Definition then
17396 end In_Access_Definition;
17398 -- Start of processing for Is_Protected_Self_Reference
17401 -- Verify that prefix is analyzed and has the proper form. Note that
17402 -- the attributes Elab_Spec, Elab_Body, and Elab_Subp_Body, which also
17403 -- produce the address of an entity, do not analyze their prefix
17404 -- because they denote entities that are not necessarily visible.
17405 -- Neither of them can apply to a protected type.
17407 return Ada_Version >= Ada_2005
17408 and then Is_Entity_Name (N)
17409 and then Present (Entity (N))
17410 and then Is_Protected_Type (Entity (N))
17411 and then In_Open_Scopes (Entity (N))
17412 and then not In_Access_Definition (N);
17413 end Is_Protected_Self_Reference;
17415 -----------------------------
17416 -- Is_RCI_Pkg_Spec_Or_Body --
17417 -----------------------------
17419 function Is_RCI_Pkg_Spec_Or_Body (Cunit : Node_Id) return Boolean is
17421 function Is_RCI_Pkg_Decl_Cunit (Cunit : Node_Id) return Boolean;
17422 -- Return True if the unit of Cunit is an RCI package declaration
17424 ---------------------------
17425 -- Is_RCI_Pkg_Decl_Cunit --
17426 ---------------------------
17428 function Is_RCI_Pkg_Decl_Cunit (Cunit : Node_Id) return Boolean is
17429 The_Unit : constant Node_Id := Unit (Cunit);
17432 if Nkind (The_Unit) /= N_Package_Declaration then
17436 return Is_Remote_Call_Interface (Defining_Entity (The_Unit));
17437 end Is_RCI_Pkg_Decl_Cunit;
17439 -- Start of processing for Is_RCI_Pkg_Spec_Or_Body
17442 return Is_RCI_Pkg_Decl_Cunit (Cunit)
17444 (Nkind (Unit (Cunit)) = N_Package_Body
17445 and then Is_RCI_Pkg_Decl_Cunit (Library_Unit (Cunit)));
17446 end Is_RCI_Pkg_Spec_Or_Body;
17448 -----------------------------------------
17449 -- Is_Remote_Access_To_Class_Wide_Type --
17450 -----------------------------------------
17452 function Is_Remote_Access_To_Class_Wide_Type
17453 (E : Entity_Id) return Boolean
17456 -- A remote access to class-wide type is a general access to object type
17457 -- declared in the visible part of a Remote_Types or Remote_Call_
17460 return Ekind (E) = E_General_Access_Type
17461 and then (Is_Remote_Call_Interface (E) or else Is_Remote_Types (E));
17462 end Is_Remote_Access_To_Class_Wide_Type;
17464 -----------------------------------------
17465 -- Is_Remote_Access_To_Subprogram_Type --
17466 -----------------------------------------
17468 function Is_Remote_Access_To_Subprogram_Type
17469 (E : Entity_Id) return Boolean
17472 return (Ekind (E) = E_Access_Subprogram_Type
17473 or else (Ekind (E) = E_Record_Type
17474 and then Present (Corresponding_Remote_Type (E))))
17475 and then (Is_Remote_Call_Interface (E) or else Is_Remote_Types (E));
17476 end Is_Remote_Access_To_Subprogram_Type;
17478 --------------------
17479 -- Is_Remote_Call --
17480 --------------------
17482 function Is_Remote_Call (N : Node_Id) return Boolean is
17484 if Nkind (N) not in N_Subprogram_Call then
17486 -- An entry call cannot be remote
17490 elsif Nkind (Name (N)) in N_Has_Entity
17491 and then Is_Remote_Call_Interface (Entity (Name (N)))
17493 -- A subprogram declared in the spec of a RCI package is remote
17497 elsif Nkind (Name (N)) = N_Explicit_Dereference
17498 and then Is_Remote_Access_To_Subprogram_Type
17499 (Etype (Prefix (Name (N))))
17501 -- The dereference of a RAS is a remote call
17505 elsif Present (Controlling_Argument (N))
17506 and then Is_Remote_Access_To_Class_Wide_Type
17507 (Etype (Controlling_Argument (N)))
17509 -- Any primitive operation call with a controlling argument of
17510 -- a RACW type is a remote call.
17515 -- All other calls are local calls
17518 end Is_Remote_Call;
17520 ----------------------
17521 -- Is_Renamed_Entry --
17522 ----------------------
17524 function Is_Renamed_Entry (Proc_Nam : Entity_Id) return Boolean is
17525 Orig_Node : Node_Id := Empty;
17526 Subp_Decl : Node_Id := Parent (Parent (Proc_Nam));
17528 function Is_Entry (Nam : Node_Id) return Boolean;
17529 -- Determine whether Nam is an entry. Traverse selectors if there are
17530 -- nested selected components.
17536 function Is_Entry (Nam : Node_Id) return Boolean is
17538 if Nkind (Nam) = N_Selected_Component then
17539 return Is_Entry (Selector_Name (Nam));
17542 return Ekind (Entity (Nam)) = E_Entry;
17545 -- Start of processing for Is_Renamed_Entry
17548 if Present (Alias (Proc_Nam)) then
17549 Subp_Decl := Parent (Parent (Alias (Proc_Nam)));
17552 -- Look for a rewritten subprogram renaming declaration
17554 if Nkind (Subp_Decl) = N_Subprogram_Declaration
17555 and then Present (Original_Node (Subp_Decl))
17557 Orig_Node := Original_Node (Subp_Decl);
17560 -- The rewritten subprogram is actually an entry
17562 if Present (Orig_Node)
17563 and then Nkind (Orig_Node) = N_Subprogram_Renaming_Declaration
17564 and then Is_Entry (Name (Orig_Node))
17570 end Is_Renamed_Entry;
17572 -----------------------------
17573 -- Is_Renaming_Declaration --
17574 -----------------------------
17576 function Is_Renaming_Declaration (N : Node_Id) return Boolean is
17579 when N_Exception_Renaming_Declaration
17580 | N_Generic_Function_Renaming_Declaration
17581 | N_Generic_Package_Renaming_Declaration
17582 | N_Generic_Procedure_Renaming_Declaration
17583 | N_Object_Renaming_Declaration
17584 | N_Package_Renaming_Declaration
17585 | N_Subprogram_Renaming_Declaration
17592 end Is_Renaming_Declaration;
17594 ----------------------------
17595 -- Is_Reversible_Iterator --
17596 ----------------------------
17598 function Is_Reversible_Iterator (Typ : Entity_Id) return Boolean is
17599 Ifaces_List : Elist_Id;
17600 Iface_Elmt : Elmt_Id;
17604 if Is_Class_Wide_Type (Typ)
17605 and then Chars (Root_Type (Typ)) = Name_Reversible_Iterator
17606 and then In_Predefined_Unit (Root_Type (Typ))
17610 elsif not Is_Tagged_Type (Typ) or else not Is_Derived_Type (Typ) then
17614 Collect_Interfaces (Typ, Ifaces_List);
17616 Iface_Elmt := First_Elmt (Ifaces_List);
17617 while Present (Iface_Elmt) loop
17618 Iface := Node (Iface_Elmt);
17619 if Chars (Iface) = Name_Reversible_Iterator
17620 and then In_Predefined_Unit (Iface)
17625 Next_Elmt (Iface_Elmt);
17630 end Is_Reversible_Iterator;
17632 ----------------------
17633 -- Is_Selector_Name --
17634 ----------------------
17636 function Is_Selector_Name (N : Node_Id) return Boolean is
17638 if not Is_List_Member (N) then
17640 P : constant Node_Id := Parent (N);
17642 return Nkind_In (P, N_Expanded_Name,
17643 N_Generic_Association,
17644 N_Parameter_Association,
17645 N_Selected_Component)
17646 and then Selector_Name (P) = N;
17651 L : constant List_Id := List_Containing (N);
17652 P : constant Node_Id := Parent (L);
17654 return (Nkind (P) = N_Discriminant_Association
17655 and then Selector_Names (P) = L)
17657 (Nkind (P) = N_Component_Association
17658 and then Choices (P) = L);
17661 end Is_Selector_Name;
17663 ---------------------------------
17664 -- Is_Single_Concurrent_Object --
17665 ---------------------------------
17667 function Is_Single_Concurrent_Object (Id : Entity_Id) return Boolean is
17670 Is_Single_Protected_Object (Id) or else Is_Single_Task_Object (Id);
17671 end Is_Single_Concurrent_Object;
17673 -------------------------------
17674 -- Is_Single_Concurrent_Type --
17675 -------------------------------
17677 function Is_Single_Concurrent_Type (Id : Entity_Id) return Boolean is
17680 Ekind_In (Id, E_Protected_Type, E_Task_Type)
17681 and then Is_Single_Concurrent_Type_Declaration
17682 (Declaration_Node (Id));
17683 end Is_Single_Concurrent_Type;
17685 -------------------------------------------
17686 -- Is_Single_Concurrent_Type_Declaration --
17687 -------------------------------------------
17689 function Is_Single_Concurrent_Type_Declaration
17690 (N : Node_Id) return Boolean
17693 return Nkind_In (Original_Node (N), N_Single_Protected_Declaration,
17694 N_Single_Task_Declaration);
17695 end Is_Single_Concurrent_Type_Declaration;
17697 ---------------------------------------------
17698 -- Is_Single_Precision_Floating_Point_Type --
17699 ---------------------------------------------
17701 function Is_Single_Precision_Floating_Point_Type
17702 (E : Entity_Id) return Boolean is
17704 return Is_Floating_Point_Type (E)
17705 and then Machine_Radix_Value (E) = Uint_2
17706 and then Machine_Mantissa_Value (E) = Uint_24
17707 and then Machine_Emax_Value (E) = Uint_2 ** Uint_7
17708 and then Machine_Emin_Value (E) = Uint_3 - (Uint_2 ** Uint_7);
17709 end Is_Single_Precision_Floating_Point_Type;
17711 --------------------------------
17712 -- Is_Single_Protected_Object --
17713 --------------------------------
17715 function Is_Single_Protected_Object (Id : Entity_Id) return Boolean is
17718 Ekind (Id) = E_Variable
17719 and then Ekind (Etype (Id)) = E_Protected_Type
17720 and then Is_Single_Concurrent_Type (Etype (Id));
17721 end Is_Single_Protected_Object;
17723 ---------------------------
17724 -- Is_Single_Task_Object --
17725 ---------------------------
17727 function Is_Single_Task_Object (Id : Entity_Id) return Boolean is
17730 Ekind (Id) = E_Variable
17731 and then Ekind (Etype (Id)) = E_Task_Type
17732 and then Is_Single_Concurrent_Type (Etype (Id));
17733 end Is_Single_Task_Object;
17735 -------------------------------------
17736 -- Is_SPARK_05_Initialization_Expr --
17737 -------------------------------------
17739 function Is_SPARK_05_Initialization_Expr (N : Node_Id) return Boolean is
17742 Comp_Assn : Node_Id;
17743 Orig_N : constant Node_Id := Original_Node (N);
17748 if not Comes_From_Source (Orig_N) then
17752 pragma Assert (Nkind (Orig_N) in N_Subexpr);
17754 case Nkind (Orig_N) is
17755 when N_Character_Literal
17756 | N_Integer_Literal
17762 when N_Expanded_Name
17765 if Is_Entity_Name (Orig_N)
17766 and then Present (Entity (Orig_N)) -- needed in some cases
17768 case Ekind (Entity (Orig_N)) is
17770 | E_Enumeration_Literal
17777 if Is_Type (Entity (Orig_N)) then
17785 when N_Qualified_Expression
17786 | N_Type_Conversion
17788 Is_Ok := Is_SPARK_05_Initialization_Expr (Expression (Orig_N));
17791 Is_Ok := Is_SPARK_05_Initialization_Expr (Right_Opnd (Orig_N));
17794 | N_Membership_Test
17797 Is_Ok := Is_SPARK_05_Initialization_Expr (Left_Opnd (Orig_N))
17799 Is_SPARK_05_Initialization_Expr (Right_Opnd (Orig_N));
17802 | N_Extension_Aggregate
17804 if Nkind (Orig_N) = N_Extension_Aggregate then
17806 Is_SPARK_05_Initialization_Expr (Ancestor_Part (Orig_N));
17809 Expr := First (Expressions (Orig_N));
17810 while Present (Expr) loop
17811 if not Is_SPARK_05_Initialization_Expr (Expr) then
17819 Comp_Assn := First (Component_Associations (Orig_N));
17820 while Present (Comp_Assn) loop
17821 Expr := Expression (Comp_Assn);
17823 -- Note: test for Present here needed for box assocation
17826 and then not Is_SPARK_05_Initialization_Expr (Expr)
17835 when N_Attribute_Reference =>
17836 if Nkind (Prefix (Orig_N)) in N_Subexpr then
17837 Is_Ok := Is_SPARK_05_Initialization_Expr (Prefix (Orig_N));
17840 Expr := First (Expressions (Orig_N));
17841 while Present (Expr) loop
17842 if not Is_SPARK_05_Initialization_Expr (Expr) then
17850 -- Selected components might be expanded named not yet resolved, so
17851 -- default on the safe side. (Eg on sparklex.ads)
17853 when N_Selected_Component =>
17862 end Is_SPARK_05_Initialization_Expr;
17864 ----------------------------------
17865 -- Is_SPARK_05_Object_Reference --
17866 ----------------------------------
17868 function Is_SPARK_05_Object_Reference (N : Node_Id) return Boolean is
17870 if Is_Entity_Name (N) then
17871 return Present (Entity (N))
17873 (Ekind_In (Entity (N), E_Constant, E_Variable)
17874 or else Ekind (Entity (N)) in Formal_Kind);
17878 when N_Selected_Component =>
17879 return Is_SPARK_05_Object_Reference (Prefix (N));
17885 end Is_SPARK_05_Object_Reference;
17887 -----------------------------
17888 -- Is_Specific_Tagged_Type --
17889 -----------------------------
17891 function Is_Specific_Tagged_Type (Typ : Entity_Id) return Boolean is
17892 Full_Typ : Entity_Id;
17895 -- Handle private types
17897 if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then
17898 Full_Typ := Full_View (Typ);
17903 -- A specific tagged type is a non-class-wide tagged type
17905 return Is_Tagged_Type (Full_Typ) and not Is_Class_Wide_Type (Full_Typ);
17906 end Is_Specific_Tagged_Type;
17912 function Is_Statement (N : Node_Id) return Boolean is
17915 Nkind (N) in N_Statement_Other_Than_Procedure_Call
17916 or else Nkind (N) = N_Procedure_Call_Statement;
17919 ----------------------------------------
17920 -- Is_Subcomponent_Of_Atomic_Object --
17921 ----------------------------------------
17923 function Is_Subcomponent_Of_Atomic_Object (N : Node_Id) return Boolean is
17927 R := Get_Referenced_Object (N);
17929 while Nkind_In (R, N_Indexed_Component, N_Selected_Component, N_Slice)
17931 R := Get_Referenced_Object (Prefix (R));
17933 -- If the prefix is an access value, only the designated type matters
17935 if Is_Access_Type (Etype (R)) then
17936 if Is_Atomic (Designated_Type (Etype (R))) then
17941 if Is_Atomic_Object (R) then
17948 end Is_Subcomponent_Of_Atomic_Object;
17950 ---------------------------------------
17951 -- Is_Subprogram_Contract_Annotation --
17952 ---------------------------------------
17954 function Is_Subprogram_Contract_Annotation
17955 (Item : Node_Id) return Boolean
17960 if Nkind (Item) = N_Aspect_Specification then
17961 Nam := Chars (Identifier (Item));
17963 else pragma Assert (Nkind (Item) = N_Pragma);
17964 Nam := Pragma_Name (Item);
17967 return Nam = Name_Contract_Cases
17968 or else Nam = Name_Depends
17969 or else Nam = Name_Extensions_Visible
17970 or else Nam = Name_Global
17971 or else Nam = Name_Post
17972 or else Nam = Name_Post_Class
17973 or else Nam = Name_Postcondition
17974 or else Nam = Name_Pre
17975 or else Nam = Name_Pre_Class
17976 or else Nam = Name_Precondition
17977 or else Nam = Name_Refined_Depends
17978 or else Nam = Name_Refined_Global
17979 or else Nam = Name_Refined_Post
17980 or else Nam = Name_Test_Case;
17981 end Is_Subprogram_Contract_Annotation;
17983 --------------------------------------------------
17984 -- Is_Subprogram_Stub_Without_Prior_Declaration --
17985 --------------------------------------------------
17987 function Is_Subprogram_Stub_Without_Prior_Declaration
17988 (N : Node_Id) return Boolean
17991 pragma Assert (Nkind (N) = N_Subprogram_Body_Stub);
17993 case Ekind (Defining_Entity (N)) is
17995 -- A subprogram stub without prior declaration serves as declaration
17996 -- for the actual subprogram body. As such, it has an attached
17997 -- defining entity of E_Function or E_Procedure.
18004 -- Otherwise, it is completes a [generic] subprogram declaration
18006 when E_Generic_Function
18007 | E_Generic_Procedure
18008 | E_Subprogram_Body
18013 raise Program_Error;
18015 end Is_Subprogram_Stub_Without_Prior_Declaration;
18017 ---------------------------
18018 -- Is_Suitable_Primitive --
18019 ---------------------------
18021 function Is_Suitable_Primitive (Subp_Id : Entity_Id) return Boolean is
18023 -- The Default_Initial_Condition and invariant procedures must not be
18024 -- treated as primitive operations even when they apply to a tagged
18025 -- type. These routines must not act as targets of dispatching calls
18026 -- because they already utilize class-wide-precondition semantics to
18027 -- handle inheritance and overriding.
18029 if Ekind (Subp_Id) = E_Procedure
18030 and then (Is_DIC_Procedure (Subp_Id)
18032 Is_Invariant_Procedure (Subp_Id))
18038 end Is_Suitable_Primitive;
18040 --------------------------
18041 -- Is_Suspension_Object --
18042 --------------------------
18044 function Is_Suspension_Object (Id : Entity_Id) return Boolean is
18046 -- This approach does an exact name match rather than to rely on
18047 -- RTSfind. Routine Is_Effectively_Volatile is used by clients of the
18048 -- front end at point where all auxiliary tables are locked and any
18049 -- modifications to them are treated as violations. Do not tamper with
18050 -- the tables, instead examine the Chars fields of all the scopes of Id.
18053 Chars (Id) = Name_Suspension_Object
18054 and then Present (Scope (Id))
18055 and then Chars (Scope (Id)) = Name_Synchronous_Task_Control
18056 and then Present (Scope (Scope (Id)))
18057 and then Chars (Scope (Scope (Id))) = Name_Ada
18058 and then Present (Scope (Scope (Scope (Id))))
18059 and then Scope (Scope (Scope (Id))) = Standard_Standard;
18060 end Is_Suspension_Object;
18062 ----------------------------
18063 -- Is_Synchronized_Object --
18064 ----------------------------
18066 function Is_Synchronized_Object (Id : Entity_Id) return Boolean is
18070 if Is_Object (Id) then
18072 -- The object is synchronized if it is of a type that yields a
18073 -- synchronized object.
18075 if Yields_Synchronized_Object (Etype (Id)) then
18078 -- The object is synchronized if it is atomic and Async_Writers is
18081 elsif Is_Atomic_Object_Entity (Id)
18082 and then Async_Writers_Enabled (Id)
18086 -- A constant is a synchronized object by default
18088 elsif Ekind (Id) = E_Constant then
18091 -- A variable is a synchronized object if it is subject to pragma
18092 -- Constant_After_Elaboration.
18094 elsif Ekind (Id) = E_Variable then
18095 Prag := Get_Pragma (Id, Pragma_Constant_After_Elaboration);
18097 return Present (Prag) and then Is_Enabled_Pragma (Prag);
18101 -- Otherwise the input is not an object or it does not qualify as a
18102 -- synchronized object.
18105 end Is_Synchronized_Object;
18107 ---------------------------------
18108 -- Is_Synchronized_Tagged_Type --
18109 ---------------------------------
18111 function Is_Synchronized_Tagged_Type (E : Entity_Id) return Boolean is
18112 Kind : constant Entity_Kind := Ekind (Base_Type (E));
18115 -- A task or protected type derived from an interface is a tagged type.
18116 -- Such a tagged type is called a synchronized tagged type, as are
18117 -- synchronized interfaces and private extensions whose declaration
18118 -- includes the reserved word synchronized.
18120 return (Is_Tagged_Type (E)
18121 and then (Kind = E_Task_Type
18123 Kind = E_Protected_Type))
18126 and then Is_Synchronized_Interface (E))
18128 (Ekind (E) = E_Record_Type_With_Private
18129 and then Nkind (Parent (E)) = N_Private_Extension_Declaration
18130 and then (Synchronized_Present (Parent (E))
18131 or else Is_Synchronized_Interface (Etype (E))));
18132 end Is_Synchronized_Tagged_Type;
18138 function Is_Transfer (N : Node_Id) return Boolean is
18139 Kind : constant Node_Kind := Nkind (N);
18142 if Kind = N_Simple_Return_Statement
18144 Kind = N_Extended_Return_Statement
18146 Kind = N_Goto_Statement
18148 Kind = N_Raise_Statement
18150 Kind = N_Requeue_Statement
18154 elsif (Kind = N_Exit_Statement or else Kind in N_Raise_xxx_Error)
18155 and then No (Condition (N))
18159 elsif Kind = N_Procedure_Call_Statement
18160 and then Is_Entity_Name (Name (N))
18161 and then Present (Entity (Name (N)))
18162 and then No_Return (Entity (Name (N)))
18166 elsif Nkind (Original_Node (N)) = N_Raise_Statement then
18178 function Is_True (U : Uint) return Boolean is
18183 --------------------------------------
18184 -- Is_Unchecked_Conversion_Instance --
18185 --------------------------------------
18187 function Is_Unchecked_Conversion_Instance (Id : Entity_Id) return Boolean is
18191 -- Look for a function whose generic parent is the predefined intrinsic
18192 -- function Unchecked_Conversion, or for one that renames such an
18195 if Ekind (Id) = E_Function then
18196 Par := Parent (Id);
18198 if Nkind (Par) = N_Function_Specification then
18199 Par := Generic_Parent (Par);
18201 if Present (Par) then
18203 Chars (Par) = Name_Unchecked_Conversion
18204 and then Is_Intrinsic_Subprogram (Par)
18205 and then In_Predefined_Unit (Par);
18208 Present (Alias (Id))
18209 and then Is_Unchecked_Conversion_Instance (Alias (Id));
18215 end Is_Unchecked_Conversion_Instance;
18217 -------------------------------
18218 -- Is_Universal_Numeric_Type --
18219 -------------------------------
18221 function Is_Universal_Numeric_Type (T : Entity_Id) return Boolean is
18223 return T = Universal_Integer or else T = Universal_Real;
18224 end Is_Universal_Numeric_Type;
18226 ------------------------------
18227 -- Is_User_Defined_Equality --
18228 ------------------------------
18230 function Is_User_Defined_Equality (Id : Entity_Id) return Boolean is
18232 return Ekind (Id) = E_Function
18233 and then Chars (Id) = Name_Op_Eq
18234 and then Comes_From_Source (Id)
18236 -- Internally generated equalities have a full type declaration
18237 -- as their parent.
18239 and then Nkind (Parent (Id)) = N_Function_Specification;
18240 end Is_User_Defined_Equality;
18242 --------------------------------------
18243 -- Is_Validation_Variable_Reference --
18244 --------------------------------------
18246 function Is_Validation_Variable_Reference (N : Node_Id) return Boolean is
18247 Var : constant Node_Id := Unqual_Conv (N);
18248 Var_Id : Entity_Id;
18253 if Is_Entity_Name (Var) then
18254 Var_Id := Entity (Var);
18259 and then Ekind (Var_Id) = E_Variable
18260 and then Present (Validated_Object (Var_Id));
18261 end Is_Validation_Variable_Reference;
18263 ----------------------------
18264 -- Is_Variable_Size_Array --
18265 ----------------------------
18267 function Is_Variable_Size_Array (E : Entity_Id) return Boolean is
18271 pragma Assert (Is_Array_Type (E));
18273 -- Check if some index is initialized with a non-constant value
18275 Idx := First_Index (E);
18276 while Present (Idx) loop
18277 if Nkind (Idx) = N_Range then
18278 if not Is_Constant_Bound (Low_Bound (Idx))
18279 or else not Is_Constant_Bound (High_Bound (Idx))
18285 Idx := Next_Index (Idx);
18289 end Is_Variable_Size_Array;
18291 -----------------------------
18292 -- Is_Variable_Size_Record --
18293 -----------------------------
18295 function Is_Variable_Size_Record (E : Entity_Id) return Boolean is
18297 Comp_Typ : Entity_Id;
18300 pragma Assert (Is_Record_Type (E));
18302 Comp := First_Component (E);
18303 while Present (Comp) loop
18304 Comp_Typ := Underlying_Type (Etype (Comp));
18306 -- Recursive call if the record type has discriminants
18308 if Is_Record_Type (Comp_Typ)
18309 and then Has_Discriminants (Comp_Typ)
18310 and then Is_Variable_Size_Record (Comp_Typ)
18314 elsif Is_Array_Type (Comp_Typ)
18315 and then Is_Variable_Size_Array (Comp_Typ)
18320 Next_Component (Comp);
18324 end Is_Variable_Size_Record;
18330 function Is_Variable
18332 Use_Original_Node : Boolean := True) return Boolean
18334 Orig_Node : Node_Id;
18336 function In_Protected_Function (E : Entity_Id) return Boolean;
18337 -- Within a protected function, the private components of the enclosing
18338 -- protected type are constants. A function nested within a (protected)
18339 -- procedure is not itself protected. Within the body of a protected
18340 -- function the current instance of the protected type is a constant.
18342 function Is_Variable_Prefix (P : Node_Id) return Boolean;
18343 -- Prefixes can involve implicit dereferences, in which case we must
18344 -- test for the case of a reference of a constant access type, which can
18345 -- can never be a variable.
18347 ---------------------------
18348 -- In_Protected_Function --
18349 ---------------------------
18351 function In_Protected_Function (E : Entity_Id) return Boolean is
18356 -- E is the current instance of a type
18358 if Is_Type (E) then
18367 if not Is_Protected_Type (Prot) then
18371 S := Current_Scope;
18372 while Present (S) and then S /= Prot loop
18373 if Ekind (S) = E_Function and then Scope (S) = Prot then
18382 end In_Protected_Function;
18384 ------------------------
18385 -- Is_Variable_Prefix --
18386 ------------------------
18388 function Is_Variable_Prefix (P : Node_Id) return Boolean is
18390 if Is_Access_Type (Etype (P)) then
18391 return not Is_Access_Constant (Root_Type (Etype (P)));
18393 -- For the case of an indexed component whose prefix has a packed
18394 -- array type, the prefix has been rewritten into a type conversion.
18395 -- Determine variable-ness from the converted expression.
18397 elsif Nkind (P) = N_Type_Conversion
18398 and then not Comes_From_Source (P)
18399 and then Is_Array_Type (Etype (P))
18400 and then Is_Packed (Etype (P))
18402 return Is_Variable (Expression (P));
18405 return Is_Variable (P);
18407 end Is_Variable_Prefix;
18409 -- Start of processing for Is_Variable
18412 -- Special check, allow x'Deref(expr) as a variable
18414 if Nkind (N) = N_Attribute_Reference
18415 and then Attribute_Name (N) = Name_Deref
18420 -- Check if we perform the test on the original node since this may be a
18421 -- test of syntactic categories which must not be disturbed by whatever
18422 -- rewriting might have occurred. For example, an aggregate, which is
18423 -- certainly NOT a variable, could be turned into a variable by
18426 if Use_Original_Node then
18427 Orig_Node := Original_Node (N);
18432 -- Definitely OK if Assignment_OK is set. Since this is something that
18433 -- only gets set for expanded nodes, the test is on N, not Orig_Node.
18435 if Nkind (N) in N_Subexpr and then Assignment_OK (N) then
18438 -- Normally we go to the original node, but there is one exception where
18439 -- we use the rewritten node, namely when it is an explicit dereference.
18440 -- The generated code may rewrite a prefix which is an access type with
18441 -- an explicit dereference. The dereference is a variable, even though
18442 -- the original node may not be (since it could be a constant of the
18445 -- In Ada 2005 we have a further case to consider: the prefix may be a
18446 -- function call given in prefix notation. The original node appears to
18447 -- be a selected component, but we need to examine the call.
18449 elsif Nkind (N) = N_Explicit_Dereference
18450 and then Nkind (Orig_Node) /= N_Explicit_Dereference
18451 and then Present (Etype (Orig_Node))
18452 and then Is_Access_Type (Etype (Orig_Node))
18454 -- Note that if the prefix is an explicit dereference that does not
18455 -- come from source, we must check for a rewritten function call in
18456 -- prefixed notation before other forms of rewriting, to prevent a
18460 (Nkind (Orig_Node) = N_Function_Call
18461 and then not Is_Access_Constant (Etype (Prefix (N))))
18463 Is_Variable_Prefix (Original_Node (Prefix (N)));
18465 -- in Ada 2012, the dereference may have been added for a type with
18466 -- a declared implicit dereference aspect. Check that it is not an
18467 -- access to constant.
18469 elsif Nkind (N) = N_Explicit_Dereference
18470 and then Present (Etype (Orig_Node))
18471 and then Ada_Version >= Ada_2012
18472 and then Has_Implicit_Dereference (Etype (Orig_Node))
18474 return not Is_Access_Constant (Etype (Prefix (N)));
18476 -- A function call is never a variable
18478 elsif Nkind (N) = N_Function_Call then
18481 -- All remaining checks use the original node
18483 elsif Is_Entity_Name (Orig_Node)
18484 and then Present (Entity (Orig_Node))
18487 E : constant Entity_Id := Entity (Orig_Node);
18488 K : constant Entity_Kind := Ekind (E);
18491 if Is_Loop_Parameter (E) then
18495 return (K = E_Variable
18496 and then Nkind (Parent (E)) /= N_Exception_Handler)
18497 or else (K = E_Component
18498 and then not In_Protected_Function (E))
18499 or else K = E_Out_Parameter
18500 or else K = E_In_Out_Parameter
18501 or else K = E_Generic_In_Out_Parameter
18503 -- Current instance of type. If this is a protected type, check
18504 -- we are not within the body of one of its protected functions.
18506 or else (Is_Type (E)
18507 and then In_Open_Scopes (E)
18508 and then not In_Protected_Function (E))
18510 or else (Is_Incomplete_Or_Private_Type (E)
18511 and then In_Open_Scopes (Full_View (E)));
18515 case Nkind (Orig_Node) is
18516 when N_Indexed_Component
18519 return Is_Variable_Prefix (Prefix (Orig_Node));
18521 when N_Selected_Component =>
18522 return (Is_Variable (Selector_Name (Orig_Node))
18523 and then Is_Variable_Prefix (Prefix (Orig_Node)))
18525 (Nkind (N) = N_Expanded_Name
18526 and then Scope (Entity (N)) = Entity (Prefix (N)));
18528 -- For an explicit dereference, the type of the prefix cannot
18529 -- be an access to constant or an access to subprogram.
18531 when N_Explicit_Dereference =>
18533 Typ : constant Entity_Id := Etype (Prefix (Orig_Node));
18535 return Is_Access_Type (Typ)
18536 and then not Is_Access_Constant (Root_Type (Typ))
18537 and then Ekind (Typ) /= E_Access_Subprogram_Type;
18540 -- The type conversion is the case where we do not deal with the
18541 -- context dependent special case of an actual parameter. Thus
18542 -- the type conversion is only considered a variable for the
18543 -- purposes of this routine if the target type is tagged. However,
18544 -- a type conversion is considered to be a variable if it does not
18545 -- come from source (this deals for example with the conversions
18546 -- of expressions to their actual subtypes).
18548 when N_Type_Conversion =>
18549 return Is_Variable (Expression (Orig_Node))
18551 (not Comes_From_Source (Orig_Node)
18553 (Is_Tagged_Type (Etype (Subtype_Mark (Orig_Node)))
18555 Is_Tagged_Type (Etype (Expression (Orig_Node)))));
18557 -- GNAT allows an unchecked type conversion as a variable. This
18558 -- only affects the generation of internal expanded code, since
18559 -- calls to instantiations of Unchecked_Conversion are never
18560 -- considered variables (since they are function calls).
18562 when N_Unchecked_Type_Conversion =>
18563 return Is_Variable (Expression (Orig_Node));
18571 ---------------------------
18572 -- Is_Visibly_Controlled --
18573 ---------------------------
18575 function Is_Visibly_Controlled (T : Entity_Id) return Boolean is
18576 Root : constant Entity_Id := Root_Type (T);
18578 return Chars (Scope (Root)) = Name_Finalization
18579 and then Chars (Scope (Scope (Root))) = Name_Ada
18580 and then Scope (Scope (Scope (Root))) = Standard_Standard;
18581 end Is_Visibly_Controlled;
18583 --------------------------------------
18584 -- Is_Volatile_Full_Access_Object --
18585 --------------------------------------
18587 function Is_Volatile_Full_Access_Object (N : Node_Id) return Boolean is
18588 function Is_VFA_Object_Entity (Id : Entity_Id) return Boolean;
18589 -- Determine whether arbitrary entity Id denotes an object that is
18590 -- Volatile_Full_Access.
18592 ----------------------------
18593 -- Is_VFA_Object_Entity --
18594 ----------------------------
18596 function Is_VFA_Object_Entity (Id : Entity_Id) return Boolean is
18600 and then (Is_Volatile_Full_Access (Id)
18602 Is_Volatile_Full_Access (Etype (Id)));
18603 end Is_VFA_Object_Entity;
18605 -- Start of processing for Is_Volatile_Full_Access_Object
18608 if Is_Entity_Name (N) then
18609 return Is_VFA_Object_Entity (Entity (N));
18611 elsif Is_Volatile_Full_Access (Etype (N)) then
18614 elsif Nkind (N) = N_Selected_Component then
18615 return Is_Volatile_Full_Access (Entity (Selector_Name (N)));
18620 end Is_Volatile_Full_Access_Object;
18622 --------------------------
18623 -- Is_Volatile_Function --
18624 --------------------------
18626 function Is_Volatile_Function (Func_Id : Entity_Id) return Boolean is
18628 pragma Assert (Ekind_In (Func_Id, E_Function, E_Generic_Function));
18630 -- A function declared within a protected type is volatile
18632 if Is_Protected_Type (Scope (Func_Id)) then
18635 -- An instance of Ada.Unchecked_Conversion is a volatile function if
18636 -- either the source or the target are effectively volatile.
18638 elsif Is_Unchecked_Conversion_Instance (Func_Id)
18639 and then Has_Effectively_Volatile_Profile (Func_Id)
18643 -- Otherwise the function is treated as volatile if it is subject to
18644 -- enabled pragma Volatile_Function.
18648 Is_Enabled_Pragma (Get_Pragma (Func_Id, Pragma_Volatile_Function));
18650 end Is_Volatile_Function;
18652 ------------------------
18653 -- Is_Volatile_Object --
18654 ------------------------
18656 function Is_Volatile_Object (N : Node_Id) return Boolean is
18657 function Is_Volatile_Object_Entity (Id : Entity_Id) return Boolean;
18658 -- Determine whether arbitrary entity Id denotes an object that is
18661 function Prefix_Has_Volatile_Components (P : Node_Id) return Boolean;
18662 -- Determine whether prefix P has volatile components. This requires
18663 -- the presence of a Volatile_Components aspect/pragma or that P be
18664 -- itself a volatile object as per RM C.6(8).
18666 ---------------------------------
18667 -- Is_Volatile_Object_Entity --
18668 ---------------------------------
18670 function Is_Volatile_Object_Entity (Id : Entity_Id) return Boolean is
18674 and then (Is_Volatile (Id) or else Is_Volatile (Etype (Id)));
18675 end Is_Volatile_Object_Entity;
18677 ------------------------------------
18678 -- Prefix_Has_Volatile_Components --
18679 ------------------------------------
18681 function Prefix_Has_Volatile_Components (P : Node_Id) return Boolean is
18682 Typ : constant Entity_Id := Etype (P);
18685 if Is_Access_Type (Typ) then
18687 Dtyp : constant Entity_Id := Designated_Type (Typ);
18690 return Has_Volatile_Components (Dtyp)
18691 or else Is_Volatile (Dtyp);
18694 elsif Has_Volatile_Components (Typ) then
18697 elsif Is_Entity_Name (P)
18698 and then Has_Volatile_Component (Entity (P))
18702 elsif Is_Volatile_Object (P) then
18708 end Prefix_Has_Volatile_Components;
18710 -- Start of processing for Is_Volatile_Object
18713 if Is_Entity_Name (N) then
18714 return Is_Volatile_Object_Entity (Entity (N));
18716 elsif Is_Volatile (Etype (N)) then
18719 elsif Nkind (N) = N_Indexed_Component then
18720 return Prefix_Has_Volatile_Components (Prefix (N));
18722 elsif Nkind (N) = N_Selected_Component then
18723 return Prefix_Has_Volatile_Components (Prefix (N))
18724 or else Is_Volatile (Entity (Selector_Name (N)));
18729 end Is_Volatile_Object;
18731 -----------------------------
18732 -- Iterate_Call_Parameters --
18733 -----------------------------
18735 procedure Iterate_Call_Parameters (Call : Node_Id) is
18736 Actual : Node_Id := First_Actual (Call);
18737 Formal : Entity_Id := First_Formal (Get_Called_Entity (Call));
18740 while Present (Formal) and then Present (Actual) loop
18741 Handle_Parameter (Formal, Actual);
18743 Next_Formal (Formal);
18744 Next_Actual (Actual);
18747 pragma Assert (No (Formal));
18748 pragma Assert (No (Actual));
18749 end Iterate_Call_Parameters;
18751 ---------------------------
18752 -- Itype_Has_Declaration --
18753 ---------------------------
18755 function Itype_Has_Declaration (Id : Entity_Id) return Boolean is
18757 pragma Assert (Is_Itype (Id));
18758 return Present (Parent (Id))
18759 and then Nkind_In (Parent (Id), N_Full_Type_Declaration,
18760 N_Subtype_Declaration)
18761 and then Defining_Entity (Parent (Id)) = Id;
18762 end Itype_Has_Declaration;
18764 -------------------------
18765 -- Kill_Current_Values --
18766 -------------------------
18768 procedure Kill_Current_Values
18770 Last_Assignment_Only : Boolean := False)
18773 if Is_Assignable (Ent) then
18774 Set_Last_Assignment (Ent, Empty);
18777 if Is_Object (Ent) then
18778 if not Last_Assignment_Only then
18780 Set_Current_Value (Ent, Empty);
18782 -- Do not reset the Is_Known_[Non_]Null and Is_Known_Valid flags
18783 -- for a constant. Once the constant is elaborated, its value is
18784 -- not changed, therefore the associated flags that describe the
18785 -- value should not be modified either.
18787 if Ekind (Ent) = E_Constant then
18790 -- Non-constant entities
18793 if not Can_Never_Be_Null (Ent) then
18794 Set_Is_Known_Non_Null (Ent, False);
18797 Set_Is_Known_Null (Ent, False);
18799 -- Reset the Is_Known_Valid flag unless the type is always
18800 -- valid. This does not apply to a loop parameter because its
18801 -- bounds are defined by the loop header and therefore always
18804 if not Is_Known_Valid (Etype (Ent))
18805 and then Ekind (Ent) /= E_Loop_Parameter
18807 Set_Is_Known_Valid (Ent, False);
18812 end Kill_Current_Values;
18814 procedure Kill_Current_Values (Last_Assignment_Only : Boolean := False) is
18817 procedure Kill_Current_Values_For_Entity_Chain (E : Entity_Id);
18818 -- Clear current value for entity E and all entities chained to E
18820 ------------------------------------------
18821 -- Kill_Current_Values_For_Entity_Chain --
18822 ------------------------------------------
18824 procedure Kill_Current_Values_For_Entity_Chain (E : Entity_Id) is
18828 while Present (Ent) loop
18829 Kill_Current_Values (Ent, Last_Assignment_Only);
18832 end Kill_Current_Values_For_Entity_Chain;
18834 -- Start of processing for Kill_Current_Values
18837 -- Kill all saved checks, a special case of killing saved values
18839 if not Last_Assignment_Only then
18843 -- Loop through relevant scopes, which includes the current scope and
18844 -- any parent scopes if the current scope is a block or a package.
18846 S := Current_Scope;
18849 -- Clear current values of all entities in current scope
18851 Kill_Current_Values_For_Entity_Chain (First_Entity (S));
18853 -- If scope is a package, also clear current values of all private
18854 -- entities in the scope.
18856 if Is_Package_Or_Generic_Package (S)
18857 or else Is_Concurrent_Type (S)
18859 Kill_Current_Values_For_Entity_Chain (First_Private_Entity (S));
18862 -- If this is a not a subprogram, deal with parents
18864 if not Is_Subprogram (S) then
18866 exit Scope_Loop when S = Standard_Standard;
18870 end loop Scope_Loop;
18871 end Kill_Current_Values;
18873 --------------------------
18874 -- Kill_Size_Check_Code --
18875 --------------------------
18877 procedure Kill_Size_Check_Code (E : Entity_Id) is
18879 if (Ekind (E) = E_Constant or else Ekind (E) = E_Variable)
18880 and then Present (Size_Check_Code (E))
18882 Remove (Size_Check_Code (E));
18883 Set_Size_Check_Code (E, Empty);
18885 end Kill_Size_Check_Code;
18887 --------------------
18888 -- Known_Non_Null --
18889 --------------------
18891 function Known_Non_Null (N : Node_Id) return Boolean is
18892 Status : constant Null_Status_Kind := Null_Status (N);
18899 -- The expression yields a non-null value ignoring simple flow analysis
18901 if Status = Is_Non_Null then
18904 -- Otherwise check whether N is a reference to an entity that appears
18905 -- within a conditional construct.
18907 elsif Is_Entity_Name (N) and then Present (Entity (N)) then
18909 -- First check if we are in decisive conditional
18911 Get_Current_Value_Condition (N, Op, Val);
18913 if Known_Null (Val) then
18914 if Op = N_Op_Eq then
18916 elsif Op = N_Op_Ne then
18921 -- If OK to do replacement, test Is_Known_Non_Null flag
18925 if OK_To_Do_Constant_Replacement (Id) then
18926 return Is_Known_Non_Null (Id);
18930 -- Otherwise it is not possible to determine whether N yields a non-null
18934 end Known_Non_Null;
18940 function Known_Null (N : Node_Id) return Boolean is
18941 Status : constant Null_Status_Kind := Null_Status (N);
18948 -- The expression yields a null value ignoring simple flow analysis
18950 if Status = Is_Null then
18953 -- Otherwise check whether N is a reference to an entity that appears
18954 -- within a conditional construct.
18956 elsif Is_Entity_Name (N) and then Present (Entity (N)) then
18958 -- First check if we are in decisive conditional
18960 Get_Current_Value_Condition (N, Op, Val);
18962 if Known_Null (Val) then
18963 if Op = N_Op_Eq then
18965 elsif Op = N_Op_Ne then
18970 -- If OK to do replacement, test Is_Known_Null flag
18974 if OK_To_Do_Constant_Replacement (Id) then
18975 return Is_Known_Null (Id);
18979 -- Otherwise it is not possible to determine whether N yields a null
18985 --------------------------
18986 -- Known_To_Be_Assigned --
18987 --------------------------
18989 function Known_To_Be_Assigned (N : Node_Id) return Boolean is
18990 P : constant Node_Id := Parent (N);
18995 -- Test left side of assignment
18997 when N_Assignment_Statement =>
18998 return N = Name (P);
19000 -- Function call arguments are never lvalues
19002 when N_Function_Call =>
19005 -- Positional parameter for procedure or accept call
19007 when N_Accept_Statement
19008 | N_Procedure_Call_Statement
19016 Proc := Get_Subprogram_Entity (P);
19022 -- If we are not a list member, something is strange, so
19023 -- be conservative and return False.
19025 if not Is_List_Member (N) then
19029 -- We are going to find the right formal by stepping forward
19030 -- through the formals, as we step backwards in the actuals.
19032 Form := First_Formal (Proc);
19035 -- If no formal, something is weird, so be conservative
19036 -- and return False.
19043 exit when No (Act);
19044 Next_Formal (Form);
19047 return Ekind (Form) /= E_In_Parameter;
19050 -- Named parameter for procedure or accept call
19052 when N_Parameter_Association =>
19058 Proc := Get_Subprogram_Entity (Parent (P));
19064 -- Loop through formals to find the one that matches
19066 Form := First_Formal (Proc);
19068 -- If no matching formal, that's peculiar, some kind of
19069 -- previous error, so return False to be conservative.
19070 -- Actually this also happens in legal code in the case
19071 -- where P is a parameter association for an Extra_Formal???
19077 -- Else test for match
19079 if Chars (Form) = Chars (Selector_Name (P)) then
19080 return Ekind (Form) /= E_In_Parameter;
19083 Next_Formal (Form);
19087 -- Test for appearing in a conversion that itself appears
19088 -- in an lvalue context, since this should be an lvalue.
19090 when N_Type_Conversion =>
19091 return Known_To_Be_Assigned (P);
19093 -- All other references are definitely not known to be modifications
19098 end Known_To_Be_Assigned;
19100 ---------------------------
19101 -- Last_Source_Statement --
19102 ---------------------------
19104 function Last_Source_Statement (HSS : Node_Id) return Node_Id is
19108 N := Last (Statements (HSS));
19109 while Present (N) loop
19110 exit when Comes_From_Source (N);
19115 end Last_Source_Statement;
19117 -----------------------
19118 -- Mark_Coextensions --
19119 -----------------------
19121 procedure Mark_Coextensions (Context_Nod : Node_Id; Root_Nod : Node_Id) is
19122 Is_Dynamic : Boolean;
19123 -- Indicates whether the context causes nested coextensions to be
19124 -- dynamic or static
19126 function Mark_Allocator (N : Node_Id) return Traverse_Result;
19127 -- Recognize an allocator node and label it as a dynamic coextension
19129 --------------------
19130 -- Mark_Allocator --
19131 --------------------
19133 function Mark_Allocator (N : Node_Id) return Traverse_Result is
19135 if Nkind (N) = N_Allocator then
19137 Set_Is_Static_Coextension (N, False);
19138 Set_Is_Dynamic_Coextension (N);
19140 -- If the allocator expression is potentially dynamic, it may
19141 -- be expanded out of order and require dynamic allocation
19142 -- anyway, so we treat the coextension itself as dynamic.
19143 -- Potential optimization ???
19145 elsif Nkind (Expression (N)) = N_Qualified_Expression
19146 and then Nkind (Expression (Expression (N))) = N_Op_Concat
19148 Set_Is_Static_Coextension (N, False);
19149 Set_Is_Dynamic_Coextension (N);
19151 Set_Is_Dynamic_Coextension (N, False);
19152 Set_Is_Static_Coextension (N);
19157 end Mark_Allocator;
19159 procedure Mark_Allocators is new Traverse_Proc (Mark_Allocator);
19161 -- Start of processing for Mark_Coextensions
19164 -- An allocator that appears on the right-hand side of an assignment is
19165 -- treated as a potentially dynamic coextension when the right-hand side
19166 -- is an allocator or a qualified expression.
19168 -- Obj := new ...'(new Coextension ...);
19170 if Nkind (Context_Nod) = N_Assignment_Statement then
19172 Nkind_In (Expression (Context_Nod), N_Allocator,
19173 N_Qualified_Expression);
19175 -- An allocator that appears within the expression of a simple return
19176 -- statement is treated as a potentially dynamic coextension when the
19177 -- expression is either aggregate, allocator, or qualified expression.
19179 -- return (new Coextension ...);
19180 -- return new ...'(new Coextension ...);
19182 elsif Nkind (Context_Nod) = N_Simple_Return_Statement then
19184 Nkind_In (Expression (Context_Nod), N_Aggregate,
19186 N_Qualified_Expression);
19188 -- An alloctor that appears within the initialization expression of an
19189 -- object declaration is considered a potentially dynamic coextension
19190 -- when the initialization expression is an allocator or a qualified
19193 -- Obj : ... := new ...'(new Coextension ...);
19195 -- A similar case arises when the object declaration is part of an
19196 -- extended return statement.
19198 -- return Obj : ... := new ...'(new Coextension ...);
19199 -- return Obj : ... := (new Coextension ...);
19201 elsif Nkind (Context_Nod) = N_Object_Declaration then
19203 Nkind_In (Root_Nod, N_Allocator, N_Qualified_Expression)
19205 Nkind (Parent (Context_Nod)) = N_Extended_Return_Statement;
19207 -- This routine should not be called with constructs that cannot contain
19211 raise Program_Error;
19214 Mark_Allocators (Root_Nod);
19215 end Mark_Coextensions;
19217 ---------------------------------
19218 -- Mark_Elaboration_Attributes --
19219 ---------------------------------
19221 procedure Mark_Elaboration_Attributes
19222 (N_Id : Node_Or_Entity_Id;
19223 Checks : Boolean := False;
19224 Level : Boolean := False;
19225 Modes : Boolean := False;
19226 Warnings : Boolean := False)
19228 function Elaboration_Checks_OK
19229 (Target_Id : Entity_Id;
19230 Context_Id : Entity_Id) return Boolean;
19231 -- Determine whether elaboration checks are enabled for target Target_Id
19232 -- which resides within context Context_Id.
19234 procedure Mark_Elaboration_Attributes_Id (Id : Entity_Id);
19235 -- Preserve relevant attributes of the context in arbitrary entity Id
19237 procedure Mark_Elaboration_Attributes_Node (N : Node_Id);
19238 -- Preserve relevant attributes of the context in arbitrary node N
19240 ---------------------------
19241 -- Elaboration_Checks_OK --
19242 ---------------------------
19244 function Elaboration_Checks_OK
19245 (Target_Id : Entity_Id;
19246 Context_Id : Entity_Id) return Boolean
19248 Encl_Scop : Entity_Id;
19251 -- Elaboration checks are suppressed for the target
19253 if Elaboration_Checks_Suppressed (Target_Id) then
19257 -- Otherwise elaboration checks are OK for the target, but may be
19258 -- suppressed for the context where the target is declared.
19260 Encl_Scop := Context_Id;
19261 while Present (Encl_Scop) and then Encl_Scop /= Standard_Standard loop
19262 if Elaboration_Checks_Suppressed (Encl_Scop) then
19266 Encl_Scop := Scope (Encl_Scop);
19269 -- Neither the target nor its declarative context have elaboration
19270 -- checks suppressed.
19273 end Elaboration_Checks_OK;
19275 ------------------------------------
19276 -- Mark_Elaboration_Attributes_Id --
19277 ------------------------------------
19279 procedure Mark_Elaboration_Attributes_Id (Id : Entity_Id) is
19281 -- Mark the status of elaboration checks in effect. Do not reset the
19282 -- status in case the entity is reanalyzed with checks suppressed.
19284 if Checks and then not Is_Elaboration_Checks_OK_Id (Id) then
19285 Set_Is_Elaboration_Checks_OK_Id (Id,
19286 Elaboration_Checks_OK
19288 Context_Id => Scope (Id)));
19291 -- Mark the status of elaboration warnings in effect. Do not reset
19292 -- the status in case the entity is reanalyzed with warnings off.
19294 if Warnings and then not Is_Elaboration_Warnings_OK_Id (Id) then
19295 Set_Is_Elaboration_Warnings_OK_Id (Id, Elab_Warnings);
19297 end Mark_Elaboration_Attributes_Id;
19299 --------------------------------------
19300 -- Mark_Elaboration_Attributes_Node --
19301 --------------------------------------
19303 procedure Mark_Elaboration_Attributes_Node (N : Node_Id) is
19304 function Extract_Name (N : Node_Id) return Node_Id;
19305 -- Obtain the Name attribute of call or instantiation N
19311 function Extract_Name (N : Node_Id) return Node_Id is
19317 -- A call to an entry family appears in indexed form
19319 if Nkind (Nam) = N_Indexed_Component then
19320 Nam := Prefix (Nam);
19323 -- The name may also appear in qualified form
19325 if Nkind (Nam) = N_Selected_Component then
19326 Nam := Selector_Name (Nam);
19334 Context_Id : Entity_Id;
19337 -- Start of processing for Mark_Elaboration_Attributes_Node
19340 -- Mark the status of elaboration checks in effect. Do not reset the
19341 -- status in case the node is reanalyzed with checks suppressed.
19343 if Checks and then not Is_Elaboration_Checks_OK_Node (N) then
19345 -- Assignments, attribute references, and variable references do
19346 -- not have a "declarative" context.
19348 Context_Id := Empty;
19350 -- The status of elaboration checks for calls and instantiations
19351 -- depends on the most recent pragma Suppress/Unsuppress, as well
19352 -- as the suppression status of the context where the target is
19356 -- function Func ...;
19360 -- procedure Main is
19361 -- pragma Suppress (Elaboration_Checks, Pack);
19362 -- X : ... := Pack.Func;
19365 -- In the example above, the call to Func has elaboration checks
19366 -- enabled because there is no active general purpose suppression
19367 -- pragma, however the elaboration checks of Pack are explicitly
19368 -- suppressed. As a result the elaboration checks of the call must
19369 -- be disabled in order to preserve this dependency.
19371 if Nkind_In (N, N_Entry_Call_Statement,
19373 N_Function_Instantiation,
19374 N_Package_Instantiation,
19375 N_Procedure_Call_Statement,
19376 N_Procedure_Instantiation)
19378 Nam := Extract_Name (N);
19380 if Is_Entity_Name (Nam) and then Present (Entity (Nam)) then
19381 Context_Id := Scope (Entity (Nam));
19385 Set_Is_Elaboration_Checks_OK_Node (N,
19386 Elaboration_Checks_OK
19387 (Target_Id => Empty,
19388 Context_Id => Context_Id));
19391 -- Mark the enclosing level of the node. Do not reset the status in
19392 -- case the node is relocated and reanalyzed.
19394 if Level and then not Is_Declaration_Level_Node (N) then
19395 Set_Is_Declaration_Level_Node (N,
19396 Find_Enclosing_Level (N) = Declaration_Level);
19399 -- Mark the Ghost and SPARK mode in effect
19402 if Ghost_Mode = Ignore then
19403 Set_Is_Ignored_Ghost_Node (N);
19406 if SPARK_Mode = On then
19407 Set_Is_SPARK_Mode_On_Node (N);
19411 -- Mark the status of elaboration warnings in effect. Do not reset
19412 -- the status in case the node is reanalyzed with warnings off.
19414 if Warnings and then not Is_Elaboration_Warnings_OK_Node (N) then
19415 Set_Is_Elaboration_Warnings_OK_Node (N, Elab_Warnings);
19417 end Mark_Elaboration_Attributes_Node;
19419 -- Start of processing for Mark_Elaboration_Attributes
19422 -- Do not capture any elaboration-related attributes when switch -gnatH
19423 -- (legacy elaboration checking mode enabled) is in effect because the
19424 -- attributes are useless to the legacy model.
19426 if Legacy_Elaboration_Checks then
19430 if Nkind (N_Id) in N_Entity then
19431 Mark_Elaboration_Attributes_Id (N_Id);
19433 Mark_Elaboration_Attributes_Node (N_Id);
19435 end Mark_Elaboration_Attributes;
19437 ----------------------------------------
19438 -- Mark_Save_Invocation_Graph_Of_Body --
19439 ----------------------------------------
19441 procedure Mark_Save_Invocation_Graph_Of_Body is
19442 Main : constant Node_Id := Cunit (Main_Unit);
19443 Main_Unit : constant Node_Id := Unit (Main);
19444 Aux_Id : Entity_Id;
19447 Set_Save_Invocation_Graph_Of_Body (Main);
19449 -- Assume that the main unit does not have a complimentary unit
19453 -- Obtain the complimentary unit of the main unit
19455 if Nkind_In (Main_Unit, N_Generic_Package_Declaration,
19456 N_Generic_Subprogram_Declaration,
19457 N_Package_Declaration,
19458 N_Subprogram_Declaration)
19460 Aux_Id := Corresponding_Body (Main_Unit);
19462 elsif Nkind_In (Main_Unit, N_Package_Body,
19464 N_Subprogram_Renaming_Declaration)
19466 Aux_Id := Corresponding_Spec (Main_Unit);
19469 if Present (Aux_Id) then
19470 Set_Save_Invocation_Graph_Of_Body
19471 (Parent (Unit_Declaration_Node (Aux_Id)));
19473 end Mark_Save_Invocation_Graph_Of_Body;
19475 ----------------------------------
19476 -- Matching_Static_Array_Bounds --
19477 ----------------------------------
19479 function Matching_Static_Array_Bounds
19481 R_Typ : Node_Id) return Boolean
19483 L_Ndims : constant Nat := Number_Dimensions (L_Typ);
19484 R_Ndims : constant Nat := Number_Dimensions (R_Typ);
19486 L_Index : Node_Id := Empty; -- init to ...
19487 R_Index : Node_Id := Empty; -- ...avoid warnings
19496 if L_Ndims /= R_Ndims then
19500 -- Unconstrained types do not have static bounds
19502 if not Is_Constrained (L_Typ) or else not Is_Constrained (R_Typ) then
19506 -- First treat specially the first dimension, as the lower bound and
19507 -- length of string literals are not stored like those of arrays.
19509 if Ekind (L_Typ) = E_String_Literal_Subtype then
19510 L_Low := String_Literal_Low_Bound (L_Typ);
19511 L_Len := String_Literal_Length (L_Typ);
19513 L_Index := First_Index (L_Typ);
19514 Get_Index_Bounds (L_Index, L_Low, L_High);
19516 if Is_OK_Static_Expression (L_Low)
19518 Is_OK_Static_Expression (L_High)
19520 if Expr_Value (L_High) < Expr_Value (L_Low) then
19523 L_Len := (Expr_Value (L_High) - Expr_Value (L_Low)) + 1;
19530 if Ekind (R_Typ) = E_String_Literal_Subtype then
19531 R_Low := String_Literal_Low_Bound (R_Typ);
19532 R_Len := String_Literal_Length (R_Typ);
19534 R_Index := First_Index (R_Typ);
19535 Get_Index_Bounds (R_Index, R_Low, R_High);
19537 if Is_OK_Static_Expression (R_Low)
19539 Is_OK_Static_Expression (R_High)
19541 if Expr_Value (R_High) < Expr_Value (R_Low) then
19544 R_Len := (Expr_Value (R_High) - Expr_Value (R_Low)) + 1;
19551 if (Is_OK_Static_Expression (L_Low)
19553 Is_OK_Static_Expression (R_Low))
19554 and then Expr_Value (L_Low) = Expr_Value (R_Low)
19555 and then L_Len = R_Len
19562 -- Then treat all other dimensions
19564 for Indx in 2 .. L_Ndims loop
19568 Get_Index_Bounds (L_Index, L_Low, L_High);
19569 Get_Index_Bounds (R_Index, R_Low, R_High);
19571 if (Is_OK_Static_Expression (L_Low) and then
19572 Is_OK_Static_Expression (L_High) and then
19573 Is_OK_Static_Expression (R_Low) and then
19574 Is_OK_Static_Expression (R_High))
19575 and then (Expr_Value (L_Low) = Expr_Value (R_Low)
19577 Expr_Value (L_High) = Expr_Value (R_High))
19585 -- If we fall through the loop, all indexes matched
19588 end Matching_Static_Array_Bounds;
19590 -------------------
19591 -- May_Be_Lvalue --
19592 -------------------
19594 function May_Be_Lvalue (N : Node_Id) return Boolean is
19595 P : constant Node_Id := Parent (N);
19600 -- Test left side of assignment
19602 when N_Assignment_Statement =>
19603 return N = Name (P);
19605 -- Test prefix of component or attribute. Note that the prefix of an
19606 -- explicit or implicit dereference cannot be an l-value. In the case
19607 -- of a 'Read attribute, the reference can be an actual in the
19608 -- argument list of the attribute.
19610 when N_Attribute_Reference =>
19611 return (N = Prefix (P)
19612 and then Name_Implies_Lvalue_Prefix (Attribute_Name (P)))
19614 Attribute_Name (P) = Name_Read;
19616 -- For an expanded name, the name is an lvalue if the expanded name
19617 -- is an lvalue, but the prefix is never an lvalue, since it is just
19618 -- the scope where the name is found.
19620 when N_Expanded_Name =>
19621 if N = Prefix (P) then
19622 return May_Be_Lvalue (P);
19627 -- For a selected component A.B, A is certainly an lvalue if A.B is.
19628 -- B is a little interesting, if we have A.B := 3, there is some
19629 -- discussion as to whether B is an lvalue or not, we choose to say
19630 -- it is. Note however that A is not an lvalue if it is of an access
19631 -- type since this is an implicit dereference.
19633 when N_Selected_Component =>
19635 and then Present (Etype (N))
19636 and then Is_Access_Type (Etype (N))
19640 return May_Be_Lvalue (P);
19643 -- For an indexed component or slice, the index or slice bounds is
19644 -- never an lvalue. The prefix is an lvalue if the indexed component
19645 -- or slice is an lvalue, except if it is an access type, where we
19646 -- have an implicit dereference.
19648 when N_Indexed_Component
19652 or else (Present (Etype (N)) and then Is_Access_Type (Etype (N)))
19656 return May_Be_Lvalue (P);
19659 -- Prefix of a reference is an lvalue if the reference is an lvalue
19661 when N_Reference =>
19662 return May_Be_Lvalue (P);
19664 -- Prefix of explicit dereference is never an lvalue
19666 when N_Explicit_Dereference =>
19669 -- Positional parameter for subprogram, entry, or accept call.
19670 -- In older versions of Ada function call arguments are never
19671 -- lvalues. In Ada 2012 functions can have in-out parameters.
19673 when N_Accept_Statement
19674 | N_Entry_Call_Statement
19675 | N_Subprogram_Call
19677 if Nkind (P) = N_Function_Call and then Ada_Version < Ada_2012 then
19681 -- The following mechanism is clumsy and fragile. A single flag
19682 -- set in Resolve_Actuals would be preferable ???
19690 Proc := Get_Subprogram_Entity (P);
19696 -- If we are not a list member, something is strange, so be
19697 -- conservative and return True.
19699 if not Is_List_Member (N) then
19703 -- We are going to find the right formal by stepping forward
19704 -- through the formals, as we step backwards in the actuals.
19706 Form := First_Formal (Proc);
19709 -- If no formal, something is weird, so be conservative and
19717 exit when No (Act);
19718 Next_Formal (Form);
19721 return Ekind (Form) /= E_In_Parameter;
19724 -- Named parameter for procedure or accept call
19726 when N_Parameter_Association =>
19732 Proc := Get_Subprogram_Entity (Parent (P));
19738 -- Loop through formals to find the one that matches
19740 Form := First_Formal (Proc);
19742 -- If no matching formal, that's peculiar, some kind of
19743 -- previous error, so return True to be conservative.
19744 -- Actually happens with legal code for an unresolved call
19745 -- where we may get the wrong homonym???
19751 -- Else test for match
19753 if Chars (Form) = Chars (Selector_Name (P)) then
19754 return Ekind (Form) /= E_In_Parameter;
19757 Next_Formal (Form);
19761 -- Test for appearing in a conversion that itself appears in an
19762 -- lvalue context, since this should be an lvalue.
19764 when N_Type_Conversion =>
19765 return May_Be_Lvalue (P);
19767 -- Test for appearance in object renaming declaration
19769 when N_Object_Renaming_Declaration =>
19772 -- All other references are definitely not lvalues
19783 function Might_Raise (N : Node_Id) return Boolean is
19784 Result : Boolean := False;
19786 function Process (N : Node_Id) return Traverse_Result;
19787 -- Set Result to True if we find something that could raise an exception
19793 function Process (N : Node_Id) return Traverse_Result is
19795 if Nkind_In (N, N_Procedure_Call_Statement,
19798 N_Raise_Constraint_Error,
19799 N_Raise_Program_Error,
19800 N_Raise_Storage_Error)
19809 procedure Set_Result is new Traverse_Proc (Process);
19811 -- Start of processing for Might_Raise
19814 -- False if exceptions can't be propagated
19816 if No_Exception_Handlers_Set then
19820 -- If the checks handled by the back end are not disabled, we cannot
19821 -- ensure that no exception will be raised.
19823 if not Access_Checks_Suppressed (Empty)
19824 or else not Discriminant_Checks_Suppressed (Empty)
19825 or else not Range_Checks_Suppressed (Empty)
19826 or else not Index_Checks_Suppressed (Empty)
19827 or else Opt.Stack_Checking_Enabled
19836 --------------------------------
19837 -- Nearest_Enclosing_Instance --
19838 --------------------------------
19840 function Nearest_Enclosing_Instance (E : Entity_Id) return Entity_Id is
19845 while Present (Inst) and then Inst /= Standard_Standard loop
19846 if Is_Generic_Instance (Inst) then
19850 Inst := Scope (Inst);
19854 end Nearest_Enclosing_Instance;
19856 ------------------------
19857 -- Needs_Finalization --
19858 ------------------------
19860 function Needs_Finalization (Typ : Entity_Id) return Boolean is
19861 function Has_Some_Controlled_Component
19862 (Input_Typ : Entity_Id) return Boolean;
19863 -- Determine whether type Input_Typ has at least one controlled
19866 -----------------------------------
19867 -- Has_Some_Controlled_Component --
19868 -----------------------------------
19870 function Has_Some_Controlled_Component
19871 (Input_Typ : Entity_Id) return Boolean
19876 -- When a type is already frozen and has at least one controlled
19877 -- component, or is manually decorated, it is sufficient to inspect
19878 -- flag Has_Controlled_Component.
19880 if Has_Controlled_Component (Input_Typ) then
19883 -- Otherwise inspect the internals of the type
19885 elsif not Is_Frozen (Input_Typ) then
19886 if Is_Array_Type (Input_Typ) then
19887 return Needs_Finalization (Component_Type (Input_Typ));
19889 elsif Is_Record_Type (Input_Typ) then
19890 Comp := First_Component (Input_Typ);
19891 while Present (Comp) loop
19892 if Needs_Finalization (Etype (Comp)) then
19896 Next_Component (Comp);
19902 end Has_Some_Controlled_Component;
19904 -- Start of processing for Needs_Finalization
19907 -- Certain run-time configurations and targets do not provide support
19908 -- for controlled types.
19910 if Restriction_Active (No_Finalization) then
19913 -- C++ types are not considered controlled. It is assumed that the non-
19914 -- Ada side will handle their clean up.
19916 elsif Convention (Typ) = Convention_CPP then
19919 -- Class-wide types are treated as controlled because derivations from
19920 -- the root type may introduce controlled components.
19922 elsif Is_Class_Wide_Type (Typ) then
19925 -- Concurrent types are controlled as long as their corresponding record
19928 elsif Is_Concurrent_Type (Typ)
19929 and then Present (Corresponding_Record_Type (Typ))
19930 and then Needs_Finalization (Corresponding_Record_Type (Typ))
19934 -- Otherwise the type is controlled when it is either derived from type
19935 -- [Limited_]Controlled and not subject to aspect Disable_Controlled, or
19936 -- contains at least one controlled component.
19940 Is_Controlled (Typ) or else Has_Some_Controlled_Component (Typ);
19942 end Needs_Finalization;
19944 ----------------------
19945 -- Needs_One_Actual --
19946 ----------------------
19948 function Needs_One_Actual (E : Entity_Id) return Boolean is
19949 Formal : Entity_Id;
19952 -- Ada 2005 or later, and formals present. The first formal must be
19953 -- of a type that supports prefix notation: a controlling argument,
19954 -- a class-wide type, or an access to such.
19956 if Ada_Version >= Ada_2005
19957 and then Present (First_Formal (E))
19958 and then No (Default_Value (First_Formal (E)))
19960 (Is_Controlling_Formal (First_Formal (E))
19961 or else Is_Class_Wide_Type (Etype (First_Formal (E)))
19962 or else Is_Anonymous_Access_Type (Etype (First_Formal (E))))
19964 Formal := Next_Formal (First_Formal (E));
19965 while Present (Formal) loop
19966 if No (Default_Value (Formal)) then
19970 Next_Formal (Formal);
19975 -- Ada 83/95 or no formals
19980 end Needs_One_Actual;
19982 ---------------------------------
19983 -- Needs_Simple_Initialization --
19984 ---------------------------------
19986 function Needs_Simple_Initialization
19988 Consider_IS : Boolean := True) return Boolean
19990 Consider_IS_NS : constant Boolean :=
19991 Normalize_Scalars or (Initialize_Scalars and Consider_IS);
19994 -- Never need initialization if it is suppressed
19996 if Initialization_Suppressed (Typ) then
20000 -- Check for private type, in which case test applies to the underlying
20001 -- type of the private type.
20003 if Is_Private_Type (Typ) then
20005 RT : constant Entity_Id := Underlying_Type (Typ);
20007 if Present (RT) then
20008 return Needs_Simple_Initialization (RT);
20014 -- Scalar type with Default_Value aspect requires initialization
20016 elsif Is_Scalar_Type (Typ) and then Has_Default_Aspect (Typ) then
20019 -- Cases needing simple initialization are access types, and, if pragma
20020 -- Normalize_Scalars or Initialize_Scalars is in effect, then all scalar
20023 elsif Is_Access_Type (Typ)
20024 or else (Consider_IS_NS and then (Is_Scalar_Type (Typ)))
20028 -- If Initialize/Normalize_Scalars is in effect, string objects also
20029 -- need initialization, unless they are created in the course of
20030 -- expanding an aggregate (since in the latter case they will be
20031 -- filled with appropriate initializing values before they are used).
20033 elsif Consider_IS_NS
20034 and then Is_Standard_String_Type (Typ)
20036 (not Is_Itype (Typ)
20037 or else Nkind (Associated_Node_For_Itype (Typ)) /= N_Aggregate)
20044 end Needs_Simple_Initialization;
20046 -------------------------------------
20047 -- Needs_Variable_Reference_Marker --
20048 -------------------------------------
20050 function Needs_Variable_Reference_Marker
20052 Calls_OK : Boolean) return Boolean
20054 function Within_Suitable_Context (Ref : Node_Id) return Boolean;
20055 -- Deteremine whether variable reference Ref appears within a suitable
20056 -- context that allows the creation of a marker.
20058 -----------------------------
20059 -- Within_Suitable_Context --
20060 -----------------------------
20062 function Within_Suitable_Context (Ref : Node_Id) return Boolean is
20067 while Present (Par) loop
20069 -- The context is not suitable when the reference appears within
20070 -- the formal part of an instantiation which acts as compilation
20071 -- unit because there is no proper list for the insertion of the
20074 if Nkind (Par) = N_Generic_Association
20075 and then Nkind (Parent (Par)) in N_Generic_Instantiation
20076 and then Nkind (Parent (Parent (Par))) = N_Compilation_Unit
20080 -- The context is not suitable when the reference appears within
20081 -- a pragma. If the pragma has run-time semantics, the reference
20082 -- will be reconsidered once the pragma is expanded.
20084 elsif Nkind (Par) = N_Pragma then
20087 -- The context is not suitable when the reference appears within a
20088 -- subprogram call, and the caller requests this behavior.
20091 and then Nkind_In (Par, N_Entry_Call_Statement,
20093 N_Procedure_Call_Statement)
20097 -- Prevent the search from going too far
20099 elsif Is_Body_Or_Package_Declaration (Par) then
20103 Par := Parent (Par);
20107 end Within_Suitable_Context;
20112 Var_Id : Entity_Id;
20114 -- Start of processing for Needs_Variable_Reference_Marker
20117 -- No marker needs to be created when switch -gnatH (legacy elaboration
20118 -- checking mode enabled) is in effect because the legacy ABE mechanism
20119 -- does not use markers.
20121 if Legacy_Elaboration_Checks then
20124 -- No marker needs to be created for ASIS because ABE diagnostics and
20125 -- checks are not performed in this mode.
20127 elsif ASIS_Mode then
20130 -- No marker needs to be created when the reference is preanalyzed
20131 -- because the marker will be inserted in the wrong place.
20133 elsif Preanalysis_Active then
20136 -- Only references warrant a marker
20138 elsif not Nkind_In (N, N_Expanded_Name, N_Identifier) then
20141 -- Only source references warrant a marker
20143 elsif not Comes_From_Source (N) then
20146 -- No marker needs to be created when the reference is erroneous, left
20147 -- in a bad state, or does not denote a variable.
20149 elsif not (Present (Entity (N))
20150 and then Ekind (Entity (N)) = E_Variable
20151 and then Entity (N) /= Any_Id)
20156 Var_Id := Entity (N);
20157 Prag := SPARK_Pragma (Var_Id);
20159 -- Both the variable and reference must appear in SPARK_Mode On regions
20160 -- because this elaboration scenario falls under the SPARK rules.
20162 if not (Comes_From_Source (Var_Id)
20163 and then Present (Prag)
20164 and then Get_SPARK_Mode_From_Annotation (Prag) = On
20165 and then Is_SPARK_Mode_On_Node (N))
20169 -- No marker needs to be created when the reference does not appear
20170 -- within a suitable context (see body for details).
20172 -- Performance note: parent traversal
20174 elsif not Within_Suitable_Context (N) then
20178 -- At this point it is known that the variable reference will play a
20179 -- role in ABE diagnostics and requires a marker.
20182 end Needs_Variable_Reference_Marker;
20184 ------------------------
20185 -- New_Copy_List_Tree --
20186 ------------------------
20188 function New_Copy_List_Tree (List : List_Id) return List_Id is
20193 if List = No_List then
20200 while Present (E) loop
20201 Append (New_Copy_Tree (E), NL);
20207 end New_Copy_List_Tree;
20209 -------------------
20210 -- New_Copy_Tree --
20211 -------------------
20213 -- The following tables play a key role in replicating entities and Itypes.
20214 -- They are intentionally declared at the library level rather than within
20215 -- New_Copy_Tree to avoid elaborating them on each call. This performance
20216 -- optimization saves up to 2% of the entire compilation time spent in the
20217 -- front end. Care should be taken to reset the tables on each new call to
20220 NCT_Table_Max : constant := 511;
20222 subtype NCT_Table_Index is Nat range 0 .. NCT_Table_Max - 1;
20224 function NCT_Table_Hash (Key : Node_Or_Entity_Id) return NCT_Table_Index;
20225 -- Obtain the hash value of node or entity Key
20227 --------------------
20228 -- NCT_Table_Hash --
20229 --------------------
20231 function NCT_Table_Hash (Key : Node_Or_Entity_Id) return NCT_Table_Index is
20233 return NCT_Table_Index (Key mod NCT_Table_Max);
20234 end NCT_Table_Hash;
20236 ----------------------
20237 -- NCT_New_Entities --
20238 ----------------------
20240 -- The following table maps old entities and Itypes to their corresponding
20241 -- new entities and Itypes.
20245 package NCT_New_Entities is new Simple_HTable (
20246 Header_Num => NCT_Table_Index,
20247 Element => Entity_Id,
20248 No_Element => Empty,
20250 Hash => NCT_Table_Hash,
20253 ------------------------
20254 -- NCT_Pending_Itypes --
20255 ------------------------
20257 -- The following table maps old Associated_Node_For_Itype nodes to a set of
20258 -- new itypes. Given a set of old Itypes Aaa, Bbb, and Ccc, where all three
20259 -- have the same Associated_Node_For_Itype Ppp, and their corresponding new
20260 -- Itypes Xxx, Yyy, Zzz, the table contains the following mapping:
20262 -- Ppp -> (Xxx, Yyy, Zzz)
20264 -- The set is expressed as an Elist
20266 package NCT_Pending_Itypes is new Simple_HTable (
20267 Header_Num => NCT_Table_Index,
20268 Element => Elist_Id,
20269 No_Element => No_Elist,
20271 Hash => NCT_Table_Hash,
20274 NCT_Tables_In_Use : Boolean := False;
20275 -- This flag keeps track of whether the two tables NCT_New_Entities and
20276 -- NCT_Pending_Itypes are in use. The flag is part of an optimization
20277 -- where certain operations are not performed if the tables are not in
20278 -- use. This saves up to 8% of the entire compilation time spent in the
20281 -------------------
20282 -- New_Copy_Tree --
20283 -------------------
20285 function New_Copy_Tree
20287 Map : Elist_Id := No_Elist;
20288 New_Sloc : Source_Ptr := No_Location;
20289 New_Scope : Entity_Id := Empty;
20290 Scopes_In_EWA_OK : Boolean := False) return Node_Id
20292 -- This routine performs low-level tree manipulations and needs access
20293 -- to the internals of the tree.
20295 use Atree.Unchecked_Access;
20296 use Atree_Private_Part;
20298 EWA_Level : Nat := 0;
20299 -- This counter keeps track of how many N_Expression_With_Actions nodes
20300 -- are encountered during a depth-first traversal of the subtree. These
20301 -- nodes may define new entities in their Actions lists and thus require
20302 -- special processing.
20304 EWA_Inner_Scope_Level : Nat := 0;
20305 -- This counter keeps track of how many scoping constructs appear within
20306 -- an N_Expression_With_Actions node.
20308 procedure Add_New_Entity (Old_Id : Entity_Id; New_Id : Entity_Id);
20309 pragma Inline (Add_New_Entity);
20310 -- Add an entry in the NCT_New_Entities table which maps key Old_Id to
20311 -- value New_Id. Old_Id is an entity which appears within the Actions
20312 -- list of an N_Expression_With_Actions node, or within an entity map.
20313 -- New_Id is the corresponding new entity generated during Phase 1.
20315 procedure Add_Pending_Itype (Assoc_Nod : Node_Id; Itype : Entity_Id);
20316 pragma Inline (Add_New_Entity);
20317 -- Add an entry in the NCT_Pending_Itypes which maps key Assoc_Nod to
20318 -- value Itype. Assoc_Nod is the associated node of an itype. Itype is
20321 procedure Build_NCT_Tables (Entity_Map : Elist_Id);
20322 pragma Inline (Build_NCT_Tables);
20323 -- Populate tables NCT_New_Entities and NCT_Pending_Itypes with the
20324 -- information supplied in entity map Entity_Map. The format of the
20325 -- entity map must be as follows:
20327 -- Old_Id1, New_Id1, Old_Id2, New_Id2, .., Old_IdN, New_IdN
20329 function Copy_Any_Node_With_Replacement
20330 (N : Node_Or_Entity_Id) return Node_Or_Entity_Id;
20331 pragma Inline (Copy_Any_Node_With_Replacement);
20332 -- Replicate entity or node N by invoking one of the following routines:
20334 -- Copy_Node_With_Replacement
20335 -- Corresponding_Entity
20337 function Copy_Elist_With_Replacement (List : Elist_Id) return Elist_Id;
20338 -- Replicate the elements of entity list List
20340 function Copy_Field_With_Replacement
20342 Old_Par : Node_Id := Empty;
20343 New_Par : Node_Id := Empty;
20344 Semantic : Boolean := False) return Union_Id;
20345 -- Replicate field Field by invoking one of the following routines:
20347 -- Copy_Elist_With_Replacement
20348 -- Copy_List_With_Replacement
20349 -- Copy_Node_With_Replacement
20350 -- Corresponding_Entity
20352 -- If the field is not an entity list, entity, itype, syntactic list,
20353 -- or node, then the field is returned unchanged. The routine always
20354 -- replicates entities, itypes, and valid syntactic fields. Old_Par is
20355 -- the expected parent of a syntactic field. New_Par is the new parent
20356 -- associated with a replicated syntactic field. Flag Semantic should
20357 -- be set when the input is a semantic field.
20359 function Copy_List_With_Replacement (List : List_Id) return List_Id;
20360 -- Replicate the elements of syntactic list List
20362 function Copy_Node_With_Replacement (N : Node_Id) return Node_Id;
20363 -- Replicate node N
20365 function Corresponding_Entity (Id : Entity_Id) return Entity_Id;
20366 pragma Inline (Corresponding_Entity);
20367 -- Return the corresponding new entity of Id generated during Phase 1.
20368 -- If there is no such entity, return Id.
20370 function In_Entity_Map
20372 Entity_Map : Elist_Id) return Boolean;
20373 pragma Inline (In_Entity_Map);
20374 -- Determine whether entity Id is one of the old ids specified in entity
20375 -- map Entity_Map. The format of the entity map must be as follows:
20377 -- Old_Id1, New_Id1, Old_Id2, New_Id2, .., Old_IdN, New_IdN
20379 procedure Update_CFS_Sloc (N : Node_Or_Entity_Id);
20380 pragma Inline (Update_CFS_Sloc);
20381 -- Update the Comes_From_Source and Sloc attributes of node or entity N
20383 procedure Update_First_Real_Statement
20384 (Old_HSS : Node_Id;
20385 New_HSS : Node_Id);
20386 pragma Inline (Update_First_Real_Statement);
20387 -- Update semantic attribute First_Real_Statement of handled sequence of
20388 -- statements New_HSS based on handled sequence of statements Old_HSS.
20390 procedure Update_Named_Associations
20391 (Old_Call : Node_Id;
20392 New_Call : Node_Id);
20393 pragma Inline (Update_Named_Associations);
20394 -- Update semantic chain First/Next_Named_Association of call New_call
20395 -- based on call Old_Call.
20397 procedure Update_New_Entities (Entity_Map : Elist_Id);
20398 pragma Inline (Update_New_Entities);
20399 -- Update the semantic attributes of all new entities generated during
20400 -- Phase 1 that do not appear in entity map Entity_Map. The format of
20401 -- the entity map must be as follows:
20403 -- Old_Id1, New_Id1, Old_Id2, New_Id2, .., Old_IdN, New_IdN
20405 procedure Update_Pending_Itypes
20406 (Old_Assoc : Node_Id;
20407 New_Assoc : Node_Id);
20408 pragma Inline (Update_Pending_Itypes);
20409 -- Update semantic attribute Associated_Node_For_Itype to refer to node
20410 -- New_Assoc for all itypes whose associated node is Old_Assoc.
20412 procedure Update_Semantic_Fields (Id : Entity_Id);
20413 pragma Inline (Update_Semantic_Fields);
20414 -- Subsidiary to Update_New_Entities. Update semantic fields of entity
20417 procedure Visit_Any_Node (N : Node_Or_Entity_Id);
20418 pragma Inline (Visit_Any_Node);
20419 -- Visit entity of node N by invoking one of the following routines:
20425 procedure Visit_Elist (List : Elist_Id);
20426 -- Visit the elements of entity list List
20428 procedure Visit_Entity (Id : Entity_Id);
20429 -- Visit entity Id. This action may create a new entity of Id and save
20430 -- it in table NCT_New_Entities.
20432 procedure Visit_Field
20434 Par_Nod : Node_Id := Empty;
20435 Semantic : Boolean := False);
20436 -- Visit field Field by invoking one of the following routines:
20444 -- If the field is not an entity list, entity, itype, syntactic list,
20445 -- or node, then the field is not visited. The routine always visits
20446 -- valid syntactic fields. Par_Nod is the expected parent of the
20447 -- syntactic field. Flag Semantic should be set when the input is a
20450 procedure Visit_Itype (Itype : Entity_Id);
20451 -- Visit itype Itype. This action may create a new entity for Itype and
20452 -- save it in table NCT_New_Entities. In addition, the routine may map
20453 -- the associated node of Itype to the new itype in NCT_Pending_Itypes.
20455 procedure Visit_List (List : List_Id);
20456 -- Visit the elements of syntactic list List
20458 procedure Visit_Node (N : Node_Id);
20461 procedure Visit_Semantic_Fields (Id : Entity_Id);
20462 pragma Inline (Visit_Semantic_Fields);
20463 -- Subsidiary to Visit_Entity and Visit_Itype. Visit common semantic
20464 -- fields of entity or itype Id.
20466 --------------------
20467 -- Add_New_Entity --
20468 --------------------
20470 procedure Add_New_Entity (Old_Id : Entity_Id; New_Id : Entity_Id) is
20472 pragma Assert (Present (Old_Id));
20473 pragma Assert (Present (New_Id));
20474 pragma Assert (Nkind (Old_Id) in N_Entity);
20475 pragma Assert (Nkind (New_Id) in N_Entity);
20477 NCT_Tables_In_Use := True;
20479 -- Sanity check the NCT_New_Entities table. No previous mapping with
20480 -- key Old_Id should exist.
20482 pragma Assert (No (NCT_New_Entities.Get (Old_Id)));
20484 -- Establish the mapping
20486 -- Old_Id -> New_Id
20488 NCT_New_Entities.Set (Old_Id, New_Id);
20489 end Add_New_Entity;
20491 -----------------------
20492 -- Add_Pending_Itype --
20493 -----------------------
20495 procedure Add_Pending_Itype (Assoc_Nod : Node_Id; Itype : Entity_Id) is
20499 pragma Assert (Present (Assoc_Nod));
20500 pragma Assert (Present (Itype));
20501 pragma Assert (Nkind (Itype) in N_Entity);
20502 pragma Assert (Is_Itype (Itype));
20504 NCT_Tables_In_Use := True;
20506 -- It is not possible to sanity check the NCT_Pendint_Itypes table
20507 -- directly because a single node may act as the associated node for
20508 -- multiple itypes.
20510 Itypes := NCT_Pending_Itypes.Get (Assoc_Nod);
20512 if No (Itypes) then
20513 Itypes := New_Elmt_List;
20514 NCT_Pending_Itypes.Set (Assoc_Nod, Itypes);
20517 -- Establish the mapping
20519 -- Assoc_Nod -> (Itype, ...)
20521 -- Avoid inserting the same itype multiple times. This involves a
20522 -- linear search, however the set of itypes with the same associated
20523 -- node is very small.
20525 Append_Unique_Elmt (Itype, Itypes);
20526 end Add_Pending_Itype;
20528 ----------------------
20529 -- Build_NCT_Tables --
20530 ----------------------
20532 procedure Build_NCT_Tables (Entity_Map : Elist_Id) is
20534 Old_Id : Entity_Id;
20535 New_Id : Entity_Id;
20538 -- Nothing to do when there is no entity map
20540 if No (Entity_Map) then
20544 Elmt := First_Elmt (Entity_Map);
20545 while Present (Elmt) loop
20547 -- Extract the (Old_Id, New_Id) pair from the entity map
20549 Old_Id := Node (Elmt);
20552 New_Id := Node (Elmt);
20555 -- Establish the following mapping within table NCT_New_Entities
20557 -- Old_Id -> New_Id
20559 Add_New_Entity (Old_Id, New_Id);
20561 -- Establish the following mapping within table NCT_Pending_Itypes
20562 -- when the new entity is an itype.
20564 -- Assoc_Nod -> (New_Id, ...)
20566 -- IMPORTANT: the associated node is that of the old itype because
20567 -- the node will be replicated in Phase 2.
20569 if Is_Itype (Old_Id) then
20571 (Assoc_Nod => Associated_Node_For_Itype (Old_Id),
20575 end Build_NCT_Tables;
20577 ------------------------------------
20578 -- Copy_Any_Node_With_Replacement --
20579 ------------------------------------
20581 function Copy_Any_Node_With_Replacement
20582 (N : Node_Or_Entity_Id) return Node_Or_Entity_Id
20585 if Nkind (N) in N_Entity then
20586 return Corresponding_Entity (N);
20588 return Copy_Node_With_Replacement (N);
20590 end Copy_Any_Node_With_Replacement;
20592 ---------------------------------
20593 -- Copy_Elist_With_Replacement --
20594 ---------------------------------
20596 function Copy_Elist_With_Replacement (List : Elist_Id) return Elist_Id is
20601 -- Copy the contents of the old list. Note that the list itself may
20602 -- be empty, in which case the routine returns a new empty list. This
20603 -- avoids sharing lists between subtrees. The element of an entity
20604 -- list could be an entity or a node, hence the invocation of routine
20605 -- Copy_Any_Node_With_Replacement.
20607 if Present (List) then
20608 Result := New_Elmt_List;
20610 Elmt := First_Elmt (List);
20611 while Present (Elmt) loop
20613 (Copy_Any_Node_With_Replacement (Node (Elmt)), Result);
20618 -- Otherwise the list does not exist
20621 Result := No_Elist;
20625 end Copy_Elist_With_Replacement;
20627 ---------------------------------
20628 -- Copy_Field_With_Replacement --
20629 ---------------------------------
20631 function Copy_Field_With_Replacement
20633 Old_Par : Node_Id := Empty;
20634 New_Par : Node_Id := Empty;
20635 Semantic : Boolean := False) return Union_Id
20638 -- The field is empty
20640 if Field = Union_Id (Empty) then
20643 -- The field is an entity/itype/node
20645 elsif Field in Node_Range then
20647 Old_N : constant Node_Id := Node_Id (Field);
20648 Syntactic : constant Boolean := Parent (Old_N) = Old_Par;
20653 -- The field is an entity/itype
20655 if Nkind (Old_N) in N_Entity then
20657 -- An entity/itype is always replicated
20659 New_N := Corresponding_Entity (Old_N);
20661 -- Update the parent pointer when the entity is a syntactic
20662 -- field. Note that itypes do not have parent pointers.
20664 if Syntactic and then New_N /= Old_N then
20665 Set_Parent (New_N, New_Par);
20668 -- The field is a node
20671 -- A node is replicated when it is either a syntactic field
20672 -- or when the caller treats it as a semantic attribute.
20674 if Syntactic or else Semantic then
20675 New_N := Copy_Node_With_Replacement (Old_N);
20677 -- Update the parent pointer when the node is a syntactic
20680 if Syntactic and then New_N /= Old_N then
20681 Set_Parent (New_N, New_Par);
20684 -- Otherwise the node is returned unchanged
20691 return Union_Id (New_N);
20694 -- The field is an entity list
20696 elsif Field in Elist_Range then
20697 return Union_Id (Copy_Elist_With_Replacement (Elist_Id (Field)));
20699 -- The field is a syntactic list
20701 elsif Field in List_Range then
20703 Old_List : constant List_Id := List_Id (Field);
20704 Syntactic : constant Boolean := Parent (Old_List) = Old_Par;
20706 New_List : List_Id;
20709 -- A list is replicated when it is either a syntactic field or
20710 -- when the caller treats it as a semantic attribute.
20712 if Syntactic or else Semantic then
20713 New_List := Copy_List_With_Replacement (Old_List);
20715 -- Update the parent pointer when the list is a syntactic
20718 if Syntactic and then New_List /= Old_List then
20719 Set_Parent (New_List, New_Par);
20722 -- Otherwise the list is returned unchanged
20725 New_List := Old_List;
20728 return Union_Id (New_List);
20731 -- Otherwise the field denotes an attribute that does not need to be
20732 -- replicated (Chars, literals, etc).
20737 end Copy_Field_With_Replacement;
20739 --------------------------------
20740 -- Copy_List_With_Replacement --
20741 --------------------------------
20743 function Copy_List_With_Replacement (List : List_Id) return List_Id is
20748 -- Copy the contents of the old list. Note that the list itself may
20749 -- be empty, in which case the routine returns a new empty list. This
20750 -- avoids sharing lists between subtrees. The element of a syntactic
20751 -- list is always a node, never an entity or itype, hence the call to
20752 -- routine Copy_Node_With_Replacement.
20754 if Present (List) then
20755 Result := New_List;
20757 Elmt := First (List);
20758 while Present (Elmt) loop
20759 Append (Copy_Node_With_Replacement (Elmt), Result);
20764 -- Otherwise the list does not exist
20771 end Copy_List_With_Replacement;
20773 --------------------------------
20774 -- Copy_Node_With_Replacement --
20775 --------------------------------
20777 function Copy_Node_With_Replacement (N : Node_Id) return Node_Id is
20781 -- Assume that the node must be returned unchanged
20785 if N > Empty_Or_Error then
20786 pragma Assert (Nkind (N) not in N_Entity);
20788 Result := New_Copy (N);
20790 Set_Field1 (Result,
20791 Copy_Field_With_Replacement
20792 (Field => Field1 (Result),
20794 New_Par => Result));
20796 Set_Field2 (Result,
20797 Copy_Field_With_Replacement
20798 (Field => Field2 (Result),
20800 New_Par => Result));
20802 Set_Field3 (Result,
20803 Copy_Field_With_Replacement
20804 (Field => Field3 (Result),
20806 New_Par => Result));
20808 Set_Field4 (Result,
20809 Copy_Field_With_Replacement
20810 (Field => Field4 (Result),
20812 New_Par => Result));
20814 Set_Field5 (Result,
20815 Copy_Field_With_Replacement
20816 (Field => Field5 (Result),
20818 New_Par => Result));
20820 -- Update the Comes_From_Source and Sloc attributes of the node
20821 -- in case the caller has supplied new values.
20823 Update_CFS_Sloc (Result);
20825 -- Update the Associated_Node_For_Itype attribute of all itypes
20826 -- created during Phase 1 whose associated node is N. As a result
20827 -- the Associated_Node_For_Itype refers to the replicated node.
20828 -- No action needs to be taken when the Associated_Node_For_Itype
20829 -- refers to an entity because this was already handled during
20830 -- Phase 1, in Visit_Itype.
20832 Update_Pending_Itypes
20834 New_Assoc => Result);
20836 -- Update the First/Next_Named_Association chain for a replicated
20839 if Nkind_In (N, N_Entry_Call_Statement,
20841 N_Procedure_Call_Statement)
20843 Update_Named_Associations
20845 New_Call => Result);
20847 -- Update the Renamed_Object attribute of a replicated object
20850 elsif Nkind (N) = N_Object_Renaming_Declaration then
20851 Set_Renamed_Object (Defining_Entity (Result), Name (Result));
20853 -- Update the First_Real_Statement attribute of a replicated
20854 -- handled sequence of statements.
20856 elsif Nkind (N) = N_Handled_Sequence_Of_Statements then
20857 Update_First_Real_Statement
20859 New_HSS => Result);
20861 -- Update the Chars attribute of identifiers
20863 elsif Nkind (N) = N_Identifier then
20865 -- The Entity field of identifiers that denote aspects is used
20866 -- to store arbitrary expressions (and hence we must check that
20867 -- they reference an actual entity before copying their Chars
20870 if Present (Entity (Result))
20871 and then Nkind (Entity (Result)) in N_Entity
20873 Set_Chars (Result, Chars (Entity (Result)));
20879 end Copy_Node_With_Replacement;
20881 --------------------------
20882 -- Corresponding_Entity --
20883 --------------------------
20885 function Corresponding_Entity (Id : Entity_Id) return Entity_Id is
20886 New_Id : Entity_Id;
20887 Result : Entity_Id;
20890 -- Assume that the entity must be returned unchanged
20894 if Id > Empty_Or_Error then
20895 pragma Assert (Nkind (Id) in N_Entity);
20897 -- Determine whether the entity has a corresponding new entity
20898 -- generated during Phase 1 and if it does, use it.
20900 if NCT_Tables_In_Use then
20901 New_Id := NCT_New_Entities.Get (Id);
20903 if Present (New_Id) then
20910 end Corresponding_Entity;
20912 -------------------
20913 -- In_Entity_Map --
20914 -------------------
20916 function In_Entity_Map
20918 Entity_Map : Elist_Id) return Boolean
20921 Old_Id : Entity_Id;
20924 -- The entity map contains pairs (Old_Id, New_Id). The advancement
20925 -- step always skips the New_Id portion of the pair.
20927 if Present (Entity_Map) then
20928 Elmt := First_Elmt (Entity_Map);
20929 while Present (Elmt) loop
20930 Old_Id := Node (Elmt);
20932 if Old_Id = Id then
20944 ---------------------
20945 -- Update_CFS_Sloc --
20946 ---------------------
20948 procedure Update_CFS_Sloc (N : Node_Or_Entity_Id) is
20950 -- A new source location defaults the Comes_From_Source attribute
20952 if New_Sloc /= No_Location then
20953 Set_Comes_From_Source (N, Default_Node.Comes_From_Source);
20954 Set_Sloc (N, New_Sloc);
20956 end Update_CFS_Sloc;
20958 ---------------------------------
20959 -- Update_First_Real_Statement --
20960 ---------------------------------
20962 procedure Update_First_Real_Statement
20963 (Old_HSS : Node_Id;
20966 Old_First_Stmt : constant Node_Id := First_Real_Statement (Old_HSS);
20968 New_Stmt : Node_Id;
20969 Old_Stmt : Node_Id;
20972 -- Recreate the First_Real_Statement attribute of a handled sequence
20973 -- of statements by traversing the statement lists of both sequences
20976 if Present (Old_First_Stmt) then
20977 New_Stmt := First (Statements (New_HSS));
20978 Old_Stmt := First (Statements (Old_HSS));
20979 while Present (Old_Stmt) and then Old_Stmt /= Old_First_Stmt loop
20984 pragma Assert (Present (New_Stmt));
20985 pragma Assert (Present (Old_Stmt));
20987 Set_First_Real_Statement (New_HSS, New_Stmt);
20989 end Update_First_Real_Statement;
20991 -------------------------------
20992 -- Update_Named_Associations --
20993 -------------------------------
20995 procedure Update_Named_Associations
20996 (Old_Call : Node_Id;
20997 New_Call : Node_Id)
21000 New_Next : Node_Id;
21002 Old_Next : Node_Id;
21005 if No (First_Named_Actual (Old_Call)) then
21009 -- Recreate the First/Next_Named_Actual chain of a call by traversing
21010 -- the chains of both the old and new calls in parallel.
21012 New_Act := First (Parameter_Associations (New_Call));
21013 Old_Act := First (Parameter_Associations (Old_Call));
21014 while Present (Old_Act) loop
21015 if Nkind (Old_Act) = N_Parameter_Association
21016 and then Explicit_Actual_Parameter (Old_Act)
21017 = First_Named_Actual (Old_Call)
21019 Set_First_Named_Actual (New_Call,
21020 Explicit_Actual_Parameter (New_Act));
21023 if Nkind (Old_Act) = N_Parameter_Association
21024 and then Present (Next_Named_Actual (Old_Act))
21026 -- Scan the actual parameter list to find the next suitable
21027 -- named actual. Note that the list may be out of order.
21029 New_Next := First (Parameter_Associations (New_Call));
21030 Old_Next := First (Parameter_Associations (Old_Call));
21031 while Nkind (Old_Next) /= N_Parameter_Association
21032 or else Explicit_Actual_Parameter (Old_Next) /=
21033 Next_Named_Actual (Old_Act)
21039 Set_Next_Named_Actual (New_Act,
21040 Explicit_Actual_Parameter (New_Next));
21046 end Update_Named_Associations;
21048 -------------------------
21049 -- Update_New_Entities --
21050 -------------------------
21052 procedure Update_New_Entities (Entity_Map : Elist_Id) is
21053 New_Id : Entity_Id := Empty;
21054 Old_Id : Entity_Id := Empty;
21057 if NCT_Tables_In_Use then
21058 NCT_New_Entities.Get_First (Old_Id, New_Id);
21060 -- Update the semantic fields of all new entities created during
21061 -- Phase 1 which were not supplied via an entity map.
21062 -- ??? Is there a better way of distinguishing those?
21064 while Present (Old_Id) and then Present (New_Id) loop
21065 if not (Present (Entity_Map)
21066 and then In_Entity_Map (Old_Id, Entity_Map))
21068 Update_Semantic_Fields (New_Id);
21071 NCT_New_Entities.Get_Next (Old_Id, New_Id);
21074 end Update_New_Entities;
21076 ---------------------------
21077 -- Update_Pending_Itypes --
21078 ---------------------------
21080 procedure Update_Pending_Itypes
21081 (Old_Assoc : Node_Id;
21082 New_Assoc : Node_Id)
21088 if NCT_Tables_In_Use then
21089 Itypes := NCT_Pending_Itypes.Get (Old_Assoc);
21091 -- Update the Associated_Node_For_Itype attribute for all itypes
21092 -- which originally refer to Old_Assoc to designate New_Assoc.
21094 if Present (Itypes) then
21095 Item := First_Elmt (Itypes);
21096 while Present (Item) loop
21097 Set_Associated_Node_For_Itype (Node (Item), New_Assoc);
21103 end Update_Pending_Itypes;
21105 ----------------------------
21106 -- Update_Semantic_Fields --
21107 ----------------------------
21109 procedure Update_Semantic_Fields (Id : Entity_Id) is
21111 -- Discriminant_Constraint
21113 if Is_Type (Id) and then Has_Discriminants (Base_Type (Id)) then
21114 Set_Discriminant_Constraint (Id, Elist_Id (
21115 Copy_Field_With_Replacement
21116 (Field => Union_Id (Discriminant_Constraint (Id)),
21117 Semantic => True)));
21122 Set_Etype (Id, Node_Id (
21123 Copy_Field_With_Replacement
21124 (Field => Union_Id (Etype (Id)),
21125 Semantic => True)));
21128 -- Packed_Array_Impl_Type
21130 if Is_Array_Type (Id) then
21131 if Present (First_Index (Id)) then
21132 Set_First_Index (Id, First (List_Id (
21133 Copy_Field_With_Replacement
21134 (Field => Union_Id (List_Containing (First_Index (Id))),
21135 Semantic => True))));
21138 if Is_Packed (Id) then
21139 Set_Packed_Array_Impl_Type (Id, Node_Id (
21140 Copy_Field_With_Replacement
21141 (Field => Union_Id (Packed_Array_Impl_Type (Id)),
21142 Semantic => True)));
21148 Set_Prev_Entity (Id, Node_Id (
21149 Copy_Field_With_Replacement
21150 (Field => Union_Id (Prev_Entity (Id)),
21151 Semantic => True)));
21155 Set_Next_Entity (Id, Node_Id (
21156 Copy_Field_With_Replacement
21157 (Field => Union_Id (Next_Entity (Id)),
21158 Semantic => True)));
21162 if Is_Discrete_Type (Id) then
21163 Set_Scalar_Range (Id, Node_Id (
21164 Copy_Field_With_Replacement
21165 (Field => Union_Id (Scalar_Range (Id)),
21166 Semantic => True)));
21171 -- Update the scope when the caller specified an explicit one
21173 if Present (New_Scope) then
21174 Set_Scope (Id, New_Scope);
21176 Set_Scope (Id, Node_Id (
21177 Copy_Field_With_Replacement
21178 (Field => Union_Id (Scope (Id)),
21179 Semantic => True)));
21181 end Update_Semantic_Fields;
21183 --------------------
21184 -- Visit_Any_Node --
21185 --------------------
21187 procedure Visit_Any_Node (N : Node_Or_Entity_Id) is
21189 if Nkind (N) in N_Entity then
21190 if Is_Itype (N) then
21198 end Visit_Any_Node;
21204 procedure Visit_Elist (List : Elist_Id) is
21208 -- The element of an entity list could be an entity, itype, or a
21209 -- node, hence the call to Visit_Any_Node.
21211 if Present (List) then
21212 Elmt := First_Elmt (List);
21213 while Present (Elmt) loop
21214 Visit_Any_Node (Node (Elmt));
21225 procedure Visit_Entity (Id : Entity_Id) is
21226 New_Id : Entity_Id;
21229 pragma Assert (Nkind (Id) in N_Entity);
21230 pragma Assert (not Is_Itype (Id));
21232 -- Nothing to do when the entity is not defined in the Actions list
21233 -- of an N_Expression_With_Actions node.
21235 if EWA_Level = 0 then
21238 -- Nothing to do when the entity is defined in a scoping construct
21239 -- within an N_Expression_With_Actions node, unless the caller has
21240 -- requested their replication.
21242 -- ??? should this restriction be eliminated?
21244 elsif EWA_Inner_Scope_Level > 0 and then not Scopes_In_EWA_OK then
21247 -- Nothing to do when the entity does not denote a construct that
21248 -- may appear within an N_Expression_With_Actions node. Relaxing
21249 -- this restriction leads to a performance penalty.
21251 -- ??? this list is flaky, and may hide dormant bugs
21252 -- Should functions be included???
21254 -- Loop parameters appear within quantified expressions and contain
21255 -- an entity declaration that must be replaced when the expander is
21256 -- active if the expression has been preanalyzed or analyzed.
21258 elsif not Ekind_In (Id, E_Block,
21264 and then not Is_Type (Id)
21268 elsif Ekind (Id) = E_Loop_Parameter
21269 and then No (Etype (Condition (Parent (Parent (Id)))))
21273 -- Nothing to do when the entity was already visited
21275 elsif NCT_Tables_In_Use
21276 and then Present (NCT_New_Entities.Get (Id))
21280 -- Nothing to do when the declaration node of the entity is not in
21281 -- the subtree being replicated.
21283 elsif not In_Subtree
21284 (N => Declaration_Node (Id),
21290 -- Create a new entity by directly copying the old entity. This
21291 -- action causes all attributes of the old entity to be inherited.
21293 New_Id := New_Copy (Id);
21295 -- Create a new name for the new entity because the back end needs
21296 -- distinct names for debugging purposes.
21298 Set_Chars (New_Id, New_Internal_Name ('T'));
21300 -- Update the Comes_From_Source and Sloc attributes of the entity in
21301 -- case the caller has supplied new values.
21303 Update_CFS_Sloc (New_Id);
21305 -- Establish the following mapping within table NCT_New_Entities:
21309 Add_New_Entity (Id, New_Id);
21311 -- Deal with the semantic fields of entities. The fields are visited
21312 -- because they may mention entities which reside within the subtree
21315 Visit_Semantic_Fields (Id);
21322 procedure Visit_Field
21324 Par_Nod : Node_Id := Empty;
21325 Semantic : Boolean := False)
21328 -- The field is empty
21330 if Field = Union_Id (Empty) then
21333 -- The field is an entity/itype/node
21335 elsif Field in Node_Range then
21337 N : constant Node_Id := Node_Id (Field);
21340 -- The field is an entity/itype
21342 if Nkind (N) in N_Entity then
21344 -- Itypes are always visited
21346 if Is_Itype (N) then
21349 -- An entity is visited when it is either a syntactic field
21350 -- or when the caller treats it as a semantic attribute.
21352 elsif Parent (N) = Par_Nod or else Semantic then
21356 -- The field is a node
21359 -- A node is visited when it is either a syntactic field or
21360 -- when the caller treats it as a semantic attribute.
21362 if Parent (N) = Par_Nod or else Semantic then
21368 -- The field is an entity list
21370 elsif Field in Elist_Range then
21371 Visit_Elist (Elist_Id (Field));
21373 -- The field is a syntax list
21375 elsif Field in List_Range then
21377 List : constant List_Id := List_Id (Field);
21380 -- A syntax list is visited when it is either a syntactic field
21381 -- or when the caller treats it as a semantic attribute.
21383 if Parent (List) = Par_Nod or else Semantic then
21388 -- Otherwise the field denotes information which does not need to be
21389 -- visited (chars, literals, etc.).
21400 procedure Visit_Itype (Itype : Entity_Id) is
21401 New_Assoc : Node_Id;
21402 New_Itype : Entity_Id;
21403 Old_Assoc : Node_Id;
21406 pragma Assert (Nkind (Itype) in N_Entity);
21407 pragma Assert (Is_Itype (Itype));
21409 -- Itypes that describe the designated type of access to subprograms
21410 -- have the structure of subprogram declarations, with signatures,
21411 -- etc. Either we duplicate the signatures completely, or choose to
21412 -- share such itypes, which is fine because their elaboration will
21413 -- have no side effects.
21415 if Ekind (Itype) = E_Subprogram_Type then
21418 -- Nothing to do if the itype was already visited
21420 elsif NCT_Tables_In_Use
21421 and then Present (NCT_New_Entities.Get (Itype))
21425 -- Nothing to do if the associated node of the itype is not within
21426 -- the subtree being replicated.
21428 elsif not In_Subtree
21429 (N => Associated_Node_For_Itype (Itype),
21435 -- Create a new itype by directly copying the old itype. This action
21436 -- causes all attributes of the old itype to be inherited.
21438 New_Itype := New_Copy (Itype);
21440 -- Create a new name for the new itype because the back end requires
21441 -- distinct names for debugging purposes.
21443 Set_Chars (New_Itype, New_Internal_Name ('T'));
21445 -- Update the Comes_From_Source and Sloc attributes of the itype in
21446 -- case the caller has supplied new values.
21448 Update_CFS_Sloc (New_Itype);
21450 -- Establish the following mapping within table NCT_New_Entities:
21452 -- Itype -> New_Itype
21454 Add_New_Entity (Itype, New_Itype);
21456 -- The new itype must be unfrozen because the resulting subtree may
21457 -- be inserted anywhere and cause an earlier or later freezing.
21459 if Present (Freeze_Node (New_Itype)) then
21460 Set_Freeze_Node (New_Itype, Empty);
21461 Set_Is_Frozen (New_Itype, False);
21464 -- If a record subtype is simply copied, the entity list will be
21465 -- shared. Thus cloned_Subtype must be set to indicate the sharing.
21466 -- ??? What does this do?
21468 if Ekind_In (Itype, E_Class_Wide_Subtype, E_Record_Subtype) then
21469 Set_Cloned_Subtype (New_Itype, Itype);
21472 -- The associated node may denote an entity, in which case it may
21473 -- already have a new corresponding entity created during a prior
21474 -- call to Visit_Entity or Visit_Itype for the same subtree.
21477 -- Old_Assoc ---------> New_Assoc
21479 -- Created by Visit_Itype
21480 -- Itype -------------> New_Itype
21481 -- ANFI = Old_Assoc ANFI = Old_Assoc < must be updated
21483 -- In the example above, Old_Assoc is an arbitrary entity that was
21484 -- already visited for the same subtree and has a corresponding new
21485 -- entity New_Assoc. Old_Assoc was inherited by New_Itype by virtue
21486 -- of copying entities, however it must be updated to New_Assoc.
21488 Old_Assoc := Associated_Node_For_Itype (Itype);
21490 if Nkind (Old_Assoc) in N_Entity then
21491 if NCT_Tables_In_Use then
21492 New_Assoc := NCT_New_Entities.Get (Old_Assoc);
21494 if Present (New_Assoc) then
21495 Set_Associated_Node_For_Itype (New_Itype, New_Assoc);
21499 -- Otherwise the associated node denotes a node. Postpone the update
21500 -- until Phase 2 when the node is replicated. Establish the following
21501 -- mapping within table NCT_Pending_Itypes:
21503 -- Old_Assoc -> (New_Type, ...)
21506 Add_Pending_Itype (Old_Assoc, New_Itype);
21509 -- Deal with the semantic fields of itypes. The fields are visited
21510 -- because they may mention entities that reside within the subtree
21513 Visit_Semantic_Fields (Itype);
21520 procedure Visit_List (List : List_Id) is
21524 -- Note that the element of a syntactic list is always a node, never
21525 -- an entity or itype, hence the call to Visit_Node.
21527 if Present (List) then
21528 Elmt := First (List);
21529 while Present (Elmt) loop
21541 procedure Visit_Node (N : Node_Or_Entity_Id) is
21543 pragma Assert (Nkind (N) not in N_Entity);
21545 -- If the node is a quantified expression and expander is active,
21546 -- it contains an implicit declaration that may require a new entity
21547 -- when the condition has already been (pre)analyzed.
21549 if Nkind (N) = N_Expression_With_Actions
21551 (Nkind (N) = N_Quantified_Expression and then Expander_Active)
21553 EWA_Level := EWA_Level + 1;
21555 elsif EWA_Level > 0
21556 and then Nkind_In (N, N_Block_Statement,
21558 N_Subprogram_Declaration)
21560 EWA_Inner_Scope_Level := EWA_Inner_Scope_Level + 1;
21564 (Field => Field1 (N),
21568 (Field => Field2 (N),
21572 (Field => Field3 (N),
21576 (Field => Field4 (N),
21580 (Field => Field5 (N),
21584 and then Nkind_In (N, N_Block_Statement,
21586 N_Subprogram_Declaration)
21588 EWA_Inner_Scope_Level := EWA_Inner_Scope_Level - 1;
21590 elsif Nkind (N) = N_Expression_With_Actions then
21591 EWA_Level := EWA_Level - 1;
21595 ---------------------------
21596 -- Visit_Semantic_Fields --
21597 ---------------------------
21599 procedure Visit_Semantic_Fields (Id : Entity_Id) is
21601 pragma Assert (Nkind (Id) in N_Entity);
21603 -- Discriminant_Constraint
21605 if Is_Type (Id) and then Has_Discriminants (Base_Type (Id)) then
21607 (Field => Union_Id (Discriminant_Constraint (Id)),
21614 (Field => Union_Id (Etype (Id)),
21618 -- Packed_Array_Impl_Type
21620 if Is_Array_Type (Id) then
21621 if Present (First_Index (Id)) then
21623 (Field => Union_Id (List_Containing (First_Index (Id))),
21627 if Is_Packed (Id) then
21629 (Field => Union_Id (Packed_Array_Impl_Type (Id)),
21636 if Is_Discrete_Type (Id) then
21638 (Field => Union_Id (Scalar_Range (Id)),
21641 end Visit_Semantic_Fields;
21643 -- Start of processing for New_Copy_Tree
21646 -- Routine New_Copy_Tree performs a deep copy of a subtree by creating
21647 -- shallow copies for each node within, and then updating the child and
21648 -- parent pointers accordingly. This process is straightforward, however
21649 -- the routine must deal with the following complications:
21651 -- * Entities defined within N_Expression_With_Actions nodes must be
21652 -- replicated rather than shared to avoid introducing two identical
21653 -- symbols within the same scope. Note that no other expression can
21654 -- currently define entities.
21657 -- Source_Low : ...;
21658 -- Source_High : ...;
21660 -- <reference to Source_Low>
21661 -- <reference to Source_High>
21664 -- New_Copy_Tree handles this case by first creating new entities
21665 -- and then updating all existing references to point to these new
21672 -- <reference to New_Low>
21673 -- <reference to New_High>
21676 -- * Itypes defined within the subtree must be replicated to avoid any
21677 -- dependencies on invalid or inaccessible data.
21679 -- subtype Source_Itype is ... range Source_Low .. Source_High;
21681 -- New_Copy_Tree handles this case by first creating a new itype in
21682 -- the same fashion as entities, and then updating various relevant
21685 -- subtype New_Itype is ... range New_Low .. New_High;
21687 -- * The Associated_Node_For_Itype field of itypes must be updated to
21688 -- reference the proper replicated entity or node.
21690 -- * Semantic fields of entities such as Etype and Scope must be
21691 -- updated to reference the proper replicated entities.
21693 -- * Semantic fields of nodes such as First_Real_Statement must be
21694 -- updated to reference the proper replicated nodes.
21696 -- Finally, quantified expressions contain an implicit delaration for
21697 -- the bound variable. Given that quantified expressions appearing
21698 -- in contracts are copied to create pragmas and eventually checking
21699 -- procedures, a new bound variable must be created for each copy, to
21700 -- prevent multiple declarations of the same symbol.
21702 -- To meet all these demands, routine New_Copy_Tree is split into two
21705 -- Phase 1 traverses the tree in order to locate entities and itypes
21706 -- defined within the subtree. New entities are generated and saved in
21707 -- table NCT_New_Entities. The semantic fields of all new entities and
21708 -- itypes are then updated accordingly.
21710 -- Phase 2 traverses the tree in order to replicate each node. Various
21711 -- semantic fields of nodes and entities are updated accordingly.
21713 -- Preparatory phase. Clear the contents of tables NCT_New_Entities and
21714 -- NCT_Pending_Itypes in case a previous call to New_Copy_Tree left some
21717 if NCT_Tables_In_Use then
21718 NCT_Tables_In_Use := False;
21720 NCT_New_Entities.Reset;
21721 NCT_Pending_Itypes.Reset;
21724 -- Populate tables NCT_New_Entities and NCT_Pending_Itypes with data
21725 -- supplied by a linear entity map. The tables offer faster access to
21728 Build_NCT_Tables (Map);
21730 -- Execute Phase 1. Traverse the subtree and generate new entities for
21731 -- the following cases:
21733 -- * An entity defined within an N_Expression_With_Actions node
21735 -- * An itype referenced within the subtree where the associated node
21736 -- is also in the subtree.
21738 -- All new entities are accessible via table NCT_New_Entities, which
21739 -- contains mappings of the form:
21741 -- Old_Entity -> New_Entity
21742 -- Old_Itype -> New_Itype
21744 -- In addition, the associated nodes of all new itypes are mapped in
21745 -- table NCT_Pending_Itypes:
21747 -- Assoc_Nod -> (New_Itype1, New_Itype2, .., New_ItypeN)
21749 Visit_Any_Node (Source);
21751 -- Update the semantic attributes of all new entities generated during
21752 -- Phase 1 before starting Phase 2. The updates could be performed in
21753 -- routine Corresponding_Entity, however this may cause the same entity
21754 -- to be updated multiple times, effectively generating useless nodes.
21755 -- Keeping the updates separates from Phase 2 ensures that only one set
21756 -- of attributes is generated for an entity at any one time.
21758 Update_New_Entities (Map);
21760 -- Execute Phase 2. Replicate the source subtree one node at a time.
21761 -- The following transformations take place:
21763 -- * References to entities and itypes are updated to refer to the
21764 -- new entities and itypes generated during Phase 1.
21766 -- * All Associated_Node_For_Itype attributes of itypes are updated
21767 -- to refer to the new replicated Associated_Node_For_Itype.
21769 return Copy_Node_With_Replacement (Source);
21772 -------------------------
21773 -- New_External_Entity --
21774 -------------------------
21776 function New_External_Entity
21777 (Kind : Entity_Kind;
21778 Scope_Id : Entity_Id;
21779 Sloc_Value : Source_Ptr;
21780 Related_Id : Entity_Id;
21781 Suffix : Character;
21782 Suffix_Index : Int := 0;
21783 Prefix : Character := ' ') return Entity_Id
21785 N : constant Entity_Id :=
21786 Make_Defining_Identifier (Sloc_Value,
21788 (Chars (Related_Id), Suffix, Suffix_Index, Prefix));
21791 Set_Ekind (N, Kind);
21792 Set_Is_Internal (N, True);
21793 Append_Entity (N, Scope_Id);
21794 Set_Public_Status (N);
21796 if Kind in Type_Kind then
21797 Init_Size_Align (N);
21801 end New_External_Entity;
21803 -------------------------
21804 -- New_Internal_Entity --
21805 -------------------------
21807 function New_Internal_Entity
21808 (Kind : Entity_Kind;
21809 Scope_Id : Entity_Id;
21810 Sloc_Value : Source_Ptr;
21811 Id_Char : Character) return Entity_Id
21813 N : constant Entity_Id := Make_Temporary (Sloc_Value, Id_Char);
21816 Set_Ekind (N, Kind);
21817 Set_Is_Internal (N, True);
21818 Append_Entity (N, Scope_Id);
21820 if Kind in Type_Kind then
21821 Init_Size_Align (N);
21825 end New_Internal_Entity;
21831 function Next_Actual (Actual_Id : Node_Id) return Node_Id is
21832 Par : constant Node_Id := Parent (Actual_Id);
21836 -- If we are pointing at a positional parameter, it is a member of a
21837 -- node list (the list of parameters), and the next parameter is the
21838 -- next node on the list, unless we hit a parameter association, then
21839 -- we shift to using the chain whose head is the First_Named_Actual in
21840 -- the parent, and then is threaded using the Next_Named_Actual of the
21841 -- Parameter_Association. All this fiddling is because the original node
21842 -- list is in the textual call order, and what we need is the
21843 -- declaration order.
21845 if Is_List_Member (Actual_Id) then
21846 N := Next (Actual_Id);
21848 if Nkind (N) = N_Parameter_Association then
21850 -- In case of a build-in-place call, the call will no longer be a
21851 -- call; it will have been rewritten.
21853 if Nkind_In (Par, N_Entry_Call_Statement,
21855 N_Procedure_Call_Statement)
21857 return First_Named_Actual (Par);
21859 -- In case of a call rewritten in GNATprove mode while "inlining
21860 -- for proof" go to the original call.
21862 elsif Nkind (Par) = N_Null_Statement then
21866 Nkind (Original_Node (Par)) in N_Subprogram_Call);
21868 return First_Named_Actual (Original_Node (Par));
21877 return Next_Named_Actual (Parent (Actual_Id));
21881 procedure Next_Actual (Actual_Id : in out Node_Id) is
21883 Actual_Id := Next_Actual (Actual_Id);
21890 function Next_Global (Node : Node_Id) return Node_Id is
21892 -- The global item may either be in a list, or by itself, in which case
21893 -- there is no next global item with the same mode.
21895 if Is_List_Member (Node) then
21896 return Next (Node);
21902 procedure Next_Global (Node : in out Node_Id) is
21904 Node := Next_Global (Node);
21907 ----------------------------------
21908 -- New_Requires_Transient_Scope --
21909 ----------------------------------
21911 function New_Requires_Transient_Scope (Id : Entity_Id) return Boolean is
21912 function Caller_Known_Size_Record (Typ : Entity_Id) return Boolean;
21913 -- This is called for untagged records and protected types, with
21914 -- nondefaulted discriminants. Returns True if the size of function
21915 -- results is known at the call site, False otherwise. Returns False
21916 -- if there is a variant part that depends on the discriminants of
21917 -- this type, or if there is an array constrained by the discriminants
21918 -- of this type. ???Currently, this is overly conservative (the array
21919 -- could be nested inside some other record that is constrained by
21920 -- nondiscriminants). That is, the recursive calls are too conservative.
21922 function Large_Max_Size_Mutable (Typ : Entity_Id) return Boolean;
21923 -- Returns True if Typ is a nonlimited record with defaulted
21924 -- discriminants whose max size makes it unsuitable for allocating on
21925 -- the primary stack.
21927 ------------------------------
21928 -- Caller_Known_Size_Record --
21929 ------------------------------
21931 function Caller_Known_Size_Record (Typ : Entity_Id) return Boolean is
21932 pragma Assert (Typ = Underlying_Type (Typ));
21935 if Has_Variant_Part (Typ) and then not Is_Definite_Subtype (Typ) then
21943 Comp := First_Entity (Typ);
21944 while Present (Comp) loop
21946 -- Only look at E_Component entities. No need to look at
21947 -- E_Discriminant entities, and we must ignore internal
21948 -- subtypes generated for constrained components.
21950 if Ekind (Comp) = E_Component then
21952 Comp_Type : constant Entity_Id :=
21953 Underlying_Type (Etype (Comp));
21956 if Is_Record_Type (Comp_Type)
21958 Is_Protected_Type (Comp_Type)
21960 if not Caller_Known_Size_Record (Comp_Type) then
21964 elsif Is_Array_Type (Comp_Type) then
21965 if Size_Depends_On_Discriminant (Comp_Type) then
21972 Next_Entity (Comp);
21977 end Caller_Known_Size_Record;
21979 ------------------------------
21980 -- Large_Max_Size_Mutable --
21981 ------------------------------
21983 function Large_Max_Size_Mutable (Typ : Entity_Id) return Boolean is
21984 pragma Assert (Typ = Underlying_Type (Typ));
21986 function Is_Large_Discrete_Type (T : Entity_Id) return Boolean;
21987 -- Returns true if the discrete type T has a large range
21989 ----------------------------
21990 -- Is_Large_Discrete_Type --
21991 ----------------------------
21993 function Is_Large_Discrete_Type (T : Entity_Id) return Boolean is
21994 Threshold : constant Int := 16;
21995 -- Arbitrary threshold above which we consider it "large". We want
21996 -- a fairly large threshold, because these large types really
21997 -- shouldn't have default discriminants in the first place, in
22001 return UI_To_Int (RM_Size (T)) > Threshold;
22002 end Is_Large_Discrete_Type;
22004 -- Start of processing for Large_Max_Size_Mutable
22007 if Is_Record_Type (Typ)
22008 and then not Is_Limited_View (Typ)
22009 and then Has_Defaulted_Discriminants (Typ)
22011 -- Loop through the components, looking for an array whose upper
22012 -- bound(s) depends on discriminants, where both the subtype of
22013 -- the discriminant and the index subtype are too large.
22019 Comp := First_Entity (Typ);
22020 while Present (Comp) loop
22021 if Ekind (Comp) = E_Component then
22023 Comp_Type : constant Entity_Id :=
22024 Underlying_Type (Etype (Comp));
22031 if Is_Array_Type (Comp_Type) then
22032 Indx := First_Index (Comp_Type);
22034 while Present (Indx) loop
22035 Ityp := Etype (Indx);
22036 Hi := Type_High_Bound (Ityp);
22038 if Nkind (Hi) = N_Identifier
22039 and then Ekind (Entity (Hi)) = E_Discriminant
22040 and then Is_Large_Discrete_Type (Ityp)
22041 and then Is_Large_Discrete_Type
22042 (Etype (Entity (Hi)))
22053 Next_Entity (Comp);
22059 end Large_Max_Size_Mutable;
22061 -- Local declarations
22063 Typ : constant Entity_Id := Underlying_Type (Id);
22065 -- Start of processing for New_Requires_Transient_Scope
22068 -- This is a private type which is not completed yet. This can only
22069 -- happen in a default expression (of a formal parameter or of a
22070 -- record component). Do not expand transient scope in this case.
22075 -- Do not expand transient scope for non-existent procedure return or
22076 -- string literal types.
22078 elsif Typ = Standard_Void_Type
22079 or else Ekind (Typ) = E_String_Literal_Subtype
22083 -- If Typ is a generic formal incomplete type, then we want to look at
22084 -- the actual type.
22086 elsif Ekind (Typ) = E_Record_Subtype
22087 and then Present (Cloned_Subtype (Typ))
22089 return New_Requires_Transient_Scope (Cloned_Subtype (Typ));
22091 -- Functions returning specific tagged types may dispatch on result, so
22092 -- their returned value is allocated on the secondary stack, even in the
22093 -- definite case. We must treat nondispatching functions the same way,
22094 -- because access-to-function types can point at both, so the calling
22095 -- conventions must be compatible. Is_Tagged_Type includes controlled
22096 -- types and class-wide types. Controlled type temporaries need
22099 -- ???It's not clear why we need to return noncontrolled types with
22100 -- controlled components on the secondary stack.
22102 elsif Is_Tagged_Type (Typ) or else Has_Controlled_Component (Typ) then
22105 -- Untagged definite subtypes are known size. This includes all
22106 -- elementary [sub]types. Tasks are known size even if they have
22107 -- discriminants. So we return False here, with one exception:
22108 -- For a type like:
22109 -- type T (Last : Natural := 0) is
22110 -- X : String (1 .. Last);
22112 -- we return True. That's because for "P(F(...));", where F returns T,
22113 -- we don't know the size of the result at the call site, so if we
22114 -- allocated it on the primary stack, we would have to allocate the
22115 -- maximum size, which is way too big.
22117 elsif Is_Definite_Subtype (Typ) or else Is_Task_Type (Typ) then
22118 return Large_Max_Size_Mutable (Typ);
22120 -- Indefinite (discriminated) untagged record or protected type
22122 elsif Is_Record_Type (Typ) or else Is_Protected_Type (Typ) then
22123 return not Caller_Known_Size_Record (Typ);
22125 -- Unconstrained array
22128 pragma Assert (Is_Array_Type (Typ) and not Is_Definite_Subtype (Typ));
22131 end New_Requires_Transient_Scope;
22133 ------------------------
22134 -- No_Caching_Enabled --
22135 ------------------------
22137 function No_Caching_Enabled (Id : Entity_Id) return Boolean is
22138 Prag : constant Node_Id := Get_Pragma (Id, Pragma_No_Caching);
22142 if Present (Prag) then
22143 Arg1 := First (Pragma_Argument_Associations (Prag));
22145 -- The pragma has an optional Boolean expression, the related
22146 -- property is enabled only when the expression evaluates to True.
22148 if Present (Arg1) then
22149 return Is_True (Expr_Value (Get_Pragma_Arg (Arg1)));
22151 -- Otherwise the lack of expression enables the property by
22158 -- The property was never set in the first place
22163 end No_Caching_Enabled;
22165 --------------------------
22166 -- No_Heap_Finalization --
22167 --------------------------
22169 function No_Heap_Finalization (Typ : Entity_Id) return Boolean is
22171 if Ekind_In (Typ, E_Access_Type, E_General_Access_Type)
22172 and then Is_Library_Level_Entity (Typ)
22174 -- A global No_Heap_Finalization pragma applies to all library-level
22175 -- named access-to-object types.
22177 if Present (No_Heap_Finalization_Pragma) then
22180 -- The library-level named access-to-object type itself is subject to
22181 -- pragma No_Heap_Finalization.
22183 elsif Present (Get_Pragma (Typ, Pragma_No_Heap_Finalization)) then
22189 end No_Heap_Finalization;
22191 -----------------------
22192 -- Normalize_Actuals --
22193 -----------------------
22195 -- Chain actuals according to formals of subprogram. If there are no named
22196 -- associations, the chain is simply the list of Parameter Associations,
22197 -- since the order is the same as the declaration order. If there are named
22198 -- associations, then the First_Named_Actual field in the N_Function_Call
22199 -- or N_Procedure_Call_Statement node points to the Parameter_Association
22200 -- node for the parameter that comes first in declaration order. The
22201 -- remaining named parameters are then chained in declaration order using
22202 -- Next_Named_Actual.
22204 -- This routine also verifies that the number of actuals is compatible with
22205 -- the number and default values of formals, but performs no type checking
22206 -- (type checking is done by the caller).
22208 -- If the matching succeeds, Success is set to True and the caller proceeds
22209 -- with type-checking. If the match is unsuccessful, then Success is set to
22210 -- False, and the caller attempts a different interpretation, if there is
22213 -- If the flag Report is on, the call is not overloaded, and a failure to
22214 -- match can be reported here, rather than in the caller.
22216 procedure Normalize_Actuals
22220 Success : out Boolean)
22222 Actuals : constant List_Id := Parameter_Associations (N);
22223 Actual : Node_Id := Empty;
22224 Formal : Entity_Id;
22225 Last : Node_Id := Empty;
22226 First_Named : Node_Id := Empty;
22229 Formals_To_Match : Integer := 0;
22230 Actuals_To_Match : Integer := 0;
22232 procedure Chain (A : Node_Id);
22233 -- Add named actual at the proper place in the list, using the
22234 -- Next_Named_Actual link.
22236 function Reporting return Boolean;
22237 -- Determines if an error is to be reported. To report an error, we
22238 -- need Report to be True, and also we do not report errors caused
22239 -- by calls to init procs that occur within other init procs. Such
22240 -- errors must always be cascaded errors, since if all the types are
22241 -- declared correctly, the compiler will certainly build decent calls.
22247 procedure Chain (A : Node_Id) is
22251 -- Call node points to first actual in list
22253 Set_First_Named_Actual (N, Explicit_Actual_Parameter (A));
22256 Set_Next_Named_Actual (Last, Explicit_Actual_Parameter (A));
22260 Set_Next_Named_Actual (Last, Empty);
22267 function Reporting return Boolean is
22272 elsif not Within_Init_Proc then
22275 elsif Is_Init_Proc (Entity (Name (N))) then
22283 -- Start of processing for Normalize_Actuals
22286 if Is_Access_Type (S) then
22288 -- The name in the call is a function call that returns an access
22289 -- to subprogram. The designated type has the list of formals.
22291 Formal := First_Formal (Designated_Type (S));
22293 Formal := First_Formal (S);
22296 while Present (Formal) loop
22297 Formals_To_Match := Formals_To_Match + 1;
22298 Next_Formal (Formal);
22301 -- Find if there is a named association, and verify that no positional
22302 -- associations appear after named ones.
22304 if Present (Actuals) then
22305 Actual := First (Actuals);
22308 while Present (Actual)
22309 and then Nkind (Actual) /= N_Parameter_Association
22311 Actuals_To_Match := Actuals_To_Match + 1;
22315 if No (Actual) and Actuals_To_Match = Formals_To_Match then
22317 -- Most common case: positional notation, no defaults
22322 elsif Actuals_To_Match > Formals_To_Match then
22324 -- Too many actuals: will not work
22327 if Is_Entity_Name (Name (N)) then
22328 Error_Msg_N ("too many arguments in call to&", Name (N));
22330 Error_Msg_N ("too many arguments in call", N);
22338 First_Named := Actual;
22340 while Present (Actual) loop
22341 if Nkind (Actual) /= N_Parameter_Association then
22343 ("positional parameters not allowed after named ones", Actual);
22348 Actuals_To_Match := Actuals_To_Match + 1;
22354 if Present (Actuals) then
22355 Actual := First (Actuals);
22358 Formal := First_Formal (S);
22359 while Present (Formal) loop
22361 -- Match the formals in order. If the corresponding actual is
22362 -- positional, nothing to do. Else scan the list of named actuals
22363 -- to find the one with the right name.
22365 if Present (Actual)
22366 and then Nkind (Actual) /= N_Parameter_Association
22369 Actuals_To_Match := Actuals_To_Match - 1;
22370 Formals_To_Match := Formals_To_Match - 1;
22373 -- For named parameters, search the list of actuals to find
22374 -- one that matches the next formal name.
22376 Actual := First_Named;
22378 while Present (Actual) loop
22379 if Chars (Selector_Name (Actual)) = Chars (Formal) then
22382 Actuals_To_Match := Actuals_To_Match - 1;
22383 Formals_To_Match := Formals_To_Match - 1;
22391 if Ekind (Formal) /= E_In_Parameter
22392 or else No (Default_Value (Formal))
22395 if (Comes_From_Source (S)
22396 or else Sloc (S) = Standard_Location)
22397 and then Is_Overloadable (S)
22401 Nkind_In (Parent (N), N_Procedure_Call_Statement,
22403 N_Parameter_Association)
22404 and then Ekind (S) /= E_Function
22406 Set_Etype (N, Etype (S));
22409 Error_Msg_Name_1 := Chars (S);
22410 Error_Msg_Sloc := Sloc (S);
22412 ("missing argument for parameter & "
22413 & "in call to % declared #", N, Formal);
22416 elsif Is_Overloadable (S) then
22417 Error_Msg_Name_1 := Chars (S);
22419 -- Point to type derivation that generated the
22422 Error_Msg_Sloc := Sloc (Parent (S));
22425 ("missing argument for parameter & "
22426 & "in call to % (inherited) #", N, Formal);
22430 ("missing argument for parameter &", N, Formal);
22438 Formals_To_Match := Formals_To_Match - 1;
22443 Next_Formal (Formal);
22446 if Formals_To_Match = 0 and then Actuals_To_Match = 0 then
22453 -- Find some superfluous named actual that did not get
22454 -- attached to the list of associations.
22456 Actual := First (Actuals);
22457 while Present (Actual) loop
22458 if Nkind (Actual) = N_Parameter_Association
22459 and then Actual /= Last
22460 and then No (Next_Named_Actual (Actual))
22462 -- A validity check may introduce a copy of a call that
22463 -- includes an extra actual (for example for an unrelated
22464 -- accessibility check). Check that the extra actual matches
22465 -- some extra formal, which must exist already because
22466 -- subprogram must be frozen at this point.
22468 if Present (Extra_Formals (S))
22469 and then not Comes_From_Source (Actual)
22470 and then Nkind (Actual) = N_Parameter_Association
22471 and then Chars (Extra_Formals (S)) =
22472 Chars (Selector_Name (Actual))
22477 ("unmatched actual & in call", Selector_Name (Actual));
22489 end Normalize_Actuals;
22491 --------------------------------
22492 -- Note_Possible_Modification --
22493 --------------------------------
22495 procedure Note_Possible_Modification (N : Node_Id; Sure : Boolean) is
22496 Modification_Comes_From_Source : constant Boolean :=
22497 Comes_From_Source (Parent (N));
22503 -- Loop to find referenced entity, if there is one
22509 if Is_Entity_Name (Exp) then
22510 Ent := Entity (Exp);
22512 -- If the entity is missing, it is an undeclared identifier,
22513 -- and there is nothing to annotate.
22519 elsif Nkind (Exp) = N_Explicit_Dereference then
22521 P : constant Node_Id := Prefix (Exp);
22524 -- In formal verification mode, keep track of all reads and
22525 -- writes through explicit dereferences.
22527 if GNATprove_Mode then
22528 SPARK_Specific.Generate_Dereference (N, 'm');
22531 if Nkind (P) = N_Selected_Component
22532 and then Present (Entry_Formal (Entity (Selector_Name (P))))
22534 -- Case of a reference to an entry formal
22536 Ent := Entry_Formal (Entity (Selector_Name (P)));
22538 elsif Nkind (P) = N_Identifier
22539 and then Nkind (Parent (Entity (P))) = N_Object_Declaration
22540 and then Present (Expression (Parent (Entity (P))))
22541 and then Nkind (Expression (Parent (Entity (P)))) =
22544 -- Case of a reference to a value on which side effects have
22547 Exp := Prefix (Expression (Parent (Entity (P))));
22555 elsif Nkind_In (Exp, N_Type_Conversion,
22556 N_Unchecked_Type_Conversion)
22558 Exp := Expression (Exp);
22561 elsif Nkind_In (Exp, N_Slice,
22562 N_Indexed_Component,
22563 N_Selected_Component)
22565 -- Special check, if the prefix is an access type, then return
22566 -- since we are modifying the thing pointed to, not the prefix.
22567 -- When we are expanding, most usually the prefix is replaced
22568 -- by an explicit dereference, and this test is not needed, but
22569 -- in some cases (notably -gnatc mode and generics) when we do
22570 -- not do full expansion, we need this special test.
22572 if Is_Access_Type (Etype (Prefix (Exp))) then
22575 -- Otherwise go to prefix and keep going
22578 Exp := Prefix (Exp);
22582 -- All other cases, not a modification
22588 -- Now look for entity being referenced
22590 if Present (Ent) then
22591 if Is_Object (Ent) then
22592 if Comes_From_Source (Exp)
22593 or else Modification_Comes_From_Source
22595 -- Give warning if pragma unmodified is given and we are
22596 -- sure this is a modification.
22598 if Has_Pragma_Unmodified (Ent) and then Sure then
22600 -- Note that the entity may be present only as a result
22601 -- of pragma Unused.
22603 if Has_Pragma_Unused (Ent) then
22604 Error_Msg_NE ("??pragma Unused given for &!", N, Ent);
22607 ("??pragma Unmodified given for &!", N, Ent);
22611 Set_Never_Set_In_Source (Ent, False);
22614 Set_Is_True_Constant (Ent, False);
22615 Set_Current_Value (Ent, Empty);
22616 Set_Is_Known_Null (Ent, False);
22618 if not Can_Never_Be_Null (Ent) then
22619 Set_Is_Known_Non_Null (Ent, False);
22622 -- Follow renaming chain
22624 if (Ekind (Ent) = E_Variable or else Ekind (Ent) = E_Constant)
22625 and then Present (Renamed_Object (Ent))
22627 Exp := Renamed_Object (Ent);
22629 -- If the entity is the loop variable in an iteration over
22630 -- a container, retrieve container expression to indicate
22631 -- possible modification.
22633 if Present (Related_Expression (Ent))
22634 and then Nkind (Parent (Related_Expression (Ent))) =
22635 N_Iterator_Specification
22637 Exp := Original_Node (Related_Expression (Ent));
22642 -- The expression may be the renaming of a subcomponent of an
22643 -- array or container. The assignment to the subcomponent is
22644 -- a modification of the container.
22646 elsif Comes_From_Source (Original_Node (Exp))
22647 and then Nkind_In (Original_Node (Exp), N_Selected_Component,
22648 N_Indexed_Component)
22650 Exp := Prefix (Original_Node (Exp));
22654 -- Generate a reference only if the assignment comes from
22655 -- source. This excludes, for example, calls to a dispatching
22656 -- assignment operation when the left-hand side is tagged. In
22657 -- GNATprove mode, we need those references also on generated
22658 -- code, as these are used to compute the local effects of
22661 if Modification_Comes_From_Source or GNATprove_Mode then
22662 Generate_Reference (Ent, Exp, 'm');
22664 -- If the target of the assignment is the bound variable
22665 -- in an iterator, indicate that the corresponding array
22666 -- or container is also modified.
22668 if Ada_Version >= Ada_2012
22669 and then Nkind (Parent (Ent)) = N_Iterator_Specification
22672 Domain : constant Node_Id := Name (Parent (Ent));
22675 -- TBD : in the full version of the construct, the
22676 -- domain of iteration can be given by an expression.
22678 if Is_Entity_Name (Domain) then
22679 Generate_Reference (Entity (Domain), Exp, 'm');
22680 Set_Is_True_Constant (Entity (Domain), False);
22681 Set_Never_Set_In_Source (Entity (Domain), False);
22690 -- If we are sure this is a modification from source, and we know
22691 -- this modifies a constant, then give an appropriate warning.
22694 and then Modification_Comes_From_Source
22695 and then Overlays_Constant (Ent)
22696 and then Address_Clause_Overlay_Warnings
22699 Addr : constant Node_Id := Address_Clause (Ent);
22704 Find_Overlaid_Entity (Addr, O_Ent, Off);
22706 Error_Msg_Sloc := Sloc (Addr);
22708 ("??constant& may be modified via address clause#",
22719 end Note_Possible_Modification;
22725 function Null_Status (N : Node_Id) return Null_Status_Kind is
22726 function Is_Null_Excluding_Def (Def : Node_Id) return Boolean;
22727 -- Determine whether definition Def carries a null exclusion
22729 function Null_Status_Of_Entity (Id : Entity_Id) return Null_Status_Kind;
22730 -- Determine the null status of arbitrary entity Id
22732 function Null_Status_Of_Type (Typ : Entity_Id) return Null_Status_Kind;
22733 -- Determine the null status of type Typ
22735 ---------------------------
22736 -- Is_Null_Excluding_Def --
22737 ---------------------------
22739 function Is_Null_Excluding_Def (Def : Node_Id) return Boolean is
22742 Nkind_In (Def, N_Access_Definition,
22743 N_Access_Function_Definition,
22744 N_Access_Procedure_Definition,
22745 N_Access_To_Object_Definition,
22746 N_Component_Definition,
22747 N_Derived_Type_Definition)
22748 and then Null_Exclusion_Present (Def);
22749 end Is_Null_Excluding_Def;
22751 ---------------------------
22752 -- Null_Status_Of_Entity --
22753 ---------------------------
22755 function Null_Status_Of_Entity
22756 (Id : Entity_Id) return Null_Status_Kind
22758 Decl : constant Node_Id := Declaration_Node (Id);
22762 -- The value of an imported or exported entity may be set externally
22763 -- regardless of a null exclusion. As a result, the value cannot be
22764 -- determined statically.
22766 if Is_Imported (Id) or else Is_Exported (Id) then
22769 elsif Nkind_In (Decl, N_Component_Declaration,
22770 N_Discriminant_Specification,
22771 N_Formal_Object_Declaration,
22772 N_Object_Declaration,
22773 N_Object_Renaming_Declaration,
22774 N_Parameter_Specification)
22776 -- A component declaration yields a non-null value when either
22777 -- its component definition or access definition carries a null
22780 if Nkind (Decl) = N_Component_Declaration then
22781 Def := Component_Definition (Decl);
22783 if Is_Null_Excluding_Def (Def) then
22784 return Is_Non_Null;
22787 Def := Access_Definition (Def);
22789 if Present (Def) and then Is_Null_Excluding_Def (Def) then
22790 return Is_Non_Null;
22793 -- A formal object declaration yields a non-null value if its
22794 -- access definition carries a null exclusion. If the object is
22795 -- default initialized, then the value depends on the expression.
22797 elsif Nkind (Decl) = N_Formal_Object_Declaration then
22798 Def := Access_Definition (Decl);
22800 if Present (Def) and then Is_Null_Excluding_Def (Def) then
22801 return Is_Non_Null;
22804 -- A constant may yield a null or non-null value depending on its
22805 -- initialization expression.
22807 elsif Ekind (Id) = E_Constant then
22808 return Null_Status (Constant_Value (Id));
22810 -- The construct yields a non-null value when it has a null
22813 elsif Null_Exclusion_Present (Decl) then
22814 return Is_Non_Null;
22816 -- An object renaming declaration yields a non-null value if its
22817 -- access definition carries a null exclusion. Otherwise the value
22818 -- depends on the renamed name.
22820 elsif Nkind (Decl) = N_Object_Renaming_Declaration then
22821 Def := Access_Definition (Decl);
22823 if Present (Def) and then Is_Null_Excluding_Def (Def) then
22824 return Is_Non_Null;
22827 return Null_Status (Name (Decl));
22832 -- At this point the declaration of the entity does not carry a null
22833 -- exclusion and lacks an initialization expression. Check the status
22836 return Null_Status_Of_Type (Etype (Id));
22837 end Null_Status_Of_Entity;
22839 -------------------------
22840 -- Null_Status_Of_Type --
22841 -------------------------
22843 function Null_Status_Of_Type (Typ : Entity_Id) return Null_Status_Kind is
22848 -- Traverse the type chain looking for types with null exclusion
22851 while Present (Curr) and then Etype (Curr) /= Curr loop
22852 Decl := Parent (Curr);
22854 -- Guard against itypes which do not always have declarations. A
22855 -- type yields a non-null value if it carries a null exclusion.
22857 if Present (Decl) then
22858 if Nkind (Decl) = N_Full_Type_Declaration
22859 and then Is_Null_Excluding_Def (Type_Definition (Decl))
22861 return Is_Non_Null;
22863 elsif Nkind (Decl) = N_Subtype_Declaration
22864 and then Null_Exclusion_Present (Decl)
22866 return Is_Non_Null;
22870 Curr := Etype (Curr);
22873 -- The type chain does not contain any null excluding types
22876 end Null_Status_Of_Type;
22878 -- Start of processing for Null_Status
22881 -- Prevent cascaded errors or infinite loops when trying to determine
22882 -- the null status of an erroneous construct.
22884 if Error_Posted (N) then
22887 -- An allocator always creates a non-null value
22889 elsif Nkind (N) = N_Allocator then
22890 return Is_Non_Null;
22892 -- Taking the 'Access of something yields a non-null value
22894 elsif Nkind (N) = N_Attribute_Reference
22895 and then Nam_In (Attribute_Name (N), Name_Access,
22896 Name_Unchecked_Access,
22897 Name_Unrestricted_Access)
22899 return Is_Non_Null;
22901 -- "null" yields null
22903 elsif Nkind (N) = N_Null then
22906 -- Check the status of the operand of a type conversion
22908 elsif Nkind (N) = N_Type_Conversion then
22909 return Null_Status (Expression (N));
22911 -- The input denotes a reference to an entity. Determine whether the
22912 -- entity or its type yields a null or non-null value.
22914 elsif Is_Entity_Name (N) and then Present (Entity (N)) then
22915 return Null_Status_Of_Entity (Entity (N));
22918 -- Otherwise it is not possible to determine the null status of the
22919 -- subexpression at compile time without resorting to simple flow
22925 --------------------------------------
22926 -- Null_To_Null_Address_Convert_OK --
22927 --------------------------------------
22929 function Null_To_Null_Address_Convert_OK
22931 Typ : Entity_Id := Empty) return Boolean
22934 if not Relaxed_RM_Semantics then
22938 if Nkind (N) = N_Null then
22939 return Present (Typ) and then Is_Descendant_Of_Address (Typ);
22941 elsif Nkind_In (N, N_Op_Eq, N_Op_Ge, N_Op_Gt, N_Op_Le, N_Op_Lt, N_Op_Ne)
22944 L : constant Node_Id := Left_Opnd (N);
22945 R : constant Node_Id := Right_Opnd (N);
22948 -- We check the Etype of the complementary operand since the
22949 -- N_Null node is not decorated at this stage.
22952 ((Nkind (L) = N_Null
22953 and then Is_Descendant_Of_Address (Etype (R)))
22955 (Nkind (R) = N_Null
22956 and then Is_Descendant_Of_Address (Etype (L))));
22961 end Null_To_Null_Address_Convert_OK;
22963 ---------------------------------
22964 -- Number_Of_Elements_In_Array --
22965 ---------------------------------
22967 function Number_Of_Elements_In_Array (T : Entity_Id) return Int is
22975 pragma Assert (Is_Array_Type (T));
22977 Indx := First_Index (T);
22978 while Present (Indx) loop
22979 Typ := Underlying_Type (Etype (Indx));
22981 -- Never look at junk bounds of a generic type
22983 if Is_Generic_Type (Typ) then
22987 -- Check the array bounds are known at compile time and return zero
22988 -- if they are not.
22990 Low := Type_Low_Bound (Typ);
22991 High := Type_High_Bound (Typ);
22993 if not Compile_Time_Known_Value (Low) then
22995 elsif not Compile_Time_Known_Value (High) then
22999 Num * UI_To_Int ((Expr_Value (High) - Expr_Value (Low) + 1));
23006 end Number_Of_Elements_In_Array;
23008 -------------------------
23009 -- Object_Access_Level --
23010 -------------------------
23012 -- Returns the static accessibility level of the view denoted by Obj. Note
23013 -- that the value returned is the result of a call to Scope_Depth. Only
23014 -- scope depths associated with dynamic scopes can actually be returned.
23015 -- Since only relative levels matter for accessibility checking, the fact
23016 -- that the distance between successive levels of accessibility is not
23017 -- always one is immaterial (invariant: if level(E2) is deeper than
23018 -- level(E1), then Scope_Depth(E1) < Scope_Depth(E2)).
23020 function Object_Access_Level (Obj : Node_Id) return Uint is
23021 function Is_Interface_Conversion (N : Node_Id) return Boolean;
23022 -- Determine whether N is a construct of the form
23023 -- Some_Type (Operand._tag'Address)
23024 -- This construct appears in the context of dispatching calls.
23026 function Reference_To (Obj : Node_Id) return Node_Id;
23027 -- An explicit dereference is created when removing side effects from
23028 -- expressions for constraint checking purposes. In this case a local
23029 -- access type is created for it. The correct access level is that of
23030 -- the original source node. We detect this case by noting that the
23031 -- prefix of the dereference is created by an object declaration whose
23032 -- initial expression is a reference.
23034 -----------------------------
23035 -- Is_Interface_Conversion --
23036 -----------------------------
23038 function Is_Interface_Conversion (N : Node_Id) return Boolean is
23040 return Nkind (N) = N_Unchecked_Type_Conversion
23041 and then Nkind (Expression (N)) = N_Attribute_Reference
23042 and then Attribute_Name (Expression (N)) = Name_Address;
23043 end Is_Interface_Conversion;
23049 function Reference_To (Obj : Node_Id) return Node_Id is
23050 Pref : constant Node_Id := Prefix (Obj);
23052 if Is_Entity_Name (Pref)
23053 and then Nkind (Parent (Entity (Pref))) = N_Object_Declaration
23054 and then Present (Expression (Parent (Entity (Pref))))
23055 and then Nkind (Expression (Parent (Entity (Pref)))) = N_Reference
23057 return (Prefix (Expression (Parent (Entity (Pref)))));
23067 -- Start of processing for Object_Access_Level
23070 if Nkind (Obj) = N_Defining_Identifier
23071 or else Is_Entity_Name (Obj)
23073 if Nkind (Obj) = N_Defining_Identifier then
23079 if Is_Prival (E) then
23080 E := Prival_Link (E);
23083 -- If E is a type then it denotes a current instance. For this case
23084 -- we add one to the normal accessibility level of the type to ensure
23085 -- that current instances are treated as always being deeper than
23086 -- than the level of any visible named access type (see 3.10.2(21)).
23088 if Is_Type (E) then
23089 return Type_Access_Level (E) + 1;
23091 elsif Present (Renamed_Object (E)) then
23092 return Object_Access_Level (Renamed_Object (E));
23094 -- Similarly, if E is a component of the current instance of a
23095 -- protected type, any instance of it is assumed to be at a deeper
23096 -- level than the type. For a protected object (whose type is an
23097 -- anonymous protected type) its components are at the same level
23098 -- as the type itself.
23100 elsif not Is_Overloadable (E)
23101 and then Ekind (Scope (E)) = E_Protected_Type
23102 and then Comes_From_Source (Scope (E))
23104 return Type_Access_Level (Scope (E)) + 1;
23107 -- Aliased formals of functions take their access level from the
23108 -- point of call, i.e. require a dynamic check. For static check
23109 -- purposes, this is smaller than the level of the subprogram
23110 -- itself. For procedures the aliased makes no difference.
23113 and then Is_Aliased (E)
23114 and then Ekind (Scope (E)) = E_Function
23116 return Type_Access_Level (Etype (E));
23119 return Scope_Depth (Enclosing_Dynamic_Scope (E));
23123 elsif Nkind_In (Obj, N_Indexed_Component, N_Selected_Component) then
23124 if Is_Access_Type (Etype (Prefix (Obj))) then
23125 return Type_Access_Level (Etype (Prefix (Obj)));
23127 return Object_Access_Level (Prefix (Obj));
23130 elsif Nkind (Obj) = N_Explicit_Dereference then
23132 -- If the prefix is a selected access discriminant then we make a
23133 -- recursive call on the prefix, which will in turn check the level
23134 -- of the prefix object of the selected discriminant.
23136 -- In Ada 2012, if the discriminant has implicit dereference and
23137 -- the context is a selected component, treat this as an object of
23138 -- unknown scope (see below). This is necessary in compile-only mode;
23139 -- otherwise expansion will already have transformed the prefix into
23142 if Nkind (Prefix (Obj)) = N_Selected_Component
23143 and then Ekind (Etype (Prefix (Obj))) = E_Anonymous_Access_Type
23145 Ekind (Entity (Selector_Name (Prefix (Obj)))) = E_Discriminant
23147 (not Has_Implicit_Dereference
23148 (Entity (Selector_Name (Prefix (Obj))))
23149 or else Nkind (Parent (Obj)) /= N_Selected_Component)
23151 return Object_Access_Level (Prefix (Obj));
23153 -- Detect an interface conversion in the context of a dispatching
23154 -- call. Use the original form of the conversion to find the access
23155 -- level of the operand.
23157 elsif Is_Interface (Etype (Obj))
23158 and then Is_Interface_Conversion (Prefix (Obj))
23159 and then Nkind (Original_Node (Obj)) = N_Type_Conversion
23161 return Object_Access_Level (Original_Node (Obj));
23163 elsif not Comes_From_Source (Obj) then
23165 Ref : constant Node_Id := Reference_To (Obj);
23167 if Present (Ref) then
23168 return Object_Access_Level (Ref);
23170 return Type_Access_Level (Etype (Prefix (Obj)));
23175 return Type_Access_Level (Etype (Prefix (Obj)));
23178 elsif Nkind_In (Obj, N_Type_Conversion, N_Unchecked_Type_Conversion) then
23179 return Object_Access_Level (Expression (Obj));
23181 elsif Nkind (Obj) = N_Function_Call then
23183 -- Function results are objects, so we get either the access level of
23184 -- the function or, in the case of an indirect call, the level of the
23185 -- access-to-subprogram type. (This code is used for Ada 95, but it
23186 -- looks wrong, because it seems that we should be checking the level
23187 -- of the call itself, even for Ada 95. However, using the Ada 2005
23188 -- version of the code causes regressions in several tests that are
23189 -- compiled with -gnat95. ???)
23191 if Ada_Version < Ada_2005 then
23192 if Is_Entity_Name (Name (Obj)) then
23193 return Subprogram_Access_Level (Entity (Name (Obj)));
23195 return Type_Access_Level (Etype (Prefix (Name (Obj))));
23198 -- For Ada 2005, the level of the result object of a function call is
23199 -- defined to be the level of the call's innermost enclosing master.
23200 -- We determine that by querying the depth of the innermost enclosing
23204 Return_Master_Scope_Depth_Of_Call : declare
23205 function Innermost_Master_Scope_Depth
23206 (N : Node_Id) return Uint;
23207 -- Returns the scope depth of the given node's innermost
23208 -- enclosing dynamic scope (effectively the accessibility
23209 -- level of the innermost enclosing master).
23211 ----------------------------------
23212 -- Innermost_Master_Scope_Depth --
23213 ----------------------------------
23215 function Innermost_Master_Scope_Depth
23216 (N : Node_Id) return Uint
23218 Node_Par : Node_Id := Parent (N);
23221 -- Locate the nearest enclosing node (by traversing Parents)
23222 -- that Defining_Entity can be applied to, and return the
23223 -- depth of that entity's nearest enclosing dynamic scope.
23225 while Present (Node_Par) loop
23226 case Nkind (Node_Par) is
23227 when N_Abstract_Subprogram_Declaration
23228 | N_Block_Statement
23230 | N_Component_Declaration
23232 | N_Entry_Declaration
23233 | N_Exception_Declaration
23234 | N_Formal_Object_Declaration
23235 | N_Formal_Package_Declaration
23236 | N_Formal_Subprogram_Declaration
23237 | N_Formal_Type_Declaration
23238 | N_Full_Type_Declaration
23239 | N_Function_Specification
23240 | N_Generic_Declaration
23241 | N_Generic_Instantiation
23242 | N_Implicit_Label_Declaration
23243 | N_Incomplete_Type_Declaration
23244 | N_Loop_Parameter_Specification
23245 | N_Number_Declaration
23246 | N_Object_Declaration
23247 | N_Package_Declaration
23248 | N_Package_Specification
23249 | N_Parameter_Specification
23250 | N_Private_Extension_Declaration
23251 | N_Private_Type_Declaration
23252 | N_Procedure_Specification
23254 | N_Protected_Type_Declaration
23255 | N_Renaming_Declaration
23256 | N_Single_Protected_Declaration
23257 | N_Single_Task_Declaration
23258 | N_Subprogram_Declaration
23259 | N_Subtype_Declaration
23261 | N_Task_Type_Declaration
23264 (Nearest_Dynamic_Scope
23265 (Defining_Entity (Node_Par)));
23267 -- For a return statement within a function, return
23268 -- the depth of the function itself. This is not just
23269 -- a small optimization, but matters when analyzing
23270 -- the expression in an expression function before
23271 -- the body is created.
23273 when N_Simple_Return_Statement =>
23274 if Ekind (Current_Scope) = E_Function then
23275 return Scope_Depth (Current_Scope);
23282 Node_Par := Parent (Node_Par);
23285 pragma Assert (False);
23287 -- Should never reach the following return
23289 return Scope_Depth (Current_Scope) + 1;
23290 end Innermost_Master_Scope_Depth;
23292 -- Start of processing for Return_Master_Scope_Depth_Of_Call
23295 return Innermost_Master_Scope_Depth (Obj);
23296 end Return_Master_Scope_Depth_Of_Call;
23299 -- For convenience we handle qualified expressions, even though they
23300 -- aren't technically object names.
23302 elsif Nkind (Obj) = N_Qualified_Expression then
23303 return Object_Access_Level (Expression (Obj));
23305 -- Ditto for aggregates. They have the level of the temporary that
23306 -- will hold their value.
23308 elsif Nkind (Obj) = N_Aggregate then
23309 return Object_Access_Level (Current_Scope);
23311 -- Otherwise return the scope level of Standard. (If there are cases
23312 -- that fall through to this point they will be treated as having
23313 -- global accessibility for now. ???)
23316 return Scope_Depth (Standard_Standard);
23318 end Object_Access_Level;
23320 ----------------------------------
23321 -- Old_Requires_Transient_Scope --
23322 ----------------------------------
23324 function Old_Requires_Transient_Scope (Id : Entity_Id) return Boolean is
23325 Typ : constant Entity_Id := Underlying_Type (Id);
23328 -- This is a private type which is not completed yet. This can only
23329 -- happen in a default expression (of a formal parameter or of a
23330 -- record component). Do not expand transient scope in this case.
23335 -- Do not expand transient scope for non-existent procedure return
23337 elsif Typ = Standard_Void_Type then
23340 -- Elementary types do not require a transient scope
23342 elsif Is_Elementary_Type (Typ) then
23345 -- Generally, indefinite subtypes require a transient scope, since the
23346 -- back end cannot generate temporaries, since this is not a valid type
23347 -- for declaring an object. It might be possible to relax this in the
23348 -- future, e.g. by declaring the maximum possible space for the type.
23350 elsif not Is_Definite_Subtype (Typ) then
23353 -- Functions returning tagged types may dispatch on result so their
23354 -- returned value is allocated on the secondary stack. Controlled
23355 -- type temporaries need finalization.
23357 elsif Is_Tagged_Type (Typ) or else Has_Controlled_Component (Typ) then
23362 elsif Is_Record_Type (Typ) then
23367 Comp := First_Entity (Typ);
23368 while Present (Comp) loop
23369 if Ekind (Comp) = E_Component then
23371 -- ???It's not clear we need a full recursive call to
23372 -- Old_Requires_Transient_Scope here. Note that the
23373 -- following can't happen.
23375 pragma Assert (Is_Definite_Subtype (Etype (Comp)));
23376 pragma Assert (not Has_Controlled_Component (Etype (Comp)));
23378 if Old_Requires_Transient_Scope (Etype (Comp)) then
23383 Next_Entity (Comp);
23389 -- String literal types never require transient scope
23391 elsif Ekind (Typ) = E_String_Literal_Subtype then
23394 -- Array type. Note that we already know that this is a constrained
23395 -- array, since unconstrained arrays will fail the indefinite test.
23397 elsif Is_Array_Type (Typ) then
23399 -- If component type requires a transient scope, the array does too
23401 if Old_Requires_Transient_Scope (Component_Type (Typ)) then
23404 -- Otherwise, we only need a transient scope if the size depends on
23405 -- the value of one or more discriminants.
23408 return Size_Depends_On_Discriminant (Typ);
23411 -- All other cases do not require a transient scope
23414 pragma Assert (Is_Protected_Type (Typ) or else Is_Task_Type (Typ));
23417 end Old_Requires_Transient_Scope;
23419 ---------------------------------
23420 -- Original_Aspect_Pragma_Name --
23421 ---------------------------------
23423 function Original_Aspect_Pragma_Name (N : Node_Id) return Name_Id is
23425 Item_Nam : Name_Id;
23428 pragma Assert (Nkind_In (N, N_Aspect_Specification, N_Pragma));
23432 -- The pragma was generated to emulate an aspect, use the original
23433 -- aspect specification.
23435 if Nkind (Item) = N_Pragma and then From_Aspect_Specification (Item) then
23436 Item := Corresponding_Aspect (Item);
23439 -- Retrieve the name of the aspect/pragma. As assertion pragmas from
23440 -- a generic instantiation might have been rewritten into pragma Check,
23441 -- we look at the original node for Item. Note also that Pre, Pre_Class,
23442 -- Post and Post_Class rewrite their pragma identifier to preserve the
23443 -- original name, so we look at the original node for the identifier.
23444 -- ??? this is kludgey
23446 if Nkind (Item) = N_Pragma then
23448 Chars (Original_Node (Pragma_Identifier (Original_Node (Item))));
23451 pragma Assert (Nkind (Item) = N_Aspect_Specification);
23452 Item_Nam := Chars (Identifier (Item));
23455 -- Deal with 'Class by converting the name to its _XXX form
23457 if Class_Present (Item) then
23458 if Item_Nam = Name_Invariant then
23459 Item_Nam := Name_uInvariant;
23461 elsif Item_Nam = Name_Post then
23462 Item_Nam := Name_uPost;
23464 elsif Item_Nam = Name_Pre then
23465 Item_Nam := Name_uPre;
23467 elsif Nam_In (Item_Nam, Name_Type_Invariant,
23468 Name_Type_Invariant_Class)
23470 Item_Nam := Name_uType_Invariant;
23472 -- Nothing to do for other cases (e.g. a Check that derived from
23473 -- Pre_Class and has the flag set). Also we do nothing if the name
23474 -- is already in special _xxx form.
23480 end Original_Aspect_Pragma_Name;
23482 --------------------------------------
23483 -- Original_Corresponding_Operation --
23484 --------------------------------------
23486 function Original_Corresponding_Operation (S : Entity_Id) return Entity_Id
23488 Typ : constant Entity_Id := Find_Dispatching_Type (S);
23491 -- If S is an inherited primitive S2 the original corresponding
23492 -- operation of S is the original corresponding operation of S2
23494 if Present (Alias (S))
23495 and then Find_Dispatching_Type (Alias (S)) /= Typ
23497 return Original_Corresponding_Operation (Alias (S));
23499 -- If S overrides an inherited subprogram S2 the original corresponding
23500 -- operation of S is the original corresponding operation of S2
23502 elsif Present (Overridden_Operation (S)) then
23503 return Original_Corresponding_Operation (Overridden_Operation (S));
23505 -- otherwise it is S itself
23510 end Original_Corresponding_Operation;
23512 -------------------
23513 -- Output_Entity --
23514 -------------------
23516 procedure Output_Entity (Id : Entity_Id) is
23520 Scop := Scope (Id);
23522 -- The entity may lack a scope when it is in the process of being
23523 -- analyzed. Use the current scope as an approximation.
23526 Scop := Current_Scope;
23529 Output_Name (Chars (Id), Scop);
23536 procedure Output_Name (Nam : Name_Id; Scop : Entity_Id := Current_Scope) is
23540 (Get_Qualified_Name
23547 ----------------------
23548 -- Policy_In_Effect --
23549 ----------------------
23551 function Policy_In_Effect (Policy : Name_Id) return Name_Id is
23552 function Policy_In_List (List : Node_Id) return Name_Id;
23553 -- Determine the mode of a policy in a N_Pragma list
23555 --------------------
23556 -- Policy_In_List --
23557 --------------------
23559 function Policy_In_List (List : Node_Id) return Name_Id is
23566 while Present (Prag) loop
23567 Arg1 := First (Pragma_Argument_Associations (Prag));
23568 Arg2 := Next (Arg1);
23570 Arg1 := Get_Pragma_Arg (Arg1);
23571 Arg2 := Get_Pragma_Arg (Arg2);
23573 -- The current Check_Policy pragma matches the requested policy or
23574 -- appears in the single argument form (Assertion, policy_id).
23576 if Nam_In (Chars (Arg1), Name_Assertion, Policy) then
23577 return Chars (Arg2);
23580 Prag := Next_Pragma (Prag);
23584 end Policy_In_List;
23590 -- Start of processing for Policy_In_Effect
23593 if not Is_Valid_Assertion_Kind (Policy) then
23594 raise Program_Error;
23597 -- Inspect all policy pragmas that appear within scopes (if any)
23599 Kind := Policy_In_List (Check_Policy_List);
23601 -- Inspect all configuration policy pragmas (if any)
23603 if Kind = No_Name then
23604 Kind := Policy_In_List (Check_Policy_List_Config);
23607 -- The context lacks policy pragmas, determine the mode based on whether
23608 -- assertions are enabled at the configuration level. This ensures that
23609 -- the policy is preserved when analyzing generics.
23611 if Kind = No_Name then
23612 if Assertions_Enabled_Config then
23613 Kind := Name_Check;
23615 Kind := Name_Ignore;
23619 -- In CodePeer mode and GNATprove mode, we need to consider all
23620 -- assertions, unless they are disabled. Force Name_Check on
23621 -- ignored assertions.
23623 if Nam_In (Kind, Name_Ignore, Name_Off)
23624 and then (CodePeer_Mode or GNATprove_Mode)
23626 Kind := Name_Check;
23630 end Policy_In_Effect;
23632 ----------------------------------
23633 -- Predicate_Tests_On_Arguments --
23634 ----------------------------------
23636 function Predicate_Tests_On_Arguments (Subp : Entity_Id) return Boolean is
23638 -- Always test predicates on indirect call
23640 if Ekind (Subp) = E_Subprogram_Type then
23643 -- Do not test predicates on call to generated default Finalize, since
23644 -- we are not interested in whether something we are finalizing (and
23645 -- typically destroying) satisfies its predicates.
23647 elsif Chars (Subp) = Name_Finalize
23648 and then not Comes_From_Source (Subp)
23652 -- Do not test predicates on any internally generated routines
23654 elsif Is_Internal_Name (Chars (Subp)) then
23657 -- Do not test predicates on call to Init_Proc, since if needed the
23658 -- predicate test will occur at some other point.
23660 elsif Is_Init_Proc (Subp) then
23663 -- Do not test predicates on call to predicate function, since this
23664 -- would cause infinite recursion.
23666 elsif Ekind (Subp) = E_Function
23667 and then (Is_Predicate_Function (Subp)
23669 Is_Predicate_Function_M (Subp))
23673 -- For now, no other exceptions
23678 end Predicate_Tests_On_Arguments;
23680 -----------------------
23681 -- Private_Component --
23682 -----------------------
23684 function Private_Component (Type_Id : Entity_Id) return Entity_Id is
23685 Ancestor : constant Entity_Id := Base_Type (Type_Id);
23687 function Trace_Components
23689 Check : Boolean) return Entity_Id;
23690 -- Recursive function that does the work, and checks against circular
23691 -- definition for each subcomponent type.
23693 ----------------------
23694 -- Trace_Components --
23695 ----------------------
23697 function Trace_Components
23699 Check : Boolean) return Entity_Id
23701 Btype : constant Entity_Id := Base_Type (T);
23702 Component : Entity_Id;
23704 Candidate : Entity_Id := Empty;
23707 if Check and then Btype = Ancestor then
23708 Error_Msg_N ("circular type definition", Type_Id);
23712 if Is_Private_Type (Btype) and then not Is_Generic_Type (Btype) then
23713 if Present (Full_View (Btype))
23714 and then Is_Record_Type (Full_View (Btype))
23715 and then not Is_Frozen (Btype)
23717 -- To indicate that the ancestor depends on a private type, the
23718 -- current Btype is sufficient. However, to check for circular
23719 -- definition we must recurse on the full view.
23721 Candidate := Trace_Components (Full_View (Btype), True);
23723 if Candidate = Any_Type then
23733 elsif Is_Array_Type (Btype) then
23734 return Trace_Components (Component_Type (Btype), True);
23736 elsif Is_Record_Type (Btype) then
23737 Component := First_Entity (Btype);
23738 while Present (Component)
23739 and then Comes_From_Source (Component)
23741 -- Skip anonymous types generated by constrained components
23743 if not Is_Type (Component) then
23744 P := Trace_Components (Etype (Component), True);
23746 if Present (P) then
23747 if P = Any_Type then
23755 Next_Entity (Component);
23763 end Trace_Components;
23765 -- Start of processing for Private_Component
23768 return Trace_Components (Type_Id, False);
23769 end Private_Component;
23771 ---------------------------
23772 -- Primitive_Names_Match --
23773 ---------------------------
23775 function Primitive_Names_Match (E1, E2 : Entity_Id) return Boolean is
23776 function Non_Internal_Name (E : Entity_Id) return Name_Id;
23777 -- Given an internal name, returns the corresponding non-internal name
23779 ------------------------
23780 -- Non_Internal_Name --
23781 ------------------------
23783 function Non_Internal_Name (E : Entity_Id) return Name_Id is
23785 Get_Name_String (Chars (E));
23786 Name_Len := Name_Len - 1;
23788 end Non_Internal_Name;
23790 -- Start of processing for Primitive_Names_Match
23793 pragma Assert (Present (E1) and then Present (E2));
23795 return Chars (E1) = Chars (E2)
23797 (not Is_Internal_Name (Chars (E1))
23798 and then Is_Internal_Name (Chars (E2))
23799 and then Non_Internal_Name (E2) = Chars (E1))
23801 (not Is_Internal_Name (Chars (E2))
23802 and then Is_Internal_Name (Chars (E1))
23803 and then Non_Internal_Name (E1) = Chars (E2))
23805 (Is_Predefined_Dispatching_Operation (E1)
23806 and then Is_Predefined_Dispatching_Operation (E2)
23807 and then Same_TSS (E1, E2))
23809 (Is_Init_Proc (E1) and then Is_Init_Proc (E2));
23810 end Primitive_Names_Match;
23812 -----------------------
23813 -- Process_End_Label --
23814 -----------------------
23816 procedure Process_End_Label
23825 Label_Ref : Boolean;
23826 -- Set True if reference to end label itself is required
23829 -- Gets set to the operator symbol or identifier that references the
23830 -- entity Ent. For the child unit case, this is the identifier from the
23831 -- designator. For other cases, this is simply Endl.
23833 procedure Generate_Parent_Ref (N : Node_Id; E : Entity_Id);
23834 -- N is an identifier node that appears as a parent unit reference in
23835 -- the case where Ent is a child unit. This procedure generates an
23836 -- appropriate cross-reference entry. E is the corresponding entity.
23838 -------------------------
23839 -- Generate_Parent_Ref --
23840 -------------------------
23842 procedure Generate_Parent_Ref (N : Node_Id; E : Entity_Id) is
23844 -- If names do not match, something weird, skip reference
23846 if Chars (E) = Chars (N) then
23848 -- Generate the reference. We do NOT consider this as a reference
23849 -- for unreferenced symbol purposes.
23851 Generate_Reference (E, N, 'r', Set_Ref => False, Force => True);
23853 if Style_Check then
23854 Style.Check_Identifier (N, E);
23857 end Generate_Parent_Ref;
23859 -- Start of processing for Process_End_Label
23862 -- If no node, ignore. This happens in some error situations, and
23863 -- also for some internally generated structures where no end label
23864 -- references are required in any case.
23870 -- Nothing to do if no End_Label, happens for internally generated
23871 -- constructs where we don't want an end label reference anyway. Also
23872 -- nothing to do if Endl is a string literal, which means there was
23873 -- some prior error (bad operator symbol)
23875 Endl := End_Label (N);
23877 if No (Endl) or else Nkind (Endl) = N_String_Literal then
23881 -- Reference node is not in extended main source unit
23883 if not In_Extended_Main_Source_Unit (N) then
23885 -- Generally we do not collect references except for the extended
23886 -- main source unit. The one exception is the 'e' entry for a
23887 -- package spec, where it is useful for a client to have the
23888 -- ending information to define scopes.
23894 Label_Ref := False;
23896 -- For this case, we can ignore any parent references, but we
23897 -- need the package name itself for the 'e' entry.
23899 if Nkind (Endl) = N_Designator then
23900 Endl := Identifier (Endl);
23904 -- Reference is in extended main source unit
23909 -- For designator, generate references for the parent entries
23911 if Nkind (Endl) = N_Designator then
23913 -- Generate references for the prefix if the END line comes from
23914 -- source (otherwise we do not need these references) We climb the
23915 -- scope stack to find the expected entities.
23917 if Comes_From_Source (Endl) then
23918 Nam := Name (Endl);
23919 Scop := Current_Scope;
23920 while Nkind (Nam) = N_Selected_Component loop
23921 Scop := Scope (Scop);
23922 exit when No (Scop);
23923 Generate_Parent_Ref (Selector_Name (Nam), Scop);
23924 Nam := Prefix (Nam);
23927 if Present (Scop) then
23928 Generate_Parent_Ref (Nam, Scope (Scop));
23932 Endl := Identifier (Endl);
23936 -- If the end label is not for the given entity, then either we have
23937 -- some previous error, or this is a generic instantiation for which
23938 -- we do not need to make a cross-reference in this case anyway. In
23939 -- either case we simply ignore the call.
23941 if Chars (Ent) /= Chars (Endl) then
23945 -- If label was really there, then generate a normal reference and then
23946 -- adjust the location in the end label to point past the name (which
23947 -- should almost always be the semicolon).
23949 Loc := Sloc (Endl);
23951 if Comes_From_Source (Endl) then
23953 -- If a label reference is required, then do the style check and
23954 -- generate an l-type cross-reference entry for the label
23957 if Style_Check then
23958 Style.Check_Identifier (Endl, Ent);
23961 Generate_Reference (Ent, Endl, 'l', Set_Ref => False);
23964 -- Set the location to point past the label (normally this will
23965 -- mean the semicolon immediately following the label). This is
23966 -- done for the sake of the 'e' or 't' entry generated below.
23968 Get_Decoded_Name_String (Chars (Endl));
23969 Set_Sloc (Endl, Sloc (Endl) + Source_Ptr (Name_Len));
23972 -- In SPARK mode, no missing label is allowed for packages and
23973 -- subprogram bodies. Detect those cases by testing whether
23974 -- Process_End_Label was called for a body (Typ = 't') or a package.
23976 if Restriction_Check_Required (SPARK_05)
23977 and then (Typ = 't' or else Ekind (Ent) = E_Package)
23979 Error_Msg_Node_1 := Endl;
23980 Check_SPARK_05_Restriction
23981 ("`END &` required", Endl, Force => True);
23985 -- Now generate the e/t reference
23987 Generate_Reference (Ent, Endl, Typ, Set_Ref => False, Force => True);
23989 -- Restore Sloc, in case modified above, since we have an identifier
23990 -- and the normal Sloc should be left set in the tree.
23992 Set_Sloc (Endl, Loc);
23993 end Process_End_Label;
23995 --------------------------------
23996 -- Propagate_Concurrent_Flags --
23997 --------------------------------
23999 procedure Propagate_Concurrent_Flags
24001 Comp_Typ : Entity_Id)
24004 if Has_Task (Comp_Typ) then
24005 Set_Has_Task (Typ);
24008 if Has_Protected (Comp_Typ) then
24009 Set_Has_Protected (Typ);
24012 if Has_Timing_Event (Comp_Typ) then
24013 Set_Has_Timing_Event (Typ);
24015 end Propagate_Concurrent_Flags;
24017 ------------------------------
24018 -- Propagate_DIC_Attributes --
24019 ------------------------------
24021 procedure Propagate_DIC_Attributes
24023 From_Typ : Entity_Id)
24025 DIC_Proc : Entity_Id;
24028 if Present (Typ) and then Present (From_Typ) then
24029 pragma Assert (Is_Type (Typ) and then Is_Type (From_Typ));
24031 -- Nothing to do if both the source and the destination denote the
24034 if From_Typ = Typ then
24037 -- Nothing to do when the destination denotes an incomplete type
24038 -- because the DIC is associated with the current instance of a
24039 -- private type, thus it can never apply to an incomplete type.
24041 elsif Is_Incomplete_Type (Typ) then
24045 DIC_Proc := DIC_Procedure (From_Typ);
24047 -- The setting of the attributes is intentionally conservative. This
24048 -- prevents accidental clobbering of enabled attributes.
24050 if Has_Inherited_DIC (From_Typ)
24051 and then not Has_Inherited_DIC (Typ)
24053 Set_Has_Inherited_DIC (Typ);
24056 if Has_Own_DIC (From_Typ) and then not Has_Own_DIC (Typ) then
24057 Set_Has_Own_DIC (Typ);
24060 if Present (DIC_Proc) and then No (DIC_Procedure (Typ)) then
24061 Set_DIC_Procedure (Typ, DIC_Proc);
24064 end Propagate_DIC_Attributes;
24066 ------------------------------------
24067 -- Propagate_Invariant_Attributes --
24068 ------------------------------------
24070 procedure Propagate_Invariant_Attributes
24072 From_Typ : Entity_Id)
24074 Full_IP : Entity_Id;
24075 Part_IP : Entity_Id;
24078 if Present (Typ) and then Present (From_Typ) then
24079 pragma Assert (Is_Type (Typ) and then Is_Type (From_Typ));
24081 -- Nothing to do if both the source and the destination denote the
24084 if From_Typ = Typ then
24088 Full_IP := Invariant_Procedure (From_Typ);
24089 Part_IP := Partial_Invariant_Procedure (From_Typ);
24091 -- The setting of the attributes is intentionally conservative. This
24092 -- prevents accidental clobbering of enabled attributes.
24094 if Has_Inheritable_Invariants (From_Typ)
24095 and then not Has_Inheritable_Invariants (Typ)
24097 Set_Has_Inheritable_Invariants (Typ);
24100 if Has_Inherited_Invariants (From_Typ)
24101 and then not Has_Inherited_Invariants (Typ)
24103 Set_Has_Inherited_Invariants (Typ);
24106 if Has_Own_Invariants (From_Typ)
24107 and then not Has_Own_Invariants (Typ)
24109 Set_Has_Own_Invariants (Typ);
24112 if Present (Full_IP) and then No (Invariant_Procedure (Typ)) then
24113 Set_Invariant_Procedure (Typ, Full_IP);
24116 if Present (Part_IP) and then No (Partial_Invariant_Procedure (Typ))
24118 Set_Partial_Invariant_Procedure (Typ, Part_IP);
24121 end Propagate_Invariant_Attributes;
24123 ---------------------------------------
24124 -- Record_Possible_Part_Of_Reference --
24125 ---------------------------------------
24127 procedure Record_Possible_Part_Of_Reference
24128 (Var_Id : Entity_Id;
24131 Encap : constant Entity_Id := Encapsulating_State (Var_Id);
24135 -- The variable is a constituent of a single protected/task type. Such
24136 -- a variable acts as a component of the type and must appear within a
24137 -- specific region (SPARK RM 9(3)). Instead of recording the reference,
24138 -- verify its legality now.
24140 if Present (Encap) and then Is_Single_Concurrent_Object (Encap) then
24141 Check_Part_Of_Reference (Var_Id, Ref);
24143 -- The variable is subject to pragma Part_Of and may eventually become a
24144 -- constituent of a single protected/task type. Record the reference to
24145 -- verify its placement when the contract of the variable is analyzed.
24147 elsif Present (Get_Pragma (Var_Id, Pragma_Part_Of)) then
24148 Refs := Part_Of_References (Var_Id);
24151 Refs := New_Elmt_List;
24152 Set_Part_Of_References (Var_Id, Refs);
24155 Append_Elmt (Ref, Refs);
24157 end Record_Possible_Part_Of_Reference;
24163 function Referenced (Id : Entity_Id; Expr : Node_Id) return Boolean is
24164 Seen : Boolean := False;
24166 function Is_Reference (N : Node_Id) return Traverse_Result;
24167 -- Determine whether node N denotes a reference to Id. If this is the
24168 -- case, set global flag Seen to True and stop the traversal.
24174 function Is_Reference (N : Node_Id) return Traverse_Result is
24176 if Is_Entity_Name (N)
24177 and then Present (Entity (N))
24178 and then Entity (N) = Id
24187 procedure Inspect_Expression is new Traverse_Proc (Is_Reference);
24189 -- Start of processing for Referenced
24192 Inspect_Expression (Expr);
24196 ------------------------------------
24197 -- References_Generic_Formal_Type --
24198 ------------------------------------
24200 function References_Generic_Formal_Type (N : Node_Id) return Boolean is
24202 function Process (N : Node_Id) return Traverse_Result;
24203 -- Process one node in search for generic formal type
24209 function Process (N : Node_Id) return Traverse_Result is
24211 if Nkind (N) in N_Has_Entity then
24213 E : constant Entity_Id := Entity (N);
24215 if Present (E) then
24216 if Is_Generic_Type (E) then
24218 elsif Present (Etype (E))
24219 and then Is_Generic_Type (Etype (E))
24230 function Traverse is new Traverse_Func (Process);
24231 -- Traverse tree to look for generic type
24234 if Inside_A_Generic then
24235 return Traverse (N) = Abandon;
24239 end References_Generic_Formal_Type;
24241 -------------------------------
24242 -- Remove_Entity_And_Homonym --
24243 -------------------------------
24245 procedure Remove_Entity_And_Homonym (Id : Entity_Id) is
24247 Remove_Entity (Id);
24248 Remove_Homonym (Id);
24249 end Remove_Entity_And_Homonym;
24251 --------------------
24252 -- Remove_Homonym --
24253 --------------------
24255 procedure Remove_Homonym (Id : Entity_Id) is
24257 Prev : Entity_Id := Empty;
24260 if Id = Current_Entity (Id) then
24261 if Present (Homonym (Id)) then
24262 Set_Current_Entity (Homonym (Id));
24264 Set_Name_Entity_Id (Chars (Id), Empty);
24268 Hom := Current_Entity (Id);
24269 while Present (Hom) and then Hom /= Id loop
24271 Hom := Homonym (Hom);
24274 -- If Id is not on the homonym chain, nothing to do
24276 if Present (Hom) then
24277 Set_Homonym (Prev, Homonym (Id));
24280 end Remove_Homonym;
24282 ------------------------------
24283 -- Remove_Overloaded_Entity --
24284 ------------------------------
24286 procedure Remove_Overloaded_Entity (Id : Entity_Id) is
24287 procedure Remove_Primitive_Of (Typ : Entity_Id);
24288 -- Remove primitive subprogram Id from the list of primitives that
24289 -- belong to type Typ.
24291 -------------------------
24292 -- Remove_Primitive_Of --
24293 -------------------------
24295 procedure Remove_Primitive_Of (Typ : Entity_Id) is
24299 if Is_Tagged_Type (Typ) then
24300 Prims := Direct_Primitive_Operations (Typ);
24302 if Present (Prims) then
24303 Remove (Prims, Id);
24306 end Remove_Primitive_Of;
24310 Formal : Entity_Id;
24312 -- Start of processing for Remove_Overloaded_Entity
24315 Remove_Entity_And_Homonym (Id);
24317 -- The entity denotes a primitive subprogram. Remove it from the list of
24318 -- primitives of the associated controlling type.
24320 if Ekind_In (Id, E_Function, E_Procedure) and then Is_Primitive (Id) then
24321 Formal := First_Formal (Id);
24322 while Present (Formal) loop
24323 if Is_Controlling_Formal (Formal) then
24324 Remove_Primitive_Of (Etype (Formal));
24328 Next_Formal (Formal);
24331 if Ekind (Id) = E_Function and then Has_Controlling_Result (Id) then
24332 Remove_Primitive_Of (Etype (Id));
24335 end Remove_Overloaded_Entity;
24337 ---------------------
24338 -- Rep_To_Pos_Flag --
24339 ---------------------
24341 function Rep_To_Pos_Flag (E : Entity_Id; Loc : Source_Ptr) return Node_Id is
24343 return New_Occurrence_Of
24344 (Boolean_Literals (not Range_Checks_Suppressed (E)), Loc);
24345 end Rep_To_Pos_Flag;
24347 --------------------
24348 -- Require_Entity --
24349 --------------------
24351 procedure Require_Entity (N : Node_Id) is
24353 if Is_Entity_Name (N) and then No (Entity (N)) then
24354 if Total_Errors_Detected /= 0 then
24355 Set_Entity (N, Any_Id);
24357 raise Program_Error;
24360 end Require_Entity;
24362 ------------------------------
24363 -- Requires_Transient_Scope --
24364 ------------------------------
24366 -- A transient scope is required when variable-sized temporaries are
24367 -- allocated on the secondary stack, or when finalization actions must be
24368 -- generated before the next instruction.
24370 function Requires_Transient_Scope (Id : Entity_Id) return Boolean is
24371 Old_Result : constant Boolean := Old_Requires_Transient_Scope (Id);
24374 if Debug_Flag_QQ then
24379 New_Result : constant Boolean := New_Requires_Transient_Scope (Id);
24382 -- Assert that we're not putting things on the secondary stack if we
24383 -- didn't before; we are trying to AVOID secondary stack when
24386 if not Old_Result then
24387 pragma Assert (not New_Result);
24391 if New_Result /= Old_Result then
24392 Results_Differ (Id, Old_Result, New_Result);
24397 end Requires_Transient_Scope;
24399 --------------------
24400 -- Results_Differ --
24401 --------------------
24403 procedure Results_Differ
24409 if False then -- False to disable; True for debugging
24410 Treepr.Print_Tree_Node (Id);
24412 if Old_Val = New_Val then
24413 raise Program_Error;
24416 end Results_Differ;
24418 --------------------------
24419 -- Reset_Analyzed_Flags --
24420 --------------------------
24422 procedure Reset_Analyzed_Flags (N : Node_Id) is
24423 function Clear_Analyzed (N : Node_Id) return Traverse_Result;
24424 -- Function used to reset Analyzed flags in tree. Note that we do
24425 -- not reset Analyzed flags in entities, since there is no need to
24426 -- reanalyze entities, and indeed, it is wrong to do so, since it
24427 -- can result in generating auxiliary stuff more than once.
24429 --------------------
24430 -- Clear_Analyzed --
24431 --------------------
24433 function Clear_Analyzed (N : Node_Id) return Traverse_Result is
24435 if Nkind (N) not in N_Entity then
24436 Set_Analyzed (N, False);
24440 end Clear_Analyzed;
24442 procedure Reset_Analyzed is new Traverse_Proc (Clear_Analyzed);
24444 -- Start of processing for Reset_Analyzed_Flags
24447 Reset_Analyzed (N);
24448 end Reset_Analyzed_Flags;
24450 ------------------------
24451 -- Restore_SPARK_Mode --
24452 ------------------------
24454 procedure Restore_SPARK_Mode
24455 (Mode : SPARK_Mode_Type;
24459 SPARK_Mode := Mode;
24460 SPARK_Mode_Pragma := Prag;
24461 end Restore_SPARK_Mode;
24463 --------------------------------
24464 -- Returns_Unconstrained_Type --
24465 --------------------------------
24467 function Returns_Unconstrained_Type (Subp : Entity_Id) return Boolean is
24469 return Ekind (Subp) = E_Function
24470 and then not Is_Scalar_Type (Etype (Subp))
24471 and then not Is_Access_Type (Etype (Subp))
24472 and then not Is_Constrained (Etype (Subp));
24473 end Returns_Unconstrained_Type;
24475 ----------------------------
24476 -- Root_Type_Of_Full_View --
24477 ----------------------------
24479 function Root_Type_Of_Full_View (T : Entity_Id) return Entity_Id is
24480 Rtyp : constant Entity_Id := Root_Type (T);
24483 -- The root type of the full view may itself be a private type. Keep
24484 -- looking for the ultimate derivation parent.
24486 if Is_Private_Type (Rtyp) and then Present (Full_View (Rtyp)) then
24487 return Root_Type_Of_Full_View (Full_View (Rtyp));
24491 end Root_Type_Of_Full_View;
24493 ---------------------------
24494 -- Safe_To_Capture_Value --
24495 ---------------------------
24497 function Safe_To_Capture_Value
24500 Cond : Boolean := False) return Boolean
24503 -- The only entities for which we track constant values are variables
24504 -- which are not renamings, constants, out parameters, and in out
24505 -- parameters, so check if we have this case.
24507 -- Note: it may seem odd to track constant values for constants, but in
24508 -- fact this routine is used for other purposes than simply capturing
24509 -- the value. In particular, the setting of Known[_Non]_Null.
24511 if (Ekind (Ent) = E_Variable and then No (Renamed_Object (Ent)))
24513 Ekind_In (Ent, E_Constant, E_Out_Parameter, E_In_Out_Parameter)
24517 -- For conditionals, we also allow loop parameters and all formals,
24518 -- including in parameters.
24520 elsif Cond and then Ekind_In (Ent, E_Loop_Parameter, E_In_Parameter) then
24523 -- For all other cases, not just unsafe, but impossible to capture
24524 -- Current_Value, since the above are the only entities which have
24525 -- Current_Value fields.
24531 -- Skip if volatile or aliased, since funny things might be going on in
24532 -- these cases which we cannot necessarily track. Also skip any variable
24533 -- for which an address clause is given, or whose address is taken. Also
24534 -- never capture value of library level variables (an attempt to do so
24535 -- can occur in the case of package elaboration code).
24537 if Treat_As_Volatile (Ent)
24538 or else Is_Aliased (Ent)
24539 or else Present (Address_Clause (Ent))
24540 or else Address_Taken (Ent)
24541 or else (Is_Library_Level_Entity (Ent)
24542 and then Ekind (Ent) = E_Variable)
24547 -- OK, all above conditions are met. We also require that the scope of
24548 -- the reference be the same as the scope of the entity, not counting
24549 -- packages and blocks and loops.
24552 E_Scope : constant Entity_Id := Scope (Ent);
24553 R_Scope : Entity_Id;
24556 R_Scope := Current_Scope;
24557 while R_Scope /= Standard_Standard loop
24558 exit when R_Scope = E_Scope;
24560 if not Ekind_In (R_Scope, E_Package, E_Block, E_Loop) then
24563 R_Scope := Scope (R_Scope);
24568 -- We also require that the reference does not appear in a context
24569 -- where it is not sure to be executed (i.e. a conditional context
24570 -- or an exception handler). We skip this if Cond is True, since the
24571 -- capturing of values from conditional tests handles this ok.
24584 -- Seems dubious that case expressions are not handled here ???
24587 while Present (P) loop
24588 if Nkind (P) = N_If_Statement
24589 or else Nkind (P) = N_Case_Statement
24590 or else (Nkind (P) in N_Short_Circuit
24591 and then Desc = Right_Opnd (P))
24592 or else (Nkind (P) = N_If_Expression
24593 and then Desc /= First (Expressions (P)))
24594 or else Nkind (P) = N_Exception_Handler
24595 or else Nkind (P) = N_Selective_Accept
24596 or else Nkind (P) = N_Conditional_Entry_Call
24597 or else Nkind (P) = N_Timed_Entry_Call
24598 or else Nkind (P) = N_Asynchronous_Select
24606 -- A special Ada 2012 case: the original node may be part
24607 -- of the else_actions of a conditional expression, in which
24608 -- case it might not have been expanded yet, and appears in
24609 -- a non-syntactic list of actions. In that case it is clearly
24610 -- not safe to save a value.
24613 and then Is_List_Member (Desc)
24614 and then No (Parent (List_Containing (Desc)))
24622 -- OK, looks safe to set value
24625 end Safe_To_Capture_Value;
24631 function Same_Name (N1, N2 : Node_Id) return Boolean is
24632 K1 : constant Node_Kind := Nkind (N1);
24633 K2 : constant Node_Kind := Nkind (N2);
24636 if (K1 = N_Identifier or else K1 = N_Defining_Identifier)
24637 and then (K2 = N_Identifier or else K2 = N_Defining_Identifier)
24639 return Chars (N1) = Chars (N2);
24641 elsif (K1 = N_Selected_Component or else K1 = N_Expanded_Name)
24642 and then (K2 = N_Selected_Component or else K2 = N_Expanded_Name)
24644 return Same_Name (Selector_Name (N1), Selector_Name (N2))
24645 and then Same_Name (Prefix (N1), Prefix (N2));
24656 function Same_Object (Node1, Node2 : Node_Id) return Boolean is
24657 N1 : constant Node_Id := Original_Node (Node1);
24658 N2 : constant Node_Id := Original_Node (Node2);
24659 -- We do the tests on original nodes, since we are most interested
24660 -- in the original source, not any expansion that got in the way.
24662 K1 : constant Node_Kind := Nkind (N1);
24663 K2 : constant Node_Kind := Nkind (N2);
24666 -- First case, both are entities with same entity
24668 if K1 in N_Has_Entity and then K2 in N_Has_Entity then
24670 EN1 : constant Entity_Id := Entity (N1);
24671 EN2 : constant Entity_Id := Entity (N2);
24673 if Present (EN1) and then Present (EN2)
24674 and then (Ekind_In (EN1, E_Variable, E_Constant)
24675 or else Is_Formal (EN1))
24683 -- Second case, selected component with same selector, same record
24685 if K1 = N_Selected_Component
24686 and then K2 = N_Selected_Component
24687 and then Chars (Selector_Name (N1)) = Chars (Selector_Name (N2))
24689 return Same_Object (Prefix (N1), Prefix (N2));
24691 -- Third case, indexed component with same subscripts, same array
24693 elsif K1 = N_Indexed_Component
24694 and then K2 = N_Indexed_Component
24695 and then Same_Object (Prefix (N1), Prefix (N2))
24700 E1 := First (Expressions (N1));
24701 E2 := First (Expressions (N2));
24702 while Present (E1) loop
24703 if not Same_Value (E1, E2) then
24714 -- Fourth case, slice of same array with same bounds
24717 and then K2 = N_Slice
24718 and then Nkind (Discrete_Range (N1)) = N_Range
24719 and then Nkind (Discrete_Range (N2)) = N_Range
24720 and then Same_Value (Low_Bound (Discrete_Range (N1)),
24721 Low_Bound (Discrete_Range (N2)))
24722 and then Same_Value (High_Bound (Discrete_Range (N1)),
24723 High_Bound (Discrete_Range (N2)))
24725 return Same_Name (Prefix (N1), Prefix (N2));
24727 -- All other cases, not clearly the same object
24738 function Same_Type (T1, T2 : Entity_Id) return Boolean is
24743 elsif not Is_Constrained (T1)
24744 and then not Is_Constrained (T2)
24745 and then Base_Type (T1) = Base_Type (T2)
24749 -- For now don't bother with case of identical constraints, to be
24750 -- fiddled with later on perhaps (this is only used for optimization
24751 -- purposes, so it is not critical to do a best possible job)
24762 function Same_Value (Node1, Node2 : Node_Id) return Boolean is
24764 if Compile_Time_Known_Value (Node1)
24765 and then Compile_Time_Known_Value (Node2)
24767 -- Handle properly compile-time expressions that are not
24770 if Is_String_Type (Etype (Node1)) then
24771 return Expr_Value_S (Node1) = Expr_Value_S (Node2);
24774 return Expr_Value (Node1) = Expr_Value (Node2);
24777 elsif Same_Object (Node1, Node2) then
24784 --------------------
24785 -- Set_SPARK_Mode --
24786 --------------------
24788 procedure Set_SPARK_Mode (Context : Entity_Id) is
24790 -- Do not consider illegal or partially decorated constructs
24792 if Ekind (Context) = E_Void or else Error_Posted (Context) then
24795 elsif Present (SPARK_Pragma (Context)) then
24797 (Mode => Get_SPARK_Mode_From_Annotation (SPARK_Pragma (Context)),
24798 Prag => SPARK_Pragma (Context));
24800 end Set_SPARK_Mode;
24802 -------------------------
24803 -- Scalar_Part_Present --
24804 -------------------------
24806 function Scalar_Part_Present (Typ : Entity_Id) return Boolean is
24807 Val_Typ : constant Entity_Id := Validated_View (Typ);
24811 if Is_Scalar_Type (Val_Typ) then
24814 elsif Is_Array_Type (Val_Typ) then
24815 return Scalar_Part_Present (Component_Type (Val_Typ));
24817 elsif Is_Record_Type (Val_Typ) then
24818 Field := First_Component_Or_Discriminant (Val_Typ);
24819 while Present (Field) loop
24820 if Scalar_Part_Present (Etype (Field)) then
24824 Next_Component_Or_Discriminant (Field);
24829 end Scalar_Part_Present;
24831 ------------------------
24832 -- Scope_Is_Transient --
24833 ------------------------
24835 function Scope_Is_Transient return Boolean is
24837 return Scope_Stack.Table (Scope_Stack.Last).Is_Transient;
24838 end Scope_Is_Transient;
24844 function Scope_Within
24845 (Inner : Entity_Id;
24846 Outer : Entity_Id) return Boolean
24852 while Present (Curr) and then Curr /= Standard_Standard loop
24853 Curr := Scope (Curr);
24855 if Curr = Outer then
24858 -- A selective accept body appears within a task type, but the
24859 -- enclosing subprogram is the procedure of the task body.
24861 elsif Ekind (Implementation_Base_Type (Curr)) = E_Task_Type
24863 Outer = Task_Body_Procedure (Implementation_Base_Type (Curr))
24867 -- Ditto for the body of a protected operation
24869 elsif Is_Subprogram (Curr)
24870 and then Outer = Protected_Body_Subprogram (Curr)
24874 -- Outside of its scope, a synchronized type may just be private
24876 elsif Is_Private_Type (Curr)
24877 and then Present (Full_View (Curr))
24878 and then Is_Concurrent_Type (Full_View (Curr))
24880 return Scope_Within (Full_View (Curr), Outer);
24887 --------------------------
24888 -- Scope_Within_Or_Same --
24889 --------------------------
24891 function Scope_Within_Or_Same
24892 (Inner : Entity_Id;
24893 Outer : Entity_Id) return Boolean
24895 Curr : Entity_Id := Inner;
24898 -- Similar to the above, but check for scope identity first
24900 while Present (Curr) and then Curr /= Standard_Standard loop
24901 if Curr = Outer then
24904 elsif Ekind (Implementation_Base_Type (Curr)) = E_Task_Type
24906 Outer = Task_Body_Procedure (Implementation_Base_Type (Curr))
24910 elsif Is_Subprogram (Curr)
24911 and then Outer = Protected_Body_Subprogram (Curr)
24915 elsif Is_Private_Type (Curr)
24916 and then Present (Full_View (Curr))
24918 if Full_View (Curr) = Outer then
24921 return Scope_Within (Full_View (Curr), Outer);
24925 Curr := Scope (Curr);
24929 end Scope_Within_Or_Same;
24931 --------------------
24932 -- Set_Convention --
24933 --------------------
24935 procedure Set_Convention (E : Entity_Id; Val : Snames.Convention_Id) is
24937 Basic_Set_Convention (E, Val);
24940 and then Is_Access_Subprogram_Type (Base_Type (E))
24941 and then Has_Foreign_Convention (E)
24943 Set_Can_Use_Internal_Rep (E, False);
24946 -- If E is an object, including a component, and the type of E is an
24947 -- anonymous access type with no convention set, then also set the
24948 -- convention of the anonymous access type. We do not do this for
24949 -- anonymous protected types, since protected types always have the
24950 -- default convention.
24952 if Present (Etype (E))
24953 and then (Is_Object (E)
24955 -- Allow E_Void (happens for pragma Convention appearing
24956 -- in the middle of a record applying to a component)
24958 or else Ekind (E) = E_Void)
24961 Typ : constant Entity_Id := Etype (E);
24964 if Ekind_In (Typ, E_Anonymous_Access_Type,
24965 E_Anonymous_Access_Subprogram_Type)
24966 and then not Has_Convention_Pragma (Typ)
24968 Basic_Set_Convention (Typ, Val);
24969 Set_Has_Convention_Pragma (Typ);
24971 -- And for the access subprogram type, deal similarly with the
24972 -- designated E_Subprogram_Type, which is always internal.
24974 if Ekind (Typ) = E_Anonymous_Access_Subprogram_Type then
24976 Dtype : constant Entity_Id := Designated_Type (Typ);
24978 if Ekind (Dtype) = E_Subprogram_Type
24979 and then not Has_Convention_Pragma (Dtype)
24981 Basic_Set_Convention (Dtype, Val);
24982 Set_Has_Convention_Pragma (Dtype);
24989 end Set_Convention;
24991 ------------------------
24992 -- Set_Current_Entity --
24993 ------------------------
24995 -- The given entity is to be set as the currently visible definition of its
24996 -- associated name (i.e. the Node_Id associated with its name). All we have
24997 -- to do is to get the name from the identifier, and then set the
24998 -- associated Node_Id to point to the given entity.
25000 procedure Set_Current_Entity (E : Entity_Id) is
25002 Set_Name_Entity_Id (Chars (E), E);
25003 end Set_Current_Entity;
25005 ---------------------------
25006 -- Set_Debug_Info_Needed --
25007 ---------------------------
25009 procedure Set_Debug_Info_Needed (T : Entity_Id) is
25011 procedure Set_Debug_Info_Needed_If_Not_Set (E : Entity_Id);
25012 pragma Inline (Set_Debug_Info_Needed_If_Not_Set);
25013 -- Used to set debug info in a related node if not set already
25015 --------------------------------------
25016 -- Set_Debug_Info_Needed_If_Not_Set --
25017 --------------------------------------
25019 procedure Set_Debug_Info_Needed_If_Not_Set (E : Entity_Id) is
25021 if Present (E) and then not Needs_Debug_Info (E) then
25022 Set_Debug_Info_Needed (E);
25024 -- For a private type, indicate that the full view also needs
25025 -- debug information.
25028 and then Is_Private_Type (E)
25029 and then Present (Full_View (E))
25031 Set_Debug_Info_Needed (Full_View (E));
25034 end Set_Debug_Info_Needed_If_Not_Set;
25036 -- Start of processing for Set_Debug_Info_Needed
25039 -- Nothing to do if there is no available entity
25044 -- Nothing to do for an entity with suppressed debug information
25046 elsif Debug_Info_Off (T) then
25049 -- Nothing to do for an ignored Ghost entity because the entity will be
25050 -- eliminated from the tree.
25052 elsif Is_Ignored_Ghost_Entity (T) then
25055 -- Nothing to do if entity comes from a predefined file. Library files
25056 -- are compiled without debug information, but inlined bodies of these
25057 -- routines may appear in user code, and debug information on them ends
25058 -- up complicating debugging the user code.
25060 elsif In_Inlined_Body and then In_Predefined_Unit (T) then
25061 Set_Needs_Debug_Info (T, False);
25064 -- Set flag in entity itself. Note that we will go through the following
25065 -- circuitry even if the flag is already set on T. That's intentional,
25066 -- it makes sure that the flag will be set in subsidiary entities.
25068 Set_Needs_Debug_Info (T);
25070 -- Set flag on subsidiary entities if not set already
25072 if Is_Object (T) then
25073 Set_Debug_Info_Needed_If_Not_Set (Etype (T));
25075 elsif Is_Type (T) then
25076 Set_Debug_Info_Needed_If_Not_Set (Etype (T));
25078 if Is_Record_Type (T) then
25080 Ent : Entity_Id := First_Entity (T);
25082 while Present (Ent) loop
25083 Set_Debug_Info_Needed_If_Not_Set (Ent);
25088 -- For a class wide subtype, we also need debug information
25089 -- for the equivalent type.
25091 if Ekind (T) = E_Class_Wide_Subtype then
25092 Set_Debug_Info_Needed_If_Not_Set (Equivalent_Type (T));
25095 elsif Is_Array_Type (T) then
25096 Set_Debug_Info_Needed_If_Not_Set (Component_Type (T));
25099 Indx : Node_Id := First_Index (T);
25101 while Present (Indx) loop
25102 Set_Debug_Info_Needed_If_Not_Set (Etype (Indx));
25103 Indx := Next_Index (Indx);
25107 -- For a packed array type, we also need debug information for
25108 -- the type used to represent the packed array. Conversely, we
25109 -- also need it for the former if we need it for the latter.
25111 if Is_Packed (T) then
25112 Set_Debug_Info_Needed_If_Not_Set (Packed_Array_Impl_Type (T));
25115 if Is_Packed_Array_Impl_Type (T) then
25116 Set_Debug_Info_Needed_If_Not_Set (Original_Array_Type (T));
25119 elsif Is_Access_Type (T) then
25120 Set_Debug_Info_Needed_If_Not_Set (Directly_Designated_Type (T));
25122 elsif Is_Private_Type (T) then
25124 FV : constant Entity_Id := Full_View (T);
25127 Set_Debug_Info_Needed_If_Not_Set (FV);
25129 -- If the full view is itself a derived private type, we need
25130 -- debug information on its underlying type.
25133 and then Is_Private_Type (FV)
25134 and then Present (Underlying_Full_View (FV))
25136 Set_Needs_Debug_Info (Underlying_Full_View (FV));
25140 elsif Is_Protected_Type (T) then
25141 Set_Debug_Info_Needed_If_Not_Set (Corresponding_Record_Type (T));
25143 elsif Is_Scalar_Type (T) then
25145 -- If the subrange bounds are materialized by dedicated constant
25146 -- objects, also include them in the debug info to make sure the
25147 -- debugger can properly use them.
25149 if Present (Scalar_Range (T))
25150 and then Nkind (Scalar_Range (T)) = N_Range
25153 Low_Bnd : constant Node_Id := Type_Low_Bound (T);
25154 High_Bnd : constant Node_Id := Type_High_Bound (T);
25157 if Is_Entity_Name (Low_Bnd) then
25158 Set_Debug_Info_Needed_If_Not_Set (Entity (Low_Bnd));
25161 if Is_Entity_Name (High_Bnd) then
25162 Set_Debug_Info_Needed_If_Not_Set (Entity (High_Bnd));
25168 end Set_Debug_Info_Needed;
25170 ----------------------------
25171 -- Set_Entity_With_Checks --
25172 ----------------------------
25174 procedure Set_Entity_With_Checks (N : Node_Id; Val : Entity_Id) is
25175 Val_Actual : Entity_Id;
25177 Post_Node : Node_Id;
25180 -- Unconditionally set the entity
25182 Set_Entity (N, Val);
25184 -- The node to post on is the selector in the case of an expanded name,
25185 -- and otherwise the node itself.
25187 if Nkind (N) = N_Expanded_Name then
25188 Post_Node := Selector_Name (N);
25193 -- Check for violation of No_Fixed_IO
25195 if Restriction_Check_Required (No_Fixed_IO)
25197 ((RTU_Loaded (Ada_Text_IO)
25198 and then (Is_RTE (Val, RE_Decimal_IO)
25200 Is_RTE (Val, RE_Fixed_IO)))
25203 (RTU_Loaded (Ada_Wide_Text_IO)
25204 and then (Is_RTE (Val, RO_WT_Decimal_IO)
25206 Is_RTE (Val, RO_WT_Fixed_IO)))
25209 (RTU_Loaded (Ada_Wide_Wide_Text_IO)
25210 and then (Is_RTE (Val, RO_WW_Decimal_IO)
25212 Is_RTE (Val, RO_WW_Fixed_IO))))
25214 -- A special extra check, don't complain about a reference from within
25215 -- the Ada.Interrupts package itself!
25217 and then not In_Same_Extended_Unit (N, Val)
25219 Check_Restriction (No_Fixed_IO, Post_Node);
25222 -- Remaining checks are only done on source nodes. Note that we test
25223 -- for violation of No_Fixed_IO even on non-source nodes, because the
25224 -- cases for checking violations of this restriction are instantiations
25225 -- where the reference in the instance has Comes_From_Source False.
25227 if not Comes_From_Source (N) then
25231 -- Check for violation of No_Abort_Statements, which is triggered by
25232 -- call to Ada.Task_Identification.Abort_Task.
25234 if Restriction_Check_Required (No_Abort_Statements)
25235 and then (Is_RTE (Val, RE_Abort_Task))
25237 -- A special extra check, don't complain about a reference from within
25238 -- the Ada.Task_Identification package itself!
25240 and then not In_Same_Extended_Unit (N, Val)
25242 Check_Restriction (No_Abort_Statements, Post_Node);
25245 if Val = Standard_Long_Long_Integer then
25246 Check_Restriction (No_Long_Long_Integers, Post_Node);
25249 -- Check for violation of No_Dynamic_Attachment
25251 if Restriction_Check_Required (No_Dynamic_Attachment)
25252 and then RTU_Loaded (Ada_Interrupts)
25253 and then (Is_RTE (Val, RE_Is_Reserved) or else
25254 Is_RTE (Val, RE_Is_Attached) or else
25255 Is_RTE (Val, RE_Current_Handler) or else
25256 Is_RTE (Val, RE_Attach_Handler) or else
25257 Is_RTE (Val, RE_Exchange_Handler) or else
25258 Is_RTE (Val, RE_Detach_Handler) or else
25259 Is_RTE (Val, RE_Reference))
25261 -- A special extra check, don't complain about a reference from within
25262 -- the Ada.Interrupts package itself!
25264 and then not In_Same_Extended_Unit (N, Val)
25266 Check_Restriction (No_Dynamic_Attachment, Post_Node);
25269 -- Check for No_Implementation_Identifiers
25271 if Restriction_Check_Required (No_Implementation_Identifiers) then
25273 -- We have an implementation defined entity if it is marked as
25274 -- implementation defined, or is defined in a package marked as
25275 -- implementation defined. However, library packages themselves
25276 -- are excluded (we don't want to flag Interfaces itself, just
25277 -- the entities within it).
25279 if (Is_Implementation_Defined (Val)
25281 (Present (Scope (Val))
25282 and then Is_Implementation_Defined (Scope (Val))))
25283 and then not (Is_Package_Or_Generic_Package (Val)
25284 and then Is_Library_Level_Entity (Val))
25286 Check_Restriction (No_Implementation_Identifiers, Post_Node);
25290 -- Do the style check
25293 and then not Suppress_Style_Checks (Val)
25294 and then not In_Instance
25296 if Nkind (N) = N_Identifier then
25298 elsif Nkind (N) = N_Expanded_Name then
25299 Nod := Selector_Name (N);
25304 -- A special situation arises for derived operations, where we want
25305 -- to do the check against the parent (since the Sloc of the derived
25306 -- operation points to the derived type declaration itself).
25309 while not Comes_From_Source (Val_Actual)
25310 and then Nkind (Val_Actual) in N_Entity
25311 and then (Ekind (Val_Actual) = E_Enumeration_Literal
25312 or else Is_Subprogram_Or_Generic_Subprogram (Val_Actual))
25313 and then Present (Alias (Val_Actual))
25315 Val_Actual := Alias (Val_Actual);
25318 -- Renaming declarations for generic actuals do not come from source,
25319 -- and have a different name from that of the entity they rename, so
25320 -- there is no style check to perform here.
25322 if Chars (Nod) = Chars (Val_Actual) then
25323 Style.Check_Identifier (Nod, Val_Actual);
25327 Set_Entity (N, Val);
25328 end Set_Entity_With_Checks;
25330 ------------------------------
25331 -- Set_Invalid_Scalar_Value --
25332 ------------------------------
25334 procedure Set_Invalid_Scalar_Value
25335 (Scal_Typ : Float_Scalar_Id;
25338 Slot : Ureal renames Invalid_Floats (Scal_Typ);
25341 -- Detect an attempt to set a different value for the same scalar type
25343 pragma Assert (Slot = No_Ureal);
25345 end Set_Invalid_Scalar_Value;
25347 ------------------------------
25348 -- Set_Invalid_Scalar_Value --
25349 ------------------------------
25351 procedure Set_Invalid_Scalar_Value
25352 (Scal_Typ : Integer_Scalar_Id;
25355 Slot : Uint renames Invalid_Integers (Scal_Typ);
25358 -- Detect an attempt to set a different value for the same scalar type
25360 pragma Assert (Slot = No_Uint);
25362 end Set_Invalid_Scalar_Value;
25364 ------------------------
25365 -- Set_Name_Entity_Id --
25366 ------------------------
25368 procedure Set_Name_Entity_Id (Id : Name_Id; Val : Entity_Id) is
25370 Set_Name_Table_Int (Id, Int (Val));
25371 end Set_Name_Entity_Id;
25373 ---------------------
25374 -- Set_Next_Actual --
25375 ---------------------
25377 procedure Set_Next_Actual (Ass1_Id : Node_Id; Ass2_Id : Node_Id) is
25379 if Nkind (Parent (Ass1_Id)) = N_Parameter_Association then
25380 Set_First_Named_Actual (Parent (Ass1_Id), Ass2_Id);
25382 end Set_Next_Actual;
25384 ----------------------------------
25385 -- Set_Optimize_Alignment_Flags --
25386 ----------------------------------
25388 procedure Set_Optimize_Alignment_Flags (E : Entity_Id) is
25390 if Optimize_Alignment = 'S' then
25391 Set_Optimize_Alignment_Space (E);
25392 elsif Optimize_Alignment = 'T' then
25393 Set_Optimize_Alignment_Time (E);
25395 end Set_Optimize_Alignment_Flags;
25397 -----------------------
25398 -- Set_Public_Status --
25399 -----------------------
25401 procedure Set_Public_Status (Id : Entity_Id) is
25402 S : constant Entity_Id := Current_Scope;
25404 function Within_HSS_Or_If (E : Entity_Id) return Boolean;
25405 -- Determines if E is defined within handled statement sequence or
25406 -- an if statement, returns True if so, False otherwise.
25408 ----------------------
25409 -- Within_HSS_Or_If --
25410 ----------------------
25412 function Within_HSS_Or_If (E : Entity_Id) return Boolean is
25415 N := Declaration_Node (E);
25422 elsif Nkind_In (N, N_Handled_Sequence_Of_Statements,
25428 end Within_HSS_Or_If;
25430 -- Start of processing for Set_Public_Status
25433 -- Everything in the scope of Standard is public
25435 if S = Standard_Standard then
25436 Set_Is_Public (Id);
25438 -- Entity is definitely not public if enclosing scope is not public
25440 elsif not Is_Public (S) then
25443 -- An object or function declaration that occurs in a handled sequence
25444 -- of statements or within an if statement is the declaration for a
25445 -- temporary object or local subprogram generated by the expander. It
25446 -- never needs to be made public and furthermore, making it public can
25447 -- cause back end problems.
25449 elsif Nkind_In (Parent (Id), N_Object_Declaration,
25450 N_Function_Specification)
25451 and then Within_HSS_Or_If (Id)
25455 -- Entities in public packages or records are public
25457 elsif Ekind (S) = E_Package or Is_Record_Type (S) then
25458 Set_Is_Public (Id);
25460 -- The bounds of an entry family declaration can generate object
25461 -- declarations that are visible to the back-end, e.g. in the
25462 -- the declaration of a composite type that contains tasks.
25464 elsif Is_Concurrent_Type (S)
25465 and then not Has_Completion (S)
25466 and then Nkind (Parent (Id)) = N_Object_Declaration
25468 Set_Is_Public (Id);
25470 end Set_Public_Status;
25472 -----------------------------
25473 -- Set_Referenced_Modified --
25474 -----------------------------
25476 procedure Set_Referenced_Modified (N : Node_Id; Out_Param : Boolean) is
25480 -- Deal with indexed or selected component where prefix is modified
25482 if Nkind_In (N, N_Indexed_Component, N_Selected_Component) then
25483 Pref := Prefix (N);
25485 -- If prefix is access type, then it is the designated object that is
25486 -- being modified, which means we have no entity to set the flag on.
25488 if No (Etype (Pref)) or else Is_Access_Type (Etype (Pref)) then
25491 -- Otherwise chase the prefix
25494 Set_Referenced_Modified (Pref, Out_Param);
25497 -- Otherwise see if we have an entity name (only other case to process)
25499 elsif Is_Entity_Name (N) and then Present (Entity (N)) then
25500 Set_Referenced_As_LHS (Entity (N), not Out_Param);
25501 Set_Referenced_As_Out_Parameter (Entity (N), Out_Param);
25503 end Set_Referenced_Modified;
25509 procedure Set_Rep_Info (T1 : Entity_Id; T2 : Entity_Id) is
25511 Set_Is_Atomic (T1, Is_Atomic (T2));
25512 Set_Is_Independent (T1, Is_Independent (T2));
25513 Set_Is_Volatile_Full_Access (T1, Is_Volatile_Full_Access (T2));
25515 if Is_Base_Type (T1) then
25516 Set_Is_Volatile (T1, Is_Volatile (T2));
25520 ----------------------------
25521 -- Set_Scope_Is_Transient --
25522 ----------------------------
25524 procedure Set_Scope_Is_Transient (V : Boolean := True) is
25526 Scope_Stack.Table (Scope_Stack.Last).Is_Transient := V;
25527 end Set_Scope_Is_Transient;
25529 -------------------
25530 -- Set_Size_Info --
25531 -------------------
25533 procedure Set_Size_Info (T1, T2 : Entity_Id) is
25535 -- We copy Esize, but not RM_Size, since in general RM_Size is
25536 -- subtype specific and does not get inherited by all subtypes.
25538 Set_Esize (T1, Esize (T2));
25539 Set_Has_Biased_Representation (T1, Has_Biased_Representation (T2));
25541 if Is_Discrete_Or_Fixed_Point_Type (T1)
25543 Is_Discrete_Or_Fixed_Point_Type (T2)
25545 Set_Is_Unsigned_Type (T1, Is_Unsigned_Type (T2));
25548 Set_Alignment (T1, Alignment (T2));
25551 ------------------------------
25552 -- Should_Ignore_Pragma_Par --
25553 ------------------------------
25555 function Should_Ignore_Pragma_Par (Prag_Name : Name_Id) return Boolean is
25556 pragma Assert (Compiler_State = Parsing);
25557 -- This one can't work during semantic analysis, because we don't have a
25558 -- correct Current_Source_File.
25560 Result : constant Boolean :=
25561 Get_Name_Table_Boolean3 (Prag_Name)
25562 and then not Is_Internal_File_Name
25563 (File_Name (Current_Source_File));
25566 end Should_Ignore_Pragma_Par;
25568 ------------------------------
25569 -- Should_Ignore_Pragma_Sem --
25570 ------------------------------
25572 function Should_Ignore_Pragma_Sem (N : Node_Id) return Boolean is
25573 pragma Assert (Compiler_State = Analyzing);
25574 Prag_Name : constant Name_Id := Pragma_Name (N);
25575 Result : constant Boolean :=
25576 Get_Name_Table_Boolean3 (Prag_Name)
25577 and then not In_Internal_Unit (N);
25581 end Should_Ignore_Pragma_Sem;
25583 --------------------
25584 -- Static_Boolean --
25585 --------------------
25587 function Static_Boolean (N : Node_Id) return Uint is
25589 Analyze_And_Resolve (N, Standard_Boolean);
25592 or else Error_Posted (N)
25593 or else Etype (N) = Any_Type
25598 if Is_OK_Static_Expression (N) then
25599 if not Raises_Constraint_Error (N) then
25600 return Expr_Value (N);
25605 elsif Etype (N) = Any_Type then
25609 Flag_Non_Static_Expr
25610 ("static boolean expression required here", N);
25613 end Static_Boolean;
25615 --------------------
25616 -- Static_Integer --
25617 --------------------
25619 function Static_Integer (N : Node_Id) return Uint is
25621 Analyze_And_Resolve (N, Any_Integer);
25624 or else Error_Posted (N)
25625 or else Etype (N) = Any_Type
25630 if Is_OK_Static_Expression (N) then
25631 if not Raises_Constraint_Error (N) then
25632 return Expr_Value (N);
25637 elsif Etype (N) = Any_Type then
25641 Flag_Non_Static_Expr
25642 ("static integer expression required here", N);
25645 end Static_Integer;
25647 --------------------------
25648 -- Statically_Different --
25649 --------------------------
25651 function Statically_Different (E1, E2 : Node_Id) return Boolean is
25652 R1 : constant Node_Id := Get_Referenced_Object (E1);
25653 R2 : constant Node_Id := Get_Referenced_Object (E2);
25655 return Is_Entity_Name (R1)
25656 and then Is_Entity_Name (R2)
25657 and then Entity (R1) /= Entity (R2)
25658 and then not Is_Formal (Entity (R1))
25659 and then not Is_Formal (Entity (R2));
25660 end Statically_Different;
25662 --------------------------------------
25663 -- Subject_To_Loop_Entry_Attributes --
25664 --------------------------------------
25666 function Subject_To_Loop_Entry_Attributes (N : Node_Id) return Boolean is
25672 -- The expansion mechanism transform a loop subject to at least one
25673 -- 'Loop_Entry attribute into a conditional block. Infinite loops lack
25674 -- the conditional part.
25676 if Nkind_In (Stmt, N_Block_Statement, N_If_Statement)
25677 and then Nkind (Original_Node (N)) = N_Loop_Statement
25679 Stmt := Original_Node (N);
25683 Nkind (Stmt) = N_Loop_Statement
25684 and then Present (Identifier (Stmt))
25685 and then Present (Entity (Identifier (Stmt)))
25686 and then Has_Loop_Entry_Attributes (Entity (Identifier (Stmt)));
25687 end Subject_To_Loop_Entry_Attributes;
25689 -----------------------------
25690 -- Subprogram_Access_Level --
25691 -----------------------------
25693 function Subprogram_Access_Level (Subp : Entity_Id) return Uint is
25695 if Present (Alias (Subp)) then
25696 return Subprogram_Access_Level (Alias (Subp));
25698 return Scope_Depth (Enclosing_Dynamic_Scope (Subp));
25700 end Subprogram_Access_Level;
25702 ---------------------
25703 -- Subprogram_Name --
25704 ---------------------
25706 function Subprogram_Name (N : Node_Id) return String is
25707 Buf : Bounded_String;
25708 Ent : Node_Id := N;
25712 while Present (Ent) loop
25713 case Nkind (Ent) is
25714 when N_Subprogram_Body =>
25715 Ent := Defining_Unit_Name (Specification (Ent));
25718 when N_Subprogram_Declaration =>
25719 Nod := Corresponding_Body (Ent);
25721 if Present (Nod) then
25724 Ent := Defining_Unit_Name (Specification (Ent));
25729 when N_Subprogram_Instantiation
25731 | N_Package_Specification
25733 Ent := Defining_Unit_Name (Ent);
25736 when N_Protected_Type_Declaration =>
25737 Ent := Corresponding_Body (Ent);
25740 when N_Protected_Body
25743 Ent := Defining_Identifier (Ent);
25750 Ent := Parent (Ent);
25754 return "unknown subprogram:unknown file:0:0";
25757 -- If the subprogram is a child unit, use its simple name to start the
25758 -- construction of the fully qualified name.
25760 if Nkind (Ent) = N_Defining_Program_Unit_Name then
25761 Ent := Defining_Identifier (Ent);
25764 Append_Entity_Name (Buf, Ent);
25766 -- Append homonym number if needed
25768 if Nkind (N) in N_Entity and then Has_Homonym (N) then
25770 H : Entity_Id := Homonym (N);
25774 while Present (H) loop
25775 if Scope (H) = Scope (N) then
25789 -- Append source location of Ent to Buf so that the string will
25790 -- look like "subp:file:line:col".
25793 Loc : constant Source_Ptr := Sloc (Ent);
25796 Append (Buf, Reference_Name (Get_Source_File_Index (Loc)));
25798 Append (Buf, Nat (Get_Logical_Line_Number (Loc)));
25800 Append (Buf, Nat (Get_Column_Number (Loc)));
25804 end Subprogram_Name;
25806 -------------------------------
25807 -- Support_Atomic_Primitives --
25808 -------------------------------
25810 function Support_Atomic_Primitives (Typ : Entity_Id) return Boolean is
25814 -- Verify the alignment of Typ is known
25816 if not Known_Alignment (Typ) then
25820 if Known_Static_Esize (Typ) then
25821 Size := UI_To_Int (Esize (Typ));
25823 -- If the Esize (Object_Size) is unknown at compile time, look at the
25824 -- RM_Size (Value_Size) which may have been set by an explicit rep item.
25826 elsif Known_Static_RM_Size (Typ) then
25827 Size := UI_To_Int (RM_Size (Typ));
25829 -- Otherwise, the size is considered to be unknown.
25835 -- Check that the size of the component is 8, 16, 32, or 64 bits and
25836 -- that Typ is properly aligned.
25839 when 8 | 16 | 32 | 64 =>
25840 return Size = UI_To_Int (Alignment (Typ)) * 8;
25845 end Support_Atomic_Primitives;
25851 procedure Trace_Scope (N : Node_Id; E : Entity_Id; Msg : String) is
25853 if Debug_Flag_W then
25854 for J in 0 .. Scope_Stack.Last loop
25859 Write_Name (Chars (E));
25860 Write_Str (" from ");
25861 Write_Location (Sloc (N));
25866 -----------------------
25867 -- Transfer_Entities --
25868 -----------------------
25870 procedure Transfer_Entities (From : Entity_Id; To : Entity_Id) is
25871 procedure Set_Public_Status_Of (Id : Entity_Id);
25872 -- Set the Is_Public attribute of arbitrary entity Id by calling routine
25873 -- Set_Public_Status. If successful and Id denotes a record type, set
25874 -- the Is_Public attribute of its fields.
25876 --------------------------
25877 -- Set_Public_Status_Of --
25878 --------------------------
25880 procedure Set_Public_Status_Of (Id : Entity_Id) is
25884 if not Is_Public (Id) then
25885 Set_Public_Status (Id);
25887 -- When the input entity is a public record type, ensure that all
25888 -- its internal fields are also exposed to the linker. The fields
25889 -- of a class-wide type are never made public.
25892 and then Is_Record_Type (Id)
25893 and then not Is_Class_Wide_Type (Id)
25895 Field := First_Entity (Id);
25896 while Present (Field) loop
25897 Set_Is_Public (Field);
25898 Next_Entity (Field);
25902 end Set_Public_Status_Of;
25906 Full_Id : Entity_Id;
25909 -- Start of processing for Transfer_Entities
25912 Id := First_Entity (From);
25914 if Present (Id) then
25916 -- Merge the entity chain of the source scope with that of the
25917 -- destination scope.
25919 if Present (Last_Entity (To)) then
25920 Link_Entities (Last_Entity (To), Id);
25922 Set_First_Entity (To, Id);
25925 Set_Last_Entity (To, Last_Entity (From));
25927 -- Inspect the entities of the source scope and update their Scope
25930 while Present (Id) loop
25931 Set_Scope (Id, To);
25932 Set_Public_Status_Of (Id);
25934 -- Handle an internally generated full view for a private type
25936 if Is_Private_Type (Id)
25937 and then Present (Full_View (Id))
25938 and then Is_Itype (Full_View (Id))
25940 Full_Id := Full_View (Id);
25942 Set_Scope (Full_Id, To);
25943 Set_Public_Status_Of (Full_Id);
25949 Set_First_Entity (From, Empty);
25950 Set_Last_Entity (From, Empty);
25952 end Transfer_Entities;
25954 ------------------------
25955 -- Traverse_More_Func --
25956 ------------------------
25958 function Traverse_More_Func (Node : Node_Id) return Traverse_Final_Result is
25960 Processing_Itype : Boolean := False;
25961 -- Set to True while traversing the nodes under an Itype, to prevent
25962 -- looping on Itype handling during that traversal.
25964 function Process_More (N : Node_Id) return Traverse_Result;
25965 -- Wrapper over the Process callback to handle parts of the AST that
25966 -- are not normally traversed as syntactic children.
25968 function Traverse_Rec (N : Node_Id) return Traverse_Final_Result;
25969 -- Main recursive traversal implemented as an instantiation of
25970 -- Traverse_Func over a modified Process callback.
25976 function Process_More (N : Node_Id) return Traverse_Result is
25978 procedure Traverse_More (N : Node_Id;
25979 Res : in out Traverse_Result);
25980 procedure Traverse_More (L : List_Id;
25981 Res : in out Traverse_Result);
25982 -- Traverse a node or list and update the traversal result to value
25983 -- Abandon when needed.
25985 -------------------
25986 -- Traverse_More --
25987 -------------------
25989 procedure Traverse_More (N : Node_Id;
25990 Res : in out Traverse_Result)
25993 -- Do not process any more nodes if Abandon was reached
25995 if Res = Abandon then
25999 if Traverse_Rec (N) = Abandon then
26004 procedure Traverse_More (L : List_Id;
26005 Res : in out Traverse_Result)
26007 N : Node_Id := First (L);
26010 -- Do not process any more nodes if Abandon was reached
26012 if Res = Abandon then
26016 while Present (N) loop
26017 Traverse_More (N, Res);
26025 Result : Traverse_Result;
26027 -- Start of processing for Process_More
26030 -- Initial callback to Process. Return immediately on Skip/Abandon.
26031 -- Otherwise update the value of Node for further processing of
26032 -- non-syntactic children.
26034 Result := Process (N);
26037 when OK => Node := N;
26038 when OK_Orig => Node := Original_Node (N);
26039 when Skip => return Skip;
26040 when Abandon => return Abandon;
26043 -- Process the relevant semantic children which are a logical part of
26044 -- the AST under this node before returning for the processing of
26045 -- syntactic children.
26047 -- Start with all non-syntactic lists of action nodes
26049 case Nkind (Node) is
26050 when N_Component_Association =>
26051 Traverse_More (Loop_Actions (Node), Result);
26053 when N_Elsif_Part =>
26054 Traverse_More (Condition_Actions (Node), Result);
26056 when N_Short_Circuit =>
26057 Traverse_More (Actions (Node), Result);
26059 when N_Case_Expression_Alternative =>
26060 Traverse_More (Actions (Node), Result);
26062 when N_Iterated_Component_Association =>
26063 Traverse_More (Loop_Actions (Node), Result);
26065 when N_Iteration_Scheme =>
26066 Traverse_More (Condition_Actions (Node), Result);
26068 when N_If_Expression =>
26069 Traverse_More (Then_Actions (Node), Result);
26070 Traverse_More (Else_Actions (Node), Result);
26072 -- Various nodes have a field Actions as a syntactic node,
26073 -- so it will be traversed in the regular syntactic traversal.
26075 when N_Compilation_Unit_Aux
26076 | N_Compound_Statement
26077 | N_Expression_With_Actions
26086 -- If Process_Itypes is True, process unattached nodes which come
26087 -- from Itypes. This only concerns currently ranges of scalar
26088 -- (possibly as index) types. This traversal is protected against
26089 -- looping with Processing_Itype.
26092 and then not Processing_Itype
26093 and then Nkind (Node) in N_Has_Etype
26094 and then Present (Etype (Node))
26095 and then Is_Itype (Etype (Node))
26098 Typ : constant Entity_Id := Etype (Node);
26100 Processing_Itype := True;
26102 case Ekind (Typ) is
26103 when Scalar_Kind =>
26104 Traverse_More (Scalar_Range (Typ), Result);
26108 Index : Node_Id := First_Index (Typ);
26111 while Present (Index) loop
26112 if Nkind (Index) in N_Has_Entity then
26113 Rng := Scalar_Range (Entity (Index));
26118 Traverse_More (Rng, Result);
26119 Next_Index (Index);
26126 Processing_Itype := False;
26133 -- Define Traverse_Rec as a renaming of the instantiation, as an
26134 -- instantiation cannot complete a previous spec.
26136 function Traverse_Recursive is new Traverse_Func (Process_More);
26137 function Traverse_Rec (N : Node_Id) return Traverse_Final_Result
26138 renames Traverse_Recursive;
26140 -- Start of processing for Traverse_More_Func
26143 return Traverse_Rec (Node);
26144 end Traverse_More_Func;
26146 ------------------------
26147 -- Traverse_More_Proc --
26148 ------------------------
26150 procedure Traverse_More_Proc (Node : Node_Id) is
26151 function Traverse is new Traverse_More_Func (Process, Process_Itypes);
26152 Discard : Traverse_Final_Result;
26153 pragma Warnings (Off, Discard);
26155 Discard := Traverse (Node);
26156 end Traverse_More_Proc;
26158 -----------------------
26159 -- Type_Access_Level --
26160 -----------------------
26162 function Type_Access_Level (Typ : Entity_Id) return Uint is
26166 Btyp := Base_Type (Typ);
26168 -- Ada 2005 (AI-230): For most cases of anonymous access types, we
26169 -- simply use the level where the type is declared. This is true for
26170 -- stand-alone object declarations, and for anonymous access types
26171 -- associated with components the level is the same as that of the
26172 -- enclosing composite type. However, special treatment is needed for
26173 -- the cases of access parameters, return objects of an anonymous access
26174 -- type, and, in Ada 95, access discriminants of limited types.
26176 if Is_Access_Type (Btyp) then
26177 if Ekind (Btyp) = E_Anonymous_Access_Type then
26179 -- If the type is a nonlocal anonymous access type (such as for
26180 -- an access parameter) we treat it as being declared at the
26181 -- library level to ensure that names such as X.all'access don't
26182 -- fail static accessibility checks.
26184 if not Is_Local_Anonymous_Access (Typ) then
26185 return Scope_Depth (Standard_Standard);
26187 -- If this is a return object, the accessibility level is that of
26188 -- the result subtype of the enclosing function. The test here is
26189 -- little complicated, because we have to account for extended
26190 -- return statements that have been rewritten as blocks, in which
26191 -- case we have to find and the Is_Return_Object attribute of the
26192 -- itype's associated object. It would be nice to find a way to
26193 -- simplify this test, but it doesn't seem worthwhile to add a new
26194 -- flag just for purposes of this test. ???
26196 elsif Ekind (Scope (Btyp)) = E_Return_Statement
26199 and then Nkind (Associated_Node_For_Itype (Btyp)) =
26200 N_Object_Declaration
26201 and then Is_Return_Object
26202 (Defining_Identifier
26203 (Associated_Node_For_Itype (Btyp))))
26209 Scop := Scope (Scope (Btyp));
26210 while Present (Scop) loop
26211 exit when Ekind (Scop) = E_Function;
26212 Scop := Scope (Scop);
26215 -- Treat the return object's type as having the level of the
26216 -- function's result subtype (as per RM05-6.5(5.3/2)).
26218 return Type_Access_Level (Etype (Scop));
26223 Btyp := Root_Type (Btyp);
26225 -- The accessibility level of anonymous access types associated with
26226 -- discriminants is that of the current instance of the type, and
26227 -- that's deeper than the type itself (AARM 3.10.2 (12.3.21)).
26229 -- AI-402: access discriminants have accessibility based on the
26230 -- object rather than the type in Ada 2005, so the above paragraph
26233 -- ??? Needs completion with rules from AI-416
26235 if Ada_Version <= Ada_95
26236 and then Ekind (Typ) = E_Anonymous_Access_Type
26237 and then Present (Associated_Node_For_Itype (Typ))
26238 and then Nkind (Associated_Node_For_Itype (Typ)) =
26239 N_Discriminant_Specification
26241 return Scope_Depth (Enclosing_Dynamic_Scope (Btyp)) + 1;
26245 -- Return library level for a generic formal type. This is done because
26246 -- RM(10.3.2) says that "The statically deeper relationship does not
26247 -- apply to ... a descendant of a generic formal type". Rather than
26248 -- checking at each point where a static accessibility check is
26249 -- performed to see if we are dealing with a formal type, this rule is
26250 -- implemented by having Type_Access_Level and Deepest_Type_Access_Level
26251 -- return extreme values for a formal type; Deepest_Type_Access_Level
26252 -- returns Int'Last. By calling the appropriate function from among the
26253 -- two, we ensure that the static accessibility check will pass if we
26254 -- happen to run into a formal type. More specifically, we should call
26255 -- Deepest_Type_Access_Level instead of Type_Access_Level whenever the
26256 -- call occurs as part of a static accessibility check and the error
26257 -- case is the case where the type's level is too shallow (as opposed
26260 if Is_Generic_Type (Root_Type (Btyp)) then
26261 return Scope_Depth (Standard_Standard);
26264 return Scope_Depth (Enclosing_Dynamic_Scope (Btyp));
26265 end Type_Access_Level;
26267 ------------------------------------
26268 -- Type_Without_Stream_Operation --
26269 ------------------------------------
26271 function Type_Without_Stream_Operation
26273 Op : TSS_Name_Type := TSS_Null) return Entity_Id
26275 BT : constant Entity_Id := Base_Type (T);
26276 Op_Missing : Boolean;
26279 if not Restriction_Active (No_Default_Stream_Attributes) then
26283 if Is_Elementary_Type (T) then
26284 if Op = TSS_Null then
26286 No (TSS (BT, TSS_Stream_Read))
26287 or else No (TSS (BT, TSS_Stream_Write));
26290 Op_Missing := No (TSS (BT, Op));
26299 elsif Is_Array_Type (T) then
26300 return Type_Without_Stream_Operation (Component_Type (T), Op);
26302 elsif Is_Record_Type (T) then
26308 Comp := First_Component (T);
26309 while Present (Comp) loop
26310 C_Typ := Type_Without_Stream_Operation (Etype (Comp), Op);
26312 if Present (C_Typ) then
26316 Next_Component (Comp);
26322 elsif Is_Private_Type (T) and then Present (Full_View (T)) then
26323 return Type_Without_Stream_Operation (Full_View (T), Op);
26327 end Type_Without_Stream_Operation;
26329 ---------------------
26330 -- Ultimate_Prefix --
26331 ---------------------
26333 function Ultimate_Prefix (N : Node_Id) return Node_Id is
26338 while Nkind_In (Pref, N_Explicit_Dereference,
26339 N_Indexed_Component,
26340 N_Selected_Component,
26343 Pref := Prefix (Pref);
26347 end Ultimate_Prefix;
26349 ----------------------------
26350 -- Unique_Defining_Entity --
26351 ----------------------------
26353 function Unique_Defining_Entity (N : Node_Id) return Entity_Id is
26355 return Unique_Entity (Defining_Entity (N));
26356 end Unique_Defining_Entity;
26358 -------------------
26359 -- Unique_Entity --
26360 -------------------
26362 function Unique_Entity (E : Entity_Id) return Entity_Id is
26363 U : Entity_Id := E;
26369 if Present (Full_View (E)) then
26370 U := Full_View (E);
26374 if Nkind (Parent (E)) = N_Entry_Body then
26376 Prot_Item : Entity_Id;
26377 Prot_Type : Entity_Id;
26380 if Ekind (E) = E_Entry then
26381 Prot_Type := Scope (E);
26383 -- Bodies of entry families are nested within an extra scope
26384 -- that contains an entry index declaration.
26387 Prot_Type := Scope (Scope (E));
26390 -- A protected type may be declared as a private type, in
26391 -- which case we need to get its full view.
26393 if Is_Private_Type (Prot_Type) then
26394 Prot_Type := Full_View (Prot_Type);
26397 -- Full view may not be present on error, in which case
26398 -- return E by default.
26400 if Present (Prot_Type) then
26401 pragma Assert (Ekind (Prot_Type) = E_Protected_Type);
26403 -- Traverse the entity list of the protected type and
26404 -- locate an entry declaration which matches the entry
26407 Prot_Item := First_Entity (Prot_Type);
26408 while Present (Prot_Item) loop
26409 if Ekind (Prot_Item) in Entry_Kind
26410 and then Corresponding_Body (Parent (Prot_Item)) = E
26416 Next_Entity (Prot_Item);
26422 when Formal_Kind =>
26423 if Present (Spec_Entity (E)) then
26424 U := Spec_Entity (E);
26427 when E_Package_Body =>
26430 if Nkind (P) = N_Defining_Program_Unit_Name then
26434 if Nkind (P) = N_Package_Body
26435 and then Present (Corresponding_Spec (P))
26437 U := Corresponding_Spec (P);
26439 elsif Nkind (P) = N_Package_Body_Stub
26440 and then Present (Corresponding_Spec_Of_Stub (P))
26442 U := Corresponding_Spec_Of_Stub (P);
26445 when E_Protected_Body =>
26448 if Nkind (P) = N_Protected_Body
26449 and then Present (Corresponding_Spec (P))
26451 U := Corresponding_Spec (P);
26453 elsif Nkind (P) = N_Protected_Body_Stub
26454 and then Present (Corresponding_Spec_Of_Stub (P))
26456 U := Corresponding_Spec_Of_Stub (P);
26458 if Is_Single_Protected_Object (U) then
26463 if Is_Private_Type (U) then
26464 U := Full_View (U);
26467 when E_Subprogram_Body =>
26470 if Nkind (P) = N_Defining_Program_Unit_Name then
26476 if Nkind (P) = N_Subprogram_Body
26477 and then Present (Corresponding_Spec (P))
26479 U := Corresponding_Spec (P);
26481 elsif Nkind (P) = N_Subprogram_Body_Stub
26482 and then Present (Corresponding_Spec_Of_Stub (P))
26484 U := Corresponding_Spec_Of_Stub (P);
26486 elsif Nkind (P) = N_Subprogram_Renaming_Declaration then
26487 U := Corresponding_Spec (P);
26490 when E_Task_Body =>
26493 if Nkind (P) = N_Task_Body
26494 and then Present (Corresponding_Spec (P))
26496 U := Corresponding_Spec (P);
26498 elsif Nkind (P) = N_Task_Body_Stub
26499 and then Present (Corresponding_Spec_Of_Stub (P))
26501 U := Corresponding_Spec_Of_Stub (P);
26503 if Is_Single_Task_Object (U) then
26508 if Is_Private_Type (U) then
26509 U := Full_View (U);
26513 if Present (Full_View (E)) then
26514 U := Full_View (E);
26528 function Unique_Name (E : Entity_Id) return String is
26530 -- Local subprograms
26532 function Add_Homonym_Suffix (E : Entity_Id) return String;
26534 function This_Name return String;
26536 ------------------------
26537 -- Add_Homonym_Suffix --
26538 ------------------------
26540 function Add_Homonym_Suffix (E : Entity_Id) return String is
26542 -- Names in E_Subprogram_Body or E_Package_Body entities are not
26543 -- reliable, as they may not include the overloading suffix.
26544 -- Instead, when looking for the name of E or one of its enclosing
26545 -- scope, we get the name of the corresponding Unique_Entity.
26547 U : constant Entity_Id := Unique_Entity (E);
26548 Nam : constant String := Get_Name_String (Chars (U));
26551 -- If E has homonyms but is not fully qualified, as done in
26552 -- GNATprove mode, append the homonym number on the fly. Strip the
26553 -- leading space character in the image of natural numbers. Also do
26554 -- not print the homonym value of 1.
26556 if Has_Homonym (U) then
26558 N : constant Pos := Homonym_Number (U);
26559 S : constant String := N'Img;
26562 return Nam & "__" & S (2 .. S'Last);
26568 end Add_Homonym_Suffix;
26574 function This_Name return String is
26576 return Add_Homonym_Suffix (E);
26581 U : constant Entity_Id := Unique_Entity (E);
26583 -- Start of processing for Unique_Name
26586 if E = Standard_Standard
26587 or else Has_Fully_Qualified_Name (E)
26591 elsif Ekind (E) = E_Enumeration_Literal then
26592 return Unique_Name (Etype (E)) & "__" & This_Name;
26596 S : constant Entity_Id := Scope (U);
26597 pragma Assert (Present (S));
26600 -- Prefix names of predefined types with standard__, but leave
26601 -- names of user-defined packages and subprograms without prefix
26602 -- (even if technically they are nested in the Standard package).
26604 if S = Standard_Standard then
26605 if Ekind (U) = E_Package or else Is_Subprogram (U) then
26608 return Unique_Name (S) & "__" & This_Name;
26611 -- For intances of generic subprograms use the name of the related
26612 -- instance and skip the scope of its wrapper package.
26614 elsif Is_Wrapper_Package (S) then
26615 pragma Assert (Scope (S) = Scope (Related_Instance (S)));
26616 -- Wrapper package and the instantiation are in the same scope
26619 Related_Name : constant String :=
26620 Add_Homonym_Suffix (Related_Instance (S));
26621 Enclosing_Name : constant String :=
26622 Unique_Name (Scope (S)) & "__" & Related_Name;
26625 if Is_Subprogram (U)
26626 and then not Is_Generic_Actual_Subprogram (U)
26628 return Enclosing_Name;
26630 return Enclosing_Name & "__" & This_Name;
26634 elsif Is_Child_Unit (U) then
26635 return Child_Prefix & Unique_Name (S) & "__" & This_Name;
26637 return Unique_Name (S) & "__" & This_Name;
26643 ---------------------
26644 -- Unit_Is_Visible --
26645 ---------------------
26647 function Unit_Is_Visible (U : Entity_Id) return Boolean is
26648 Curr : constant Node_Id := Cunit (Current_Sem_Unit);
26649 Curr_Entity : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
26651 function Unit_In_Parent_Context (Par_Unit : Node_Id) return Boolean;
26652 -- For a child unit, check whether unit appears in a with_clause
26655 function Unit_In_Context (Comp_Unit : Node_Id) return Boolean;
26656 -- Scan the context clause of one compilation unit looking for a
26657 -- with_clause for the unit in question.
26659 ----------------------------
26660 -- Unit_In_Parent_Context --
26661 ----------------------------
26663 function Unit_In_Parent_Context (Par_Unit : Node_Id) return Boolean is
26665 if Unit_In_Context (Par_Unit) then
26668 elsif Is_Child_Unit (Defining_Entity (Unit (Par_Unit))) then
26669 return Unit_In_Parent_Context (Parent_Spec (Unit (Par_Unit)));
26674 end Unit_In_Parent_Context;
26676 ---------------------
26677 -- Unit_In_Context --
26678 ---------------------
26680 function Unit_In_Context (Comp_Unit : Node_Id) return Boolean is
26684 Clause := First (Context_Items (Comp_Unit));
26685 while Present (Clause) loop
26686 if Nkind (Clause) = N_With_Clause then
26687 if Library_Unit (Clause) = U then
26690 -- The with_clause may denote a renaming of the unit we are
26691 -- looking for, eg. Text_IO which renames Ada.Text_IO.
26694 Renamed_Entity (Entity (Name (Clause))) =
26695 Defining_Entity (Unit (U))
26705 end Unit_In_Context;
26707 -- Start of processing for Unit_Is_Visible
26710 -- The currrent unit is directly visible
26715 elsif Unit_In_Context (Curr) then
26718 -- If the current unit is a body, check the context of the spec
26720 elsif Nkind (Unit (Curr)) = N_Package_Body
26722 (Nkind (Unit (Curr)) = N_Subprogram_Body
26723 and then not Acts_As_Spec (Unit (Curr)))
26725 if Unit_In_Context (Library_Unit (Curr)) then
26730 -- If the spec is a child unit, examine the parents
26732 if Is_Child_Unit (Curr_Entity) then
26733 if Nkind (Unit (Curr)) in N_Unit_Body then
26735 Unit_In_Parent_Context
26736 (Parent_Spec (Unit (Library_Unit (Curr))));
26738 return Unit_In_Parent_Context (Parent_Spec (Unit (Curr)));
26744 end Unit_Is_Visible;
26746 ------------------------------
26747 -- Universal_Interpretation --
26748 ------------------------------
26750 function Universal_Interpretation (Opnd : Node_Id) return Entity_Id is
26751 Index : Interp_Index;
26755 -- The argument may be a formal parameter of an operator or subprogram
26756 -- with multiple interpretations, or else an expression for an actual.
26758 if Nkind (Opnd) = N_Defining_Identifier
26759 or else not Is_Overloaded (Opnd)
26761 if Etype (Opnd) = Universal_Integer
26762 or else Etype (Opnd) = Universal_Real
26764 return Etype (Opnd);
26770 Get_First_Interp (Opnd, Index, It);
26771 while Present (It.Typ) loop
26772 if It.Typ = Universal_Integer
26773 or else It.Typ = Universal_Real
26778 Get_Next_Interp (Index, It);
26783 end Universal_Interpretation;
26789 function Unqualify (Expr : Node_Id) return Node_Id is
26791 -- Recurse to handle unlikely case of multiple levels of qualification
26793 if Nkind (Expr) = N_Qualified_Expression then
26794 return Unqualify (Expression (Expr));
26796 -- Normal case, not a qualified expression
26807 function Unqual_Conv (Expr : Node_Id) return Node_Id is
26809 -- Recurse to handle unlikely case of multiple levels of qualification
26810 -- and/or conversion.
26812 if Nkind_In (Expr, N_Qualified_Expression,
26814 N_Unchecked_Type_Conversion)
26816 return Unqual_Conv (Expression (Expr));
26818 -- Normal case, not a qualified expression
26825 --------------------
26826 -- Validated_View --
26827 --------------------
26829 function Validated_View (Typ : Entity_Id) return Entity_Id is
26830 Continue : Boolean;
26831 Val_Typ : Entity_Id;
26835 Val_Typ := Base_Type (Typ);
26837 -- Obtain the full view of the input type by stripping away concurrency,
26838 -- derivations, and privacy.
26840 while Continue loop
26843 if Is_Concurrent_Type (Val_Typ) then
26844 if Present (Corresponding_Record_Type (Val_Typ)) then
26846 Val_Typ := Corresponding_Record_Type (Val_Typ);
26849 elsif Is_Derived_Type (Val_Typ) then
26851 Val_Typ := Etype (Val_Typ);
26853 elsif Is_Private_Type (Val_Typ) then
26854 if Present (Underlying_Full_View (Val_Typ)) then
26856 Val_Typ := Underlying_Full_View (Val_Typ);
26858 elsif Present (Full_View (Val_Typ)) then
26860 Val_Typ := Full_View (Val_Typ);
26866 end Validated_View;
26868 -----------------------
26869 -- Visible_Ancestors --
26870 -----------------------
26872 function Visible_Ancestors (Typ : Entity_Id) return Elist_Id is
26878 pragma Assert (Is_Record_Type (Typ) and then Is_Tagged_Type (Typ));
26880 -- Collect all the parents and progenitors of Typ. If the full-view of
26881 -- private parents and progenitors is available then it is used to
26882 -- generate the list of visible ancestors; otherwise their partial
26883 -- view is added to the resulting list.
26888 Use_Full_View => True);
26892 Ifaces_List => List_2,
26893 Exclude_Parents => True,
26894 Use_Full_View => True);
26896 -- Join the two lists. Avoid duplications because an interface may
26897 -- simultaneously be parent and progenitor of a type.
26899 Elmt := First_Elmt (List_2);
26900 while Present (Elmt) loop
26901 Append_Unique_Elmt (Node (Elmt), List_1);
26906 end Visible_Ancestors;
26908 ----------------------
26909 -- Within_Init_Proc --
26910 ----------------------
26912 function Within_Init_Proc return Boolean is
26916 S := Current_Scope;
26917 while not Is_Overloadable (S) loop
26918 if S = Standard_Standard then
26925 return Is_Init_Proc (S);
26926 end Within_Init_Proc;
26928 ---------------------------
26929 -- Within_Protected_Type --
26930 ---------------------------
26932 function Within_Protected_Type (E : Entity_Id) return Boolean is
26933 Scop : Entity_Id := Scope (E);
26936 while Present (Scop) loop
26937 if Ekind (Scop) = E_Protected_Type then
26941 Scop := Scope (Scop);
26945 end Within_Protected_Type;
26951 function Within_Scope (E : Entity_Id; S : Entity_Id) return Boolean is
26953 return Scope_Within_Or_Same (Scope (E), S);
26956 ----------------------------
26957 -- Within_Subprogram_Call --
26958 ----------------------------
26960 function Within_Subprogram_Call (N : Node_Id) return Boolean is
26964 -- Climb the parent chain looking for a function or procedure call
26967 while Present (Par) loop
26968 if Nkind_In (Par, N_Entry_Call_Statement,
26970 N_Procedure_Call_Statement)
26974 -- Prevent the search from going too far
26976 elsif Is_Body_Or_Package_Declaration (Par) then
26980 Par := Parent (Par);
26984 end Within_Subprogram_Call;
26990 procedure Wrong_Type (Expr : Node_Id; Expected_Type : Entity_Id) is
26991 Found_Type : constant Entity_Id := First_Subtype (Etype (Expr));
26992 Expec_Type : constant Entity_Id := First_Subtype (Expected_Type);
26994 Matching_Field : Entity_Id;
26995 -- Entity to give a more precise suggestion on how to write a one-
26996 -- element positional aggregate.
26998 function Has_One_Matching_Field return Boolean;
26999 -- Determines if Expec_Type is a record type with a single component or
27000 -- discriminant whose type matches the found type or is one dimensional
27001 -- array whose component type matches the found type. In the case of
27002 -- one discriminant, we ignore the variant parts. That's not accurate,
27003 -- but good enough for the warning.
27005 ----------------------------
27006 -- Has_One_Matching_Field --
27007 ----------------------------
27009 function Has_One_Matching_Field return Boolean is
27013 Matching_Field := Empty;
27015 if Is_Array_Type (Expec_Type)
27016 and then Number_Dimensions (Expec_Type) = 1
27017 and then Covers (Etype (Component_Type (Expec_Type)), Found_Type)
27019 -- Use type name if available. This excludes multidimensional
27020 -- arrays and anonymous arrays.
27022 if Comes_From_Source (Expec_Type) then
27023 Matching_Field := Expec_Type;
27025 -- For an assignment, use name of target
27027 elsif Nkind (Parent (Expr)) = N_Assignment_Statement
27028 and then Is_Entity_Name (Name (Parent (Expr)))
27030 Matching_Field := Entity (Name (Parent (Expr)));
27035 elsif not Is_Record_Type (Expec_Type) then
27039 E := First_Entity (Expec_Type);
27044 elsif not Ekind_In (E, E_Discriminant, E_Component)
27045 or else Nam_In (Chars (E), Name_uTag, Name_uParent)
27054 if not Covers (Etype (E), Found_Type) then
27057 elsif Present (Next_Entity (E))
27058 and then (Ekind (E) = E_Component
27059 or else Ekind (Next_Entity (E)) = E_Discriminant)
27064 Matching_Field := E;
27068 end Has_One_Matching_Field;
27070 -- Start of processing for Wrong_Type
27073 -- Don't output message if either type is Any_Type, or if a message
27074 -- has already been posted for this node. We need to do the latter
27075 -- check explicitly (it is ordinarily done in Errout), because we
27076 -- are using ! to force the output of the error messages.
27078 if Expec_Type = Any_Type
27079 or else Found_Type = Any_Type
27080 or else Error_Posted (Expr)
27084 -- If one of the types is a Taft-Amendment type and the other it its
27085 -- completion, it must be an illegal use of a TAT in the spec, for
27086 -- which an error was already emitted. Avoid cascaded errors.
27088 elsif Is_Incomplete_Type (Expec_Type)
27089 and then Has_Completion_In_Body (Expec_Type)
27090 and then Full_View (Expec_Type) = Etype (Expr)
27094 elsif Is_Incomplete_Type (Etype (Expr))
27095 and then Has_Completion_In_Body (Etype (Expr))
27096 and then Full_View (Etype (Expr)) = Expec_Type
27100 -- In an instance, there is an ongoing problem with completion of
27101 -- types derived from private types. Their structure is what Gigi
27102 -- expects, but the Etype is the parent type rather than the
27103 -- derived private type itself. Do not flag error in this case. The
27104 -- private completion is an entity without a parent, like an Itype.
27105 -- Similarly, full and partial views may be incorrect in the instance.
27106 -- There is no simple way to insure that it is consistent ???
27108 -- A similar view discrepancy can happen in an inlined body, for the
27109 -- same reason: inserted body may be outside of the original package
27110 -- and only partial views are visible at the point of insertion.
27112 -- If In_Generic_Actual (Expr) is True then we cannot assume that
27113 -- the successful semantic analysis of the generic guarantees anything
27114 -- useful about type checking of this instance, so we ignore
27115 -- In_Instance in that case. There may be cases where this is not
27116 -- right (the symptom would probably be rejecting something
27117 -- that ought to be accepted) but we don't currently have any
27118 -- concrete examples of this.
27120 elsif (In_Instance and then not In_Generic_Actual (Expr))
27121 or else In_Inlined_Body
27123 if Etype (Etype (Expr)) = Etype (Expected_Type)
27125 (Has_Private_Declaration (Expected_Type)
27126 or else Has_Private_Declaration (Etype (Expr)))
27127 and then No (Parent (Expected_Type))
27131 elsif Nkind (Parent (Expr)) = N_Qualified_Expression
27132 and then Entity (Subtype_Mark (Parent (Expr))) = Expected_Type
27136 elsif Is_Private_Type (Expected_Type)
27137 and then Present (Full_View (Expected_Type))
27138 and then Covers (Full_View (Expected_Type), Etype (Expr))
27142 -- Conversely, type of expression may be the private one
27144 elsif Is_Private_Type (Base_Type (Etype (Expr)))
27145 and then Full_View (Base_Type (Etype (Expr))) = Expected_Type
27151 -- An interesting special check. If the expression is parenthesized
27152 -- and its type corresponds to the type of the sole component of the
27153 -- expected record type, or to the component type of the expected one
27154 -- dimensional array type, then assume we have a bad aggregate attempt.
27156 if Nkind (Expr) in N_Subexpr
27157 and then Paren_Count (Expr) /= 0
27158 and then Has_One_Matching_Field
27160 Error_Msg_N ("positional aggregate cannot have one component", Expr);
27162 if Present (Matching_Field) then
27163 if Is_Array_Type (Expec_Type) then
27165 ("\write instead `&''First ='> ...`", Expr, Matching_Field);
27168 ("\write instead `& ='> ...`", Expr, Matching_Field);
27172 -- Another special check, if we are looking for a pool-specific access
27173 -- type and we found an E_Access_Attribute_Type, then we have the case
27174 -- of an Access attribute being used in a context which needs a pool-
27175 -- specific type, which is never allowed. The one extra check we make
27176 -- is that the expected designated type covers the Found_Type.
27178 elsif Is_Access_Type (Expec_Type)
27179 and then Ekind (Found_Type) = E_Access_Attribute_Type
27180 and then Ekind (Base_Type (Expec_Type)) /= E_General_Access_Type
27181 and then Ekind (Base_Type (Expec_Type)) /= E_Anonymous_Access_Type
27183 (Designated_Type (Expec_Type), Designated_Type (Found_Type))
27185 Error_Msg_N -- CODEFIX
27186 ("result must be general access type!", Expr);
27187 Error_Msg_NE -- CODEFIX
27188 ("add ALL to }!", Expr, Expec_Type);
27190 -- Another special check, if the expected type is an integer type,
27191 -- but the expression is of type System.Address, and the parent is
27192 -- an addition or subtraction operation whose left operand is the
27193 -- expression in question and whose right operand is of an integral
27194 -- type, then this is an attempt at address arithmetic, so give
27195 -- appropriate message.
27197 elsif Is_Integer_Type (Expec_Type)
27198 and then Is_RTE (Found_Type, RE_Address)
27199 and then Nkind_In (Parent (Expr), N_Op_Add, N_Op_Subtract)
27200 and then Expr = Left_Opnd (Parent (Expr))
27201 and then Is_Integer_Type (Etype (Right_Opnd (Parent (Expr))))
27204 ("address arithmetic not predefined in package System",
27207 ("\possible missing with/use of System.Storage_Elements",
27211 -- If the expected type is an anonymous access type, as for access
27212 -- parameters and discriminants, the error is on the designated types.
27214 elsif Ekind (Expec_Type) = E_Anonymous_Access_Type then
27215 if Comes_From_Source (Expec_Type) then
27216 Error_Msg_NE ("expected}!", Expr, Expec_Type);
27219 ("expected an access type with designated}",
27220 Expr, Designated_Type (Expec_Type));
27223 if Is_Access_Type (Found_Type)
27224 and then not Comes_From_Source (Found_Type)
27227 ("\\found an access type with designated}!",
27228 Expr, Designated_Type (Found_Type));
27230 if From_Limited_With (Found_Type) then
27231 Error_Msg_NE ("\\found incomplete}!", Expr, Found_Type);
27232 Error_Msg_Qual_Level := 99;
27233 Error_Msg_NE -- CODEFIX
27234 ("\\missing `WITH &;", Expr, Scope (Found_Type));
27235 Error_Msg_Qual_Level := 0;
27237 Error_Msg_NE ("found}!", Expr, Found_Type);
27241 -- Normal case of one type found, some other type expected
27244 -- If the names of the two types are the same, see if some number
27245 -- of levels of qualification will help. Don't try more than three
27246 -- levels, and if we get to standard, it's no use (and probably
27247 -- represents an error in the compiler) Also do not bother with
27248 -- internal scope names.
27251 Expec_Scope : Entity_Id;
27252 Found_Scope : Entity_Id;
27255 Expec_Scope := Expec_Type;
27256 Found_Scope := Found_Type;
27258 for Levels in Nat range 0 .. 3 loop
27259 if Chars (Expec_Scope) /= Chars (Found_Scope) then
27260 Error_Msg_Qual_Level := Levels;
27264 Expec_Scope := Scope (Expec_Scope);
27265 Found_Scope := Scope (Found_Scope);
27267 exit when Expec_Scope = Standard_Standard
27268 or else Found_Scope = Standard_Standard
27269 or else not Comes_From_Source (Expec_Scope)
27270 or else not Comes_From_Source (Found_Scope);
27274 if Is_Record_Type (Expec_Type)
27275 and then Present (Corresponding_Remote_Type (Expec_Type))
27277 Error_Msg_NE ("expected}!", Expr,
27278 Corresponding_Remote_Type (Expec_Type));
27280 Error_Msg_NE ("expected}!", Expr, Expec_Type);
27283 if Is_Entity_Name (Expr)
27284 and then Is_Package_Or_Generic_Package (Entity (Expr))
27286 Error_Msg_N ("\\found package name!", Expr);
27288 elsif Is_Entity_Name (Expr)
27289 and then Ekind_In (Entity (Expr), E_Procedure, E_Generic_Procedure)
27291 if Ekind (Expec_Type) = E_Access_Subprogram_Type then
27293 ("found procedure name, possibly missing Access attribute!",
27297 ("\\found procedure name instead of function!", Expr);
27300 elsif Nkind (Expr) = N_Function_Call
27301 and then Ekind (Expec_Type) = E_Access_Subprogram_Type
27302 and then Etype (Designated_Type (Expec_Type)) = Etype (Expr)
27303 and then No (Parameter_Associations (Expr))
27306 ("found function name, possibly missing Access attribute!",
27309 -- Catch common error: a prefix or infix operator which is not
27310 -- directly visible because the type isn't.
27312 elsif Nkind (Expr) in N_Op
27313 and then Is_Overloaded (Expr)
27314 and then not Is_Immediately_Visible (Expec_Type)
27315 and then not Is_Potentially_Use_Visible (Expec_Type)
27316 and then not In_Use (Expec_Type)
27317 and then Has_Compatible_Type (Right_Opnd (Expr), Expec_Type)
27320 ("operator of the type is not directly visible!", Expr);
27322 elsif Ekind (Found_Type) = E_Void
27323 and then Present (Parent (Found_Type))
27324 and then Nkind (Parent (Found_Type)) = N_Full_Type_Declaration
27326 Error_Msg_NE ("\\found premature usage of}!", Expr, Found_Type);
27329 Error_Msg_NE ("\\found}!", Expr, Found_Type);
27332 -- A special check for cases like M1 and M2 = 0 where M1 and M2 are
27333 -- of the same modular type, and (M1 and M2) = 0 was intended.
27335 if Expec_Type = Standard_Boolean
27336 and then Is_Modular_Integer_Type (Found_Type)
27337 and then Nkind_In (Parent (Expr), N_Op_And, N_Op_Or, N_Op_Xor)
27338 and then Nkind (Right_Opnd (Parent (Expr))) in N_Op_Compare
27341 Op : constant Node_Id := Right_Opnd (Parent (Expr));
27342 L : constant Node_Id := Left_Opnd (Op);
27343 R : constant Node_Id := Right_Opnd (Op);
27346 -- The case for the message is when the left operand of the
27347 -- comparison is the same modular type, or when it is an
27348 -- integer literal (or other universal integer expression),
27349 -- which would have been typed as the modular type if the
27350 -- parens had been there.
27352 if (Etype (L) = Found_Type
27354 Etype (L) = Universal_Integer)
27355 and then Is_Integer_Type (Etype (R))
27358 ("\\possible missing parens for modular operation", Expr);
27363 -- Reset error message qualification indication
27365 Error_Msg_Qual_Level := 0;
27369 --------------------------------
27370 -- Yields_Synchronized_Object --
27371 --------------------------------
27373 function Yields_Synchronized_Object (Typ : Entity_Id) return Boolean is
27374 Has_Sync_Comp : Boolean := False;
27378 -- An array type yields a synchronized object if its component type
27379 -- yields a synchronized object.
27381 if Is_Array_Type (Typ) then
27382 return Yields_Synchronized_Object (Component_Type (Typ));
27384 -- A descendant of type Ada.Synchronous_Task_Control.Suspension_Object
27385 -- yields a synchronized object by default.
27387 elsif Is_Descendant_Of_Suspension_Object (Typ) then
27390 -- A protected type yields a synchronized object by default
27392 elsif Is_Protected_Type (Typ) then
27395 -- A record type or type extension yields a synchronized object when its
27396 -- discriminants (if any) lack default values and all components are of
27397 -- a type that yields a synchronized object.
27399 elsif Is_Record_Type (Typ) then
27401 -- Inspect all entities defined in the scope of the type, looking for
27402 -- components of a type that does not yield a synchronized object or
27403 -- for discriminants with default values.
27405 Id := First_Entity (Typ);
27406 while Present (Id) loop
27407 if Comes_From_Source (Id) then
27408 if Ekind (Id) = E_Component then
27409 if Yields_Synchronized_Object (Etype (Id)) then
27410 Has_Sync_Comp := True;
27412 -- The component does not yield a synchronized object
27418 elsif Ekind (Id) = E_Discriminant
27419 and then Present (Expression (Parent (Id)))
27428 -- Ensure that the parent type of a type extension yields a
27429 -- synchronized object.
27431 if Etype (Typ) /= Typ
27432 and then not Is_Private_Type (Etype (Typ))
27433 and then not Yields_Synchronized_Object (Etype (Typ))
27438 -- If we get here, then all discriminants lack default values and all
27439 -- components are of a type that yields a synchronized object.
27441 return Has_Sync_Comp;
27443 -- A synchronized interface type yields a synchronized object by default
27445 elsif Is_Synchronized_Interface (Typ) then
27448 -- A task type yields a synchronized object by default
27450 elsif Is_Task_Type (Typ) then
27453 -- A private type yields a synchronized object if its underlying type
27456 elsif Is_Private_Type (Typ)
27457 and then Present (Underlying_Type (Typ))
27459 return Yields_Synchronized_Object (Underlying_Type (Typ));
27461 -- Otherwise the type does not yield a synchronized object
27466 end Yields_Synchronized_Object;
27468 ---------------------------
27469 -- Yields_Universal_Type --
27470 ---------------------------
27472 function Yields_Universal_Type (N : Node_Id) return Boolean is
27474 -- Integer and real literals are of a universal type
27476 if Nkind_In (N, N_Integer_Literal, N_Real_Literal) then
27479 -- The values of certain attributes are of a universal type
27481 elsif Nkind (N) = N_Attribute_Reference then
27483 Universal_Type_Attribute (Get_Attribute_Id (Attribute_Name (N)));
27485 -- ??? There are possibly other cases to consider
27490 end Yields_Universal_Type;
27492 package body Interval_Lists is
27494 function In_Interval
27495 (Value : Uint; Interval : Discrete_Interval) return Boolean;
27496 -- Does the given value lie within the given interval?
27501 function In_Interval
27502 (Value : Uint; Interval : Discrete_Interval) return Boolean is
27504 return Value >= Interval.Low and then Value <= Interval.High;
27507 procedure Check_Consistency (Intervals : Discrete_Interval_List);
27508 -- Check that list is sorted, lacks null intervals, and has gaps
27509 -- between intervals.
27511 ------------------------
27512 -- Check_Consistency --
27513 ------------------------
27514 procedure Check_Consistency (Intervals : Discrete_Interval_List) is
27516 if Serious_Errors_Detected > 0 then
27520 -- low bound is 1 and high bound equals length
27521 pragma Assert (Intervals'First = 1 and Intervals'Last >= 0);
27522 for Idx in Intervals'Range loop
27523 -- each interval is non-null
27524 pragma Assert (Intervals (Idx).Low <= Intervals (Idx).High);
27525 if Idx /= Intervals'First then
27526 -- intervals are sorted with non-empty gaps between them
27528 (Intervals (Idx - 1).High < (Intervals (Idx).Low - 1));
27532 end Check_Consistency;
27534 function Chosen_Interval (Choice : Node_Id) return Discrete_Interval;
27535 -- Given an element of a Discrete_Choices list, a
27536 -- Static_Discrete_Predicate list, or an Others_Discrete_Choices
27537 -- list (but not an N_Others_Choice node) return the corresponding
27538 -- interval. If an element that does not represent a single
27539 -- contiguous interval due to a static predicate (or which
27540 -- represents a single contiguous interval whose bounds depend on
27541 -- a static predicate) is encountered, then that is an error on the
27542 -- part of whoever built the list in question.
27544 ---------------------
27545 -- Chosen_Interval --
27546 ---------------------
27547 function Chosen_Interval (Choice : Node_Id) return Discrete_Interval is
27549 case Nkind (Choice) is
27551 return (Low => Expr_Value (Low_Bound (Choice)),
27552 High => Expr_Value (High_Bound (Choice)));
27554 when N_Subtype_Indication =>
27556 Range_Exp : constant Node_Id
27557 := Range_Expression (Constraint (Choice));
27559 return (Low => Expr_Value (Low_Bound (Range_Exp)),
27560 High => Expr_Value (High_Bound (Range_Exp)));
27563 when N_Others_Choice =>
27564 raise Program_Error;
27567 if Is_Entity_Name (Choice) and then Is_Type (Entity (Choice))
27570 (Low => Expr_Value (Type_Low_Bound (Entity (Choice))),
27571 High => Expr_Value (Type_High_Bound (Entity (Choice))));
27574 return (Low | High => Expr_Value (Choice));
27577 end Chosen_Interval;
27579 --------------------
27580 -- Type_Intervals --
27581 --------------------
27582 function Type_Intervals
27583 (Typ : Entity_Id) return Discrete_Interval_List
27586 if Has_Static_Predicate (Typ) then
27588 -- No sorting or merging needed
27589 SDP_List : constant List_Id := Static_Discrete_Predicate (Typ);
27590 Range_Or_Expr : Node_Id := First (SDP_List);
27592 Discrete_Interval_List (1 .. List_Length (SDP_List));
27594 for Idx in Result'Range loop
27595 Result (Idx) := Chosen_Interval (Range_Or_Expr);
27596 Range_Or_Expr := Next (Range_Or_Expr);
27598 pragma Assert (not Present (Range_Or_Expr));
27599 Check_Consistency (Result);
27604 Low : constant Uint := Expr_Value (Type_Low_Bound (Typ));
27605 High : constant Uint := Expr_Value (Type_High_Bound (Typ));
27609 Null_Array : Discrete_Interval_List (1 .. 0);
27614 return (1 => (Low => Low, High => High));
27618 end Type_Intervals;
27620 procedure Normalize_Interval_List
27621 (List : in out Discrete_Interval_List; Last : out Nat);
27622 -- Perform sorting and merging as required by Check_Consistency.
27624 -----------------------------
27625 -- Normalize_Interval_List --
27626 -----------------------------
27627 procedure Normalize_Interval_List
27628 (List : in out Discrete_Interval_List; Last : out Nat) is
27630 procedure Move_Interval (From, To : Natural);
27631 -- Copy interval from one location to another
27633 function Lt_Interval (Idx1, Idx2 : Natural) return Boolean;
27634 -- Compare two list elements
27636 Temp_0 : Discrete_Interval := (others => Uint_0);
27637 -- cope with Heap_Sort_G idiosyncrasies.
27639 function Read_Interval (From : Natural) return Discrete_Interval;
27640 -- Normal array indexing unless From = 0
27642 -------------------
27643 -- Read_Interval --
27644 -------------------
27645 function Read_Interval (From : Natural) return Discrete_Interval is
27650 return List (Pos (From));
27654 -------------------
27655 -- Move_Interval --
27656 -------------------
27657 procedure Move_Interval (From, To : Natural) is
27658 Rhs : constant Discrete_Interval := Read_Interval (From);
27663 List (Pos (To)) := Rhs;
27670 function Lt_Interval (Idx1, Idx2 : Natural) return Boolean is
27671 Elem1 : constant Discrete_Interval := Read_Interval (Idx1);
27672 Elem2 : constant Discrete_Interval := Read_Interval (Idx2);
27673 Null_1 : constant Boolean := Elem1.Low > Elem1.High;
27674 Null_2 : constant Boolean := Elem2.Low > Elem2.High;
27676 if Null_1 /= Null_2 then
27677 -- So that sorting moves null intervals to high end
27679 elsif Elem1.Low /= Elem2.Low then
27680 return Elem1.Low < Elem2.Low;
27682 return Elem1.High < Elem2.High;
27686 package Interval_Sorting is
27687 new Gnat.Heap_Sort_G (Move_Interval, Lt_Interval);
27689 function Is_Null (Idx : Pos) return Boolean;
27690 -- True iff List (Idx) defines a null range
27692 function Is_Null (Idx : Pos) return Boolean is
27694 return List (Idx).Low > List (Idx).High;
27697 procedure Merge_Intervals (Null_Interval_Count : out Nat);
27698 -- Merge contiguous ranges by replacing one with merged range
27699 -- and the other with a null value. Return a count of the
27700 -- null intervals, both preexisting and those introduced by
27703 ---------------------
27704 -- Merge_Intervals --
27705 ---------------------
27706 procedure Merge_Intervals (Null_Interval_Count : out Nat) is
27707 Not_Null : Pos range List'Range;
27708 -- Index of the most recently examined non-null interval
27710 Null_Interval : constant Discrete_Interval
27711 := (Low => Uint_1, High => Uint_0); -- any null range ok here
27713 if List'Length = 0 or else Is_Null (List'First) then
27714 Null_Interval_Count := List'Length;
27715 -- no non-null elements, so no merge candidates
27719 Null_Interval_Count := 0;
27720 Not_Null := List'First;
27721 for Idx in List'First + 1 .. List'Last loop
27722 if Is_Null (Idx) then
27723 -- all remaining elements are null
27724 Null_Interval_Count :=
27725 Null_Interval_Count + List (Idx .. List'Last)'Length;
27727 elsif List (Idx).Low = List (Not_Null).High + 1 then
27728 -- Merge the two intervals into one; discard the other
27729 List (Not_Null).High := List (Idx).High;
27730 List (Idx) := Null_Interval;
27731 Null_Interval_Count := Null_Interval_Count + 1;
27733 pragma Assert (List (Idx).Low > List (Not_Null).High);
27737 end Merge_Intervals;
27739 Interval_Sorting.Sort (Natural (List'Last));
27741 Null_Interval_Count : Nat;
27743 Merge_Intervals (Null_Interval_Count);
27744 Last := List'Last - Null_Interval_Count;
27745 if Null_Interval_Count /= 0 then
27746 -- Move null intervals introduced during merging to high end
27747 Interval_Sorting.Sort (Natural (List'Last));
27750 end Normalize_Interval_List;
27752 ---------------------------
27753 -- Choice_List_Intervals --
27754 ---------------------------
27755 function Choice_List_Intervals
27756 (Discrete_Choices : List_Id) return Discrete_Interval_List
27758 function Unmerged_Choice_Count return Nat;
27759 -- The number of intervals before adjacent intervals are merged.
27761 ---------------------------
27762 -- Unmerged_Choice_Count --
27763 ---------------------------
27764 function Unmerged_Choice_Count return Nat is
27765 Choice : Node_Id := First (Discrete_Choices);
27768 while Present (Choice) loop
27769 -- Non-contiguous choices involving static predicates
27770 -- have already been normalized away.
27772 if Nkind (Choice) = N_Others_Choice then
27774 Count + List_Length (Others_Discrete_Choices (Choice));
27776 Count := Count + 1; -- an ordinary expression or range
27779 Choice := Next (Choice);
27782 end Unmerged_Choice_Count;
27784 Choice : Node_Id := First (Discrete_Choices);
27785 Result : Discrete_Interval_List (1 .. Unmerged_Choice_Count);
27788 while Present (Choice) loop
27789 if Nkind (Choice) = N_Others_Choice then
27791 Others_Choice : Node_Id
27792 := First (Others_Discrete_Choices (Choice));
27794 while Present (Others_Choice) loop
27795 Count := Count + 1;
27796 Result (Count) := Chosen_Interval (Others_Choice);
27797 Others_Choice := Next (Others_Choice);
27801 Count := Count + 1;
27802 Result (Count) := Chosen_Interval (Choice);
27804 Choice := Next (Choice);
27806 pragma Assert (Count = Result'Last);
27807 Normalize_Interval_List (Result, Count);
27808 Check_Consistency (Result (1 .. Count));
27809 return Result (1 .. Count);
27810 end Choice_List_Intervals;
27816 (Subset, Of_Set : Discrete_Interval_List) return Boolean
27818 -- Returns True iff for each interval of Subset we can find
27819 -- a single interval of Of_Set which contains the Subset interval.
27821 if Of_Set'Length = 0 then
27822 return Subset'Length = 0;
27826 Set_Index : Pos range Of_Set'Range := Of_Set'First;
27828 for Ss_Idx in Subset'Range loop
27829 while not In_Interval
27830 (Value => Subset (Ss_Idx).Low,
27831 Interval => Of_Set (Set_Index))
27833 if Set_Index = Of_Set'Last then
27836 Set_Index := Set_Index + 1;
27840 (Value => Subset (Ss_Idx).High,
27841 Interval => Of_Set (Set_Index))
27851 end Interval_Lists;
27854 Erroutc.Subprogram_Name_Ptr := Subprogram_Name'Access;