1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2023, 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 Accessibility
; use Accessibility
;
27 with Casing
; use Casing
;
28 with Checks
; use Checks
;
29 with Debug
; use Debug
;
30 with Einfo
.Utils
; use Einfo
.Utils
;
31 with Elists
; use Elists
;
32 with Errout
; use Errout
;
33 with Erroutc
; use Erroutc
;
34 with Exp_Ch6
; use Exp_Ch6
;
35 with Exp_Ch11
; use Exp_Ch11
;
36 with Exp_Util
; use Exp_Util
;
37 with Fname
; use Fname
;
38 with Freeze
; use Freeze
;
39 with Itypes
; use Itypes
;
41 with Lib
.Xref
; use Lib
.Xref
;
42 with Namet
.Sp
; use Namet
.Sp
;
43 with Nlists
; use Nlists
;
44 with Nmake
; use Nmake
;
45 with Output
; use Output
;
46 with Restrict
; use Restrict
;
47 with Rident
; use Rident
;
48 with Rtsfind
; use Rtsfind
;
50 with Sem_Aux
; use Sem_Aux
;
51 with Sem_Attr
; use Sem_Attr
;
52 with Sem_Cat
; use Sem_Cat
;
53 with Sem_Ch6
; use Sem_Ch6
;
54 with Sem_Ch8
; use Sem_Ch8
;
55 with Sem_Ch13
; use Sem_Ch13
;
56 with Sem_Disp
; use Sem_Disp
;
57 with Sem_Elab
; use Sem_Elab
;
58 with Sem_Eval
; use Sem_Eval
;
59 with Sem_Prag
; use Sem_Prag
;
60 with Sem_Res
; use Sem_Res
;
61 with Sem_Warn
; use Sem_Warn
;
62 with Sem_Type
; use Sem_Type
;
63 with Sinfo
; use Sinfo
;
64 with Sinfo
.Nodes
; use Sinfo
.Nodes
;
65 with Sinfo
.Utils
; use Sinfo
.Utils
;
66 with Sinput
; use Sinput
;
67 with Stand
; use Stand
;
69 with Stringt
; use Stringt
;
70 with Targparm
; use Targparm
;
71 with Tbuild
; use Tbuild
;
72 with Ttypes
; use Ttypes
;
73 with Uname
; use Uname
;
74 with Warnsw
; use Warnsw
;
76 with GNAT
.Heap_Sort_G
;
77 with GNAT
.HTable
; use GNAT
.HTable
;
79 package body Sem_Util
is
81 ---------------------------
82 -- Local Data Structures --
83 ---------------------------
85 Invalid_Binder_Values
: array (Scalar_Id
) of Entity_Id
:= (others => Empty
);
86 -- A collection to hold the entities of the variables declared in package
87 -- System.Scalar_Values which describe the invalid values of scalar types.
89 Invalid_Binder_Values_Set
: Boolean := False;
90 -- This flag prevents multiple attempts to initialize Invalid_Binder_Values
92 Invalid_Floats
: array (Float_Scalar_Id
) of Ureal
:= (others => No_Ureal
);
93 -- A collection to hold the invalid values of float types as specified by
94 -- pragma Initialize_Scalars.
96 Invalid_Integers
: array (Integer_Scalar_Id
) of Uint
:= (others => No_Uint
);
97 -- A collection to hold the invalid values of integer types as specified
98 -- by pragma Initialize_Scalars.
100 -----------------------
101 -- Local Subprograms --
102 -----------------------
104 function Build_Component_Subtype
107 T
: Entity_Id
) return Node_Id
;
108 -- This function builds the subtype for Build_Actual_Subtype_Of_Component
109 -- and Build_Discriminal_Subtype_Of_Component. C is a list of constraints,
110 -- Loc is the source location, T is the original subtype.
112 procedure Examine_Array_Bounds
114 All_Static
: out Boolean;
115 Has_Empty
: out Boolean);
116 -- Inspect the index constraints of array type Typ. Flag All_Static is set
117 -- when all ranges are static. Flag Has_Empty is set only when All_Static
118 -- is set and indicates that at least one range is empty.
120 function Has_Enabled_Property
121 (Item_Id
: Entity_Id
;
122 Property
: Name_Id
) return Boolean;
123 -- Subsidiary to routines Async_xxx_Enabled and Effective_xxx_Enabled.
124 -- Determine whether the state abstraction, object, or type denoted by
125 -- entity Item_Id has enabled property Property.
127 function Has_Null_Extension
(T
: Entity_Id
) return Boolean;
128 -- T is a derived tagged type. Check whether the type extension is null.
129 -- If the parent type is fully initialized, T can be treated as such.
131 function Is_Atomic_Object_Entity
(Id
: Entity_Id
) return Boolean;
132 -- Determine whether arbitrary entity Id denotes an atomic object as per
136 with function Is_Effectively_Volatile_Entity
137 (Id
: Entity_Id
) return Boolean;
138 -- Function to use on object and type entities
139 function Is_Effectively_Volatile_Object_Shared
140 (N
: Node_Id
) return Boolean;
141 -- Shared function used to detect effectively volatile objects and
142 -- effectively volatile objects for reading.
144 function Is_Fully_Initialized_Variant
(Typ
: Entity_Id
) return Boolean;
145 -- Subsidiary to Is_Fully_Initialized_Type. For an unconstrained type
146 -- with discriminants whose default values are static, examine only the
147 -- components in the selected variant to determine whether all of them
150 function Is_Preelaborable_Function
(Id
: Entity_Id
) return Boolean;
151 -- Ada 2022: Determine whether the specified function is suitable as the
152 -- name of a call in a preelaborable construct (RM 10.2.1(7/5)).
154 type Null_Status_Kind
is
156 -- This value indicates that a subexpression is known to have a null
157 -- value at compile time.
160 -- This value indicates that a subexpression is known to have a non-null
161 -- value at compile time.
164 -- This value indicates that it cannot be determined at compile time
165 -- whether a subexpression yields a null or non-null value.
167 function Null_Status
(N
: Node_Id
) return Null_Status_Kind
;
168 -- Determine whether subexpression N of an access type yields a null value,
169 -- a non-null value, or the value cannot be determined at compile time. The
170 -- routine does not take simple flow diagnostics into account, it relies on
171 -- static facts such as the presence of null exclusions.
173 function Subprogram_Name
(N
: Node_Id
) return String;
174 -- Return the fully qualified name of the enclosing subprogram for the
175 -- given node N, with file:line:col information appended, e.g.
176 -- "subp:file:line:col", corresponding to the source location of the
177 -- body of the subprogram.
179 -----------------------------
180 -- Abstract_Interface_List --
181 -----------------------------
183 function Abstract_Interface_List
(Typ
: Entity_Id
) return List_Id
is
187 if Is_Concurrent_Type
(Typ
) then
189 -- If we are dealing with a synchronized subtype, go to the base
190 -- type, whose declaration has the interface list.
192 Nod
:= Declaration_Node
(Base_Type
(Typ
));
194 if Nkind
(Nod
) in N_Full_Type_Declaration | 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
314 Scope
: Entity_Id
:= Current_Scope
)
316 Loc
: constant Source_Ptr
:= Sloc
(N
);
319 pragma Assert
(Nkind
(N
) = N_Block_Statement
);
321 -- The block already has a label, return its entity
323 if Present
(Identifier
(N
)) then
324 Id
:= Entity
(Identifier
(N
));
326 -- Create a new block label and set its attributes
329 Id
:= New_Internal_Entity
(E_Block
, Scope
, Loc
, 'B');
330 Set_Etype
(Id
, Standard_Void_Type
);
332 Set_Identifier
(N
, New_Occurrence_Of
(Id
, Loc
));
333 Set_Block_Node
(Id
, Identifier
(N
));
335 end Add_Block_Identifier
;
337 ----------------------------
338 -- Add_Global_Declaration --
339 ----------------------------
341 procedure Add_Global_Declaration
(N
: Node_Id
) is
342 Aux_Node
: constant Node_Id
:= Aux_Decls_Node
(Cunit
(Current_Sem_Unit
));
345 if No
(Declarations
(Aux_Node
)) then
346 Set_Declarations
(Aux_Node
, New_List
);
349 Append_To
(Declarations
(Aux_Node
), N
);
351 end Add_Global_Declaration
;
353 --------------------------------
354 -- Address_Integer_Convert_OK --
355 --------------------------------
357 function Address_Integer_Convert_OK
(T1
, T2
: Entity_Id
) return Boolean is
359 if Allow_Integer_Address
360 and then ((Is_Descendant_Of_Address
(T1
)
361 and then Is_Private_Type
(T1
)
362 and then Is_Integer_Type
(T2
))
364 (Is_Descendant_Of_Address
(T2
)
365 and then Is_Private_Type
(T2
)
366 and then Is_Integer_Type
(T1
)))
372 end Address_Integer_Convert_OK
;
378 function Address_Value
(N
: Node_Id
) return Node_Id
is
383 -- For constant, get constant expression
385 if Is_Entity_Name
(Expr
)
386 and then Ekind
(Entity
(Expr
)) = E_Constant
388 Expr
:= Constant_Value
(Entity
(Expr
));
390 -- For unchecked conversion, get result to convert
392 elsif Nkind
(Expr
) = N_Unchecked_Type_Conversion
then
393 Expr
:= Expression
(Expr
);
395 -- For (common case) of To_Address call, get argument
397 elsif Nkind
(Expr
) = N_Function_Call
398 and then Is_Entity_Name
(Name
(Expr
))
399 and then Is_RTE
(Entity
(Name
(Expr
)), RE_To_Address
)
401 Expr
:= First_Actual
(Expr
);
403 -- We finally have the real expression
417 function Addressable
(V
: Uint
) return Boolean is
423 return V
= Uint_8
or else
427 (V
= Uint_128
and then System_Max_Integer_Size
= 128);
430 function Addressable
(V
: Int
) return Boolean is
436 V
= System_Max_Integer_Size
;
439 ---------------------------------
440 -- Aggregate_Constraint_Checks --
441 ---------------------------------
443 procedure Aggregate_Constraint_Checks
445 Check_Typ
: Entity_Id
)
447 Exp_Typ
: constant Entity_Id
:= Etype
(Exp
);
450 if Raises_Constraint_Error
(Exp
) then
454 -- Ada 2005 (AI-230): Generate a conversion to an anonymous access
455 -- component's type to force the appropriate accessibility checks.
457 -- Ada 2005 (AI-231): Generate conversion to the null-excluding type to
458 -- force the corresponding run-time check
460 if Is_Access_Type
(Check_Typ
)
461 and then Is_Local_Anonymous_Access
(Check_Typ
)
463 Rewrite
(Exp
, Convert_To
(Check_Typ
, Relocate_Node
(Exp
)));
464 Analyze_And_Resolve
(Exp
, Check_Typ
);
465 Check_Unset_Reference
(Exp
);
468 -- What follows is really expansion activity, so check that expansion
469 -- is on and is allowed. In GNATprove mode, we also want check flags to
470 -- be added in the tree, so that the formal verification can rely on
471 -- those to be present. In GNATprove mode for formal verification, some
472 -- treatment typically only done during expansion needs to be performed
473 -- on the tree, but it should not be applied inside generics. Otherwise,
474 -- this breaks the name resolution mechanism for generic instances.
476 if not Expander_Active
477 and not (GNATprove_Mode
and not Inside_A_Generic
)
482 if Is_Access_Type
(Check_Typ
)
483 and then Can_Never_Be_Null
(Check_Typ
)
484 and then not Can_Never_Be_Null
(Exp_Typ
)
486 Install_Null_Excluding_Check
(Exp
);
489 -- First check if we have to insert discriminant checks
491 if Has_Discriminants
(Exp_Typ
) then
492 Apply_Discriminant_Check
(Exp
, Check_Typ
);
494 -- Next emit length checks for array aggregates
496 elsif Is_Array_Type
(Exp_Typ
) then
497 Apply_Length_Check
(Exp
, Check_Typ
);
499 -- Finally emit scalar and string checks. If we are dealing with a
500 -- scalar literal we need to check by hand because the Etype of
501 -- literals is not necessarily correct.
503 elsif Is_Scalar_Type
(Exp_Typ
)
504 and then Compile_Time_Known_Value
(Exp
)
506 if Is_Out_Of_Range
(Exp
, Base_Type
(Check_Typ
)) then
507 Apply_Compile_Time_Constraint_Error
508 (Exp
, "value not in range of}??", CE_Range_Check_Failed
,
509 Ent
=> Base_Type
(Check_Typ
),
510 Typ
=> Base_Type
(Check_Typ
));
512 elsif Is_Out_Of_Range
(Exp
, Check_Typ
) then
513 Apply_Compile_Time_Constraint_Error
514 (Exp
, "value not in range of}??", CE_Range_Check_Failed
,
518 elsif not Range_Checks_Suppressed
(Check_Typ
) then
519 Apply_Scalar_Range_Check
(Exp
, Check_Typ
);
522 -- Verify that target type is also scalar, to prevent view anomalies
523 -- in instantiations.
525 elsif (Is_Scalar_Type
(Exp_Typ
)
526 or else Nkind
(Exp
) = N_String_Literal
)
527 and then Is_Scalar_Type
(Check_Typ
)
528 and then Exp_Typ
/= Check_Typ
530 -- If expression is a constant, it is worthwhile checking whether it
531 -- is a bound of the type.
533 if Is_Entity_Name
(Exp
)
534 and then Ekind
(Entity
(Exp
)) = E_Constant
536 if (Is_Entity_Name
(Type_Low_Bound
(Check_Typ
))
537 and then Entity
(Exp
) = Entity
(Type_Low_Bound
(Check_Typ
)))
539 (Is_Entity_Name
(Type_High_Bound
(Check_Typ
))
540 and then Entity
(Exp
) = Entity
(Type_High_Bound
(Check_Typ
)))
546 -- Change Exp into Check_Typ'(Exp) to ensure that range checks are
547 -- performed at run time.
549 Rewrite
(Exp
, Convert_To
(Check_Typ
, Relocate_Node
(Exp
)));
550 Analyze_And_Resolve
(Exp
, Check_Typ
);
551 Check_Unset_Reference
(Exp
);
554 end Aggregate_Constraint_Checks
;
556 -----------------------
557 -- Alignment_In_Bits --
558 -----------------------
560 function Alignment_In_Bits
(E
: Entity_Id
) return Uint
is
562 return Alignment
(E
) * System_Storage_Unit
;
563 end Alignment_In_Bits
;
565 --------------------------------------
566 -- All_Composite_Constraints_Static --
567 --------------------------------------
569 function All_Composite_Constraints_Static
570 (Constr
: Node_Id
) return Boolean
573 if No
(Constr
) or else Error_Posted
(Constr
) then
577 case Nkind
(Constr
) is
579 if Nkind
(Constr
) in N_Has_Entity
580 and then Present
(Entity
(Constr
))
582 if Is_Type
(Entity
(Constr
)) then
584 not Is_Discrete_Type
(Entity
(Constr
))
585 or else Is_OK_Static_Subtype
(Entity
(Constr
));
588 elsif Nkind
(Constr
) = N_Range
then
590 Is_OK_Static_Expression
(Low_Bound
(Constr
))
592 Is_OK_Static_Expression
(High_Bound
(Constr
));
594 elsif Nkind
(Constr
) = N_Attribute_Reference
595 and then Attribute_Name
(Constr
) = Name_Range
598 Is_OK_Static_Expression
599 (Type_Low_Bound
(Etype
(Prefix
(Constr
))))
601 Is_OK_Static_Expression
602 (Type_High_Bound
(Etype
(Prefix
(Constr
))));
606 No
(Etype
(Constr
)) -- previous error
607 or else not Is_Discrete_Type
(Etype
(Constr
))
608 or else Is_OK_Static_Expression
(Constr
);
610 when N_Discriminant_Association
=>
611 return All_Composite_Constraints_Static
(Expression
(Constr
));
613 when N_Range_Constraint
=>
615 All_Composite_Constraints_Static
(Range_Expression
(Constr
));
617 when N_Index_Or_Discriminant_Constraint
=>
619 One_Cstr
: Entity_Id
;
621 One_Cstr
:= First
(Constraints
(Constr
));
622 while Present
(One_Cstr
) loop
623 if not All_Composite_Constraints_Static
(One_Cstr
) then
633 when N_Subtype_Indication
=>
635 All_Composite_Constraints_Static
(Subtype_Mark
(Constr
))
637 All_Composite_Constraints_Static
(Constraint
(Constr
));
642 end All_Composite_Constraints_Static
;
644 ------------------------
645 -- Append_Entity_Name --
646 ------------------------
648 procedure Append_Entity_Name
(Buf
: in out Bounded_String
; E
: Entity_Id
) is
649 Temp
: Bounded_String
;
651 procedure Inner
(E
: Entity_Id
);
652 -- Inner recursive routine, keep outer routine nonrecursive to ease
653 -- debugging when we get strange results from this routine.
659 procedure Inner
(E
: Entity_Id
) is
663 -- If entity has an internal name, skip by it, and print its scope.
664 -- Note that we strip a final R from the name before the test; this
665 -- is needed for some cases of instantiations.
668 E_Name
: Bounded_String
;
671 Append
(E_Name
, Chars
(E
));
673 if E_Name
.Chars
(E_Name
.Length
) = 'R' then
674 E_Name
.Length
:= E_Name
.Length
- 1;
677 if Is_Internal_Name
(E_Name
) then
685 -- Just print entity name if its scope is at the outer level
687 if Scop
= Standard_Standard
then
690 -- If scope comes from source, write scope and entity
692 elsif Comes_From_Source
(Scop
) then
693 Append_Entity_Name
(Temp
, Scop
);
696 -- If in wrapper package skip past it
698 elsif Present
(Scop
) and then Is_Wrapper_Package
(Scop
) then
699 Append_Entity_Name
(Temp
, Scope
(Scop
));
702 -- Otherwise nothing to output (happens in unnamed block statements)
711 E_Name
: Bounded_String
;
714 Append_Unqualified_Decoded
(E_Name
, Chars
(E
));
716 -- Remove trailing upper-case letters from the name (useful for
717 -- dealing with some cases of internal names generated in the case
718 -- of references from within a generic).
720 while E_Name
.Length
> 1
721 and then E_Name
.Chars
(E_Name
.Length
) in 'A' .. 'Z'
723 E_Name
.Length
:= E_Name
.Length
- 1;
726 -- Adjust casing appropriately (gets name from source if possible)
728 Adjust_Name_Case
(E_Name
, Sloc
(E
));
729 Append
(Temp
, E_Name
);
733 -- Start of processing for Append_Entity_Name
738 end Append_Entity_Name
;
740 ---------------------------------
741 -- Append_Inherited_Subprogram --
742 ---------------------------------
744 procedure Append_Inherited_Subprogram
(S
: Entity_Id
) is
745 Par
: constant Entity_Id
:= Alias
(S
);
746 -- The parent subprogram
748 Scop
: constant Entity_Id
:= Scope
(Par
);
749 -- The scope of definition of the parent subprogram
751 Typ
: constant Entity_Id
:= Defining_Entity
(Parent
(S
));
752 -- The derived type of which S is a primitive operation
758 if Ekind
(Current_Scope
) = E_Package
759 and then In_Private_Part
(Current_Scope
)
760 and then Has_Private_Declaration
(Typ
)
761 and then Is_Tagged_Type
(Typ
)
762 and then Scop
= Current_Scope
764 -- The inherited operation is available at the earliest place after
765 -- the derived type declaration (RM 7.3.1 (6/1)). This is only
766 -- relevant for type extensions. If the parent operation appears
767 -- after the type extension, the operation is not visible.
770 (Visible_Declarations
771 (Package_Specification
(Current_Scope
)));
772 while Present
(Decl
) loop
773 if Nkind
(Decl
) = N_Private_Extension_Declaration
774 and then Defining_Entity
(Decl
) = Typ
776 if Sloc
(Decl
) > Sloc
(Par
) then
777 Next_E
:= Next_Entity
(Par
);
778 Link_Entities
(Par
, S
);
779 Link_Entities
(S
, Next_E
);
791 -- If partial view is not a type extension, or it appears before the
792 -- subprogram declaration, insert normally at end of entity list.
794 Append_Entity
(S
, Current_Scope
);
795 end Append_Inherited_Subprogram
;
797 -----------------------------------------
798 -- Apply_Compile_Time_Constraint_Error --
799 -----------------------------------------
801 procedure Apply_Compile_Time_Constraint_Error
804 Reason
: RT_Exception_Code
;
805 Ent
: Entity_Id
:= Empty
;
806 Typ
: Entity_Id
:= Empty
;
807 Loc
: Source_Ptr
:= No_Location
;
808 Warn
: Boolean := False;
809 Emit_Message
: Boolean := True)
811 Stat
: constant Boolean := Is_Static_Expression
(N
);
812 R_Stat
: constant Node_Id
:=
813 Make_Raise_Constraint_Error
(Sloc
(N
), Reason
=> Reason
);
825 (Compile_Time_Constraint_Error
(N
, Msg
, Ent
, Loc
, Warn
=> Warn
));
828 -- Now we replace the node by an N_Raise_Constraint_Error node
829 -- This does not need reanalyzing, so set it as analyzed now.
832 Set_Analyzed
(N
, True);
835 Set_Raises_Constraint_Error
(N
);
837 -- Now deal with possible local raise handling
839 Possible_Local_Raise
(N
, Standard_Constraint_Error
);
841 -- If the original expression was marked as static, the result is
842 -- still marked as static, but the Raises_Constraint_Error flag is
843 -- always set so that further static evaluation is not attempted.
846 Set_Is_Static_Expression
(N
);
848 end Apply_Compile_Time_Constraint_Error
;
850 ---------------------------
851 -- Async_Readers_Enabled --
852 ---------------------------
854 function Async_Readers_Enabled
(Id
: Entity_Id
) return Boolean is
856 return Has_Enabled_Property
(Id
, Name_Async_Readers
);
857 end Async_Readers_Enabled
;
859 ---------------------------
860 -- Async_Writers_Enabled --
861 ---------------------------
863 function Async_Writers_Enabled
(Id
: Entity_Id
) return Boolean is
865 return Has_Enabled_Property
(Id
, Name_Async_Writers
);
866 end Async_Writers_Enabled
;
868 --------------------------------------
869 -- Available_Full_View_Of_Component --
870 --------------------------------------
872 function Available_Full_View_Of_Component
(T
: Entity_Id
) return Boolean is
873 ST
: constant Entity_Id
:= Scope
(T
);
874 SCT
: constant Entity_Id
:= Scope
(Component_Type
(T
));
876 return In_Open_Scopes
(ST
)
877 and then In_Open_Scopes
(SCT
)
878 and then Scope_Depth
(ST
) >= Scope_Depth
(SCT
);
879 end Available_Full_View_Of_Component
;
888 Warn
: Boolean := False)
891 Error_Msg_Warn
:= Warn
;
892 Error_Msg_N
("<<& is not a valid aspect identifier", N
);
894 -- Check bad spelling
895 Error_Msg_Name_1
:= Aspect_Spell_Check
(Nam
);
896 if Error_Msg_Name_1
/= No_Name
then
897 Error_Msg_N
-- CODEFIX
898 ("\<<possible misspelling of %", N
);
906 procedure Bad_Attribute
909 Warn
: Boolean := False)
912 Error_Msg_Warn
:= Warn
;
913 Error_Msg_N
("<<unrecognized attribute&", N
);
915 -- Check for possible misspelling
917 Error_Msg_Name_1
:= Attribute_Spell_Check
(Nam
);
918 if Error_Msg_Name_1
/= No_Name
then
919 Error_Msg_N
-- CODEFIX
920 ("\<<possible misspelling of %", N
);
924 --------------------------------
925 -- Bad_Predicated_Subtype_Use --
926 --------------------------------
928 procedure Bad_Predicated_Subtype_Use
932 Suggest_Static
: Boolean := False)
937 -- Avoid cascaded errors
939 if Error_Posted
(N
) then
943 if Inside_A_Generic
then
944 Gen
:= Current_Scope
;
945 while Present
(Gen
) and then Ekind
(Gen
) /= E_Generic_Package
loop
953 if Is_Generic_Formal
(Typ
) and then Is_Discrete_Type
(Typ
) then
954 Set_No_Predicate_On_Actual
(Typ
);
957 elsif Has_Predicates
(Typ
) then
958 if Is_Generic_Actual_Type
(Typ
) then
960 -- The restriction on loop parameters is only that the type
961 -- should only have static predicates.
963 if Nkind
(Parent
(N
)) = N_Loop_Parameter_Specification
964 and then not Has_Dynamic_Predicate_Aspect
(Typ
)
965 and then not Has_Ghost_Predicate_Aspect
(Typ
)
966 and then Is_OK_Static_Subtype
(Typ
)
971 Gen
:= Current_Scope
;
972 while not Is_Generic_Instance
(Gen
) loop
976 pragma Assert
(Present
(Gen
));
978 if Ekind
(Gen
) = E_Package
and then In_Package_Body
(Gen
) then
979 Error_Msg_Warn
:= SPARK_Mode
/= On
;
980 Error_Msg_FE
(Msg
& "<<", N
, Typ
);
981 Error_Msg_F
("\Program_Error [<<", N
);
984 Make_Raise_Program_Error
(Sloc
(N
),
985 Reason
=> PE_Bad_Predicated_Generic_Type
));
988 Error_Msg_FE
(Msg
, N
, Typ
);
992 Error_Msg_FE
(Msg
, N
, Typ
);
995 -- Suggest to use First_Valid/Last_Valid instead of First/Last/Range
996 -- if the predicate is static.
998 if not Has_Dynamic_Predicate_Aspect
(Typ
)
999 and then not Has_Ghost_Predicate_Aspect
(Typ
)
1000 and then Has_Static_Predicate
(Typ
)
1001 and then Nkind
(N
) = N_Attribute_Reference
1004 Aname
: constant Name_Id
:= Attribute_Name
(N
);
1005 Attr_Id
: constant Attribute_Id
:= Get_Attribute_Id
(Aname
);
1008 when Attribute_First
=>
1009 Error_Msg_F
("\use attribute First_Valid instead", N
);
1010 when Attribute_Last
=>
1011 Error_Msg_F
("\use attribute Last_Valid instead", N
);
1012 when Attribute_Range
=>
1013 Error_Msg_F
("\use attributes First_Valid and "
1014 & "Last_Valid instead", N
);
1021 -- Emit an optional suggestion on how to remedy the error if the
1022 -- context warrants it.
1024 if Suggest_Static
and then Has_Static_Predicate
(Typ
) then
1025 Error_Msg_FE
("\predicate of & should be marked static", N
, Typ
);
1028 end Bad_Predicated_Subtype_Use
;
1030 -----------------------------------------
1031 -- Bad_Unordered_Enumeration_Reference --
1032 -----------------------------------------
1034 function Bad_Unordered_Enumeration_Reference
1036 T
: Entity_Id
) return Boolean
1039 return Is_Enumeration_Type
(T
)
1040 and then Warn_On_Unordered_Enumeration_Type
1041 and then not Is_Generic_Type
(T
)
1042 and then Comes_From_Source
(N
)
1043 and then not Has_Pragma_Ordered
(T
)
1044 and then not In_Same_Extended_Unit
(N
, T
);
1045 end Bad_Unordered_Enumeration_Reference
;
1047 ----------------------------
1048 -- Begin_Keyword_Location --
1049 ----------------------------
1051 function Begin_Keyword_Location
(N
: Node_Id
) return Source_Ptr
is
1063 HSS
:= Handled_Statement_Sequence
(N
);
1065 -- When the handled sequence of statements comes from source, the
1066 -- location of the "begin" keyword is that of the sequence itself.
1067 -- Note that an internal construct may inherit a source sequence.
1069 if Comes_From_Source
(HSS
) then
1072 -- The parser generates an internal handled sequence of statements to
1073 -- capture the location of the "begin" keyword if present in the source.
1074 -- Since there are no source statements, the location of the "begin"
1075 -- keyword is effectively that of the "end" keyword.
1077 elsif Comes_From_Source
(N
) then
1080 -- Otherwise the construct is internal and should carry the location of
1081 -- the original construct which prompted its creation.
1086 end Begin_Keyword_Location
;
1088 --------------------------
1089 -- Build_Actual_Subtype --
1090 --------------------------
1092 function Build_Actual_Subtype
1094 N
: Node_Or_Entity_Id
) return Node_Id
1097 -- Normally Sloc (N), but may point to corresponding body in some cases
1099 Constraints
: List_Id
;
1105 Disc_Type
: Entity_Id
;
1112 if Nkind
(N
) = N_Defining_Identifier
then
1113 Obj
:= New_Occurrence_Of
(N
, Loc
);
1115 -- If this is a formal parameter of a subprogram declaration, and
1116 -- we are compiling the body, we want the declaration for the
1117 -- actual subtype to carry the source position of the body, to
1118 -- prevent anomalies in gdb when stepping through the code.
1120 if Is_Formal
(N
) then
1122 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Scope
(N
));
1124 if Nkind
(Decl
) = N_Subprogram_Declaration
1125 and then Present
(Corresponding_Body
(Decl
))
1127 Loc
:= Sloc
(Corresponding_Body
(Decl
));
1136 if Is_Array_Type
(T
) then
1137 Constraints
:= New_List
;
1138 Index
:= First_Index
(T
);
1140 for J
in 1 .. Number_Dimensions
(T
) loop
1142 -- Build an array subtype declaration with the nominal subtype and
1143 -- the bounds of the actual. Add the declaration in front of the
1144 -- local declarations for the subprogram, for analysis before any
1145 -- reference to the formal in the body.
1147 -- If this is for an index with a fixed lower bound, then use
1148 -- the fixed lower bound as the lower bound of the actual
1149 -- subtype's corresponding index.
1151 if not Is_Constrained
(T
)
1152 and then Is_Fixed_Lower_Bound_Index_Subtype
(Etype
(Index
))
1154 Lo
:= New_Copy_Tree
(Type_Low_Bound
(Etype
(Index
)));
1158 Make_Attribute_Reference
(Loc
,
1160 Duplicate_Subexpr_No_Checks
(Obj
, Name_Req
=> True),
1161 Attribute_Name
=> Name_First
,
1162 Expressions
=> New_List
(
1163 Make_Integer_Literal
(Loc
, J
)));
1167 Make_Attribute_Reference
(Loc
,
1169 Duplicate_Subexpr_No_Checks
(Obj
, Name_Req
=> True),
1170 Attribute_Name
=> Name_Last
,
1171 Expressions
=> New_List
(
1172 Make_Integer_Literal
(Loc
, J
)));
1174 Append
(Make_Range
(Loc
, Lo
, Hi
), Constraints
);
1179 -- If the type has unknown discriminants there is no constrained
1180 -- subtype to build. This is never called for a formal or for a
1181 -- lhs, so returning the type is ok ???
1183 elsif Has_Unknown_Discriminants
(T
) then
1187 Constraints
:= New_List
;
1189 -- Type T is a generic derived type, inherit the discriminants from
1192 if Is_Private_Type
(T
)
1193 and then No
(Full_View
(T
))
1195 -- T was flagged as an error if it was declared as a formal
1196 -- derived type with known discriminants. In this case there
1197 -- is no need to look at the parent type since T already carries
1198 -- its own discriminants.
1200 and then not Error_Posted
(T
)
1202 Disc_Type
:= Etype
(Base_Type
(T
));
1207 Discr
:= First_Discriminant
(Disc_Type
);
1208 while Present
(Discr
) loop
1209 Append_To
(Constraints
,
1210 Make_Selected_Component
(Loc
,
1212 Duplicate_Subexpr_No_Checks
(Obj
),
1213 Selector_Name
=> New_Occurrence_Of
(Discr
, Loc
)));
1214 Next_Discriminant
(Discr
);
1218 Subt
:= Make_Temporary
(Loc
, 'S', Related_Node
=> N
);
1219 Set_Is_Internal
(Subt
);
1222 Make_Subtype_Declaration
(Loc
,
1223 Defining_Identifier
=> Subt
,
1224 Subtype_Indication
=>
1225 Make_Subtype_Indication
(Loc
,
1226 Subtype_Mark
=> New_Occurrence_Of
(T
, Loc
),
1228 Make_Index_Or_Discriminant_Constraint
(Loc
,
1229 Constraints
=> Constraints
)));
1231 Mark_Rewrite_Insertion
(Decl
);
1233 end Build_Actual_Subtype
;
1235 ---------------------------------------
1236 -- Build_Actual_Subtype_Of_Component --
1237 ---------------------------------------
1239 function Build_Actual_Subtype_Of_Component
1241 N
: Node_Id
) return Node_Id
1243 Loc
: constant Source_Ptr
:= Sloc
(N
);
1244 P
: constant Node_Id
:= Prefix
(N
);
1248 Index_Typ
: Entity_Id
;
1249 Sel
: Entity_Id
:= Empty
;
1251 Desig_Typ
: Entity_Id
;
1252 -- This is either a copy of T, or if T is an access type, then it is
1253 -- the directly designated type of this access type.
1255 function Build_Access_Record_Constraint
(C
: List_Id
) return List_Id
;
1256 -- If the record component is a constrained access to the current
1257 -- record, the subtype has not been constructed during analysis of
1258 -- the enclosing record type (see Analyze_Access). In that case, build
1259 -- a constrained access subtype after replacing references to the
1260 -- enclosing discriminants with the corresponding discriminant values
1263 function Build_Actual_Array_Constraint
return List_Id
;
1264 -- If one or more of the bounds of the component depends on
1265 -- discriminants, build actual constraint using the discriminants
1266 -- of the prefix, as above.
1268 function Build_Actual_Record_Constraint
return List_Id
;
1269 -- Similar to previous one, for discriminated components constrained
1270 -- by the discriminant of the enclosing object.
1272 function Build_Discriminant_Reference
1273 (Discrim_Name
: Node_Id
; Obj
: Node_Id
:= P
) return Node_Id
;
1274 -- Build a reference to the discriminant denoted by Discrim_Name.
1275 -- The prefix of the result is usually Obj, but it could be
1276 -- a prefix of Obj in some corner cases.
1278 function Copy_And_Maybe_Dereference
(N
: Node_Id
) return Node_Id
;
1279 -- Copy the subtree rooted at N and insert an explicit dereference if it
1280 -- is of an access type.
1282 -----------------------------------
1283 -- Build_Actual_Array_Constraint --
1284 -----------------------------------
1286 function Build_Actual_Array_Constraint
return List_Id
is
1287 Constraints
: constant List_Id
:= New_List
;
1295 Indx
:= First_Index
(Desig_Typ
);
1296 while Present
(Indx
) loop
1297 Old_Lo
:= Type_Low_Bound
(Etype
(Indx
));
1298 Old_Hi
:= Type_High_Bound
(Etype
(Indx
));
1300 if Denotes_Discriminant
(Old_Lo
) then
1301 Lo
:= Build_Discriminant_Reference
(Old_Lo
);
1303 Lo
:= New_Copy_Tree
(Old_Lo
);
1305 -- The new bound will be reanalyzed in the enclosing
1306 -- declaration. For literal bounds that come from a type
1307 -- declaration, the type of the context must be imposed, so
1308 -- insure that analysis will take place. For non-universal
1309 -- types this is not strictly necessary.
1311 Set_Analyzed
(Lo
, False);
1314 if Denotes_Discriminant
(Old_Hi
) then
1315 Hi
:= Build_Discriminant_Reference
(Old_Hi
);
1317 Hi
:= New_Copy_Tree
(Old_Hi
);
1318 Set_Analyzed
(Hi
, False);
1321 Append
(Make_Range
(Loc
, Lo
, Hi
), Constraints
);
1326 end Build_Actual_Array_Constraint
;
1328 ------------------------------------
1329 -- Build_Actual_Record_Constraint --
1330 ------------------------------------
1332 function Build_Actual_Record_Constraint
return List_Id
is
1333 Constraints
: constant List_Id
:= New_List
;
1338 D
:= First_Elmt
(Discriminant_Constraint
(Desig_Typ
));
1339 while Present
(D
) loop
1340 if Denotes_Discriminant
(Node
(D
)) then
1341 D_Val
:= Build_Discriminant_Reference
(Node
(D
));
1343 D_Val
:= New_Copy_Tree
(Node
(D
));
1346 Append
(D_Val
, Constraints
);
1351 end Build_Actual_Record_Constraint
;
1353 ----------------------------------
1354 -- Build_Discriminant_Reference --
1355 ----------------------------------
1357 function Build_Discriminant_Reference
1358 (Discrim_Name
: Node_Id
; Obj
: Node_Id
:= P
) return Node_Id
1360 Discrim
: constant Entity_Id
:= Entity
(Discrim_Name
);
1362 function Obj_Is_Good_Prefix
return Boolean;
1363 -- Returns True if Obj.Discrim makes sense; that is, if
1364 -- Obj has Discrim as one of its discriminants (or is an
1365 -- access value that designates such an object).
1367 ------------------------
1368 -- Obj_Is_Good_Prefix --
1369 ------------------------
1371 function Obj_Is_Good_Prefix
return Boolean is
1372 Obj_Type
: Entity_Id
:=
1373 Implementation_Base_Type
(Etype
(Obj
));
1375 Discriminated_Type
: constant Entity_Id
:=
1376 Implementation_Base_Type
1377 (Scope
(Original_Record_Component
(Discrim
)));
1379 -- The order of the following two tests matters in the
1380 -- access-to-class-wide case.
1382 if Is_Access_Type
(Obj_Type
) then
1383 Obj_Type
:= Implementation_Base_Type
1384 (Designated_Type
(Obj_Type
));
1387 if Is_Class_Wide_Type
(Obj_Type
) then
1388 Obj_Type
:= Implementation_Base_Type
1389 (Find_Specific_Type
(Obj_Type
));
1392 -- If a type T1 defines a discriminant D1, then Obj.D1 is ok (for
1393 -- our purposes here) if T1 is an ancestor of the type of Obj.
1394 -- So that's what we would like to test for here.
1395 -- The bad news: Is_Ancestor is only defined in the tagged case.
1396 -- The good news: in the untagged case, Implementation_Base_Type
1397 -- looks through derived types so we can use a simpler test.
1399 if Is_Tagged_Type
(Discriminated_Type
) then
1400 return Is_Ancestor
(Discriminated_Type
, Obj_Type
);
1402 return Discriminated_Type
= Obj_Type
;
1404 end Obj_Is_Good_Prefix
;
1406 -- Start of processing for Build_Discriminant_Reference
1409 if not Obj_Is_Good_Prefix
then
1410 -- If the given discriminant is not a component of the given
1411 -- object, then try the enclosing object.
1413 if Nkind
(Obj
) = N_Selected_Component
then
1414 return Build_Discriminant_Reference
1415 (Discrim_Name
=> Discrim_Name
,
1416 Obj
=> Prefix
(Obj
));
1417 elsif Nkind
(Obj
) in N_Has_Entity
1418 and then Nkind
(Parent
(Entity
(Obj
))) =
1419 N_Object_Renaming_Declaration
1421 -- Look through a renaming (a corner case of a corner case).
1422 return Build_Discriminant_Reference
1423 (Discrim_Name
=> Discrim_Name
,
1424 Obj
=> Name
(Parent
(Entity
(Obj
))));
1426 -- We are in some unexpected case here, so revert to the
1427 -- old behavior (by falling through to it).
1432 return Make_Selected_Component
(Loc
,
1433 Prefix
=> Copy_And_Maybe_Dereference
(Obj
),
1434 Selector_Name
=> New_Occurrence_Of
(Discrim
, Loc
));
1435 end Build_Discriminant_Reference
;
1437 ------------------------------------
1438 -- Build_Access_Record_Constraint --
1439 ------------------------------------
1441 function Build_Access_Record_Constraint
(C
: List_Id
) return List_Id
is
1442 Constraints
: constant List_Id
:= New_List
;
1447 -- Retrieve the constraint from the component declaration, because
1448 -- the component subtype has not been constructed and the component
1449 -- type is an unconstrained access.
1452 while Present
(D
) loop
1453 if Nkind
(D
) = N_Discriminant_Association
1454 and then Denotes_Discriminant
(Expression
(D
))
1456 D_Val
:= New_Copy_Tree
(D
);
1457 Set_Expression
(D_Val
,
1458 Make_Selected_Component
(Loc
,
1459 Prefix
=> Copy_And_Maybe_Dereference
(P
),
1461 New_Occurrence_Of
(Entity
(Expression
(D
)), Loc
)));
1463 elsif Denotes_Discriminant
(D
) then
1464 D_Val
:= Make_Selected_Component
(Loc
,
1465 Prefix
=> Copy_And_Maybe_Dereference
(P
),
1466 Selector_Name
=> New_Occurrence_Of
(Entity
(D
), Loc
));
1469 D_Val
:= New_Copy_Tree
(D
);
1472 Append
(D_Val
, Constraints
);
1477 end Build_Access_Record_Constraint
;
1479 --------------------------------
1480 -- Copy_And_Maybe_Dereference --
1481 --------------------------------
1483 function Copy_And_Maybe_Dereference
(N
: Node_Id
) return Node_Id
is
1484 New_N
: constant Node_Id
:= New_Copy_Tree
(N
);
1487 if Is_Access_Type
(Etype
(N
)) then
1488 return Make_Explicit_Dereference
(Sloc
(Parent
(N
)), New_N
);
1493 end Copy_And_Maybe_Dereference
;
1495 -- Start of processing for Build_Actual_Subtype_Of_Component
1498 -- The subtype does not need to be created for a selected component
1499 -- in a Spec_Expression.
1501 if In_Spec_Expression
then
1504 -- More comments for the rest of this body would be good ???
1506 elsif Nkind
(N
) = N_Explicit_Dereference
then
1507 if Is_Composite_Type
(T
)
1508 and then not Is_Constrained
(T
)
1509 and then not (Is_Class_Wide_Type
(T
)
1510 and then Is_Constrained
(Root_Type
(T
)))
1511 and then not Has_Unknown_Discriminants
(T
)
1513 -- If the type of the dereference is already constrained, it is an
1516 if Is_Array_Type
(Etype
(N
))
1517 and then Is_Constrained
(Etype
(N
))
1521 Remove_Side_Effects
(P
);
1522 return Build_Actual_Subtype
(T
, N
);
1529 elsif Nkind
(N
) = N_Selected_Component
then
1530 -- The entity of the selected component allows us to retrieve
1531 -- the original constraint from its component declaration.
1533 Sel
:= Entity
(Selector_Name
(N
));
1534 if Parent_Kind
(Sel
) /= N_Component_Declaration
then
1539 if Is_Access_Type
(T
) then
1540 Desig_Typ
:= Designated_Type
(T
);
1546 if Ekind
(Desig_Typ
) = E_Array_Subtype
then
1547 Id
:= First_Index
(Desig_Typ
);
1549 -- Check whether an index bound is constrained by a discriminant
1551 while Present
(Id
) loop
1552 Index_Typ
:= Underlying_Type
(Etype
(Id
));
1554 if Denotes_Discriminant
(Type_Low_Bound
(Index_Typ
))
1556 Denotes_Discriminant
(Type_High_Bound
(Index_Typ
))
1558 Remove_Side_Effects
(P
);
1560 Build_Component_Subtype
1561 (Build_Actual_Array_Constraint
, Loc
, Base_Type
(T
));
1567 elsif Is_Composite_Type
(Desig_Typ
)
1568 and then Has_Discriminants
(Desig_Typ
)
1569 and then not Is_Empty_Elmt_List
(Discriminant_Constraint
(Desig_Typ
))
1570 and then not Has_Unknown_Discriminants
(Desig_Typ
)
1572 if Is_Private_Type
(Desig_Typ
)
1573 and then No
(Discriminant_Constraint
(Desig_Typ
))
1575 Desig_Typ
:= Full_View
(Desig_Typ
);
1578 D
:= First_Elmt
(Discriminant_Constraint
(Desig_Typ
));
1579 while Present
(D
) loop
1580 if Denotes_Discriminant
(Node
(D
)) then
1581 Remove_Side_Effects
(P
);
1583 Build_Component_Subtype
(
1584 Build_Actual_Record_Constraint
, Loc
, Base_Type
(T
));
1590 -- Special processing for an access record component that is
1591 -- the target of an assignment. If the designated type is an
1592 -- unconstrained discriminated record we create its actual
1595 elsif Ekind
(T
) = E_Access_Type
1596 and then Present
(Sel
)
1597 and then Has_Per_Object_Constraint
(Sel
)
1598 and then Nkind
(Parent
(N
)) = N_Assignment_Statement
1599 and then N
= Name
(Parent
(N
))
1600 -- and then not Inside_Init_Proc
1601 -- and then Has_Discriminants (Desig_Typ)
1602 -- and then not Is_Constrained (Desig_Typ)
1605 S_Indic
: constant Node_Id
:=
1607 (Component_Definition
(Parent
(Sel
))));
1610 if Nkind
(S_Indic
) = N_Subtype_Indication
then
1611 Discs
:= Constraints
(Constraint
(S_Indic
));
1613 Remove_Side_Effects
(P
);
1614 return Build_Component_Subtype
1615 (Build_Access_Record_Constraint
(Discs
), Loc
, T
);
1622 -- If none of the above, the actual and nominal subtypes are the same
1625 end Build_Actual_Subtype_Of_Component
;
1627 -----------------------------
1628 -- Build_Component_Subtype --
1629 -----------------------------
1631 function Build_Component_Subtype
1634 T
: Entity_Id
) return Node_Id
1640 -- Unchecked_Union components do not require component subtypes
1642 if Is_Unchecked_Union
(T
) then
1646 Subt
:= Make_Temporary
(Loc
, 'S');
1647 Set_Is_Internal
(Subt
);
1650 Make_Subtype_Declaration
(Loc
,
1651 Defining_Identifier
=> Subt
,
1652 Subtype_Indication
=>
1653 Make_Subtype_Indication
(Loc
,
1654 Subtype_Mark
=> New_Occurrence_Of
(Base_Type
(T
), Loc
),
1656 Make_Index_Or_Discriminant_Constraint
(Loc
,
1657 Constraints
=> C
)));
1659 Mark_Rewrite_Insertion
(Decl
);
1661 end Build_Component_Subtype
;
1663 -----------------------------
1664 -- Build_Constrained_Itype --
1665 -----------------------------
1667 procedure Build_Constrained_Itype
1670 New_Assoc_List
: List_Id
)
1672 Constrs
: constant List_Id
:= New_List
;
1673 Loc
: constant Source_Ptr
:= Sloc
(N
);
1676 New_Assoc
: Node_Id
;
1677 Subtyp_Decl
: Node_Id
;
1680 New_Assoc
:= First
(New_Assoc_List
);
1681 while Present
(New_Assoc
) loop
1683 -- There is exactly one choice in the component association (and
1684 -- it is either a discriminant, a component or the others clause).
1685 pragma Assert
(List_Length
(Choices
(New_Assoc
)) = 1);
1687 -- Duplicate expression for the discriminant and put it on the
1688 -- list of constraints for the itype declaration.
1690 if Is_Entity_Name
(First
(Choices
(New_Assoc
)))
1692 Ekind
(Entity
(First
(Choices
(New_Assoc
)))) = E_Discriminant
1694 Append_To
(Constrs
, Duplicate_Subexpr
(Expression
(New_Assoc
)));
1700 if Has_Unknown_Discriminants
(Typ
)
1701 and then Present
(Underlying_Record_View
(Typ
))
1704 Make_Subtype_Indication
(Loc
,
1706 New_Occurrence_Of
(Underlying_Record_View
(Typ
), Loc
),
1708 Make_Index_Or_Discriminant_Constraint
(Loc
,
1709 Constraints
=> Constrs
));
1712 Make_Subtype_Indication
(Loc
,
1714 New_Occurrence_Of
(Base_Type
(Typ
), Loc
),
1716 Make_Index_Or_Discriminant_Constraint
(Loc
,
1717 Constraints
=> Constrs
));
1720 Def_Id
:= Create_Itype
(Ekind
(Typ
), N
);
1723 Make_Subtype_Declaration
(Loc
,
1724 Defining_Identifier
=> Def_Id
,
1725 Subtype_Indication
=> Indic
);
1726 Set_Parent
(Subtyp_Decl
, Parent
(N
));
1728 -- Itypes must be analyzed with checks off (see itypes.ads)
1730 Analyze
(Subtyp_Decl
, Suppress
=> All_Checks
);
1732 Set_Etype
(N
, Def_Id
);
1733 end Build_Constrained_Itype
;
1735 ---------------------------
1736 -- Build_Default_Subtype --
1737 ---------------------------
1739 function Build_Default_Subtype
1741 N
: Node_Id
) return Entity_Id
1743 Loc
: constant Source_Ptr
:= Sloc
(N
);
1747 -- The base type that is to be constrained by the defaults
1750 if not Has_Discriminants
(T
) or else Is_Constrained
(T
) then
1754 Bas
:= Base_Type
(T
);
1756 -- If T is non-private but its base type is private, this is the
1757 -- completion of a subtype declaration whose parent type is private
1758 -- (see Complete_Private_Subtype in Sem_Ch3). The proper discriminants
1759 -- are to be found in the full view of the base. Check that the private
1760 -- status of T and its base differ.
1762 if Is_Private_Type
(Bas
)
1763 and then not Is_Private_Type
(T
)
1764 and then Present
(Full_View
(Bas
))
1766 Bas
:= Full_View
(Bas
);
1769 Disc
:= First_Discriminant
(T
);
1771 if No
(Discriminant_Default_Value
(Disc
)) then
1776 Act
: constant Entity_Id
:= Make_Temporary
(Loc
, 'S');
1777 Constraints
: constant List_Id
:= New_List
;
1781 while Present
(Disc
) loop
1782 Append_To
(Constraints
,
1783 New_Copy_Tree
(Discriminant_Default_Value
(Disc
)));
1784 Next_Discriminant
(Disc
);
1788 Make_Subtype_Declaration
(Loc
,
1789 Defining_Identifier
=> Act
,
1790 Subtype_Indication
=>
1791 Make_Subtype_Indication
(Loc
,
1792 Subtype_Mark
=> New_Occurrence_Of
(Bas
, Loc
),
1794 Make_Index_Or_Discriminant_Constraint
(Loc
,
1795 Constraints
=> Constraints
)));
1797 Insert_Action
(N
, Decl
);
1799 -- If the context is a component declaration the subtype declaration
1800 -- will be analyzed when the enclosing type is frozen, otherwise do
1803 if Ekind
(Current_Scope
) /= E_Record_Type
then
1809 end Build_Default_Subtype
;
1811 ------------------------------
1812 -- Build_Default_Subtype_OK --
1813 ------------------------------
1815 function Build_Default_Subtype_OK
(T
: Entity_Id
) return Boolean is
1817 function Default_Discriminant_Values_Known_At_Compile_Time
1818 (T
: Entity_Id
) return Boolean;
1819 -- For an unconstrained type T, return False if the given type has a
1820 -- discriminant with default value not known at compile time. Return
1823 ---------------------------------------------------------
1824 -- Default_Discriminant_Values_Known_At_Compile_Time --
1825 ---------------------------------------------------------
1827 function Default_Discriminant_Values_Known_At_Compile_Time
1828 (T
: Entity_Id
) return Boolean
1835 -- If the type has no discriminant, we know them all at compile time
1837 if not Has_Discriminants
(T
) then
1841 -- The type has discriminants, check that none of them has a default
1842 -- value not known at compile time.
1844 Discr
:= First_Discriminant
(T
);
1846 while Present
(Discr
) loop
1847 DDV
:= Discriminant_Default_Value
(Discr
);
1849 if Present
(DDV
) and then not Compile_Time_Known_Value
(DDV
) then
1853 Next_Discriminant
(Discr
);
1857 end Default_Discriminant_Values_Known_At_Compile_Time
;
1859 -- Start of processing for Build_Default_Subtype_OK
1863 if Is_Constrained
(T
) then
1865 -- We won't build a new subtype if T is constrained
1870 if not Default_Discriminant_Values_Known_At_Compile_Time
(T
) then
1872 -- This is a special case of definite subtypes. To allocate a
1873 -- specific size to the subtype, we need to know the value at compile
1874 -- time. This might not be the case if the default value is the
1875 -- result of a function. In that case, the object might be definite
1876 -- and limited but the needed size might not be statically known or
1877 -- too tricky to obtain. In that case, we will not build the subtype.
1882 return Is_Definite_Subtype
(T
) and then Is_Limited_View
(T
);
1883 end Build_Default_Subtype_OK
;
1885 --------------------------------------------
1886 -- Build_Discriminal_Subtype_Of_Component --
1887 --------------------------------------------
1889 function Build_Discriminal_Subtype_Of_Component
1890 (T
: Entity_Id
) return Node_Id
1892 Loc
: constant Source_Ptr
:= Sloc
(T
);
1896 function Build_Discriminal_Array_Constraint
return List_Id
;
1897 -- If one or more of the bounds of the component depends on
1898 -- discriminants, build actual constraint using the discriminants
1901 function Build_Discriminal_Record_Constraint
return List_Id
;
1902 -- Similar to previous one, for discriminated components constrained by
1903 -- the discriminant of the enclosing object.
1905 ----------------------------------------
1906 -- Build_Discriminal_Array_Constraint --
1907 ----------------------------------------
1909 function Build_Discriminal_Array_Constraint
return List_Id
is
1910 Constraints
: constant List_Id
:= New_List
;
1918 Indx
:= First_Index
(T
);
1919 while Present
(Indx
) loop
1920 Old_Lo
:= Type_Low_Bound
(Etype
(Indx
));
1921 Old_Hi
:= Type_High_Bound
(Etype
(Indx
));
1923 if Denotes_Discriminant
(Old_Lo
) then
1924 Lo
:= New_Occurrence_Of
(Discriminal
(Entity
(Old_Lo
)), Loc
);
1927 Lo
:= New_Copy_Tree
(Old_Lo
);
1930 if Denotes_Discriminant
(Old_Hi
) then
1931 Hi
:= New_Occurrence_Of
(Discriminal
(Entity
(Old_Hi
)), Loc
);
1934 Hi
:= New_Copy_Tree
(Old_Hi
);
1937 Append
(Make_Range
(Loc
, Lo
, Hi
), Constraints
);
1942 end Build_Discriminal_Array_Constraint
;
1944 -----------------------------------------
1945 -- Build_Discriminal_Record_Constraint --
1946 -----------------------------------------
1948 function Build_Discriminal_Record_Constraint
return List_Id
is
1949 Constraints
: constant List_Id
:= New_List
;
1954 D
:= First_Elmt
(Discriminant_Constraint
(T
));
1955 while Present
(D
) loop
1956 if Denotes_Discriminant
(Node
(D
)) then
1958 New_Occurrence_Of
(Discriminal
(Entity
(Node
(D
))), Loc
);
1960 D_Val
:= New_Copy_Tree
(Node
(D
));
1963 Append
(D_Val
, Constraints
);
1968 end Build_Discriminal_Record_Constraint
;
1970 -- Start of processing for Build_Discriminal_Subtype_Of_Component
1973 if Ekind
(T
) = E_Array_Subtype
then
1974 Id
:= First_Index
(T
);
1975 while Present
(Id
) loop
1976 if Denotes_Discriminant
(Type_Low_Bound
(Etype
(Id
)))
1978 Denotes_Discriminant
(Type_High_Bound
(Etype
(Id
)))
1980 return Build_Component_Subtype
1981 (Build_Discriminal_Array_Constraint
, Loc
, T
);
1987 elsif Ekind
(T
) = E_Record_Subtype
1988 and then Has_Discriminants
(T
)
1989 and then not Has_Unknown_Discriminants
(T
)
1991 D
:= First_Elmt
(Discriminant_Constraint
(T
));
1992 while Present
(D
) loop
1993 if Denotes_Discriminant
(Node
(D
)) then
1994 return Build_Component_Subtype
1995 (Build_Discriminal_Record_Constraint
, Loc
, T
);
2002 -- If none of the above, the actual and nominal subtypes are the same
2005 end Build_Discriminal_Subtype_Of_Component
;
2007 ------------------------------
2008 -- Build_Elaboration_Entity --
2009 ------------------------------
2011 procedure Build_Elaboration_Entity
(N
: Node_Id
; Spec_Id
: Entity_Id
) is
2012 Loc
: constant Source_Ptr
:= Sloc
(N
);
2014 Elab_Ent
: Entity_Id
;
2016 procedure Set_Package_Name
(Ent
: Entity_Id
);
2017 -- Given an entity, sets the fully qualified name of the entity in
2018 -- Name_Buffer, with components separated by double underscores. This
2019 -- is a recursive routine that climbs the scope chain to Standard.
2021 ----------------------
2022 -- Set_Package_Name --
2023 ----------------------
2025 procedure Set_Package_Name
(Ent
: Entity_Id
) is
2027 if Scope
(Ent
) /= Standard_Standard
then
2028 Set_Package_Name
(Scope
(Ent
));
2031 Nam
: constant String := Get_Name_String
(Chars
(Ent
));
2033 Name_Buffer
(Name_Len
+ 1) := '_';
2034 Name_Buffer
(Name_Len
+ 2) := '_';
2035 Name_Buffer
(Name_Len
+ 3 .. Name_Len
+ Nam
'Length + 2) := Nam
;
2036 Name_Len
:= Name_Len
+ Nam
'Length + 2;
2040 Get_Name_String
(Chars
(Ent
));
2042 end Set_Package_Name
;
2044 -- Start of processing for Build_Elaboration_Entity
2047 -- Ignore call if already constructed
2049 if Present
(Elaboration_Entity
(Spec_Id
)) then
2052 -- Do not generate an elaboration entity in GNATprove move because the
2053 -- elaboration counter is a form of expansion.
2055 elsif GNATprove_Mode
then
2058 -- See if we need elaboration entity
2060 -- We always need an elaboration entity when preserving control flow, as
2061 -- we want to remain explicit about the unit's elaboration order.
2063 elsif Opt
.Suppress_Control_Flow_Optimizations
then
2066 -- We always need an elaboration entity for the dynamic elaboration
2067 -- model, since it is needed to properly generate the PE exception for
2068 -- access before elaboration.
2070 elsif Dynamic_Elaboration_Checks
then
2073 -- For the static model, we don't need the elaboration counter if this
2074 -- unit is sure to have no elaboration code, since that means there
2075 -- is no elaboration unit to be called. Note that we can't just decide
2076 -- after the fact by looking to see whether there was elaboration code,
2077 -- because that's too late to make this decision.
2079 elsif Restriction_Active
(No_Elaboration_Code
) then
2082 -- Similarly, for the static model, we can skip the elaboration counter
2083 -- if we have the No_Multiple_Elaboration restriction, since for the
2084 -- static model, that's the only purpose of the counter (to avoid
2085 -- multiple elaboration).
2087 elsif Restriction_Active
(No_Multiple_Elaboration
) then
2091 -- Here we need the elaboration entity
2093 -- Construct name of elaboration entity as xxx_E, where xxx is the unit
2094 -- name with dots replaced by double underscore. We have to manually
2095 -- construct this name, since it will be elaborated in the outer scope,
2096 -- and thus will not have the unit name automatically prepended.
2098 Set_Package_Name
(Spec_Id
);
2099 Add_Str_To_Name_Buffer
("_E");
2101 -- Create elaboration counter
2103 Elab_Ent
:= Make_Defining_Identifier
(Loc
, Chars
=> Name_Find
);
2104 Set_Elaboration_Entity
(Spec_Id
, Elab_Ent
);
2107 Make_Object_Declaration
(Loc
,
2108 Defining_Identifier
=> Elab_Ent
,
2109 Object_Definition
=>
2110 New_Occurrence_Of
(Standard_Short_Integer
, Loc
),
2111 Expression
=> Make_Integer_Literal
(Loc
, Uint_0
));
2113 Push_Scope
(Standard_Standard
);
2114 Add_Global_Declaration
(Decl
);
2117 -- Reset True_Constant indication, since we will indeed assign a value
2118 -- to the variable in the binder main. We also kill the Current_Value
2119 -- and Last_Assignment fields for the same reason.
2121 Set_Is_True_Constant
(Elab_Ent
, False);
2122 Set_Current_Value
(Elab_Ent
, Empty
);
2123 Set_Last_Assignment
(Elab_Ent
, Empty
);
2125 -- We do not want any further qualification of the name (if we did not
2126 -- do this, we would pick up the name of the generic package in the case
2127 -- of a library level generic instantiation).
2129 Set_Has_Qualified_Name
(Elab_Ent
);
2130 Set_Has_Fully_Qualified_Name
(Elab_Ent
);
2131 end Build_Elaboration_Entity
;
2133 --------------------------------
2134 -- Build_Explicit_Dereference --
2135 --------------------------------
2137 procedure Build_Explicit_Dereference
2141 Loc
: constant Source_Ptr
:= Sloc
(Expr
);
2146 -- An entity of a type with a reference aspect is overloaded with
2147 -- both interpretations: with and without the dereference. Now that
2148 -- the dereference is made explicit, set the type of the node properly,
2149 -- to prevent anomalies in the backend. Same if the expression is an
2150 -- overloaded function call whose return type has a reference aspect.
2152 if Is_Entity_Name
(Expr
) then
2153 Set_Etype
(Expr
, Etype
(Entity
(Expr
)));
2155 -- The designated entity will not be examined again when resolving
2156 -- the dereference, so generate a reference to it now.
2158 Generate_Reference
(Entity
(Expr
), Expr
);
2160 elsif Nkind
(Expr
) = N_Function_Call
then
2162 -- If the name of the indexing function is overloaded, locate the one
2163 -- whose return type has an implicit dereference on the desired
2164 -- discriminant, and set entity and type of function call.
2166 if Is_Overloaded
(Name
(Expr
)) then
2167 Get_First_Interp
(Name
(Expr
), I
, It
);
2169 while Present
(It
.Nam
) loop
2170 if Ekind
((It
.Typ
)) = E_Record_Type
2171 and then First_Entity
((It
.Typ
)) = Disc
2173 Set_Entity
(Name
(Expr
), It
.Nam
);
2174 Set_Etype
(Name
(Expr
), Etype
(It
.Nam
));
2178 Get_Next_Interp
(I
, It
);
2182 -- Set type of call from resolved function name.
2184 Set_Etype
(Expr
, Etype
(Name
(Expr
)));
2187 Set_Is_Overloaded
(Expr
, False);
2189 -- The expression will often be a generalized indexing that yields a
2190 -- container element that is then dereferenced, in which case the
2191 -- generalized indexing call is also non-overloaded.
2193 if Nkind
(Expr
) = N_Indexed_Component
2194 and then Present
(Generalized_Indexing
(Expr
))
2196 Set_Is_Overloaded
(Generalized_Indexing
(Expr
), False);
2200 Make_Explicit_Dereference
(Loc
,
2202 Make_Selected_Component
(Loc
,
2203 Prefix
=> Relocate_Node
(Expr
),
2204 Selector_Name
=> New_Occurrence_Of
(Disc
, Loc
))));
2205 Set_Etype
(Prefix
(Expr
), Etype
(Disc
));
2206 Set_Etype
(Expr
, Designated_Type
(Etype
(Disc
)));
2207 end Build_Explicit_Dereference
;
2209 ---------------------------
2210 -- Build_Overriding_Spec --
2211 ---------------------------
2213 function Build_Overriding_Spec
2215 Typ
: Entity_Id
) return Node_Id
2217 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
2218 Par_Typ
: constant Entity_Id
:= Find_Dispatching_Type
(Op
);
2219 Spec
: constant Node_Id
:= Specification
(Unit_Declaration_Node
(Op
));
2221 Formal_Spec
: Node_Id
;
2222 Formal_Type
: Node_Id
;
2226 New_Spec
:= Copy_Subprogram_Spec
(Spec
);
2228 Formal_Spec
:= First
(Parameter_Specifications
(New_Spec
));
2229 while Present
(Formal_Spec
) loop
2230 Formal_Type
:= Parameter_Type
(Formal_Spec
);
2232 if Is_Entity_Name
(Formal_Type
)
2233 and then Entity
(Formal_Type
) = Par_Typ
2235 Rewrite
(Formal_Type
, New_Occurrence_Of
(Typ
, Loc
));
2237 elsif Nkind
(Formal_Type
) = N_Access_Definition
2238 and then Entity
(Subtype_Mark
(Formal_Type
)) = Par_Typ
2240 Rewrite
(Subtype_Mark
(Formal_Type
), New_Occurrence_Of
(Typ
, Loc
));
2247 end Build_Overriding_Spec
;
2253 function Build_Subtype
2254 (Related_Node
: Node_Id
;
2257 Constraints
: List_Id
)
2261 Subtyp_Decl
: Node_Id
;
2263 Btyp
: Entity_Id
:= Base_Type
(Typ
);
2266 -- The Related_Node better be here or else we won't be able to
2267 -- attach new itypes to a node in the tree.
2269 pragma Assert
(Present
(Related_Node
));
2271 -- If the view of the component's type is incomplete or private
2272 -- with unknown discriminants, then the constraint must be applied
2273 -- to the full type.
2275 if Has_Unknown_Discriminants
(Btyp
)
2276 and then Present
(Underlying_Type
(Btyp
))
2278 Btyp
:= Underlying_Type
(Btyp
);
2282 Make_Subtype_Indication
(Loc
,
2283 Subtype_Mark
=> New_Occurrence_Of
(Btyp
, Loc
),
2285 Make_Index_Or_Discriminant_Constraint
(Loc
, Constraints
));
2287 Def_Id
:= Create_Itype
(Ekind
(Typ
), Related_Node
);
2290 Make_Subtype_Declaration
(Loc
,
2291 Defining_Identifier
=> Def_Id
,
2292 Subtype_Indication
=> Indic
);
2294 Set_Parent
(Subtyp_Decl
, Parent
(Related_Node
));
2296 -- Itypes must be analyzed with checks off (see package Itypes)
2298 Analyze
(Subtyp_Decl
, Suppress
=> All_Checks
);
2300 if Is_Itype
(Def_Id
) and then Has_Predicates
(Typ
) then
2301 Inherit_Predicate_Flags
(Def_Id
, Typ
);
2303 -- Indicate where the predicate function may be found
2305 if Is_Itype
(Typ
) then
2306 if Present
(Predicate_Function
(Def_Id
)) then
2309 elsif Present
(Predicate_Function
(Typ
)) then
2310 Set_Predicate_Function
(Def_Id
, Predicate_Function
(Typ
));
2313 Set_Predicated_Parent
(Def_Id
, Predicated_Parent
(Typ
));
2316 elsif No
(Predicate_Function
(Def_Id
)) then
2317 Set_Predicated_Parent
(Def_Id
, Typ
);
2324 -----------------------------------
2325 -- Cannot_Raise_Constraint_Error --
2326 -----------------------------------
2328 function Cannot_Raise_Constraint_Error
(Expr
: Node_Id
) return Boolean is
2330 function List_Cannot_Raise_CE
(L
: List_Id
) return Boolean;
2331 -- Returns True if none of the list members cannot possibly raise
2332 -- Constraint_Error.
2334 --------------------------
2335 -- List_Cannot_Raise_CE --
2336 --------------------------
2338 function List_Cannot_Raise_CE
(L
: List_Id
) return Boolean is
2342 while Present
(N
) loop
2343 if Cannot_Raise_Constraint_Error
(N
) then
2351 end List_Cannot_Raise_CE
;
2353 -- Start of processing for Cannot_Raise_Constraint_Error
2356 if Compile_Time_Known_Value
(Expr
) then
2359 elsif Do_Range_Check
(Expr
) then
2362 elsif Raises_Constraint_Error
(Expr
) then
2366 case Nkind
(Expr
) is
2367 when N_Identifier
=>
2370 when N_Expanded_Name
=>
2373 when N_Indexed_Component
=>
2374 return not Do_Range_Check
(Expr
)
2375 and then Cannot_Raise_Constraint_Error
(Prefix
(Expr
))
2376 and then List_Cannot_Raise_CE
(Expressions
(Expr
));
2378 when N_Selected_Component
=>
2379 return not Do_Discriminant_Check
(Expr
)
2380 and then Cannot_Raise_Constraint_Error
(Prefix
(Expr
));
2382 when N_Attribute_Reference
=>
2383 if Do_Overflow_Check
(Expr
) then
2386 elsif No
(Expressions
(Expr
)) then
2390 return List_Cannot_Raise_CE
(Expressions
(Expr
));
2393 when N_Type_Conversion
=>
2394 if Do_Overflow_Check
(Expr
)
2395 or else Do_Length_Check
(Expr
)
2399 return Cannot_Raise_Constraint_Error
(Expression
(Expr
));
2402 when N_Unchecked_Type_Conversion
=>
2403 return Cannot_Raise_Constraint_Error
(Expression
(Expr
));
2406 if Do_Overflow_Check
(Expr
) then
2409 return Cannot_Raise_Constraint_Error
(Right_Opnd
(Expr
));
2416 if Do_Division_Check
(Expr
)
2418 Do_Overflow_Check
(Expr
)
2423 Cannot_Raise_Constraint_Error
(Left_Opnd
(Expr
))
2425 Cannot_Raise_Constraint_Error
(Right_Opnd
(Expr
));
2444 | N_Op_Shift_Right_Arithmetic
2448 if Do_Overflow_Check
(Expr
) then
2452 Cannot_Raise_Constraint_Error
(Left_Opnd
(Expr
))
2454 Cannot_Raise_Constraint_Error
(Right_Opnd
(Expr
));
2461 end Cannot_Raise_Constraint_Error
;
2463 -------------------------------
2464 -- Check_Ambiguous_Aggregate --
2465 -------------------------------
2467 procedure Check_Ambiguous_Aggregate
(Call
: Node_Id
) is
2471 if All_Extensions_Allowed
then
2472 Actual
:= First_Actual
(Call
);
2473 while Present
(Actual
) loop
2474 if Nkind
(Actual
) = N_Aggregate
then
2476 ("\add type qualification to aggregate actual", Actual
);
2479 Next_Actual
(Actual
);
2482 end Check_Ambiguous_Aggregate
;
2484 -----------------------------------------
2485 -- Check_Dynamically_Tagged_Expression --
2486 -----------------------------------------
2488 procedure Check_Dynamically_Tagged_Expression
2491 Related_Nod
: Node_Id
)
2494 pragma Assert
(Is_Tagged_Type
(Typ
));
2496 -- In order to avoid spurious errors when analyzing the expanded code,
2497 -- this check is done only for nodes that come from source and for
2498 -- actuals of generic instantiations.
2500 if (Comes_From_Source
(Related_Nod
)
2501 or else In_Generic_Actual
(Expr
))
2502 and then (Is_Class_Wide_Type
(Etype
(Expr
))
2503 or else Is_Dynamically_Tagged
(Expr
))
2504 and then not Is_Class_Wide_Type
(Typ
)
2506 Error_Msg_N
("dynamically tagged expression not allowed!", Expr
);
2508 end Check_Dynamically_Tagged_Expression
;
2510 --------------------------
2511 -- Check_Fully_Declared --
2512 --------------------------
2514 procedure Check_Fully_Declared
(T
: Entity_Id
; N
: Node_Id
) is
2516 if Ekind
(T
) = E_Incomplete_Type
then
2518 -- Ada 2005 (AI-50217): If the type is available through a limited
2519 -- with_clause, verify that its full view has been analyzed.
2521 if From_Limited_With
(T
)
2522 and then Present
(Non_Limited_View
(T
))
2523 and then Ekind
(Non_Limited_View
(T
)) /= E_Incomplete_Type
2525 -- The non-limited view is fully declared
2531 ("premature usage of incomplete}", N
, First_Subtype
(T
));
2534 -- Need comments for these tests ???
2536 elsif Has_Private_Component
(T
)
2537 and then not Is_Generic_Type
(Root_Type
(T
))
2538 and then not In_Spec_Expression
2540 -- Special case: if T is the anonymous type created for a single
2541 -- task or protected object, use the name of the source object.
2543 if Is_Concurrent_Type
(T
)
2544 and then not Comes_From_Source
(T
)
2545 and then Nkind
(N
) = N_Object_Declaration
2548 ("type of& has incomplete component",
2549 N
, Defining_Identifier
(N
));
2552 ("premature usage of incomplete}",
2553 N
, First_Subtype
(T
));
2556 end Check_Fully_Declared
;
2558 -------------------------------------------
2559 -- Check_Function_With_Address_Parameter --
2560 -------------------------------------------
2562 procedure Check_Function_With_Address_Parameter
(Subp_Id
: Entity_Id
) is
2567 F
:= First_Formal
(Subp_Id
);
2568 while Present
(F
) loop
2571 if Is_Private_Type
(T
) and then Present
(Full_View
(T
)) then
2575 if Is_Descendant_Of_Address
(T
) or else Is_Limited_Type
(T
) then
2576 Set_Is_Pure
(Subp_Id
, False);
2582 end Check_Function_With_Address_Parameter
;
2584 -------------------------------------
2585 -- Check_Function_Writable_Actuals --
2586 -------------------------------------
2588 procedure Check_Function_Writable_Actuals
(N
: Node_Id
) is
2589 Writable_Actuals_List
: Elist_Id
:= No_Elist
;
2590 Identifiers_List
: Elist_Id
:= No_Elist
;
2591 Aggr_Error_Node
: Node_Id
:= Empty
;
2592 Error_Node
: Node_Id
:= Empty
;
2594 procedure Collect_Identifiers
(N
: Node_Id
);
2595 -- In a single traversal of subtree N collect in Writable_Actuals_List
2596 -- all the actuals of functions with writable actuals, and in the list
2597 -- Identifiers_List collect all the identifiers that are not actuals of
2598 -- functions with writable actuals. If a writable actual is referenced
2599 -- twice as writable actual then Error_Node is set to reference its
2600 -- second occurrence, the error is reported, and the tree traversal
2603 -------------------------
2604 -- Collect_Identifiers --
2605 -------------------------
2607 procedure Collect_Identifiers
(N
: Node_Id
) is
2609 function Check_Node
(N
: Node_Id
) return Traverse_Result
;
2610 -- Process a single node during the tree traversal to collect the
2611 -- writable actuals of functions and all the identifiers which are
2612 -- not writable actuals of functions.
2614 function Contains
(List
: Elist_Id
; N
: Node_Id
) return Boolean;
2615 -- Returns True if List has a node whose Entity is Entity (N)
2621 function Check_Node
(N
: Node_Id
) return Traverse_Result
is
2622 Is_Writable_Actual
: Boolean := False;
2623 Id
: Entity_Id
:= Empty
;
2624 -- Default init of Id for CodePeer
2627 if Nkind
(N
) = N_Identifier
then
2629 -- No analysis possible if the entity is not decorated
2631 if No
(Entity
(N
)) then
2634 -- Don't collect identifiers of packages, called functions, etc
2636 elsif Ekind
(Entity
(N
)) in
2637 E_Package | E_Function | E_Procedure | E_Entry
2641 -- For rewritten nodes, continue the traversal in the original
2642 -- subtree. Needed to handle aggregates in original expressions
2643 -- extracted from the tree by Remove_Side_Effects.
2645 elsif Is_Rewrite_Substitution
(N
) then
2646 Collect_Identifiers
(Original_Node
(N
));
2649 -- For now we skip aggregate discriminants, since they require
2650 -- performing the analysis in two phases to identify conflicts:
2651 -- first one analyzing discriminants and second one analyzing
2652 -- the rest of components (since at run time, discriminants are
2653 -- evaluated prior to components): too much computation cost
2654 -- to identify a corner case???
2656 elsif Nkind
(Parent
(N
)) = N_Component_Association
2657 and then Nkind
(Parent
(Parent
(N
))) in
2658 N_Aggregate | N_Extension_Aggregate
2661 Choice
: constant Node_Id
:= First
(Choices
(Parent
(N
)));
2664 if Ekind
(Entity
(N
)) = E_Discriminant
then
2667 elsif Expression
(Parent
(N
)) = N
2668 and then Nkind
(Choice
) = N_Identifier
2669 and then Ekind
(Entity
(Choice
)) = E_Discriminant
2675 -- Analyze if N is a writable actual of a function
2677 elsif Nkind
(Parent
(N
)) = N_Function_Call
then
2679 Call
: constant Node_Id
:= Parent
(N
);
2684 Id
:= Get_Called_Entity
(Call
);
2686 -- In case of previous error, no check is possible
2692 if Ekind
(Id
) in E_Function | E_Generic_Function
2693 and then Has_Out_Or_In_Out_Parameter
(Id
)
2695 Formal
:= First_Formal
(Id
);
2696 Actual
:= First_Actual
(Call
);
2697 while Present
(Actual
) and then Present
(Formal
) loop
2699 if Ekind
(Formal
) in E_Out_Parameter
2700 | E_In_Out_Parameter
2702 Is_Writable_Actual
:= True;
2708 Next_Formal
(Formal
);
2709 Next_Actual
(Actual
);
2715 if Is_Writable_Actual
then
2717 -- Skip checking the error in non-elementary types since
2718 -- RM 6.4.1(6.15/3) is restricted to elementary types, but
2719 -- store this actual in Writable_Actuals_List since it is
2720 -- needed to perform checks on other constructs that have
2721 -- arbitrary order of evaluation (for example, aggregates).
2723 if not Is_Elementary_Type
(Etype
(N
)) then
2724 if not Contains
(Writable_Actuals_List
, N
) then
2725 Append_New_Elmt
(N
, To
=> Writable_Actuals_List
);
2728 -- Second occurrence of an elementary type writable actual
2730 elsif Contains
(Writable_Actuals_List
, N
) then
2732 -- Report the error on the second occurrence of the
2733 -- identifier. We cannot assume that N is the second
2734 -- occurrence (according to their location in the
2735 -- sources), since Traverse_Func walks through Field2
2736 -- last (see comment in the body of Traverse_Func).
2742 Elmt
:= First_Elmt
(Writable_Actuals_List
);
2743 while Present
(Elmt
)
2744 and then Entity
(Node
(Elmt
)) /= Entity
(N
)
2749 if Sloc
(N
) > Sloc
(Node
(Elmt
)) then
2752 Error_Node
:= Node
(Elmt
);
2756 ("value may be affected by call to & "
2757 & "because order of evaluation is arbitrary",
2762 -- First occurrence of a elementary type writable actual
2765 Append_New_Elmt
(N
, To
=> Writable_Actuals_List
);
2769 if No
(Identifiers_List
) then
2770 Identifiers_List
:= New_Elmt_List
;
2773 Append_Unique_Elmt
(N
, Identifiers_List
);
2786 N
: Node_Id
) return Boolean
2788 pragma Assert
(Nkind
(N
) in N_Has_Entity
);
2797 Elmt
:= First_Elmt
(List
);
2798 while Present
(Elmt
) loop
2799 if Entity
(Node
(Elmt
)) = Entity
(N
) then
2813 procedure Do_Traversal
is new Traverse_Proc
(Check_Node
);
2814 -- The traversal procedure
2816 -- Start of processing for Collect_Identifiers
2819 if Present
(Error_Node
) then
2823 if Nkind
(N
) in N_Subexpr
and then Is_OK_Static_Expression
(N
) then
2828 end Collect_Identifiers
;
2830 -- Start of processing for Check_Function_Writable_Actuals
2833 -- The check only applies to Ada 2012 code on which Check_Actuals has
2834 -- been set, and only to constructs that have multiple constituents
2835 -- whose order of evaluation is not specified by the language.
2837 if Ada_Version
< Ada_2012
2838 or else not Check_Actuals
(N
)
2839 or else Nkind
(N
) not in N_Op
2843 | N_Extension_Aggregate
2844 | N_Full_Type_Declaration
2846 | N_Procedure_Call_Statement
2847 | N_Entry_Call_Statement
2848 or else (Nkind
(N
) = N_Full_Type_Declaration
2849 and then not Is_Record_Type
(Defining_Identifier
(N
)))
2851 -- In addition, this check only applies to source code, not to code
2852 -- generated by constraint checks.
2854 or else not Comes_From_Source
(N
)
2859 -- If a construct C has two or more direct constituents that are names
2860 -- or expressions whose evaluation may occur in an arbitrary order, at
2861 -- least one of which contains a function call with an in out or out
2862 -- parameter, then the construct is legal only if: for each name N that
2863 -- is passed as a parameter of mode in out or out to some inner function
2864 -- call C2 (not including the construct C itself), there is no other
2865 -- name anywhere within a direct constituent of the construct C other
2866 -- than the one containing C2, that is known to refer to the same
2867 -- object (RM 6.4.1(6.17/3)).
2871 Collect_Identifiers
(Low_Bound
(N
));
2872 Collect_Identifiers
(High_Bound
(N
));
2874 when N_Membership_Test
2881 Collect_Identifiers
(Left_Opnd
(N
));
2883 if Present
(Right_Opnd
(N
)) then
2884 Collect_Identifiers
(Right_Opnd
(N
));
2887 if Nkind
(N
) in N_Membership_Test
then
2888 Expr
:= First
(Alternatives
(N
));
2889 while Present
(Expr
) loop
2890 Collect_Identifiers
(Expr
);
2897 when N_Full_Type_Declaration
=>
2899 function Get_Record_Part
(N
: Node_Id
) return Node_Id
;
2900 -- Return the record part of this record type definition
2902 ---------------------
2903 -- Get_Record_Part --
2904 ---------------------
2906 function Get_Record_Part
(N
: Node_Id
) return Node_Id
is
2907 Type_Def
: constant Node_Id
:= Type_Definition
(N
);
2909 if Nkind
(Type_Def
) = N_Derived_Type_Definition
then
2910 return Record_Extension_Part
(Type_Def
);
2914 end Get_Record_Part
;
2917 Def_Id
: Entity_Id
:= Defining_Identifier
(N
);
2918 Rec
: Node_Id
:= Get_Record_Part
(N
);
2921 -- No need to perform any analysis if the record has no
2924 if No
(Rec
) or else No
(Component_List
(Rec
)) then
2928 -- Collect the identifiers starting from the deepest
2929 -- derivation. Done to report the error in the deepest
2933 if Present
(Component_List
(Rec
)) then
2934 Comp
:= First
(Component_Items
(Component_List
(Rec
)));
2935 while Present
(Comp
) loop
2936 if Nkind
(Comp
) = N_Component_Declaration
2937 and then Present
(Expression
(Comp
))
2939 Collect_Identifiers
(Expression
(Comp
));
2946 exit when No
(Underlying_Type
(Etype
(Def_Id
)))
2947 or else Base_Type
(Underlying_Type
(Etype
(Def_Id
)))
2950 Def_Id
:= Base_Type
(Underlying_Type
(Etype
(Def_Id
)));
2951 Rec
:= Get_Record_Part
(Parent
(Def_Id
));
2955 when N_Entry_Call_Statement
2959 Id
: constant Entity_Id
:= Get_Called_Entity
(N
);
2964 Formal
:= First_Formal
(Id
);
2965 Actual
:= First_Actual
(N
);
2966 while Present
(Actual
) and then Present
(Formal
) loop
2967 if Ekind
(Formal
) in E_Out_Parameter | E_In_Out_Parameter
2969 Collect_Identifiers
(Actual
);
2972 Next_Formal
(Formal
);
2973 Next_Actual
(Actual
);
2978 | N_Extension_Aggregate
2983 Comp_Expr
: Node_Id
;
2986 -- Handle the N_Others_Choice of array aggregates with static
2987 -- bounds. There is no need to perform this analysis in
2988 -- aggregates without static bounds since we cannot evaluate
2989 -- if the N_Others_Choice covers several elements. There is
2990 -- no need to handle the N_Others choice of record aggregates
2991 -- since at this stage it has been already expanded by
2992 -- Resolve_Record_Aggregate.
2994 if Is_Array_Type
(Etype
(N
))
2995 and then Nkind
(N
) = N_Aggregate
2996 and then Present
(Aggregate_Bounds
(N
))
2997 and then Compile_Time_Known_Bounds
(Etype
(N
))
2998 and then Expr_Value
(High_Bound
(Aggregate_Bounds
(N
)))
3000 Expr_Value
(Low_Bound
(Aggregate_Bounds
(N
)))
3003 Count_Components
: Uint
:= Uint_0
;
3004 Num_Components
: Uint
;
3005 Others_Assoc
: Node_Id
:= Empty
;
3006 Others_Choice
: Node_Id
:= Empty
;
3007 Others_Box_Present
: Boolean := False;
3010 -- Count positional associations
3012 if Present
(Expressions
(N
)) then
3013 Comp_Expr
:= First
(Expressions
(N
));
3014 while Present
(Comp_Expr
) loop
3015 Count_Components
:= Count_Components
+ 1;
3020 -- Count the rest of elements and locate the N_Others
3023 Assoc
:= First
(Component_Associations
(N
));
3024 while Present
(Assoc
) loop
3025 Choice
:= First
(Choices
(Assoc
));
3026 while Present
(Choice
) loop
3027 if Nkind
(Choice
) = N_Others_Choice
then
3028 Others_Assoc
:= Assoc
;
3029 Others_Choice
:= Choice
;
3030 Others_Box_Present
:= Box_Present
(Assoc
);
3032 -- Count several components
3034 elsif Nkind
(Choice
) in
3035 N_Range | N_Subtype_Indication
3036 or else (Is_Entity_Name
(Choice
)
3037 and then Is_Type
(Entity
(Choice
)))
3042 Get_Index_Bounds
(Choice
, L
, H
);
3044 (Compile_Time_Known_Value
(L
)
3045 and then Compile_Time_Known_Value
(H
));
3048 + Expr_Value
(H
) - Expr_Value
(L
) + 1;
3051 -- Count single component. No other case available
3052 -- since we are handling an aggregate with static
3056 pragma Assert
(Is_OK_Static_Expression
(Choice
)
3057 or else Nkind
(Choice
) = N_Identifier
3058 or else Nkind
(Choice
) = N_Integer_Literal
);
3060 Count_Components
:= Count_Components
+ 1;
3070 Expr_Value
(High_Bound
(Aggregate_Bounds
(N
))) -
3071 Expr_Value
(Low_Bound
(Aggregate_Bounds
(N
))) + 1;
3073 pragma Assert
(Count_Components
<= Num_Components
);
3075 -- Handle the N_Others choice if it covers several
3078 if Present
(Others_Choice
)
3079 and then (Num_Components
- Count_Components
) > 1
3081 if not Others_Box_Present
then
3083 -- At this stage, if expansion is active, the
3084 -- expression of the others choice has not been
3085 -- analyzed. Hence we generate a duplicate and
3086 -- we analyze it silently to have available the
3087 -- minimum decoration required to collect the
3090 pragma Assert
(Present
(Others_Assoc
));
3092 if not Expander_Active
then
3093 Comp_Expr
:= Expression
(Others_Assoc
);
3096 New_Copy_Tree
(Expression
(Others_Assoc
));
3097 Preanalyze_Without_Errors
(Comp_Expr
);
3100 Collect_Identifiers
(Comp_Expr
);
3102 if Present
(Writable_Actuals_List
) then
3104 -- As suggested by Robert, at current stage we
3105 -- report occurrences of this case as warnings.
3108 ("writable function parameter may affect "
3109 & "value in other component because order "
3110 & "of evaluation is unspecified??",
3111 Node
(First_Elmt
(Writable_Actuals_List
)));
3117 -- For an array aggregate, a discrete_choice_list that has
3118 -- a nonstatic range is considered as two or more separate
3119 -- occurrences of the expression (RM 6.4.1(20/3)).
3121 elsif Is_Array_Type
(Etype
(N
))
3122 and then Nkind
(N
) = N_Aggregate
3123 and then Present
(Aggregate_Bounds
(N
))
3124 and then not Compile_Time_Known_Bounds
(Etype
(N
))
3126 -- Collect identifiers found in the dynamic bounds
3129 Count_Components
: Natural := 0;
3130 Low
, High
: Node_Id
;
3133 Assoc
:= First
(Component_Associations
(N
));
3134 while Present
(Assoc
) loop
3135 Choice
:= First
(Choices
(Assoc
));
3136 while Present
(Choice
) loop
3137 if Nkind
(Choice
) in
3138 N_Range | N_Subtype_Indication
3139 or else (Is_Entity_Name
(Choice
)
3140 and then Is_Type
(Entity
(Choice
)))
3142 Get_Index_Bounds
(Choice
, Low
, High
);
3144 if not Compile_Time_Known_Value
(Low
) then
3145 Collect_Identifiers
(Low
);
3147 if No
(Aggr_Error_Node
) then
3148 Aggr_Error_Node
:= Low
;
3152 if not Compile_Time_Known_Value
(High
) then
3153 Collect_Identifiers
(High
);
3155 if No
(Aggr_Error_Node
) then
3156 Aggr_Error_Node
:= High
;
3160 -- The RM rule is violated if there is more than
3161 -- a single choice in a component association.
3164 Count_Components
:= Count_Components
+ 1;
3166 if No
(Aggr_Error_Node
)
3167 and then Count_Components
> 1
3169 Aggr_Error_Node
:= Choice
;
3172 if not Compile_Time_Known_Value
(Choice
) then
3173 Collect_Identifiers
(Choice
);
3185 -- Handle ancestor part of extension aggregates
3187 if Nkind
(N
) = N_Extension_Aggregate
then
3188 Collect_Identifiers
(Ancestor_Part
(N
));
3191 -- Handle positional associations
3193 if Present
(Expressions
(N
)) then
3194 Comp_Expr
:= First
(Expressions
(N
));
3195 while Present
(Comp_Expr
) loop
3196 if not Is_OK_Static_Expression
(Comp_Expr
) then
3197 Collect_Identifiers
(Comp_Expr
);
3204 -- Handle discrete associations
3206 if Present
(Component_Associations
(N
)) then
3207 Assoc
:= First
(Component_Associations
(N
));
3208 while Present
(Assoc
) loop
3210 if not Box_Present
(Assoc
) then
3211 Choice
:= First
(Choices
(Assoc
));
3212 while Present
(Choice
) loop
3214 -- For now we skip discriminants since it requires
3215 -- performing the analysis in two phases: first one
3216 -- analyzing discriminants and second one analyzing
3217 -- the rest of components since discriminants are
3218 -- evaluated prior to components: too much extra
3219 -- work to detect a corner case???
3221 if Nkind
(Choice
) in N_Has_Entity
3222 and then Present
(Entity
(Choice
))
3223 and then Ekind
(Entity
(Choice
)) = E_Discriminant
3227 elsif Box_Present
(Assoc
) then
3231 if not Analyzed
(Expression
(Assoc
)) then
3233 New_Copy_Tree
(Expression
(Assoc
));
3234 Set_Parent
(Comp_Expr
, Parent
(N
));
3235 Preanalyze_Without_Errors
(Comp_Expr
);
3237 Comp_Expr
:= Expression
(Assoc
);
3240 Collect_Identifiers
(Comp_Expr
);
3256 -- No further action needed if we already reported an error
3258 if Present
(Error_Node
) then
3262 -- Check violation of RM 6.20/3 in aggregates
3264 if Present
(Aggr_Error_Node
)
3265 and then Present
(Writable_Actuals_List
)
3268 ("value may be affected by call in other component because they "
3269 & "are evaluated in unspecified order",
3270 Node
(First_Elmt
(Writable_Actuals_List
)));
3274 -- Check if some writable argument of a function is referenced
3276 if Present
(Writable_Actuals_List
)
3277 and then Present
(Identifiers_List
)
3284 Elmt_1
:= First_Elmt
(Writable_Actuals_List
);
3285 while Present
(Elmt_1
) loop
3286 Elmt_2
:= First_Elmt
(Identifiers_List
);
3287 while Present
(Elmt_2
) loop
3288 if Entity
(Node
(Elmt_1
)) = Entity
(Node
(Elmt_2
)) then
3289 case Nkind
(Parent
(Node
(Elmt_2
))) is
3291 | N_Component_Association
3292 | N_Component_Declaration
3295 ("value may be affected by call in other "
3296 & "component because they are evaluated "
3297 & "in unspecified order",
3300 when N_Membership_Test
=>
3302 ("value may be affected by call in other "
3303 & "alternative because they are evaluated "
3304 & "in unspecified order",
3309 ("value of actual may be affected by call in "
3310 & "other actual because they are evaluated "
3311 & "in unspecified order",
3323 end Check_Function_Writable_Actuals
;
3325 --------------------------------
3326 -- Check_Implicit_Dereference --
3327 --------------------------------
3329 procedure Check_Implicit_Dereference
(N
: Node_Id
; Typ
: Entity_Id
) is
3335 if Nkind
(N
) = N_Indexed_Component
3336 and then Present
(Generalized_Indexing
(N
))
3338 Nam
:= Generalized_Indexing
(N
);
3343 if Ada_Version
< Ada_2012
3344 or else not Has_Implicit_Dereference
(Base_Type
(Typ
))
3348 elsif not Comes_From_Source
(N
)
3349 and then Nkind
(N
) /= N_Indexed_Component
3353 elsif Is_Entity_Name
(Nam
) and then Is_Type
(Entity
(Nam
)) then
3357 Disc
:= First_Discriminant
(Typ
);
3358 while Present
(Disc
) loop
3359 if Has_Implicit_Dereference
(Disc
) then
3360 Desig
:= Designated_Type
(Etype
(Disc
));
3361 Add_One_Interp
(Nam
, Disc
, Desig
);
3363 -- If the node is a generalized indexing, add interpretation
3364 -- to that node as well, for subsequent resolution.
3366 if Nkind
(N
) = N_Indexed_Component
then
3367 Add_One_Interp
(N
, Disc
, Desig
);
3370 -- If the operation comes from a generic unit and the context
3371 -- is a selected component, the selector name may be global
3372 -- and set in the instance already. Remove the entity to
3373 -- force resolution of the selected component, and the
3374 -- generation of an explicit dereference if needed.
3377 and then Nkind
(Parent
(Nam
)) = N_Selected_Component
3379 Set_Entity
(Selector_Name
(Parent
(Nam
)), Empty
);
3385 Next_Discriminant
(Disc
);
3388 end Check_Implicit_Dereference
;
3390 ----------------------------------
3391 -- Check_Internal_Protected_Use --
3392 ----------------------------------
3394 procedure Check_Internal_Protected_Use
(N
: Node_Id
; Nam
: Entity_Id
) is
3402 while Present
(S
) loop
3403 if S
= Standard_Standard
then
3406 elsif Ekind
(S
) = E_Function
3407 and then Ekind
(Scope
(S
)) = E_Protected_Type
3417 and then Scope
(Nam
) = Prot
3418 and then Ekind
(Nam
) /= E_Function
3420 -- An indirect function call (e.g. a callback within a protected
3421 -- function body) is not statically illegal. If the access type is
3422 -- anonymous and is the type of an access parameter, the scope of Nam
3423 -- will be the protected type, but it is not a protected operation.
3425 if Ekind
(Nam
) = E_Subprogram_Type
3426 and then Nkind
(Associated_Node_For_Itype
(Nam
)) =
3427 N_Function_Specification
3431 elsif Nkind
(N
) = N_Subprogram_Renaming_Declaration
then
3433 ("within protected function cannot use protected procedure in "
3434 & "renaming or as generic actual", N
);
3436 elsif Nkind
(N
) = N_Attribute_Reference
then
3438 ("within protected function cannot take access of protected "
3443 ("within protected function, protected object is constant", N
);
3445 ("\cannot call operation that may modify it", N
);
3449 -- Verify that an internal call does not appear within a precondition
3450 -- of a protected operation. This implements AI12-0166.
3451 -- The precondition aspect has been rewritten as a pragma Precondition
3452 -- and we check whether the scope of the called subprogram is the same
3453 -- as that of the entity to which the aspect applies.
3455 if Convention
(Nam
) = Convention_Protected
then
3461 while Present
(P
) loop
3462 if Nkind
(P
) = N_Pragma
3463 and then Chars
(Pragma_Identifier
(P
)) = Name_Precondition
3464 and then From_Aspect_Specification
(P
)
3466 Scope
(Entity
(Corresponding_Aspect
(P
))) = Scope
(Nam
)
3469 ("internal call cannot appear in precondition of "
3470 & "protected operation", N
);
3473 elsif Nkind
(P
) = N_Pragma
3474 and then Chars
(Pragma_Identifier
(P
)) = Name_Contract_Cases
3476 -- Check whether call is in a case guard. It is legal in a
3480 while Present
(P
) loop
3481 if Nkind
(Parent
(P
)) = N_Component_Association
3482 and then P
/= Expression
(Parent
(P
))
3485 ("internal call cannot appear in case guard in a "
3486 & "contract case", N
);
3494 elsif Nkind
(P
) = N_Parameter_Specification
3495 and then Scope
(Current_Scope
) = Scope
(Nam
)
3496 and then Nkind
(Parent
(P
)) in
3497 N_Entry_Declaration | N_Subprogram_Declaration
3500 ("internal call cannot appear in default for formal of "
3501 & "protected operation", N
);
3504 -- Prevent the search from going too far
3506 elsif Is_Body_Or_Package_Declaration
(P
) then
3514 end Check_Internal_Protected_Use
;
3516 ---------------------------------------
3517 -- Check_Later_Vs_Basic_Declarations --
3518 ---------------------------------------
3520 procedure Check_Later_Vs_Basic_Declarations
3522 During_Parsing
: Boolean)
3524 Body_Sloc
: Source_Ptr
;
3527 function Is_Later_Declarative_Item
(Decl
: Node_Id
) return Boolean;
3528 -- Return whether Decl is considered as a declarative item.
3529 -- When During_Parsing is True, the semantics of Ada 83 is followed.
3530 -- When During_Parsing is False, the semantics of SPARK is followed.
3532 -------------------------------
3533 -- Is_Later_Declarative_Item --
3534 -------------------------------
3536 function Is_Later_Declarative_Item
(Decl
: Node_Id
) return Boolean is
3538 if Nkind
(Decl
) in N_Later_Decl_Item
then
3541 elsif Nkind
(Decl
) = N_Pragma
then
3544 elsif During_Parsing
then
3547 -- In SPARK, a package declaration is not considered as a later
3548 -- declarative item.
3550 elsif Nkind
(Decl
) = N_Package_Declaration
then
3553 -- In SPARK, a renaming is considered as a later declarative item
3555 elsif Nkind
(Decl
) in N_Renaming_Declaration
then
3561 end Is_Later_Declarative_Item
;
3563 -- Start of processing for Check_Later_Vs_Basic_Declarations
3566 Decl
:= First
(Decls
);
3568 -- Loop through sequence of basic declarative items
3570 Outer
: while Present
(Decl
) loop
3571 if Nkind
(Decl
) not in
3572 N_Subprogram_Body | N_Package_Body | N_Task_Body
3573 and then Nkind
(Decl
) not in N_Body_Stub
3577 -- Once a body is encountered, we only allow later declarative
3578 -- items. The inner loop checks the rest of the list.
3581 Body_Sloc
:= Sloc
(Decl
);
3583 Inner
: while Present
(Decl
) loop
3584 if not Is_Later_Declarative_Item
(Decl
) then
3585 if During_Parsing
then
3586 if Ada_Version
= Ada_83
then
3587 Error_Msg_Sloc
:= Body_Sloc
;
3589 ("(Ada 83) decl cannot appear after body#", Decl
);
3598 end Check_Later_Vs_Basic_Declarations
;
3600 ---------------------------
3601 -- Check_No_Hidden_State --
3602 ---------------------------
3604 procedure Check_No_Hidden_State
(Id
: Entity_Id
) is
3605 Context
: Entity_Id
:= Empty
;
3606 Not_Visible
: Boolean := False;
3610 pragma Assert
(Ekind
(Id
) in E_Abstract_State | E_Variable
);
3612 -- Nothing to do for internally-generated abstract states and variables
3613 -- because they do not represent the hidden state of the source unit.
3615 if not Comes_From_Source
(Id
) then
3619 -- Find the proper context where the object or state appears
3622 while Present
(Scop
) loop
3625 -- Keep track of the context's visibility
3627 Not_Visible
:= Not_Visible
or else In_Private_Part
(Context
);
3629 -- Prevent the search from going too far
3631 if Context
= Standard_Standard
then
3634 -- Objects and states that appear immediately within a subprogram or
3635 -- entry inside a construct nested within a subprogram do not
3636 -- introduce a hidden state. They behave as local variable
3637 -- declarations. The same is true for elaboration code inside a block
3640 elsif Is_Subprogram_Or_Entry
(Context
)
3641 or else Ekind
(Context
) in E_Block | E_Task_Type
3646 -- Stop the traversal when a package subject to a null abstract state
3649 if Is_Package_Or_Generic_Package
(Context
)
3650 and then Has_Null_Abstract_State
(Context
)
3655 Scop
:= Scope
(Scop
);
3658 -- At this point we know that there is at least one package with a null
3659 -- abstract state in visibility. Emit an error message unconditionally
3660 -- if the entity being processed is a state because the placement of the
3661 -- related package is irrelevant. This is not the case for objects as
3662 -- the intermediate context matters.
3664 if Present
(Context
)
3665 and then (Ekind
(Id
) = E_Abstract_State
or else Not_Visible
)
3667 Error_Msg_N
("cannot introduce hidden state &", Id
);
3668 Error_Msg_NE
("\package & has null abstract state", Id
, Context
);
3670 end Check_No_Hidden_State
;
3672 ---------------------------------------------
3673 -- Check_Nonoverridable_Aspect_Consistency --
3674 ---------------------------------------------
3676 procedure Check_Inherited_Nonoverridable_Aspects
3677 (Inheritor
: Entity_Id
;
3678 Interface_List
: List_Id
;
3679 Parent_Type
: Entity_Id
) is
3681 -- array needed for iterating over subtype values
3682 Nonoverridable_Aspects
: constant array (Positive range <>) of
3683 Nonoverridable_Aspect_Id
:=
3684 (Aspect_Default_Iterator
,
3685 Aspect_Iterator_Element
,
3686 Aspect_Implicit_Dereference
,
3687 Aspect_Constant_Indexing
,
3688 Aspect_Variable_Indexing
,
3690 Aspect_Max_Entry_Queue_Length
3691 -- , Aspect_No_Controlled_Parts
3694 -- Note that none of these 8 aspects can be specified (for a type)
3695 -- via a pragma. For 7 of them, the corresponding pragma does not
3696 -- exist. The Pragma_Id enumeration type does include
3697 -- Pragma_Max_Entry_Queue_Length, but that pragma is only use to
3698 -- specify the aspect for a protected entry or entry family, not for
3699 -- a type, and therefore cannot introduce the sorts of inheritance
3700 -- issues that we are concerned with in this procedure.
3702 type Entity_Array
is array (Nat
range <>) of Entity_Id
;
3704 function Ancestor_Entities
return Entity_Array
;
3705 -- Returns all progenitors (including parent type, if present)
3707 procedure Check_Consistency_For_One_Aspect_Of_Two_Ancestors
3708 (Aspect
: Nonoverridable_Aspect_Id
;
3709 Ancestor_1
: Entity_Id
;
3710 Aspect_Spec_1
: Node_Id
;
3711 Ancestor_2
: Entity_Id
;
3712 Aspect_Spec_2
: Node_Id
);
3713 -- A given aspect has been specified for each of two ancestors;
3714 -- check that the two aspect specifications are compatible (see
3715 -- RM 13.1.1(18.5) and AI12-0211).
3717 -----------------------
3718 -- Ancestor_Entities --
3719 -----------------------
3721 function Ancestor_Entities
return Entity_Array
is
3722 Ifc_Count
: constant Nat
:= List_Length
(Interface_List
);
3723 Ifc_Ancestors
: Entity_Array
(1 .. Ifc_Count
);
3724 Ifc
: Node_Id
:= First
(Interface_List
);
3726 for Idx
in Ifc_Ancestors
'Range loop
3727 Ifc_Ancestors
(Idx
) := Entity
(Ifc
);
3728 pragma Assert
(Present
(Ifc_Ancestors
(Idx
)));
3731 pragma Assert
(No
(Ifc
));
3732 if Present
(Parent_Type
) then
3733 return Parent_Type
& Ifc_Ancestors
;
3735 return Ifc_Ancestors
;
3737 end Ancestor_Entities
;
3739 -------------------------------------------------------
3740 -- Check_Consistency_For_One_Aspect_Of_Two_Ancestors --
3741 -------------------------------------------------------
3743 procedure Check_Consistency_For_One_Aspect_Of_Two_Ancestors
3744 (Aspect
: Nonoverridable_Aspect_Id
;
3745 Ancestor_1
: Entity_Id
;
3746 Aspect_Spec_1
: Node_Id
;
3747 Ancestor_2
: Entity_Id
;
3748 Aspect_Spec_2
: Node_Id
) is
3750 if not Is_Confirming
(Aspect
, Aspect_Spec_1
, Aspect_Spec_2
) then
3751 Error_Msg_Name_1
:= Aspect_Names
(Aspect
);
3752 Error_Msg_Name_2
:= Chars
(Ancestor_1
);
3753 Error_Msg_Name_3
:= Chars
(Ancestor_2
);
3756 "incompatible % aspects inherited from ancestors % and %",
3759 end Check_Consistency_For_One_Aspect_Of_Two_Ancestors
;
3761 Ancestors
: constant Entity_Array
:= Ancestor_Entities
;
3763 -- start of processing for Check_Inherited_Nonoverridable_Aspects
3765 -- No Ada_Version check here; AI12-0211 is a binding interpretation.
3767 if Ancestors
'Length < 2 then
3768 return; -- Inconsistency impossible; it takes 2 to disagree.
3769 elsif In_Instance_Body
then
3770 return; -- No legality checking in an instance body.
3773 for Aspect
of Nonoverridable_Aspects
loop
3775 First_Ancestor_With_Aspect
: Entity_Id
:= Empty
;
3776 First_Aspect_Spec
, Current_Aspect_Spec
: Node_Id
:= Empty
;
3778 for Ancestor
of Ancestors
loop
3779 Current_Aspect_Spec
:= Find_Aspect
(Ancestor
, Aspect
);
3780 if Present
(Current_Aspect_Spec
) then
3781 if Present
(First_Ancestor_With_Aspect
) then
3782 Check_Consistency_For_One_Aspect_Of_Two_Ancestors
3784 Ancestor_1
=> First_Ancestor_With_Aspect
,
3785 Aspect_Spec_1
=> First_Aspect_Spec
,
3786 Ancestor_2
=> Ancestor
,
3787 Aspect_Spec_2
=> Current_Aspect_Spec
);
3789 First_Ancestor_With_Aspect
:= Ancestor
;
3790 First_Aspect_Spec
:= Current_Aspect_Spec
;
3796 end Check_Inherited_Nonoverridable_Aspects
;
3798 ----------------------------------------
3799 -- Check_Nonvolatile_Function_Profile --
3800 ----------------------------------------
3802 procedure Check_Nonvolatile_Function_Profile
(Func_Id
: Entity_Id
) is
3806 -- Inspect all formal parameters
3808 Formal
:= First_Formal
(Func_Id
);
3809 while Present
(Formal
) loop
3810 if Is_Effectively_Volatile_For_Reading
(Etype
(Formal
)) then
3812 ("nonvolatile function & cannot have a volatile parameter",
3816 Next_Formal
(Formal
);
3819 -- Inspect the return type
3821 if Is_Effectively_Volatile_For_Reading
(Etype
(Func_Id
)) then
3823 ("nonvolatile function & cannot have a volatile return type",
3824 Result_Definition
(Parent
(Func_Id
)), Func_Id
);
3826 end Check_Nonvolatile_Function_Profile
;
3832 function Check_Parents
(N
: Node_Id
; List
: Elist_Id
) return Boolean is
3835 (Parent_Node
: Node_Id
;
3836 N
: Node_Id
) return Traverse_Result
;
3837 -- Process a single node.
3844 (Parent_Node
: Node_Id
;
3845 N
: Node_Id
) return Traverse_Result
is
3847 if Nkind
(N
) = N_Identifier
3848 and then Parent
(N
) /= Parent_Node
3849 and then Present
(Entity
(N
))
3850 and then Contains
(List
, Entity
(N
))
3858 function Traverse
is new Traverse_Func_With_Parent
(Check_Node
);
3860 -- Start of processing for Check_Parents
3863 return Traverse
(N
) = OK
;
3866 -----------------------------
3867 -- Check_Part_Of_Reference --
3868 -----------------------------
3870 procedure Check_Part_Of_Reference
(Var_Id
: Entity_Id
; Ref
: Node_Id
) is
3871 function Is_Enclosing_Package_Body
3872 (Body_Decl
: Node_Id
;
3873 Obj_Id
: Entity_Id
) return Boolean;
3874 pragma Inline
(Is_Enclosing_Package_Body
);
3875 -- Determine whether package body Body_Decl or its corresponding spec
3876 -- immediately encloses the declaration of object Obj_Id.
3878 function Is_Internal_Declaration_Or_Body
3879 (Decl
: Node_Id
) return Boolean;
3880 pragma Inline
(Is_Internal_Declaration_Or_Body
);
3881 -- Determine whether declaration or body denoted by Decl is internal
3883 function Is_Single_Declaration_Or_Body
3885 Conc_Typ
: Entity_Id
) return Boolean;
3886 pragma Inline
(Is_Single_Declaration_Or_Body
);
3887 -- Determine whether protected/task declaration or body denoted by Decl
3888 -- belongs to single concurrent type Conc_Typ.
3890 function Is_Single_Task_Pragma
3892 Task_Typ
: Entity_Id
) return Boolean;
3893 pragma Inline
(Is_Single_Task_Pragma
);
3894 -- Determine whether pragma Prag belongs to single task type Task_Typ
3896 -------------------------------
3897 -- Is_Enclosing_Package_Body --
3898 -------------------------------
3900 function Is_Enclosing_Package_Body
3901 (Body_Decl
: Node_Id
;
3902 Obj_Id
: Entity_Id
) return Boolean
3904 Obj_Context
: Node_Id
;
3907 -- Find the context of the object declaration
3909 Obj_Context
:= Parent
(Declaration_Node
(Obj_Id
));
3911 if Nkind
(Obj_Context
) = N_Package_Specification
then
3912 Obj_Context
:= Parent
(Obj_Context
);
3915 -- The object appears immediately within the package body
3917 if Obj_Context
= Body_Decl
then
3920 -- The object appears immediately within the corresponding spec
3922 elsif Nkind
(Obj_Context
) = N_Package_Declaration
3923 and then Unit_Declaration_Node
(Corresponding_Spec
(Body_Decl
)) =
3930 end Is_Enclosing_Package_Body
;
3932 -------------------------------------
3933 -- Is_Internal_Declaration_Or_Body --
3934 -------------------------------------
3936 function Is_Internal_Declaration_Or_Body
3937 (Decl
: Node_Id
) return Boolean
3940 if Comes_From_Source
(Decl
) then
3943 -- A body generated for an expression function which has not been
3944 -- inserted into the tree yet (In_Spec_Expression is True) is not
3945 -- considered internal.
3947 elsif Nkind
(Decl
) = N_Subprogram_Body
3948 and then Was_Expression_Function
(Decl
)
3949 and then not In_Spec_Expression
3955 end Is_Internal_Declaration_Or_Body
;
3957 -----------------------------------
3958 -- Is_Single_Declaration_Or_Body --
3959 -----------------------------------
3961 function Is_Single_Declaration_Or_Body
3963 Conc_Typ
: Entity_Id
) return Boolean
3965 Spec_Id
: constant Entity_Id
:= Unique_Defining_Entity
(Decl
);
3969 Present
(Anonymous_Object
(Spec_Id
))
3970 and then Anonymous_Object
(Spec_Id
) = Conc_Typ
;
3971 end Is_Single_Declaration_Or_Body
;
3973 ---------------------------
3974 -- Is_Single_Task_Pragma --
3975 ---------------------------
3977 function Is_Single_Task_Pragma
3979 Task_Typ
: Entity_Id
) return Boolean
3981 Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(Prag
);
3984 -- To qualify, the pragma must be associated with single task type
3988 Is_Single_Task_Object
(Task_Typ
)
3989 and then Nkind
(Decl
) = N_Object_Declaration
3990 and then Defining_Entity
(Decl
) = Task_Typ
;
3991 end Is_Single_Task_Pragma
;
3995 Conc_Obj
: constant Entity_Id
:= Encapsulating_State
(Var_Id
);
4000 -- Start of processing for Check_Part_Of_Reference
4003 -- Nothing to do when the variable was recorded, but did not become a
4004 -- constituent of a single concurrent type.
4006 if No
(Conc_Obj
) then
4010 -- Traverse the parent chain looking for a suitable context for the
4011 -- reference to the concurrent constituent.
4014 Par
:= Parent
(Prev
);
4015 while Present
(Par
) loop
4016 if Nkind
(Par
) = N_Pragma
then
4017 Prag_Nam
:= Pragma_Name
(Par
);
4019 -- A concurrent constituent is allowed to appear in pragmas
4020 -- Initial_Condition and Initializes as this is part of the
4021 -- elaboration checks for the constituent (SPARK RM 9(3)).
4023 if Prag_Nam
in Name_Initial_Condition | Name_Initializes
then
4026 -- When the reference appears within pragma Depends or Global,
4027 -- check whether the pragma applies to a single task type. Note
4028 -- that the pragma may not encapsulated by the type definition,
4029 -- but this is still a valid context.
4031 elsif Prag_Nam
in Name_Depends | Name_Global
4032 and then Is_Single_Task_Pragma
(Par
, Conc_Obj
)
4037 -- The reference appears somewhere in the definition of a single
4038 -- concurrent type (SPARK RM 9(3)).
4040 elsif Nkind
(Par
) in
4041 N_Single_Protected_Declaration | N_Single_Task_Declaration
4042 and then Defining_Entity
(Par
) = Conc_Obj
4046 -- The reference appears within the declaration or body of a single
4047 -- concurrent type (SPARK RM 9(3)).
4049 elsif Nkind
(Par
) in N_Protected_Body
4050 | N_Protected_Type_Declaration
4052 | N_Task_Type_Declaration
4053 and then Is_Single_Declaration_Or_Body
(Par
, Conc_Obj
)
4057 -- The reference appears within the statement list of the object's
4058 -- immediately enclosing package (SPARK RM 9(3)).
4060 elsif Nkind
(Par
) = N_Package_Body
4061 and then Nkind
(Prev
) = N_Handled_Sequence_Of_Statements
4062 and then Is_Enclosing_Package_Body
(Par
, Var_Id
)
4066 -- The reference has been relocated within an internally generated
4067 -- package or subprogram. Assume that the reference is legal as the
4068 -- real check was already performed in the original context of the
4071 elsif Nkind
(Par
) in N_Package_Body
4072 | N_Package_Declaration
4074 | N_Subprogram_Declaration
4075 and then Is_Internal_Declaration_Or_Body
(Par
)
4079 -- The reference has been relocated to an inlined body for GNATprove.
4080 -- Assume that the reference is legal as the real check was already
4081 -- performed in the original context of the reference.
4083 elsif GNATprove_Mode
4084 and then Nkind
(Par
) = N_Subprogram_Body
4085 and then Chars
(Defining_Entity
(Par
)) = Name_uParent
4091 Par
:= Parent
(Prev
);
4094 -- At this point it is known that the reference does not appear within a
4098 ("reference to variable & cannot appear in this context", Ref
, Var_Id
);
4099 Error_Msg_Name_1
:= Chars
(Var_Id
);
4101 if Is_Single_Protected_Object
(Conc_Obj
) then
4103 ("\% is constituent of single protected type &", Ref
, Conc_Obj
);
4107 ("\% is constituent of single task type &", Ref
, Conc_Obj
);
4109 end Check_Part_Of_Reference
;
4111 ------------------------------------------
4112 -- Check_Potentially_Blocking_Operation --
4113 ------------------------------------------
4115 procedure Check_Potentially_Blocking_Operation
(N
: Node_Id
) is
4119 -- N is one of the potentially blocking operations listed in 9.5.1(8).
4120 -- When pragma Detect_Blocking is active, the run time will raise
4121 -- Program_Error. Here we only issue a warning, since we generally
4122 -- support the use of potentially blocking operations in the absence
4125 -- Indirect blocking through a subprogram call cannot be diagnosed
4126 -- statically without interprocedural analysis, so we do not attempt
4129 S
:= Scope
(Current_Scope
);
4130 while Present
(S
) and then S
/= Standard_Standard
loop
4131 if Is_Protected_Type
(S
) then
4133 ("potentially blocking operation in protected operation??", N
);
4139 end Check_Potentially_Blocking_Operation
;
4141 ------------------------------------
4142 -- Check_Previous_Null_Procedure --
4143 ------------------------------------
4145 procedure Check_Previous_Null_Procedure
4150 if Ekind
(Prev
) = E_Procedure
4151 and then Nkind
(Parent
(Prev
)) = N_Procedure_Specification
4152 and then Null_Present
(Parent
(Prev
))
4154 Error_Msg_Sloc
:= Sloc
(Prev
);
4156 ("declaration cannot complete previous null procedure#", Decl
);
4158 end Check_Previous_Null_Procedure
;
4160 ---------------------------------
4161 -- Check_Result_And_Post_State --
4162 ---------------------------------
4164 procedure Check_Result_And_Post_State
(Subp_Id
: Entity_Id
) is
4165 procedure Check_Result_And_Post_State_In_Pragma
4167 Result_Seen
: in out Boolean);
4168 -- Determine whether pragma Prag mentions attribute 'Result and whether
4169 -- the pragma contains an expression that evaluates differently in pre-
4170 -- and post-state. Prag is a [refined] postcondition or a contract-cases
4171 -- pragma. Result_Seen is set when the pragma mentions attribute 'Result
4173 -------------------------------------------
4174 -- Check_Result_And_Post_State_In_Pragma --
4175 -------------------------------------------
4177 procedure Check_Result_And_Post_State_In_Pragma
4179 Result_Seen
: in out Boolean)
4181 procedure Check_Conjunct
(Expr
: Node_Id
);
4182 -- Check an individual conjunct in a conjunction of Boolean
4183 -- expressions, connected by "and" or "and then" operators.
4185 procedure Check_Conjuncts
(Expr
: Node_Id
);
4186 -- Apply the post-state check to every conjunct in an expression, in
4187 -- case this is a conjunction of Boolean expressions. Otherwise apply
4188 -- it to the expression as a whole.
4190 procedure Check_Expression
(Expr
: Node_Id
);
4191 -- Perform the 'Result and post-state checks on a given expression
4193 function Is_Function_Result
(N
: Node_Id
) return Traverse_Result
;
4194 -- Attempt to find attribute 'Result in a subtree denoted by N
4196 function Mentions_Post_State
(N
: Node_Id
) return Boolean;
4197 -- Determine whether a subtree denoted by N mentions any construct
4198 -- that denotes a post-state.
4200 procedure Check_Function_Result
is
4201 new Traverse_Proc
(Is_Function_Result
);
4203 --------------------
4204 -- Check_Conjunct --
4205 --------------------
4207 procedure Check_Conjunct
(Expr
: Node_Id
) is
4208 function Adjust_Message
(Msg
: String) return String;
4209 -- Prepend a prefix to the input message Msg denoting that the
4210 -- message applies to a conjunct in the expression, when this
4213 function Applied_On_Conjunct
return Boolean;
4214 -- Returns True if the message applies to a conjunct in the
4215 -- expression, instead of the whole expression.
4217 function Has_Global_Output
(Subp
: Entity_Id
) return Boolean;
4218 -- Returns True if Subp has an output in its Global contract
4220 function Has_No_Output
(Subp
: Entity_Id
) return Boolean;
4221 -- Returns True if Subp has no declared output: no function
4222 -- result, no output parameter, and no output in its Global
4225 --------------------
4226 -- Adjust_Message --
4227 --------------------
4229 function Adjust_Message
(Msg
: String) return String is
4231 if Applied_On_Conjunct
then
4232 return "conjunct in " & Msg
;
4238 -------------------------
4239 -- Applied_On_Conjunct --
4240 -------------------------
4242 function Applied_On_Conjunct
return Boolean is
4244 -- Expr is the conjunct of an enclosing "and" expression
4246 return Nkind
(Parent
(Expr
)) in N_Subexpr
4248 -- or Expr is a conjunct of an enclosing "and then"
4249 -- expression in a postcondition aspect that was split into
4250 -- multiple pragmas. The first conjunct has the "and then"
4251 -- expression as Original_Node, and other conjuncts have
4252 -- Split_PCC set to True.
4254 or else Nkind
(Original_Node
(Expr
)) = N_And_Then
4255 or else Split_PPC
(Prag
);
4256 end Applied_On_Conjunct
;
4258 -----------------------
4259 -- Has_Global_Output --
4260 -----------------------
4262 function Has_Global_Output
(Subp
: Entity_Id
) return Boolean is
4263 Global
: constant Node_Id
:= Get_Pragma
(Subp
, Pragma_Global
);
4272 List
:= Expression
(Get_Argument
(Global
, Subp
));
4274 -- Empty list (no global items) or single global item
4275 -- declaration (only input items).
4277 if Nkind
(List
) in N_Null
4280 | N_Selected_Component
4284 -- Simple global list (only input items) or moded global list
4287 elsif Nkind
(List
) = N_Aggregate
then
4288 if Present
(Expressions
(List
)) then
4292 Assoc
:= First
(Component_Associations
(List
));
4293 while Present
(Assoc
) loop
4294 if Chars
(First
(Choices
(Assoc
))) /= Name_Input
then
4304 -- To accommodate partial decoration of disabled SPARK
4305 -- features, this routine may be called with illegal input.
4306 -- If this is the case, do not raise Program_Error.
4311 end Has_Global_Output
;
4317 function Has_No_Output
(Subp
: Entity_Id
) return Boolean is
4321 -- A function has its result as output
4323 if Ekind
(Subp
) = E_Function
then
4327 -- An OUT or IN OUT parameter is an output
4329 Param
:= First_Formal
(Subp
);
4330 while Present
(Param
) loop
4331 if Ekind
(Param
) in E_Out_Parameter | E_In_Out_Parameter
then
4335 Next_Formal
(Param
);
4338 -- An item of mode Output or In_Out in the Global contract is
4341 if Has_Global_Output
(Subp
) then
4351 -- Error node when reporting a warning on a (refined)
4354 -- Start of processing for Check_Conjunct
4357 if Applied_On_Conjunct
then
4363 -- Do not report missing reference to outcome in postcondition if
4364 -- either the postcondition is trivially True or False, or if the
4365 -- subprogram is ghost and has no declared output.
4367 if not Is_Trivial_Boolean
(Expr
)
4368 and then not Mentions_Post_State
(Expr
)
4369 and then not (Is_Ghost_Entity
(Subp_Id
)
4370 and then Has_No_Output
(Subp_Id
))
4371 and then not Is_Wrapper
(Subp_Id
)
4373 if Pragma_Name
(Prag
) = Name_Contract_Cases
then
4374 Error_Msg_NE
(Adjust_Message
4375 ("contract case does not check the outcome of calling "
4376 & "&?.t?"), Expr
, Subp_Id
);
4378 elsif Pragma_Name
(Prag
) = Name_Refined_Post
then
4379 Error_Msg_NE
(Adjust_Message
4380 ("refined postcondition does not check the outcome of "
4381 & "calling &?.t?"), Err_Node
, Subp_Id
);
4384 Error_Msg_NE
(Adjust_Message
4385 ("postcondition does not check the outcome of calling "
4386 & "&?.t?"), Err_Node
, Subp_Id
);
4391 ---------------------
4392 -- Check_Conjuncts --
4393 ---------------------
4395 procedure Check_Conjuncts
(Expr
: Node_Id
) is
4397 if Nkind
(Expr
) in N_Op_And | N_And_Then
then
4398 Check_Conjuncts
(Left_Opnd
(Expr
));
4399 Check_Conjuncts
(Right_Opnd
(Expr
));
4401 Check_Conjunct
(Expr
);
4403 end Check_Conjuncts
;
4405 ----------------------
4406 -- Check_Expression --
4407 ----------------------
4409 procedure Check_Expression
(Expr
: Node_Id
) is
4411 if not Is_Trivial_Boolean
(Expr
) then
4412 Check_Function_Result
(Expr
);
4413 Check_Conjuncts
(Expr
);
4415 end Check_Expression
;
4417 ------------------------
4418 -- Is_Function_Result --
4419 ------------------------
4421 function Is_Function_Result
(N
: Node_Id
) return Traverse_Result
is
4423 if Is_Attribute_Result
(N
) then
4424 Result_Seen
:= True;
4427 -- Warn on infinite recursion if call is to current function
4429 elsif Nkind
(N
) = N_Function_Call
4430 and then Is_Entity_Name
(Name
(N
))
4431 and then Entity
(Name
(N
)) = Subp_Id
4432 and then not Is_Potentially_Unevaluated
(N
)
4435 ("call to & within its postcondition will lead to infinite "
4436 & "recursion?", N
, Subp_Id
);
4439 -- Continue the traversal
4444 end Is_Function_Result
;
4446 -------------------------
4447 -- Mentions_Post_State --
4448 -------------------------
4450 function Mentions_Post_State
(N
: Node_Id
) return Boolean is
4451 Post_State_Seen
: Boolean := False;
4453 function Is_Post_State
(N
: Node_Id
) return Traverse_Result
;
4454 -- Attempt to find a construct that denotes a post-state. If this
4455 -- is the case, set flag Post_State_Seen.
4461 function Is_Post_State
(N
: Node_Id
) return Traverse_Result
is
4465 if Nkind
(N
) in N_Explicit_Dereference | N_Function_Call
then
4466 Post_State_Seen
:= True;
4469 elsif Nkind
(N
) in N_Expanded_Name | N_Identifier
then
4472 -- Treat an undecorated reference as OK
4476 -- A reference to an assignable entity is considered a
4477 -- change in the post-state of a subprogram.
4479 or else Ekind
(Ent
) in E_Generic_In_Out_Parameter
4480 | E_In_Out_Parameter
4484 -- The reference may be modified through a dereference
4486 or else (Is_Access_Type
(Etype
(Ent
))
4487 and then Nkind
(Parent
(N
)) =
4488 N_Selected_Component
)
4490 Post_State_Seen
:= True;
4494 elsif Nkind
(N
) = N_Attribute_Reference
then
4495 if Attribute_Name
(N
) = Name_Old
then
4498 elsif Attribute_Name
(N
) = Name_Result
then
4499 Post_State_Seen
:= True;
4507 procedure Find_Post_State
is new Traverse_Proc
(Is_Post_State
);
4509 -- Start of processing for Mentions_Post_State
4512 Find_Post_State
(N
);
4514 return Post_State_Seen
;
4515 end Mentions_Post_State
;
4519 Expr
: constant Node_Id
:=
4521 (First
(Pragma_Argument_Associations
(Prag
)));
4522 Nam
: constant Name_Id
:= Pragma_Name
(Prag
);
4525 -- Start of processing for Check_Result_And_Post_State_In_Pragma
4528 -- Examine all consequences
4530 if Nam
= Name_Contract_Cases
then
4531 CCase
:= First
(Component_Associations
(Expr
));
4532 while Present
(CCase
) loop
4533 Check_Expression
(Expression
(CCase
));
4538 -- Examine the expression of a postcondition
4540 else pragma Assert
(Nam
in Name_Postcondition | Name_Refined_Post
);
4541 Check_Expression
(Expr
);
4543 end Check_Result_And_Post_State_In_Pragma
;
4547 Items
: constant Node_Id
:= Contract
(Subp_Id
);
4548 Case_Prag
: Node_Id
:= Empty
;
4549 Post_Prag
: Node_Id
:= Empty
;
4551 Seen_In_Case
: Boolean := False;
4552 Seen_In_Post
: Boolean := False;
4553 Spec_Id
: constant Entity_Id
:= Unique_Entity
(Subp_Id
);
4555 -- Start of processing for Check_Result_And_Post_State
4558 -- The lack of attribute 'Result or a post-state is classified as a
4559 -- suspicious contract. Do not perform the check if the corresponding
4560 -- swich is not set.
4562 if not Warn_On_Suspicious_Contract
then
4565 -- Nothing to do if there is no contract
4567 elsif No
(Items
) then
4570 -- If the subprogram has a contract Exceptional_Cases, it is often
4571 -- useful to refer only to the pre-state in the postcondition, to
4572 -- indicate when the subprogram might terminate normally.
4574 elsif Present
(Get_Pragma
(Subp_Id
, Pragma_Exceptional_Cases
)) then
4577 -- Same if the subprogram has a contract Always_Terminates => Cond,
4578 -- where Cond is not syntactically True.
4582 Prag
: constant Node_Id
:=
4583 Get_Pragma
(Subp_Id
, Pragma_Always_Terminates
);
4586 and then Present
(Pragma_Argument_Associations
(Prag
))
4589 Cond
: constant Node_Id
:=
4591 (First
(Pragma_Argument_Associations
(Prag
)));
4593 if not Compile_Time_Known_Value
(Cond
)
4594 or else not Is_True
(Expr_Value
(Cond
))
4603 -- Examine all postconditions for attribute 'Result and a post-state
4605 Prag
:= Pre_Post_Conditions
(Items
);
4606 while Present
(Prag
) loop
4607 if Pragma_Name_Unmapped
(Prag
)
4608 in Name_Postcondition | Name_Refined_Post
4609 and then not Error_Posted
(Prag
)
4612 Check_Result_And_Post_State_In_Pragma
(Prag
, Seen_In_Post
);
4615 Prag
:= Next_Pragma
(Prag
);
4618 -- Examine the contract cases of the subprogram for attribute 'Result
4619 -- and a post-state.
4621 Prag
:= Contract_Test_Cases
(Items
);
4622 while Present
(Prag
) loop
4623 if Pragma_Name
(Prag
) = Name_Contract_Cases
4624 and then not Error_Posted
(Prag
)
4627 Check_Result_And_Post_State_In_Pragma
(Prag
, Seen_In_Case
);
4630 Prag
:= Next_Pragma
(Prag
);
4633 -- Do not emit any errors if the subprogram is not a function
4635 if Ekind
(Spec_Id
) not in E_Function | E_Generic_Function
then
4638 -- Regardless of whether the function has postconditions or contract
4639 -- cases, or whether they mention attribute 'Result, an [IN] OUT formal
4640 -- parameter is always treated as a result.
4642 elsif Has_Out_Or_In_Out_Parameter
(Spec_Id
) then
4645 -- The function has both a postcondition and contract cases and they do
4646 -- not mention attribute 'Result.
4648 elsif Present
(Case_Prag
)
4649 and then not Seen_In_Case
4650 and then Present
(Post_Prag
)
4651 and then not Seen_In_Post
4654 ("neither postcondition nor contract cases mention function "
4655 & "result?.t?", Post_Prag
);
4657 -- The function has contract cases only and they do not mention
4658 -- attribute 'Result.
4660 elsif Present
(Case_Prag
) and then not Seen_In_Case
then
4662 ("contract cases do not mention function result?.t?", Case_Prag
);
4664 -- The function has non-trivial postconditions only and they do not
4665 -- mention attribute 'Result.
4667 elsif Present
(Post_Prag
)
4668 and then not Seen_In_Post
4669 and then not Is_Trivial_Boolean
4670 (Get_Pragma_Arg
(First
(Pragma_Argument_Associations
(Post_Prag
))))
4673 ("postcondition does not mention function result?.t?", Post_Prag
);
4675 end Check_Result_And_Post_State
;
4677 -----------------------------
4678 -- Check_State_Refinements --
4679 -----------------------------
4681 procedure Check_State_Refinements
4683 Is_Main_Unit
: Boolean := False)
4685 procedure Check_Package
(Pack
: Node_Id
);
4686 -- Verify that all abstract states of a [generic] package denoted by its
4687 -- declarative node Pack have proper refinement. Recursively verify the
4688 -- visible and private declarations of the [generic] package for other
4691 procedure Check_Packages_In
(Decls
: List_Id
);
4692 -- Seek out [generic] package declarations within declarative list Decls
4693 -- and verify the status of their abstract state refinement.
4695 function SPARK_Mode_Is_Off
(N
: Node_Id
) return Boolean;
4696 -- Determine whether construct N is subject to pragma SPARK_Mode Off
4702 procedure Check_Package
(Pack
: Node_Id
) is
4703 Body_Id
: constant Entity_Id
:= Corresponding_Body
(Pack
);
4704 Spec
: constant Node_Id
:= Specification
(Pack
);
4705 States
: constant Elist_Id
:=
4706 Abstract_States
(Defining_Entity
(Pack
));
4708 State_Elmt
: Elmt_Id
;
4709 State_Id
: Entity_Id
;
4712 -- Do not verify proper state refinement when the package is subject
4713 -- to pragma SPARK_Mode Off because this disables the requirement for
4714 -- state refinement.
4716 if SPARK_Mode_Is_Off
(Pack
) then
4719 -- State refinement can only occur in a completing package body. Do
4720 -- not verify proper state refinement when the body is subject to
4721 -- pragma SPARK_Mode Off because this disables the requirement for
4722 -- state refinement.
4724 elsif Present
(Body_Id
)
4725 and then SPARK_Mode_Is_Off
(Unit_Declaration_Node
(Body_Id
))
4729 -- Do not verify proper state refinement when the package is an
4730 -- instance as this check was already performed in the generic.
4732 elsif Present
(Generic_Parent
(Spec
)) then
4735 -- Otherwise examine the contents of the package
4738 if Present
(States
) then
4739 State_Elmt
:= First_Elmt
(States
);
4740 while Present
(State_Elmt
) loop
4741 State_Id
:= Node
(State_Elmt
);
4743 -- Emit an error when a non-null state lacks refinement,
4744 -- but has Part_Of constituents or there is a package
4745 -- body (SPARK RM 7.1.4(4)). Constituents in private
4746 -- child packages, which are not known at this stage,
4747 -- independently require the existence of a package body.
4749 if not Is_Null_State
(State_Id
)
4750 and then No
(Refinement_Constituents
(State_Id
))
4752 (Present
(Part_Of_Constituents
(State_Id
))
4756 Error_Msg_N
("state & requires refinement", State_Id
);
4757 Error_Msg_N
("\package body should have Refined_State "
4758 & "for state & with constituents", State_Id
);
4761 Next_Elmt
(State_Elmt
);
4765 Check_Packages_In
(Visible_Declarations
(Spec
));
4766 Check_Packages_In
(Private_Declarations
(Spec
));
4770 -----------------------
4771 -- Check_Packages_In --
4772 -----------------------
4774 procedure Check_Packages_In
(Decls
: List_Id
) is
4778 if Present
(Decls
) then
4779 Decl
:= First
(Decls
);
4780 while Present
(Decl
) loop
4781 if Nkind
(Decl
) in N_Generic_Package_Declaration
4782 | N_Package_Declaration
4784 Check_Package
(Decl
);
4790 end Check_Packages_In
;
4792 -----------------------
4793 -- SPARK_Mode_Is_Off --
4794 -----------------------
4796 function SPARK_Mode_Is_Off
(N
: Node_Id
) return Boolean is
4797 Id
: constant Entity_Id
:= Defining_Entity
(N
);
4798 Prag
: constant Node_Id
:= SPARK_Pragma
(Id
);
4801 -- Default the mode to "off" when the context is an instance and all
4802 -- SPARK_Mode pragmas found within are to be ignored.
4804 if Ignore_SPARK_Mode_Pragmas
(Id
) then
4810 and then Get_SPARK_Mode_From_Annotation
(Prag
) = Off
;
4812 end SPARK_Mode_Is_Off
;
4814 -- Start of processing for Check_State_Refinements
4817 -- A block may declare a nested package
4819 if Nkind
(Context
) = N_Block_Statement
then
4820 Check_Packages_In
(Declarations
(Context
));
4822 -- An entry, protected, subprogram, or task body may declare a nested
4825 elsif Nkind
(Context
) in N_Entry_Body
4830 -- Do not verify proper state refinement when the body is subject to
4831 -- pragma SPARK_Mode Off because this disables the requirement for
4832 -- state refinement.
4834 if not SPARK_Mode_Is_Off
(Context
) then
4835 Check_Packages_In
(Declarations
(Context
));
4838 -- A package body may declare a nested package
4840 elsif Nkind
(Context
) = N_Package_Body
then
4841 Check_Package
(Unit_Declaration_Node
(Corresponding_Spec
(Context
)));
4843 -- Do not verify proper state refinement when the body is subject to
4844 -- pragma SPARK_Mode Off because this disables the requirement for
4845 -- state refinement.
4847 if not SPARK_Mode_Is_Off
(Context
) then
4848 Check_Packages_In
(Declarations
(Context
));
4851 -- A library level [generic] package may declare a nested package
4853 elsif Nkind
(Context
) in
4854 N_Generic_Package_Declaration | N_Package_Declaration
4855 and then Is_Main_Unit
4857 Check_Package
(Context
);
4859 end Check_State_Refinements
;
4861 ------------------------------
4862 -- Check_Unprotected_Access --
4863 ------------------------------
4865 procedure Check_Unprotected_Access
4869 Cont_Encl_Typ
: Entity_Id
;
4870 Pref_Encl_Typ
: Entity_Id
;
4872 function Enclosing_Protected_Type
(Obj
: Node_Id
) return Entity_Id
;
4873 -- Check whether Obj is a private component of a protected object.
4874 -- Return the protected type where the component resides, Empty
4877 function Is_Public_Operation
return Boolean;
4878 -- Verify that the enclosing operation is callable from outside the
4879 -- protected object, to minimize false positives.
4881 ------------------------------
4882 -- Enclosing_Protected_Type --
4883 ------------------------------
4885 function Enclosing_Protected_Type
(Obj
: Node_Id
) return Entity_Id
is
4887 if Is_Entity_Name
(Obj
) then
4889 Ent
: Entity_Id
:= Entity
(Obj
);
4892 -- The object can be a renaming of a private component, use
4893 -- the original record component.
4895 if Is_Prival
(Ent
) then
4896 Ent
:= Prival_Link
(Ent
);
4899 if Is_Protected_Type
(Scope
(Ent
)) then
4905 -- For indexed and selected components, recursively check the prefix
4907 if Nkind
(Obj
) in N_Indexed_Component | N_Selected_Component
then
4908 return Enclosing_Protected_Type
(Prefix
(Obj
));
4910 -- The object does not denote a protected component
4915 end Enclosing_Protected_Type
;
4917 -------------------------
4918 -- Is_Public_Operation --
4919 -------------------------
4921 function Is_Public_Operation
return Boolean is
4927 while Present
(S
) and then S
/= Pref_Encl_Typ
loop
4928 if Scope
(S
) = Pref_Encl_Typ
then
4929 E
:= First_Entity
(Pref_Encl_Typ
);
4931 and then E
/= First_Private_Entity
(Pref_Encl_Typ
)
4945 end Is_Public_Operation
;
4947 -- Start of processing for Check_Unprotected_Access
4950 if Nkind
(Expr
) = N_Attribute_Reference
4951 and then Attribute_Name
(Expr
) = Name_Unchecked_Access
4953 Cont_Encl_Typ
:= Enclosing_Protected_Type
(Context
);
4954 Pref_Encl_Typ
:= Enclosing_Protected_Type
(Prefix
(Expr
));
4956 -- Check whether we are trying to export a protected component to a
4957 -- context with an equal or lower access level.
4959 if Present
(Pref_Encl_Typ
)
4960 and then No
(Cont_Encl_Typ
)
4961 and then Is_Public_Operation
4962 and then Scope_Depth
(Pref_Encl_Typ
)
4963 >= Static_Accessibility_Level
4964 (Context
, Object_Decl_Level
)
4967 ("??possible unprotected access to protected data", Expr
);
4970 end Check_Unprotected_Access
;
4972 ------------------------------
4973 -- Check_Unused_Body_States --
4974 ------------------------------
4976 procedure Check_Unused_Body_States
(Body_Id
: Entity_Id
) is
4977 procedure Process_Refinement_Clause
4980 -- Inspect all constituents of refinement clause Clause and remove any
4981 -- matches from body state list States.
4983 procedure Report_Unused_Body_States
(States
: Elist_Id
);
4984 -- Emit errors for each abstract state or object found in list States
4986 -------------------------------
4987 -- Process_Refinement_Clause --
4988 -------------------------------
4990 procedure Process_Refinement_Clause
4994 procedure Process_Constituent
(Constit
: Node_Id
);
4995 -- Remove constituent Constit from body state list States
4997 -------------------------
4998 -- Process_Constituent --
4999 -------------------------
5001 procedure Process_Constituent
(Constit
: Node_Id
) is
5002 Constit_Id
: Entity_Id
;
5005 -- Guard against illegal constituents. Only abstract states and
5006 -- objects can appear on the right hand side of a refinement.
5008 if Is_Entity_Name
(Constit
) then
5009 Constit_Id
:= Entity_Of
(Constit
);
5011 if Present
(Constit_Id
)
5012 and then Ekind
(Constit_Id
) in
5013 E_Abstract_State | E_Constant | E_Variable
5015 Remove
(States
, Constit_Id
);
5018 end Process_Constituent
;
5024 -- Start of processing for Process_Refinement_Clause
5027 if Nkind
(Clause
) = N_Component_Association
then
5028 Constit
:= Expression
(Clause
);
5030 -- Multiple constituents appear as an aggregate
5032 if Nkind
(Constit
) = N_Aggregate
then
5033 Constit
:= First
(Expressions
(Constit
));
5034 while Present
(Constit
) loop
5035 Process_Constituent
(Constit
);
5039 -- Various forms of a single constituent
5042 Process_Constituent
(Constit
);
5045 end Process_Refinement_Clause
;
5047 -------------------------------
5048 -- Report_Unused_Body_States --
5049 -------------------------------
5051 procedure Report_Unused_Body_States
(States
: Elist_Id
) is
5052 Posted
: Boolean := False;
5053 State_Elmt
: Elmt_Id
;
5054 State_Id
: Entity_Id
;
5057 if Present
(States
) then
5058 State_Elmt
:= First_Elmt
(States
);
5059 while Present
(State_Elmt
) loop
5060 State_Id
:= Node
(State_Elmt
);
5062 -- Constants are part of the hidden state of a package, but the
5063 -- compiler cannot determine whether they have variable input
5064 -- (SPARK RM 7.1.1(2)) and cannot classify them properly as a
5065 -- hidden state. Do not emit an error when a constant does not
5066 -- participate in a state refinement, even though it acts as a
5069 if Ekind
(State_Id
) = E_Constant
then
5072 -- Overlays do not contribute to package state
5074 elsif Ekind
(State_Id
) = E_Variable
5075 and then Present
(Ultimate_Overlaid_Entity
(State_Id
))
5079 -- Generate an error message of the form:
5081 -- body of package ... has unused hidden states
5082 -- abstract state ... defined at ...
5083 -- variable ... defined at ...
5089 ("body of package & has unused hidden states", Body_Id
);
5092 Error_Msg_Sloc
:= Sloc
(State_Id
);
5094 if Ekind
(State_Id
) = E_Abstract_State
then
5096 ("\abstract state & defined #", Body_Id
, State_Id
);
5099 SPARK_Msg_NE
("\variable & defined #", Body_Id
, State_Id
);
5103 Next_Elmt
(State_Elmt
);
5106 end Report_Unused_Body_States
;
5110 Prag
: constant Node_Id
:= Get_Pragma
(Body_Id
, Pragma_Refined_State
);
5111 Spec_Id
: constant Entity_Id
:= Spec_Entity
(Body_Id
);
5115 -- Start of processing for Check_Unused_Body_States
5118 -- Inspect the clauses of pragma Refined_State and determine whether all
5119 -- visible states declared within the package body participate in the
5122 if Present
(Prag
) then
5123 Clause
:= Expression
(Get_Argument
(Prag
, Spec_Id
));
5124 States
:= Collect_Body_States
(Body_Id
);
5126 -- Multiple non-null state refinements appear as an aggregate
5128 if Nkind
(Clause
) = N_Aggregate
then
5129 Clause
:= First
(Component_Associations
(Clause
));
5130 while Present
(Clause
) loop
5131 Process_Refinement_Clause
(Clause
, States
);
5135 -- Various forms of a single state refinement
5138 Process_Refinement_Clause
(Clause
, States
);
5141 -- Ensure that all abstract states and objects declared in the
5142 -- package body state space are utilized as constituents.
5144 Report_Unused_Body_States
(States
);
5146 end Check_Unused_Body_States
;
5148 ------------------------------------
5149 -- Check_Volatility_Compatibility --
5150 ------------------------------------
5152 procedure Check_Volatility_Compatibility
5153 (Id1
, Id2
: Entity_Id
;
5154 Description_1
, Description_2
: String;
5155 Srcpos_Bearer
: Node_Id
) is
5158 if SPARK_Mode
/= On
then
5163 AR1
: constant Boolean := Async_Readers_Enabled
(Id1
);
5164 AW1
: constant Boolean := Async_Writers_Enabled
(Id1
);
5165 ER1
: constant Boolean := Effective_Reads_Enabled
(Id1
);
5166 EW1
: constant Boolean := Effective_Writes_Enabled
(Id1
);
5167 AR2
: constant Boolean := Async_Readers_Enabled
(Id2
);
5168 AW2
: constant Boolean := Async_Writers_Enabled
(Id2
);
5169 ER2
: constant Boolean := Effective_Reads_Enabled
(Id2
);
5170 EW2
: constant Boolean := Effective_Writes_Enabled
(Id2
);
5172 AR_Check_Failed
: constant Boolean := AR1
and not AR2
;
5173 AW_Check_Failed
: constant Boolean := AW1
and not AW2
;
5174 ER_Check_Failed
: constant Boolean := ER1
and not ER2
;
5175 EW_Check_Failed
: constant Boolean := EW1
and not EW2
;
5177 package Failure_Description
is
5178 procedure Note_If_Failure
5179 (Failed
: Boolean; Aspect_Name
: String);
5180 -- If Failed is False, do nothing.
5181 -- If Failed is True, add Aspect_Name to the failure description.
5183 function Failure_Text
return String;
5184 -- returns accumulated list of failing aspects
5185 end Failure_Description
;
5187 package body Failure_Description
is
5188 Description_Buffer
: Bounded_String
;
5190 ---------------------
5191 -- Note_If_Failure --
5192 ---------------------
5194 procedure Note_If_Failure
5195 (Failed
: Boolean; Aspect_Name
: String) is
5198 if Description_Buffer
.Length
/= 0 then
5199 Append
(Description_Buffer
, ", ");
5201 Append
(Description_Buffer
, Aspect_Name
);
5203 end Note_If_Failure
;
5209 function Failure_Text
return String is
5211 return +Description_Buffer
;
5213 end Failure_Description
;
5215 use Failure_Description
;
5222 Note_If_Failure
(AR_Check_Failed
, "Async_Readers");
5223 Note_If_Failure
(AW_Check_Failed
, "Async_Writers");
5224 Note_If_Failure
(ER_Check_Failed
, "Effective_Reads");
5225 Note_If_Failure
(EW_Check_Failed
, "Effective_Writes");
5231 & " are not compatible with respect to volatility due to "
5236 end Check_Volatility_Compatibility
;
5242 function Choice_List
(N
: Node_Id
) return List_Id
is
5244 if Nkind
(N
) = N_Iterated_Component_Association
then
5245 return Discrete_Choices
(N
);
5251 ---------------------
5252 -- Class_Condition --
5253 ---------------------
5255 function Class_Condition
5256 (Kind
: Condition_Kind
;
5257 Subp
: Entity_Id
) return Node_Id
is
5261 when Class_Postcondition
=>
5262 return Class_Postconditions
(Subp
);
5264 when Class_Precondition
=>
5265 return Class_Preconditions
(Subp
);
5267 when Ignored_Class_Postcondition
=>
5268 return Ignored_Class_Postconditions
(Subp
);
5270 when Ignored_Class_Precondition
=>
5271 return Ignored_Class_Preconditions
(Subp
);
5273 end Class_Condition
;
5275 -------------------------
5276 -- Collect_Body_States --
5277 -------------------------
5279 function Collect_Body_States
(Body_Id
: Entity_Id
) return Elist_Id
is
5280 function Is_Visible_Object
(Obj_Id
: Entity_Id
) return Boolean;
5281 -- Determine whether object Obj_Id is a suitable visible state of a
5284 procedure Collect_Visible_States
5285 (Pack_Id
: Entity_Id
;
5286 States
: in out Elist_Id
);
5287 -- Gather the entities of all abstract states and objects declared in
5288 -- the visible state space of package Pack_Id.
5290 ----------------------------
5291 -- Collect_Visible_States --
5292 ----------------------------
5294 procedure Collect_Visible_States
5295 (Pack_Id
: Entity_Id
;
5296 States
: in out Elist_Id
)
5298 Item_Id
: Entity_Id
;
5301 -- Traverse the entity chain of the package and inspect all visible
5304 Item_Id
:= First_Entity
(Pack_Id
);
5305 while Present
(Item_Id
) and then not In_Private_Part
(Item_Id
) loop
5307 -- Do not consider internally generated items as those cannot be
5308 -- named and participate in refinement.
5310 if not Comes_From_Source
(Item_Id
) then
5313 elsif Ekind
(Item_Id
) = E_Abstract_State
then
5314 Append_New_Elmt
(Item_Id
, States
);
5316 elsif Ekind
(Item_Id
) in E_Constant | E_Variable
5317 and then Is_Visible_Object
(Item_Id
)
5319 Append_New_Elmt
(Item_Id
, States
);
5321 -- Recursively gather the visible states of a nested package
5322 -- except for nested package renamings.
5324 elsif Ekind
(Item_Id
) = E_Package
5325 and then No
(Renamed_Entity
(Item_Id
))
5327 Collect_Visible_States
(Item_Id
, States
);
5330 Next_Entity
(Item_Id
);
5332 end Collect_Visible_States
;
5334 -----------------------
5335 -- Is_Visible_Object --
5336 -----------------------
5338 function Is_Visible_Object
(Obj_Id
: Entity_Id
) return Boolean is
5340 -- Objects that map generic formals to their actuals are not visible
5341 -- from outside the generic instantiation.
5343 if Present
(Corresponding_Generic_Association
5344 (Declaration_Node
(Obj_Id
)))
5348 -- Constituents of a single protected/task type act as components of
5349 -- the type and are not visible from outside the type.
5351 elsif Ekind
(Obj_Id
) = E_Variable
5352 and then Present
(Encapsulating_State
(Obj_Id
))
5353 and then Is_Single_Concurrent_Object
(Encapsulating_State
(Obj_Id
))
5360 end Is_Visible_Object
;
5364 Body_Decl
: constant Node_Id
:= Unit_Declaration_Node
(Body_Id
);
5366 Item_Id
: Entity_Id
;
5367 States
: Elist_Id
:= No_Elist
;
5369 -- Start of processing for Collect_Body_States
5372 -- Inspect the declarations of the body looking for source objects,
5373 -- packages and package instantiations. Note that even though this
5374 -- processing is very similar to Collect_Visible_States, a package
5375 -- body does not have a First/Next_Entity list.
5377 Decl
:= First
(Declarations
(Body_Decl
));
5378 while Present
(Decl
) loop
5380 -- Capture source objects as internally generated temporaries cannot
5381 -- be named and participate in refinement.
5383 if Nkind
(Decl
) = N_Object_Declaration
then
5384 Item_Id
:= Defining_Entity
(Decl
);
5386 if Comes_From_Source
(Item_Id
)
5387 and then Is_Visible_Object
(Item_Id
)
5389 Append_New_Elmt
(Item_Id
, States
);
5392 -- Capture the visible abstract states and objects of a source
5393 -- package [instantiation].
5395 elsif Nkind
(Decl
) = N_Package_Declaration
then
5396 Item_Id
:= Defining_Entity
(Decl
);
5398 if Comes_From_Source
(Item_Id
) then
5399 Collect_Visible_States
(Item_Id
, States
);
5407 end Collect_Body_States
;
5409 ------------------------
5410 -- Collect_Interfaces --
5411 ------------------------
5413 procedure Collect_Interfaces
5415 Ifaces_List
: out Elist_Id
;
5416 Exclude_Parents
: Boolean := False;
5417 Use_Full_View
: Boolean := True)
5419 procedure Collect
(Typ
: Entity_Id
);
5420 -- Subsidiary subprogram used to traverse the whole list
5421 -- of directly and indirectly implemented interfaces
5427 procedure Collect
(Typ
: Entity_Id
) is
5428 Ancestor
: Entity_Id
;
5436 -- Handle private types and subtypes
5439 and then Is_Private_Type
(Typ
)
5440 and then Present
(Full_View
(Typ
))
5442 Full_T
:= Full_View
(Typ
);
5444 if Ekind
(Full_T
) = E_Record_Subtype
then
5445 Full_T
:= Etype
(Typ
);
5447 if Present
(Full_View
(Full_T
)) then
5448 Full_T
:= Full_View
(Full_T
);
5453 -- Include the ancestor if we are generating the whole list of
5454 -- abstract interfaces.
5456 if Etype
(Full_T
) /= Typ
5458 -- Protect the frontend against wrong sources. For example:
5461 -- type A is tagged null record;
5462 -- type B is new A with private;
5463 -- type C is new A with private;
5465 -- type B is new C with null record;
5466 -- type C is new B with null record;
5469 and then Etype
(Full_T
) /= T
5471 Ancestor
:= Etype
(Full_T
);
5474 if Is_Interface
(Ancestor
) and then not Exclude_Parents
then
5475 Append_Unique_Elmt
(Ancestor
, Ifaces_List
);
5479 -- Traverse the graph of ancestor interfaces
5481 Id
:= First
(Abstract_Interface_List
(Full_T
));
5482 while Present
(Id
) loop
5483 Iface
:= Etype
(Id
);
5485 -- Protect against wrong uses. For example:
5486 -- type I is interface;
5487 -- type O is tagged null record;
5488 -- type Wrong is new I and O with null record; -- ERROR
5490 if Is_Interface
(Iface
) then
5492 and then Etype
(T
) /= T
5493 and then Interface_Present_In_Ancestor
(Etype
(T
), Iface
)
5498 Append_Unique_Elmt
(Iface
, Ifaces_List
);
5506 -- Start of processing for Collect_Interfaces
5509 pragma Assert
(Is_Tagged_Type
(T
) or else Is_Concurrent_Type
(T
));
5510 Ifaces_List
:= New_Elmt_List
;
5512 end Collect_Interfaces
;
5514 ----------------------------------
5515 -- Collect_Interface_Components --
5516 ----------------------------------
5518 procedure Collect_Interface_Components
5519 (Tagged_Type
: Entity_Id
;
5520 Components_List
: out Elist_Id
)
5522 procedure Collect
(Typ
: Entity_Id
);
5523 -- Subsidiary subprogram used to climb to the parents
5529 procedure Collect
(Typ
: Entity_Id
) is
5530 Tag_Comp
: Entity_Id
;
5531 Parent_Typ
: Entity_Id
;
5534 -- Handle private types
5536 if Present
(Full_View
(Etype
(Typ
))) then
5537 Parent_Typ
:= Full_View
(Etype
(Typ
));
5539 Parent_Typ
:= Etype
(Typ
);
5542 if Parent_Typ
/= Typ
5544 -- Protect the frontend against wrong sources. For example:
5547 -- type A is tagged null record;
5548 -- type B is new A with private;
5549 -- type C is new A with private;
5551 -- type B is new C with null record;
5552 -- type C is new B with null record;
5555 and then Parent_Typ
/= Tagged_Type
5557 Collect
(Parent_Typ
);
5560 -- Collect the components containing tags of secondary dispatch
5563 Tag_Comp
:= Next_Tag_Component
(First_Tag_Component
(Typ
));
5564 while Present
(Tag_Comp
) loop
5565 pragma Assert
(Present
(Related_Type
(Tag_Comp
)));
5566 Append_Elmt
(Tag_Comp
, Components_List
);
5568 Tag_Comp
:= Next_Tag_Component
(Tag_Comp
);
5572 -- Start of processing for Collect_Interface_Components
5575 pragma Assert
(Ekind
(Tagged_Type
) = E_Record_Type
5576 and then Is_Tagged_Type
(Tagged_Type
));
5578 Components_List
:= New_Elmt_List
;
5579 Collect
(Tagged_Type
);
5580 end Collect_Interface_Components
;
5582 -----------------------------
5583 -- Collect_Interfaces_Info --
5584 -----------------------------
5586 procedure Collect_Interfaces_Info
5588 Ifaces_List
: out Elist_Id
;
5589 Components_List
: out Elist_Id
;
5590 Tags_List
: out Elist_Id
)
5592 Comps_List
: Elist_Id
;
5593 Comp_Elmt
: Elmt_Id
;
5594 Comp_Iface
: Entity_Id
;
5595 Iface_Elmt
: Elmt_Id
;
5598 function Search_Tag
(Iface
: Entity_Id
) return Entity_Id
;
5599 -- Search for the secondary tag associated with the interface type
5600 -- Iface that is implemented by T.
5606 function Search_Tag
(Iface
: Entity_Id
) return Entity_Id
is
5609 if not Is_CPP_Class
(T
) then
5610 ADT
:= Next_Elmt
(Next_Elmt
(First_Elmt
(Access_Disp_Table
(T
))));
5612 ADT
:= Next_Elmt
(First_Elmt
(Access_Disp_Table
(T
)));
5616 and then Is_Tag
(Node
(ADT
))
5617 and then Related_Type
(Node
(ADT
)) /= Iface
5619 -- Skip secondary dispatch table referencing thunks to user
5620 -- defined primitives covered by this interface.
5622 pragma Assert
(Has_Suffix
(Node
(ADT
), 'P'));
5625 -- Skip secondary dispatch tables of Ada types
5627 if not Is_CPP_Class
(T
) then
5629 -- Skip secondary dispatch table referencing thunks to
5630 -- predefined primitives.
5632 pragma Assert
(Has_Suffix
(Node
(ADT
), 'Y'));
5635 -- Skip secondary dispatch table referencing user-defined
5636 -- primitives covered by this interface.
5638 pragma Assert
(Has_Suffix
(Node
(ADT
), 'D'));
5641 -- Skip secondary dispatch table referencing predefined
5644 pragma Assert
(Has_Suffix
(Node
(ADT
), 'Z'));
5649 pragma Assert
(Is_Tag
(Node
(ADT
)));
5653 -- Start of processing for Collect_Interfaces_Info
5656 Collect_Interfaces
(T
, Ifaces_List
);
5657 Collect_Interface_Components
(T
, Comps_List
);
5659 -- Search for the record component and tag associated with each
5660 -- interface type of T.
5662 Components_List
:= New_Elmt_List
;
5663 Tags_List
:= New_Elmt_List
;
5665 Iface_Elmt
:= First_Elmt
(Ifaces_List
);
5666 while Present
(Iface_Elmt
) loop
5667 Iface
:= Node
(Iface_Elmt
);
5669 -- Associate the primary tag component and the primary dispatch table
5670 -- with all the interfaces that are parents of T
5672 if Is_Ancestor
(Iface
, T
, Use_Full_View
=> True) then
5673 Append_Elmt
(First_Tag_Component
(T
), Components_List
);
5674 Append_Elmt
(Node
(First_Elmt
(Access_Disp_Table
(T
))), Tags_List
);
5676 -- Otherwise search for the tag component and secondary dispatch
5680 Comp_Elmt
:= First_Elmt
(Comps_List
);
5681 while Present
(Comp_Elmt
) loop
5682 Comp_Iface
:= Related_Type
(Node
(Comp_Elmt
));
5684 if Comp_Iface
= Iface
5685 or else Is_Ancestor
(Iface
, Comp_Iface
, Use_Full_View
=> True)
5687 Append_Elmt
(Node
(Comp_Elmt
), Components_List
);
5688 Append_Elmt
(Search_Tag
(Comp_Iface
), Tags_List
);
5692 Next_Elmt
(Comp_Elmt
);
5694 pragma Assert
(Present
(Comp_Elmt
));
5697 Next_Elmt
(Iface_Elmt
);
5699 end Collect_Interfaces_Info
;
5701 ---------------------
5702 -- Collect_Parents --
5703 ---------------------
5705 procedure Collect_Parents
5707 List
: out Elist_Id
;
5708 Use_Full_View
: Boolean := True)
5710 Current_Typ
: Entity_Id
:= T
;
5711 Parent_Typ
: Entity_Id
;
5714 List
:= New_Elmt_List
;
5716 -- No action if the if the type has no parents
5718 if T
= Etype
(T
) then
5723 Parent_Typ
:= Etype
(Current_Typ
);
5725 if Is_Private_Type
(Parent_Typ
)
5726 and then Present
(Full_View
(Parent_Typ
))
5727 and then Use_Full_View
5729 Parent_Typ
:= Full_View
(Base_Type
(Parent_Typ
));
5732 Append_Elmt
(Parent_Typ
, List
);
5734 exit when Parent_Typ
= Current_Typ
;
5735 Current_Typ
:= Parent_Typ
;
5737 end Collect_Parents
;
5739 ----------------------------------
5740 -- Collect_Primitive_Operations --
5741 ----------------------------------
5743 function Collect_Primitive_Operations
(T
: Entity_Id
) return Elist_Id
is
5744 B_Type
: constant Entity_Id
:= Base_Type
(T
);
5746 function Match
(E
: Entity_Id
) return Boolean;
5747 -- True if E's base type is B_Type, or E is of an anonymous access type
5748 -- and the base type of its designated type is B_Type.
5754 function Match
(E
: Entity_Id
) return Boolean is
5755 Etyp
: Entity_Id
:= Etype
(E
);
5758 if Ekind
(Etyp
) = E_Anonymous_Access_Type
then
5759 Etyp
:= Designated_Type
(Etyp
);
5762 -- In Ada 2012 a primitive operation may have a formal of an
5763 -- incomplete view of the parent type.
5765 return Base_Type
(Etyp
) = B_Type
5767 (Ada_Version
>= Ada_2012
5768 and then Ekind
(Etyp
) = E_Incomplete_Type
5769 and then Full_View
(Etyp
) = B_Type
);
5774 B_Decl
: constant Node_Id
:= Original_Node
(Parent
(B_Type
));
5775 B_Scope
: Entity_Id
:= Scope
(B_Type
);
5777 Eq_Prims_List
: Elist_Id
:= No_Elist
;
5780 Is_Type_In_Pkg
: Boolean;
5781 Formal_Derived
: Boolean := False;
5784 -- Start of processing for Collect_Primitive_Operations
5787 -- For tagged types, the primitive operations are collected as they
5788 -- are declared, and held in an explicit list which is simply returned.
5790 if Is_Tagged_Type
(B_Type
) then
5791 return Primitive_Operations
(B_Type
);
5793 -- An untagged generic type that is a derived type inherits the
5794 -- primitive operations of its parent type. Other formal types only
5795 -- have predefined operators, which are not explicitly represented.
5797 elsif Is_Generic_Type
(B_Type
) then
5798 if Nkind
(B_Decl
) = N_Formal_Type_Declaration
5799 and then Nkind
(Formal_Type_Definition
(B_Decl
)) =
5800 N_Formal_Derived_Type_Definition
5802 Formal_Derived
:= True;
5804 return New_Elmt_List
;
5808 Op_List
:= New_Elmt_List
;
5810 if B_Scope
= Standard_Standard
then
5811 if B_Type
= Standard_String
then
5812 Append_Elmt
(Standard_Op_Concat
, Op_List
);
5814 elsif B_Type
= Standard_Wide_String
then
5815 Append_Elmt
(Standard_Op_Concatw
, Op_List
);
5821 -- Locate the primitive subprograms of the type
5824 -- The primitive operations appear after the base type, except if the
5825 -- derivation happens within the private part of B_Scope and the type
5826 -- is a private type, in which case both the type and some primitive
5827 -- operations may appear before the base type, and the list of
5828 -- candidates starts after the type.
5830 if In_Open_Scopes
(B_Scope
)
5831 and then Scope
(T
) = B_Scope
5832 and then In_Private_Part
(B_Scope
)
5834 Id
:= Next_Entity
(T
);
5836 -- In Ada 2012, If the type has an incomplete partial view, there may
5837 -- be primitive operations declared before the full view, so we need
5838 -- to start scanning from the incomplete view, which is earlier on
5839 -- the entity chain.
5841 elsif Nkind
(Parent
(B_Type
)) = N_Full_Type_Declaration
5842 and then Present
(Incomplete_View
(Parent
(B_Type
)))
5844 Id
:= Incomplete_View
(Parent
(B_Type
));
5846 -- If T is a derived from a type with an incomplete view declared
5847 -- elsewhere, that incomplete view is irrelevant, we want the
5848 -- operations in the scope of T.
5850 if Scope
(Id
) /= Scope
(B_Type
) then
5851 Id
:= Next_Entity
(B_Type
);
5855 Id
:= Next_Entity
(B_Type
);
5858 -- Set flag if this is a type in a package spec
5861 Is_Package_Or_Generic_Package
(B_Scope
)
5863 Parent_Kind
(Declaration_Node
(First_Subtype
(T
))) /=
5866 while Present
(Id
) loop
5868 -- Test whether the result type or any of the parameter types of
5869 -- each subprogram following the type match that type when the
5870 -- type is declared in a package spec, is a derived type, or the
5871 -- subprogram is marked as primitive. (The Is_Primitive test is
5872 -- needed to find primitives of nonderived types in declarative
5873 -- parts that happen to override the predefined "=" operator.)
5875 -- Note that generic formal subprograms are not considered to be
5876 -- primitive operations and thus are never inherited.
5878 if Is_Overloadable
(Id
)
5879 and then (Is_Type_In_Pkg
5880 or else Is_Derived_Type
(B_Type
)
5881 or else Is_Primitive
(Id
))
5882 and then Parent_Kind
(Parent
(Id
))
5883 not in N_Formal_Subprogram_Declaration
5891 Formal
:= First_Formal
(Id
);
5892 while Present
(Formal
) loop
5893 if Match
(Formal
) then
5898 Next_Formal
(Formal
);
5902 -- For a formal derived type, the only primitives are the ones
5903 -- inherited from the parent type. Operations appearing in the
5904 -- package declaration are not primitive for it.
5907 and then (not Formal_Derived
or else Present
(Alias
(Id
)))
5909 -- In the special case of an equality operator aliased to
5910 -- an overriding dispatching equality belonging to the same
5911 -- type, we don't include it in the list of primitives.
5912 -- This avoids inheriting multiple equality operators when
5913 -- deriving from untagged private types whose full type is
5914 -- tagged, which can otherwise cause ambiguities. Note that
5915 -- this should only happen for this kind of untagged parent
5916 -- type, since normally dispatching operations are inherited
5917 -- using the type's Primitive_Operations list.
5919 if Chars
(Id
) = Name_Op_Eq
5920 and then Is_Dispatching_Operation
(Id
)
5921 and then Present
(Alias
(Id
))
5922 and then Present
(Overridden_Operation
(Alias
(Id
)))
5923 and then Base_Type
(Etype
(First_Entity
(Id
))) =
5924 Base_Type
(Etype
(First_Entity
(Alias
(Id
))))
5928 -- Include the subprogram in the list of primitives
5931 Append_Elmt
(Id
, Op_List
);
5933 -- Save collected equality primitives for later filtering
5934 -- (if we are processing a private type for which we can
5935 -- collect several candidates).
5937 if Inherits_From_Tagged_Full_View
(T
)
5938 and then Chars
(Id
) = Name_Op_Eq
5939 and then Etype
(First_Formal
(Id
)) =
5940 Etype
(Next_Formal
(First_Formal
(Id
)))
5942 Append_New_Elmt
(Id
, Eq_Prims_List
);
5950 -- For a type declared in System, some of its operations may
5951 -- appear in the target-specific extension to System.
5954 and then Is_RTU
(B_Scope
, System
)
5955 and then Present_System_Aux
5957 B_Scope
:= System_Aux_Id
;
5958 Id
:= First_Entity
(System_Aux_Id
);
5962 -- Filter collected equality primitives
5964 if Inherits_From_Tagged_Full_View
(T
)
5965 and then Present
(Eq_Prims_List
)
5968 First
: constant Elmt_Id
:= First_Elmt
(Eq_Prims_List
);
5972 pragma Assert
(No
(Next_Elmt
(First
))
5973 or else No
(Next_Elmt
(Next_Elmt
(First
))));
5975 -- No action needed if we have collected a single equality
5978 if Present
(Next_Elmt
(First
)) then
5979 Second
:= Next_Elmt
(First
);
5981 if Is_Dispatching_Operation
5982 (Ultimate_Alias
(Node
(First
)))
5984 Remove
(Op_List
, Node
(First
));
5986 elsif Is_Dispatching_Operation
5987 (Ultimate_Alias
(Node
(Second
)))
5989 Remove
(Op_List
, Node
(Second
));
5992 raise Program_Error
;
6000 end Collect_Primitive_Operations
;
6002 -----------------------------------
6003 -- Compile_Time_Constraint_Error --
6004 -----------------------------------
6006 function Compile_Time_Constraint_Error
6009 Ent
: Entity_Id
:= Empty
;
6010 Loc
: Source_Ptr
:= No_Location
;
6011 Warn
: Boolean := False;
6012 Extra_Msg
: String := "") return Node_Id
6014 Msgc
: String (1 .. Msg
'Length + 3);
6015 -- Copy of message, with room for possible ?? or << and ! at end
6022 -- If this is a warning, convert it into an error if we are in code
6023 -- subject to SPARK_Mode being set On, unless Warn is True to force a
6024 -- warning. The rationale is that a compile-time constraint error should
6025 -- lead to an error instead of a warning when SPARK_Mode is On, but in
6026 -- a few cases we prefer to issue a warning and generate both a suitable
6027 -- run-time error in GNAT and a suitable check message in GNATprove.
6028 -- Those cases are those that likely correspond to deactivated SPARK
6029 -- code, so that this kind of code can be compiled and analyzed instead
6030 -- of being rejected.
6032 Error_Msg_Warn
:= Warn
or SPARK_Mode
/= On
;
6034 -- A static constraint error in an instance body is not a fatal error.
6035 -- We choose to inhibit the message altogether, because there is no
6036 -- obvious node (for now) on which to post it. On the other hand the
6037 -- offending node must be replaced with a constraint_error in any case.
6039 -- No messages are generated if we already posted an error on this node
6041 if not Error_Posted
(N
) then
6042 if Loc
/= No_Location
then
6048 -- Copy message to Msgc, converting any ? in the message into <
6049 -- instead, so that we have an error in GNATprove mode.
6053 for J
in 1 .. Msgl
loop
6054 if Msg
(J
) = '?' and then (J
= 1 or else Msg
(J
- 1) /= ''') then
6057 Msgc
(J
) := Msg
(J
);
6061 -- Message is a warning, even in Ada 95 case
6063 if Msg
(Msg
'Last) = '?' or else Msg
(Msg
'Last) = '<' then
6066 -- In Ada 83, all messages are warnings. In the private part and the
6067 -- body of an instance, constraint_checks are only warnings. We also
6068 -- make this a warning if the Warn parameter is set.
6071 or else (Ada_Version
= Ada_83
and then Comes_From_Source
(N
))
6072 or else In_Instance_Not_Visible
6080 -- Otherwise we have a real error message (Ada 95 static case) and we
6081 -- make this an unconditional message. Note that in the warning case
6082 -- we do not make the message unconditional, it seems reasonable to
6083 -- delete messages like this (about exceptions that will be raised)
6092 -- One more test, skip the warning if the related expression is
6093 -- statically unevaluated, since we don't want to warn about what
6094 -- will happen when something is evaluated if it never will be
6097 -- Suppress error reporting when checking that the expression of a
6098 -- static expression function is a potentially static expression,
6099 -- because we don't want additional errors being reported during the
6100 -- preanalysis of the expression (see Analyze_Expression_Function).
6102 if not Is_Statically_Unevaluated
(N
)
6103 and then not Checking_Potentially_Static_Expression
6105 if Present
(Ent
) then
6106 Error_Msg_NEL
(Msgc
(1 .. Msgl
), N
, Ent
, Eloc
);
6108 Error_Msg_NEL
(Msgc
(1 .. Msgl
), N
, Etype
(N
), Eloc
);
6111 -- Emit any extra message as a continuation
6113 if Extra_Msg
/= "" then
6114 Error_Msg_N
('\' & Extra_Msg
, N
);
6119 -- Check whether the context is an Init_Proc
6121 if Inside_Init_Proc
then
6123 Init_Proc_Type
: constant Entity_Id
:=
6124 Etype
(First_Formal
(Current_Scope_No_Loops
));
6126 Conc_Typ
: constant Entity_Id
:=
6127 (if Present
(Init_Proc_Type
)
6128 and then Ekind
(Init_Proc_Type
) = E_Record_Type
6129 then Corresponding_Concurrent_Type
(Init_Proc_Type
)
6133 -- Don't complain if the corresponding concurrent type
6134 -- doesn't come from source (i.e. a single task/protected
6137 if Present
(Conc_Typ
)
6138 and then not Comes_From_Source
(Conc_Typ
)
6140 Error_Msg
("\& [<<", Eloc
, N
);
6143 if GNATprove_Mode
then
6145 ("\Constraint_Error would have been raised"
6146 & " for objects of this type", Eloc
, N
);
6149 ("\Constraint_Error will be raised"
6150 & " for objects of this type??", Eloc
, N
);
6156 Error_Msg
("\Constraint_Error [<<", Eloc
, N
);
6160 Error_Msg
("\static expression fails Constraint_Check", Eloc
);
6161 Set_Error_Posted
(N
);
6167 end Compile_Time_Constraint_Error
;
6169 ----------------------------
6170 -- Compute_Returns_By_Ref --
6171 ----------------------------
6173 procedure Compute_Returns_By_Ref
(Func
: Entity_Id
) is
6174 Kind
: constant Entity_Kind
:= Ekind
(Func
);
6175 Typ
: constant Entity_Id
:= Etype
(Func
);
6178 -- Nothing to do for procedures
6180 if Kind
in E_Procedure | E_Generic_Procedure
6181 or else (Kind
= E_Subprogram_Type
and then Typ
= Standard_Void_Type
)
6185 -- The build-in-place protocols return a reference to the result
6187 elsif Is_Build_In_Place_Function
(Func
) then
6188 Set_Returns_By_Ref
(Func
);
6190 -- In Ada 95, limited types are returned by reference, but not if the
6191 -- convention is other than Ada.
6193 elsif Is_Limited_View
(Typ
)
6194 and then not Has_Foreign_Convention
(Func
)
6196 Set_Returns_By_Ref
(Func
);
6198 end Compute_Returns_By_Ref
;
6200 --------------------------------
6201 -- Collect_Types_In_Hierarchy --
6202 --------------------------------
6204 function Collect_Types_In_Hierarchy
6206 Examine_Components
: Boolean := False) return Elist_Id
6210 procedure Process_Type
(Typ
: Entity_Id
);
6211 -- Collect type Typ if it satisfies function Predicate. Do so for its
6212 -- parent type, base type, progenitor types, and any component types.
6218 procedure Process_Type
(Typ
: Entity_Id
) is
6220 Iface_Elmt
: Elmt_Id
;
6223 if not Is_Type
(Typ
) or else Error_Posted
(Typ
) then
6227 -- Collect the current type if it satisfies the predicate
6229 if Predicate
(Typ
) then
6230 Append_Elmt
(Typ
, Results
);
6233 -- Process component types
6235 if Examine_Components
then
6237 -- Examine components and discriminants
6239 if Is_Concurrent_Type
(Typ
)
6240 or else Is_Incomplete_Or_Private_Type
(Typ
)
6241 or else Is_Record_Type
(Typ
)
6242 or else Has_Discriminants
(Typ
)
6244 Comp
:= First_Component_Or_Discriminant
(Typ
);
6246 while Present
(Comp
) loop
6247 Process_Type
(Etype
(Comp
));
6249 Next_Component_Or_Discriminant
(Comp
);
6252 -- Examine array components
6254 elsif Ekind
(Typ
) = E_Array_Type
then
6255 Process_Type
(Component_Type
(Typ
));
6259 -- Examine parent type
6261 if Etype
(Typ
) /= Typ
then
6262 -- Prevent infinite recursion, which can happen in illegal
6263 -- programs. Silently return if illegal. For now, just deal
6264 -- with the 2-type cycle case. Larger cycles will get
6265 -- SIGSEGV at compile time from running out of stack.
6267 if Etype
(Etype
(Typ
)) = Typ
then
6268 if Total_Errors_Detected
= 0 then
6269 raise Program_Error
;
6275 Process_Type
(Etype
(Typ
));
6278 -- Examine base type
6280 if Base_Type
(Typ
) /= Typ
then
6281 Process_Type
(Base_Type
(Typ
));
6284 -- Examine interfaces
6286 if Is_Record_Type
(Typ
)
6287 and then Present
(Interfaces
(Typ
))
6289 Iface_Elmt
:= First_Elmt
(Interfaces
(Typ
));
6290 while Present
(Iface_Elmt
) loop
6291 Process_Type
(Node
(Iface_Elmt
));
6293 Next_Elmt
(Iface_Elmt
);
6298 -- Start of processing for Collect_Types_In_Hierarchy
6301 Results
:= New_Elmt_List
;
6304 end Collect_Types_In_Hierarchy
;
6306 -----------------------
6307 -- Conditional_Delay --
6308 -----------------------
6310 procedure Conditional_Delay
(New_Ent
, Old_Ent
: Entity_Id
) is
6312 if Has_Delayed_Freeze
(Old_Ent
) and then not Is_Frozen
(Old_Ent
) then
6313 Set_Has_Delayed_Freeze
(New_Ent
);
6315 end Conditional_Delay
;
6317 -------------------------
6318 -- Copy_Component_List --
6319 -------------------------
6321 function Copy_Component_List
6323 Loc
: Source_Ptr
) return List_Id
6326 Comps
: constant List_Id
:= New_List
;
6329 Comp
:= First_Component
(Underlying_Type
(R_Typ
));
6330 while Present
(Comp
) loop
6331 if Comes_From_Source
(Comp
) then
6333 Comp_Decl
: constant Node_Id
:= Declaration_Node
(Comp
);
6336 Make_Component_Declaration
(Loc
,
6337 Defining_Identifier
=>
6338 Make_Defining_Identifier
(Loc
, Chars
(Comp
)),
6339 Component_Definition
=>
6341 (Component_Definition
(Comp_Decl
), New_Sloc
=> Loc
)));
6345 Next_Component
(Comp
);
6349 end Copy_Component_List
;
6351 -----------------------
6352 -- Copy_Ghost_Aspect --
6353 -----------------------
6355 procedure Copy_Ghost_Aspect
(From
: Node_Id
; To
: Node_Id
) is
6356 pragma Assert
(not Has_Aspects
(To
));
6360 if Has_Aspects
(From
) then
6361 Asp
:= Find_Aspect
(Defining_Entity
(From
), Aspect_Ghost
);
6363 if Present
(Asp
) then
6364 Set_Aspect_Specifications
(To
, New_List
(New_Copy_Tree
(Asp
)));
6367 end Copy_Ghost_Aspect
;
6369 -------------------------
6370 -- Copy_Parameter_List --
6371 -------------------------
6373 function Copy_Parameter_List
(Subp_Id
: Entity_Id
) return List_Id
is
6374 Loc
: constant Source_Ptr
:= Sloc
(Subp_Id
);
6376 Formal
: Entity_Id
:= First_Formal
(Subp_Id
);
6379 if Present
(Formal
) then
6381 while Present
(Formal
) loop
6383 Make_Parameter_Specification
(Loc
,
6384 Defining_Identifier
=>
6385 Make_Defining_Identifier
(Sloc
(Formal
), Chars
(Formal
)),
6386 In_Present
=> In_Present
(Parent
(Formal
)),
6387 Out_Present
=> Out_Present
(Parent
(Formal
)),
6389 New_Occurrence_Of
(Etype
(Formal
), Loc
),
6391 New_Copy_Tree
(Expression
(Parent
(Formal
)))));
6393 Next_Formal
(Formal
);
6400 end Copy_Parameter_List
;
6402 ----------------------------
6403 -- Copy_SPARK_Mode_Aspect --
6404 ----------------------------
6406 procedure Copy_SPARK_Mode_Aspect
(From
: Node_Id
; To
: Node_Id
) is
6407 pragma Assert
(not Has_Aspects
(To
));
6411 if Has_Aspects
(From
) then
6412 Asp
:= Find_Aspect
(Defining_Entity
(From
), Aspect_SPARK_Mode
);
6414 if Present
(Asp
) then
6415 Set_Aspect_Specifications
(To
, New_List
(New_Copy_Tree
(Asp
)));
6418 end Copy_SPARK_Mode_Aspect
;
6420 --------------------------
6421 -- Copy_Subprogram_Spec --
6422 --------------------------
6424 function Copy_Subprogram_Spec
6426 New_Sloc
: Source_Ptr
:= No_Location
) return Node_Id
6429 Formal_Spec
: Node_Id
;
6433 -- The structure of the original tree must be replicated without any
6434 -- alterations. Use New_Copy_Tree for this purpose.
6436 Result
:= New_Copy_Tree
(Spec
, New_Sloc
=> New_Sloc
);
6438 -- However, the spec of a null procedure carries the corresponding null
6439 -- statement of the body (created by the parser), and this cannot be
6440 -- shared with the new subprogram spec.
6442 if Nkind
(Result
) = N_Procedure_Specification
then
6443 Set_Null_Statement
(Result
, Empty
);
6446 -- Create a new entity for the defining unit name
6448 Def_Id
:= Defining_Unit_Name
(Result
);
6449 Set_Defining_Unit_Name
(Result
,
6450 Make_Defining_Identifier
(Sloc
(Def_Id
), Chars
(Def_Id
)));
6452 -- Create new entities for the formal parameters
6454 Formal_Spec
:= First
(Parameter_Specifications
(Result
));
6455 while Present
(Formal_Spec
) loop
6456 Def_Id
:= Defining_Identifier
(Formal_Spec
);
6457 Set_Defining_Identifier
(Formal_Spec
,
6458 Make_Defining_Identifier
(Sloc
(Def_Id
), Chars
(Def_Id
)));
6464 end Copy_Subprogram_Spec
;
6466 --------------------------------
6467 -- Corresponding_Generic_Type --
6468 --------------------------------
6470 function Corresponding_Generic_Type
(T
: Entity_Id
) return Entity_Id
is
6476 if not Is_Generic_Actual_Type
(T
) then
6479 -- If the actual is the actual of an enclosing instance, resolution
6480 -- was correct in the generic.
6482 elsif Nkind
(Parent
(T
)) = N_Subtype_Declaration
6483 and then Is_Entity_Name
(Subtype_Indication
(Parent
(T
)))
6485 Is_Generic_Actual_Type
(Entity
(Subtype_Indication
(Parent
(T
))))
6492 if Is_Wrapper_Package
(Inst
) then
6493 Inst
:= Related_Instance
(Inst
);
6498 (Specification
(Unit_Declaration_Node
(Inst
)));
6500 -- Generic actual has the same name as the corresponding formal
6502 Typ
:= First_Entity
(Gen
);
6503 while Present
(Typ
) loop
6504 if Chars
(Typ
) = Chars
(T
) then
6513 end Corresponding_Generic_Type
;
6515 --------------------------------
6516 -- Corresponding_Primitive_Op --
6517 --------------------------------
6519 function Corresponding_Primitive_Op
6520 (Ancestor_Op
: Entity_Id
;
6521 Descendant_Type
: Entity_Id
) return Entity_Id
6523 function Find_Untagged_Type_Of
(Prim
: Entity_Id
) return Entity_Id
;
6524 -- Search for the untagged type of the primitive operation Prim.
6526 function Profile_Matches_Ancestor
(S
: Entity_Id
) return Boolean;
6527 -- Returns True if subprogram S has the proper profile for an
6528 -- overriding of Ancestor_Op (that is, corresponding formals either
6529 -- have the same type, or are corresponding controlling formals,
6530 -- and similarly for result types).
6532 ---------------------------
6533 -- Find_Untagged_Type_Of --
6534 ---------------------------
6536 function Find_Untagged_Type_Of
(Prim
: Entity_Id
) return Entity_Id
is
6537 E
: Entity_Id
:= First_Entity
(Scope
(Prim
));
6540 while Present
(E
) and then E
/= Prim
loop
6541 if not Is_Tagged_Type
(E
)
6542 and then Contains
(Direct_Primitive_Operations
(E
), Prim
)
6550 pragma Assert
(False);
6552 end Find_Untagged_Type_Of
;
6554 Typ
: constant Entity_Id
:=
6555 (if Is_Dispatching_Operation
(Ancestor_Op
)
6556 then Find_Dispatching_Type
(Ancestor_Op
)
6557 else Find_Untagged_Type_Of
(Ancestor_Op
));
6559 ------------------------------
6560 -- Profile_Matches_Ancestor --
6561 ------------------------------
6563 function Profile_Matches_Ancestor
(S
: Entity_Id
) return Boolean is
6564 F1
: Entity_Id
:= First_Formal
(Ancestor_Op
);
6565 F2
: Entity_Id
:= First_Formal
(S
);
6568 if Ekind
(Ancestor_Op
) /= Ekind
(S
) then
6572 -- ??? This should probably account for anonymous access formals,
6573 -- but the parent function (Corresponding_Primitive_Op) is currently
6574 -- only called for user-defined literal functions, which can't have
6575 -- such formals. But if this is ever used in a more general context
6576 -- it should be extended to handle such formals (and result types).
6578 while Present
(F1
) and then Present
(F2
) loop
6579 if Etype
(F1
) = Etype
(F2
)
6580 or else Is_Ancestor
(Typ
, Etype
(F2
))
6591 and then (Etype
(Ancestor_Op
) = Etype
(S
)
6592 or else Is_Ancestor
(Typ
, Etype
(S
)));
6593 end Profile_Matches_Ancestor
;
6600 -- Start of processing for Corresponding_Primitive_Op
6603 pragma Assert
(Is_Ancestor
(Typ
, Descendant_Type
)
6604 or else Is_Progenitor
(Typ
, Descendant_Type
));
6606 Elmt
:= First_Elmt
(Primitive_Operations
(Descendant_Type
));
6608 while Present
(Elmt
) loop
6609 Subp
:= Node
(Elmt
);
6611 -- For regular primitives we need to check the profile against
6612 -- the ancestor when the name matches the name of Ancestor_Op,
6613 -- but for predefined dispatching operations we cannot rely on
6614 -- the name of the primitive to identify a candidate since their
6615 -- name is internally built by adding a suffix to the name of the
6618 if Chars
(Subp
) = Chars
(Ancestor_Op
)
6619 or else Is_Predefined_Dispatching_Operation
(Subp
)
6621 -- Handle case where Ancestor_Op is a primitive of a progenitor.
6622 -- We rely on internal entities that map interface primitives:
6623 -- their attribute Interface_Alias references the interface
6624 -- primitive, and their Alias attribute references the primitive
6625 -- of Descendant_Type implementing that interface primitive.
6627 if Present
(Interface_Alias
(Subp
)) then
6628 if Interface_Alias
(Subp
) = Ancestor_Op
then
6629 return Alias
(Subp
);
6632 -- Otherwise, return subprogram when profile matches its ancestor
6634 elsif Profile_Matches_Ancestor
(Subp
) then
6642 pragma Assert
(False);
6644 end Corresponding_Primitive_Op
;
6646 --------------------
6647 -- Current_Entity --
6648 --------------------
6650 -- The currently visible definition for a given identifier is the
6651 -- one most chained at the start of the visibility chain, i.e. the
6652 -- one that is referenced by the Node_Id value of the name of the
6653 -- given identifier.
6655 function Current_Entity
(N
: Node_Id
) return Entity_Id
is
6657 return Get_Name_Entity_Id
(Chars
(N
));
6660 -----------------------------
6661 -- Current_Entity_In_Scope --
6662 -----------------------------
6664 function Current_Entity_In_Scope
(N
: Name_Id
) return Entity_Id
is
6665 CS
: constant Entity_Id
:= Current_Scope
;
6670 E
:= Get_Name_Entity_Id
(N
);
6675 elsif Scope_Is_Transient
then
6676 while Present
(E
) loop
6677 exit when Scope
(E
) = CS
or else Scope
(E
) = Scope
(CS
);
6683 while Present
(E
) loop
6684 exit when Scope
(E
) = CS
;
6691 end Current_Entity_In_Scope
;
6693 -----------------------------
6694 -- Current_Entity_In_Scope --
6695 -----------------------------
6697 function Current_Entity_In_Scope
(N
: Node_Id
) return Entity_Id
is
6699 return Current_Entity_In_Scope
(Chars
(N
));
6700 end Current_Entity_In_Scope
;
6706 function Current_Scope
return Entity_Id
is
6708 if Scope_Stack
.Last
= -1 then
6709 return Standard_Standard
;
6712 C
: constant Entity_Id
:=
6713 Scope_Stack
.Table
(Scope_Stack
.Last
).Entity
;
6718 return Standard_Standard
;
6724 ----------------------------
6725 -- Current_Scope_No_Loops --
6726 ----------------------------
6728 function Current_Scope_No_Loops
return Entity_Id
is
6732 -- Examine the scope stack starting from the current scope and skip any
6733 -- internally generated loops.
6736 while Present
(S
) and then S
/= Standard_Standard
loop
6737 if Ekind
(S
) = E_Loop
and then not Comes_From_Source
(S
) then
6745 end Current_Scope_No_Loops
;
6747 ------------------------
6748 -- Current_Subprogram --
6749 ------------------------
6751 function Current_Subprogram
return Entity_Id
is
6752 Scop
: constant Entity_Id
:= Current_Scope
;
6754 if Is_Subprogram_Or_Generic_Subprogram
(Scop
) then
6757 return Enclosing_Subprogram
(Scop
);
6759 end Current_Subprogram
;
6761 ------------------------------
6762 -- CW_Or_Needs_Finalization --
6763 ------------------------------
6765 function CW_Or_Needs_Finalization
(Typ
: Entity_Id
) return Boolean is
6767 return Is_Class_Wide_Type
(Typ
) or else Needs_Finalization
(Typ
);
6768 end CW_Or_Needs_Finalization
;
6770 ---------------------
6771 -- Defining_Entity --
6772 ---------------------
6774 function Defining_Entity
(N
: Node_Id
) return Entity_Id
is
6775 Ent
: constant Entity_Id
:= Defining_Entity_Or_Empty
(N
);
6778 if Present
(Ent
) then
6782 raise Program_Error
;
6784 end Defining_Entity
;
6786 ------------------------------
6787 -- Defining_Entity_Or_Empty --
6788 ------------------------------
6790 function Defining_Entity_Or_Empty
(N
: Node_Id
) return Entity_Id
is
6793 when N_Abstract_Subprogram_Declaration
6794 | N_Expression_Function
6795 | N_Formal_Subprogram_Declaration
6796 | N_Generic_Package_Declaration
6797 | N_Generic_Subprogram_Declaration
6798 | N_Package_Declaration
6800 | N_Subprogram_Body_Stub
6801 | N_Subprogram_Declaration
6802 | N_Subprogram_Renaming_Declaration
6804 return Defining_Entity
(Specification
(N
));
6806 when N_Component_Declaration
6807 | N_Defining_Program_Unit_Name
6808 | N_Discriminant_Specification
6810 | N_Entry_Declaration
6811 | N_Entry_Index_Specification
6812 | N_Exception_Declaration
6813 | N_Exception_Renaming_Declaration
6814 | N_Formal_Object_Declaration
6815 | N_Formal_Package_Declaration
6816 | N_Formal_Type_Declaration
6817 | N_Full_Type_Declaration
6818 | N_Implicit_Label_Declaration
6819 | N_Incomplete_Type_Declaration
6820 | N_Iterator_Specification
6821 | N_Loop_Parameter_Specification
6822 | N_Number_Declaration
6823 | N_Object_Declaration
6824 | N_Object_Renaming_Declaration
6825 | N_Package_Body_Stub
6826 | N_Parameter_Specification
6827 | N_Private_Extension_Declaration
6828 | N_Private_Type_Declaration
6830 | N_Protected_Body_Stub
6831 | N_Protected_Type_Declaration
6832 | N_Single_Protected_Declaration
6833 | N_Single_Task_Declaration
6834 | N_Subtype_Declaration
6837 | N_Task_Type_Declaration
6839 return Defining_Identifier
(N
);
6841 when N_Compilation_Unit
=>
6842 return Defining_Entity
(Unit
(N
));
6845 return Defining_Entity
(Proper_Body
(N
));
6847 when N_Function_Instantiation
6848 | N_Function_Specification
6849 | N_Generic_Function_Renaming_Declaration
6850 | N_Generic_Package_Renaming_Declaration
6851 | N_Generic_Procedure_Renaming_Declaration
6853 | N_Package_Instantiation
6854 | N_Package_Renaming_Declaration
6855 | N_Package_Specification
6856 | N_Procedure_Instantiation
6857 | N_Procedure_Specification
6860 Nam
: constant Node_Id
:= Defining_Unit_Name
(N
);
6861 Err
: Entity_Id
:= Empty
;
6864 if Nkind
(Nam
) in N_Entity
then
6867 -- For Error, make up a name and attach to declaration so we
6868 -- can continue semantic analysis.
6870 elsif Nam
= Error
then
6871 Err
:= Make_Temporary
(Sloc
(N
), 'T');
6872 Set_Defining_Unit_Name
(N
, Err
);
6876 -- If not an entity, get defining identifier
6879 return Defining_Identifier
(Nam
);
6883 when N_Block_Statement
6886 return Entity
(Identifier
(N
));
6891 end Defining_Entity_Or_Empty
;
6893 --------------------------
6894 -- Denotes_Discriminant --
6895 --------------------------
6897 function Denotes_Discriminant
6899 Check_Concurrent
: Boolean := False) return Boolean
6904 if not Is_Entity_Name
(N
) or else No
(Entity
(N
)) then
6910 -- If we are checking for a protected type, the discriminant may have
6911 -- been rewritten as the corresponding discriminal of the original type
6912 -- or of the corresponding concurrent record, depending on whether we
6913 -- are in the spec or body of the protected type.
6915 return Ekind
(E
) = E_Discriminant
6918 and then Ekind
(E
) = E_In_Parameter
6919 and then Present
(Discriminal_Link
(E
))
6921 (Is_Concurrent_Type
(Scope
(Discriminal_Link
(E
)))
6923 Is_Concurrent_Record_Type
(Scope
(Discriminal_Link
(E
)))));
6924 end Denotes_Discriminant
;
6926 -------------------------
6927 -- Denotes_Same_Object --
6928 -------------------------
6930 function Denotes_Same_Object
(A1
, A2
: Node_Id
) return Boolean is
6931 function Is_Object_Renaming
(N
: Node_Id
) return Boolean;
6932 -- Return true if N names an object renaming entity
6934 function Is_Valid_Renaming
(N
: Node_Id
) return Boolean;
6935 -- For renamings, return False if the prefix of any dereference within
6936 -- the renamed object_name is a variable, or any expression within the
6937 -- renamed object_name contains references to variables or calls on
6938 -- nonstatic functions; otherwise return True (RM 6.4.1(6.10/3))
6940 ------------------------
6941 -- Is_Object_Renaming --
6942 ------------------------
6944 function Is_Object_Renaming
(N
: Node_Id
) return Boolean is
6946 return Is_Entity_Name
(N
)
6947 and then Ekind
(Entity
(N
)) in E_Variable | E_Constant
6948 and then Present
(Renamed_Object
(Entity
(N
)));
6949 end Is_Object_Renaming
;
6951 -----------------------
6952 -- Is_Valid_Renaming --
6953 -----------------------
6955 function Is_Valid_Renaming
(N
: Node_Id
) return Boolean is
6957 if Is_Object_Renaming
(N
)
6958 and then not Is_Valid_Renaming
(Renamed_Object
(Entity
(N
)))
6963 -- Check if any expression within the renamed object_name contains no
6964 -- references to variables nor calls on nonstatic functions.
6966 if Nkind
(N
) = N_Indexed_Component
then
6971 Indx
:= First
(Expressions
(N
));
6972 while Present
(Indx
) loop
6973 if not Is_OK_Static_Expression
(Indx
) then
6981 elsif Nkind
(N
) = N_Slice
then
6983 Rng
: constant Node_Id
:= Discrete_Range
(N
);
6985 -- Bounds specified as a range
6987 if Nkind
(Rng
) = N_Range
then
6988 if not Is_OK_Static_Range
(Rng
) then
6992 -- Bounds specified as a constrained subtype indication
6994 elsif Nkind
(Rng
) = N_Subtype_Indication
then
6995 if not Is_OK_Static_Range
6996 (Range_Expression
(Constraint
(Rng
)))
7001 -- Bounds specified as a subtype name
7003 elsif not Is_OK_Static_Expression
(Rng
) then
7009 if Has_Prefix
(N
) then
7011 P
: constant Node_Id
:= Prefix
(N
);
7014 if Nkind
(N
) = N_Explicit_Dereference
7015 and then Is_Variable
(P
)
7019 elsif Is_Entity_Name
(P
)
7020 and then Ekind
(Entity
(P
)) = E_Function
7024 elsif Nkind
(P
) = N_Function_Call
then
7028 -- Recursion to continue traversing the prefix of the
7029 -- renaming expression
7031 return Is_Valid_Renaming
(P
);
7036 end Is_Valid_Renaming
;
7038 -- Start of processing for Denotes_Same_Object
7041 -- Both names statically denote the same stand-alone object or
7042 -- parameter (RM 6.4.1(6.6/3)).
7044 if Is_Entity_Name
(A1
)
7045 and then Is_Entity_Name
(A2
)
7046 and then Entity
(A1
) = Entity
(A2
)
7050 -- Both names are selected_components, their prefixes are known to
7051 -- denote the same object, and their selector_names denote the same
7052 -- component (RM 6.4.1(6.7/3)).
7054 elsif Nkind
(A1
) = N_Selected_Component
7055 and then Nkind
(A2
) = N_Selected_Component
7057 return Denotes_Same_Object
(Prefix
(A1
), Prefix
(A2
))
7059 Entity
(Selector_Name
(A1
)) = Entity
(Selector_Name
(A2
));
7061 -- Both names are dereferences and the dereferenced names are known to
7062 -- denote the same object (RM 6.4.1(6.8/3)).
7064 elsif Nkind
(A1
) = N_Explicit_Dereference
7065 and then Nkind
(A2
) = N_Explicit_Dereference
7067 return Denotes_Same_Object
(Prefix
(A1
), Prefix
(A2
));
7069 -- Both names are indexed_components, their prefixes are known to denote
7070 -- the same object, and each of the pairs of corresponding index values
7071 -- are either both static expressions with the same static value or both
7072 -- names that are known to denote the same object (RM 6.4.1(6.9/3)).
7074 elsif Nkind
(A1
) = N_Indexed_Component
7075 and then Nkind
(A2
) = N_Indexed_Component
7077 if not Denotes_Same_Object
(Prefix
(A1
), Prefix
(A2
)) then
7085 Indx1
:= First
(Expressions
(A1
));
7086 Indx2
:= First
(Expressions
(A2
));
7087 while Present
(Indx1
) loop
7089 -- Indexes must denote the same static value or same object
7091 if Is_OK_Static_Expression
(Indx1
) then
7092 if not Is_OK_Static_Expression
(Indx2
) then
7095 elsif Expr_Value
(Indx1
) /= Expr_Value
(Indx2
) then
7099 elsif not Denotes_Same_Object
(Indx1
, Indx2
) then
7111 -- Both names are slices, their prefixes are known to denote the same
7112 -- object, and the two slices have statically matching index constraints
7113 -- (RM 6.4.1(6.10/3)).
7115 elsif Nkind
(A1
) = N_Slice
7116 and then Nkind
(A2
) = N_Slice
7118 if not Denotes_Same_Object
(Prefix
(A1
), Prefix
(A2
)) then
7122 Lo1
, Lo2
, Hi1
, Hi2
: Node_Id
;
7125 Get_Index_Bounds
(Discrete_Range
(A1
), Lo1
, Hi1
);
7126 Get_Index_Bounds
(Discrete_Range
(A2
), Lo2
, Hi2
);
7128 -- Check whether bounds are statically identical. There is no
7129 -- attempt to detect partial overlap of slices.
7131 return Is_OK_Static_Expression
(Lo1
)
7132 and then Is_OK_Static_Expression
(Lo2
)
7133 and then Is_OK_Static_Expression
(Hi1
)
7134 and then Is_OK_Static_Expression
(Hi2
)
7135 and then Expr_Value
(Lo1
) = Expr_Value
(Lo2
)
7136 and then Expr_Value
(Hi1
) = Expr_Value
(Hi2
);
7140 -- One of the two names statically denotes a renaming declaration whose
7141 -- renamed object_name is known to denote the same object as the other;
7142 -- the prefix of any dereference within the renamed object_name is not a
7143 -- variable, and any expression within the renamed object_name contains
7144 -- no references to variables nor calls on nonstatic functions (RM
7147 elsif Is_Object_Renaming
(A1
)
7148 and then Is_Valid_Renaming
(A1
)
7150 return Denotes_Same_Object
(Renamed_Object
(Entity
(A1
)), A2
);
7152 elsif Is_Object_Renaming
(A2
)
7153 and then Is_Valid_Renaming
(A2
)
7155 return Denotes_Same_Object
(A1
, Renamed_Object
(Entity
(A2
)));
7160 end Denotes_Same_Object
;
7162 -------------------------
7163 -- Denotes_Same_Prefix --
7164 -------------------------
7166 function Denotes_Same_Prefix
(A1
, A2
: Node_Id
) return Boolean is
7168 if Is_Entity_Name
(A1
) then
7169 if Nkind
(A2
) in N_Selected_Component | N_Indexed_Component
7170 and then not Is_Access_Type
(Etype
(A1
))
7172 return Denotes_Same_Object
(A1
, Prefix
(A2
))
7173 or else Denotes_Same_Prefix
(A1
, Prefix
(A2
));
7178 elsif Is_Entity_Name
(A2
) then
7179 return Denotes_Same_Prefix
(A1
=> A2
, A2
=> A1
);
7181 elsif Nkind
(A1
) in N_Selected_Component | N_Indexed_Component | N_Slice
7183 Nkind
(A2
) in N_Selected_Component | N_Indexed_Component | N_Slice
7186 Root1
, Root2
: Node_Id
;
7187 Depth1
, Depth2
: Nat
:= 0;
7190 Root1
:= Prefix
(A1
);
7191 while not Is_Entity_Name
(Root1
) loop
7192 if Nkind
(Root1
) not in
7193 N_Selected_Component | N_Indexed_Component
7197 Root1
:= Prefix
(Root1
);
7200 Depth1
:= Depth1
+ 1;
7203 Root2
:= Prefix
(A2
);
7204 while not Is_Entity_Name
(Root2
) loop
7205 if Nkind
(Root2
) not in
7206 N_Selected_Component | N_Indexed_Component
7210 Root2
:= Prefix
(Root2
);
7213 Depth2
:= Depth2
+ 1;
7216 -- If both have the same depth and they do not denote the same
7217 -- object, they are disjoint and no warning is needed.
7219 if Depth1
= Depth2
then
7222 elsif Depth1
> Depth2
then
7223 Root1
:= Prefix
(A1
);
7224 for J
in 1 .. Depth1
- Depth2
- 1 loop
7225 Root1
:= Prefix
(Root1
);
7228 return Denotes_Same_Object
(Root1
, A2
);
7231 Root2
:= Prefix
(A2
);
7232 for J
in 1 .. Depth2
- Depth1
- 1 loop
7233 Root2
:= Prefix
(Root2
);
7236 return Denotes_Same_Object
(A1
, Root2
);
7243 end Denotes_Same_Prefix
;
7245 ----------------------
7246 -- Denotes_Variable --
7247 ----------------------
7249 function Denotes_Variable
(N
: Node_Id
) return Boolean is
7251 return Is_Variable
(N
) and then Paren_Count
(N
) = 0;
7252 end Denotes_Variable
;
7254 -----------------------------
7255 -- Depends_On_Discriminant --
7256 -----------------------------
7258 function Depends_On_Discriminant
(N
: Node_Id
) return Boolean is
7263 Get_Index_Bounds
(N
, L
, H
);
7264 return Denotes_Discriminant
(L
) or else Denotes_Discriminant
(H
);
7265 end Depends_On_Discriminant
;
7267 -------------------------------------
7268 -- Derivation_Too_Early_To_Inherit --
7269 -------------------------------------
7271 function Derivation_Too_Early_To_Inherit
7272 (Typ
: Entity_Id
; Streaming_Op
: TSS_Name_Type
) return Boolean is
7274 Btyp
: constant Entity_Id
:= Implementation_Base_Type
(Typ
);
7275 Parent_Type
: Entity_Id
;
7279 -- Start of processing for Derivation_Too_Early_To_Inherit
7282 if Is_Derived_Type
(Btyp
) then
7283 Parent_Type
:= Implementation_Base_Type
(Etype
(Btyp
));
7284 pragma Assert
(Parent_Type
/= Btyp
);
7286 if Has_Stream_Attribute_Definition
7287 (Parent_Type
, Streaming_Op
, Real_Rep
=> Real_Rep
)
7289 and then In_Same_Extended_Unit
(Btyp
, Parent_Type
)
7290 and then Instantiation
(Get_Source_File_Index
(Sloc
(Btyp
))) =
7291 Instantiation
(Get_Source_File_Index
(Sloc
(Parent_Type
)))
7293 return Earlier_In_Extended_Unit
(Btyp
, Real_Rep
);
7298 end Derivation_Too_Early_To_Inherit
;
7300 -------------------------
7301 -- Designate_Same_Unit --
7302 -------------------------
7304 function Designate_Same_Unit
7306 Name2
: Node_Id
) return Boolean
7308 K1
: constant Node_Kind
:= Nkind
(Name1
);
7309 K2
: constant Node_Kind
:= Nkind
(Name2
);
7311 function Prefix_Node
(N
: Node_Id
) return Node_Id
;
7312 -- Returns the parent unit name node of a defining program unit name
7313 -- or the prefix if N is a selected component or an expanded name.
7315 function Select_Node
(N
: Node_Id
) return Node_Id
;
7316 -- Returns the defining identifier node of a defining program unit
7317 -- name or the selector node if N is a selected component or an
7324 function Prefix_Node
(N
: Node_Id
) return Node_Id
is
7326 if Nkind
(N
) = N_Defining_Program_Unit_Name
then
7337 function Select_Node
(N
: Node_Id
) return Node_Id
is
7339 if Nkind
(N
) = N_Defining_Program_Unit_Name
then
7340 return Defining_Identifier
(N
);
7342 return Selector_Name
(N
);
7346 -- Start of processing for Designate_Same_Unit
7349 if K1
in N_Identifier | N_Defining_Identifier
7351 K2
in N_Identifier | N_Defining_Identifier
7353 return Chars
(Name1
) = Chars
(Name2
);
7355 elsif K1
in N_Expanded_Name
7356 | N_Selected_Component
7357 | N_Defining_Program_Unit_Name
7359 K2
in N_Expanded_Name
7360 | N_Selected_Component
7361 | N_Defining_Program_Unit_Name
7364 Chars
(Select_Node
(Name1
)) = Chars
(Select_Node
(Name2
))
7366 Designate_Same_Unit
(Prefix_Node
(Name1
), Prefix_Node
(Name2
));
7371 end Designate_Same_Unit
;
7373 ---------------------------------------------
7374 -- Diagnose_Iterated_Component_Association --
7375 ---------------------------------------------
7377 procedure Diagnose_Iterated_Component_Association
(N
: Node_Id
) is
7378 Def_Id
: constant Entity_Id
:= Defining_Identifier
(N
);
7382 -- Determine whether the iterated component association appears within
7383 -- an aggregate. If this is the case, raise Program_Error because the
7384 -- iterated component association cannot be left in the tree as is and
7385 -- must always be processed by the related aggregate.
7388 while Present
(Aggr
) loop
7389 if Nkind
(Aggr
) = N_Aggregate
then
7390 raise Program_Error
;
7392 -- Prevent the search from going too far
7394 elsif Is_Body_Or_Package_Declaration
(Aggr
) then
7398 Aggr
:= Parent
(Aggr
);
7401 -- At this point it is known that the iterated component association is
7402 -- not within an aggregate. This is really a quantified expression with
7403 -- a missing "all" or "some" quantifier.
7405 Error_Msg_N
("missing quantifier", Def_Id
);
7407 -- Rewrite the iterated component association as True to prevent any
7410 Rewrite
(N
, New_Occurrence_Of
(Standard_True
, Sloc
(N
)));
7412 end Diagnose_Iterated_Component_Association
;
7414 ------------------------
7415 -- Discriminated_Size --
7416 ------------------------
7418 function Discriminated_Size
(Comp
: Entity_Id
) return Boolean is
7419 function Non_Static_Bound
(Bound
: Node_Id
) return Boolean;
7420 -- Check whether the bound of an index is non-static and does denote
7421 -- a discriminant, in which case any object of the type (protected or
7422 -- otherwise) will have a non-static size.
7424 ----------------------
7425 -- Non_Static_Bound --
7426 ----------------------
7428 function Non_Static_Bound
(Bound
: Node_Id
) return Boolean is
7430 if Is_OK_Static_Expression
(Bound
) then
7433 -- If the bound is given by a discriminant it is non-static
7434 -- (A static constraint replaces the reference with the value).
7435 -- In an protected object the discriminant has been replaced by
7436 -- the corresponding discriminal within the protected operation.
7438 elsif Is_Entity_Name
(Bound
)
7440 (Ekind
(Entity
(Bound
)) = E_Discriminant
7441 or else Present
(Discriminal_Link
(Entity
(Bound
))))
7448 end Non_Static_Bound
;
7452 Typ
: constant Entity_Id
:= Etype
(Comp
);
7455 -- Start of processing for Discriminated_Size
7458 if not Is_Array_Type
(Typ
) then
7462 if Ekind
(Typ
) = E_Array_Subtype
then
7463 Index
:= First_Index
(Typ
);
7464 while Present
(Index
) loop
7465 if Non_Static_Bound
(Low_Bound
(Index
))
7466 or else Non_Static_Bound
(High_Bound
(Index
))
7478 end Discriminated_Size
;
7480 -----------------------------
7481 -- Effective_Reads_Enabled --
7482 -----------------------------
7484 function Effective_Reads_Enabled
(Id
: Entity_Id
) return Boolean is
7486 return Has_Enabled_Property
(Id
, Name_Effective_Reads
);
7487 end Effective_Reads_Enabled
;
7489 ------------------------------
7490 -- Effective_Writes_Enabled --
7491 ------------------------------
7493 function Effective_Writes_Enabled
(Id
: Entity_Id
) return Boolean is
7495 return Has_Enabled_Property
(Id
, Name_Effective_Writes
);
7496 end Effective_Writes_Enabled
;
7498 ------------------------------
7499 -- Enclosing_Comp_Unit_Node --
7500 ------------------------------
7502 function Enclosing_Comp_Unit_Node
(N
: Node_Id
) return Node_Id
is
7503 Current_Node
: Node_Id
;
7507 while Present
(Current_Node
)
7508 and then Nkind
(Current_Node
) /= N_Compilation_Unit
7510 Current_Node
:= Parent
(Current_Node
);
7513 return Current_Node
;
7514 end Enclosing_Comp_Unit_Node
;
7516 --------------------------
7517 -- Enclosing_CPP_Parent --
7518 --------------------------
7520 function Enclosing_CPP_Parent
(Typ
: Entity_Id
) return Entity_Id
is
7521 Parent_Typ
: Entity_Id
:= Typ
;
7524 while not Is_CPP_Class
(Parent_Typ
)
7525 and then Etype
(Parent_Typ
) /= Parent_Typ
7527 Parent_Typ
:= Etype
(Parent_Typ
);
7529 if Is_Private_Type
(Parent_Typ
) then
7530 Parent_Typ
:= Full_View
(Base_Type
(Parent_Typ
));
7534 pragma Assert
(Is_CPP_Class
(Parent_Typ
));
7536 end Enclosing_CPP_Parent
;
7538 ---------------------------
7539 -- Enclosing_Declaration --
7540 ---------------------------
7542 function Enclosing_Declaration
(N
: Node_Id
) return Node_Id
is
7543 Decl
: Node_Id
:= N
;
7546 while Present
(Decl
)
7547 and then not (Nkind
(Decl
) in N_Declaration
7549 Nkind
(Decl
) in N_Later_Decl_Item
7551 Nkind
(Decl
) in N_Renaming_Declaration
7553 Nkind
(Decl
) = N_Number_Declaration
)
7555 Decl
:= Parent
(Decl
);
7559 end Enclosing_Declaration
;
7561 ----------------------------------------
7562 -- Enclosing_Declaration_Or_Statement --
7563 ----------------------------------------
7565 function Enclosing_Declaration_Or_Statement
7566 (N
: Node_Id
) return Node_Id
7572 while Present
(Par
) loop
7573 if Is_Declaration
(Par
) or else Is_Statement
(Par
) then
7576 -- Prevent the search from going too far
7578 elsif Is_Body_Or_Package_Declaration
(Par
) then
7582 Par
:= Parent
(Par
);
7586 end Enclosing_Declaration_Or_Statement
;
7588 ----------------------------
7589 -- Enclosing_Generic_Body --
7590 ----------------------------
7592 function Enclosing_Generic_Body
(N
: Node_Id
) return Node_Id
is
7594 Spec_Id
: Entity_Id
;
7598 while Present
(Par
) loop
7599 if Nkind
(Par
) in N_Package_Body | N_Subprogram_Body
then
7600 Spec_Id
:= Corresponding_Spec
(Par
);
7602 if Present
(Spec_Id
)
7603 and then Nkind
(Unit_Declaration_Node
(Spec_Id
)) in
7604 N_Generic_Declaration
7610 Par
:= Parent
(Par
);
7614 end Enclosing_Generic_Body
;
7616 ----------------------------
7617 -- Enclosing_Generic_Unit --
7618 ----------------------------
7620 function Enclosing_Generic_Unit
(N
: Node_Id
) return Node_Id
is
7622 Spec_Decl
: Node_Id
;
7623 Spec_Id
: Entity_Id
;
7627 while Present
(Par
) loop
7628 if Nkind
(Par
) in N_Generic_Declaration
then
7631 elsif Nkind
(Par
) in N_Package_Body | N_Subprogram_Body
then
7632 Spec_Id
:= Corresponding_Spec
(Par
);
7634 if Present
(Spec_Id
) then
7635 Spec_Decl
:= Unit_Declaration_Node
(Spec_Id
);
7637 if Nkind
(Spec_Decl
) in N_Generic_Declaration
then
7643 Par
:= Parent
(Par
);
7647 end Enclosing_Generic_Unit
;
7653 function Enclosing_HSS
(Stmt
: Node_Id
) return Node_Id
is
7656 pragma Assert
(Is_Statement
(Stmt
));
7658 Par
:= Parent
(Stmt
);
7659 while Present
(Par
) loop
7661 if Nkind
(Par
) = N_Handled_Sequence_Of_Statements
then
7664 -- Prevent the search from going too far
7666 elsif Is_Body_Or_Package_Declaration
(Par
) then
7671 Par
:= Parent
(Par
);
7677 -------------------------------
7678 -- Enclosing_Lib_Unit_Entity --
7679 -------------------------------
7681 function Enclosing_Lib_Unit_Entity
7682 (E
: Entity_Id
:= Current_Scope
) return Entity_Id
7684 Unit_Entity
: Entity_Id
;
7687 -- Look for enclosing library unit entity by following scope links.
7688 -- Equivalent to, but faster than indexing through the scope stack.
7691 while (Present
(Scope
(Unit_Entity
))
7692 and then Scope
(Unit_Entity
) /= Standard_Standard
)
7693 and not Is_Child_Unit
(Unit_Entity
)
7695 Unit_Entity
:= Scope
(Unit_Entity
);
7699 end Enclosing_Lib_Unit_Entity
;
7701 -----------------------------
7702 -- Enclosing_Lib_Unit_Node --
7703 -----------------------------
7705 function Enclosing_Lib_Unit_Node
(N
: Node_Id
) return Node_Id
is
7706 Encl_Unit
: Node_Id
;
7709 Encl_Unit
:= Enclosing_Comp_Unit_Node
(N
);
7710 while Present
(Encl_Unit
)
7711 and then Nkind
(Unit
(Encl_Unit
)) = N_Subunit
7713 Encl_Unit
:= Library_Unit
(Encl_Unit
);
7716 pragma Assert
(Nkind
(Encl_Unit
) = N_Compilation_Unit
);
7718 end Enclosing_Lib_Unit_Node
;
7720 -----------------------
7721 -- Enclosing_Package --
7722 -----------------------
7724 function Enclosing_Package
(N
: Node_Or_Entity_Id
) return Entity_Id
is
7725 Dynamic_Scope
: Entity_Id
;
7728 -- Obtain the enclosing scope when N is a Node_Id - taking care to
7729 -- handle the case when the enclosing scope is already a package.
7731 if Nkind
(N
) not in N_Entity
then
7733 Encl_Scop
: constant Entity_Id
:= Find_Enclosing_Scope
(N
);
7735 if No
(Encl_Scop
) then
7737 elsif Ekind
(Encl_Scop
) in
7738 E_Generic_Package | E_Package | E_Package_Body
7743 return Enclosing_Package
(Encl_Scop
);
7747 -- When N is already an Entity_Id proceed
7749 Dynamic_Scope
:= Enclosing_Dynamic_Scope
(N
);
7750 if Dynamic_Scope
= Standard_Standard
then
7751 return Standard_Standard
;
7753 elsif Dynamic_Scope
= Empty
then
7756 elsif Ekind
(Dynamic_Scope
) in
7757 E_Generic_Package | E_Package | E_Package_Body
7759 return Dynamic_Scope
;
7762 return Enclosing_Package
(Dynamic_Scope
);
7764 end Enclosing_Package
;
7766 -------------------------------------
7767 -- Enclosing_Package_Or_Subprogram --
7768 -------------------------------------
7770 function Enclosing_Package_Or_Subprogram
(E
: Entity_Id
) return Entity_Id
is
7775 while Present
(S
) loop
7776 if Is_Package_Or_Generic_Package
(S
)
7777 or else Is_Subprogram_Or_Generic_Subprogram
(S
)
7787 end Enclosing_Package_Or_Subprogram
;
7789 --------------------------
7790 -- Enclosing_Subprogram --
7791 --------------------------
7793 function Enclosing_Subprogram
(N
: Node_Or_Entity_Id
) return Entity_Id
is
7794 Dyn_Scop
: Entity_Id
;
7795 Encl_Scop
: Entity_Id
;
7798 -- Obtain the enclosing scope when N is a Node_Id - taking care to
7799 -- handle the case when the enclosing scope is already a subprogram.
7801 if Nkind
(N
) not in N_Entity
then
7802 Encl_Scop
:= Find_Enclosing_Scope
(N
);
7804 if No
(Encl_Scop
) then
7806 elsif Ekind
(Encl_Scop
) in Subprogram_Kind
then
7810 return Enclosing_Subprogram
(Encl_Scop
);
7813 -- When N is already an Entity_Id proceed
7815 Dyn_Scop
:= Enclosing_Dynamic_Scope
(N
);
7816 if Dyn_Scop
= Standard_Standard
then
7819 elsif Dyn_Scop
= Empty
then
7822 elsif Ekind
(Dyn_Scop
) = E_Subprogram_Body
then
7823 return Corresponding_Spec
(Parent
(Parent
(Dyn_Scop
)));
7825 elsif Ekind
(Dyn_Scop
) in E_Block | E_Loop | E_Return_Statement
then
7826 return Enclosing_Subprogram
(Dyn_Scop
);
7828 elsif Ekind
(Dyn_Scop
) in E_Entry | E_Entry_Family
then
7830 -- For a task entry or entry family, return the enclosing subprogram
7831 -- of the task itself.
7833 if Ekind
(Scope
(Dyn_Scop
)) = E_Task_Type
then
7834 return Enclosing_Subprogram
(Dyn_Scop
);
7836 -- A protected entry or entry family is rewritten as a protected
7837 -- procedure which is the desired enclosing subprogram. This is
7838 -- relevant when unnesting a procedure local to an entry body.
7841 return Protected_Body_Subprogram
(Dyn_Scop
);
7844 elsif Ekind
(Dyn_Scop
) = E_Task_Type
then
7845 return Get_Task_Body_Procedure
(Dyn_Scop
);
7847 -- The scope may appear as a private type or as a private extension
7848 -- whose completion is a task or protected type.
7850 elsif Ekind
(Dyn_Scop
) in
7851 E_Limited_Private_Type | E_Record_Type_With_Private
7852 and then Present
(Full_View
(Dyn_Scop
))
7853 and then Ekind
(Full_View
(Dyn_Scop
)) in E_Task_Type | E_Protected_Type
7855 return Get_Task_Body_Procedure
(Full_View
(Dyn_Scop
));
7857 -- No body is generated if the protected operation is eliminated
7859 elsif not Is_Eliminated
(Dyn_Scop
)
7860 and then Present
(Protected_Body_Subprogram
(Dyn_Scop
))
7862 return Protected_Body_Subprogram
(Dyn_Scop
);
7867 end Enclosing_Subprogram
;
7869 --------------------------
7870 -- End_Keyword_Location --
7871 --------------------------
7873 function End_Keyword_Location
(N
: Node_Id
) return Source_Ptr
is
7874 function End_Label_Loc
(Nod
: Node_Id
) return Source_Ptr
;
7875 -- Return the source location of Nod's end label according to the
7876 -- following precedence rules:
7878 -- 1) If the end label exists, return its location
7879 -- 2) If Nod exists, return its location
7880 -- 3) Return the location of N
7886 function End_Label_Loc
(Nod
: Node_Id
) return Source_Ptr
is
7890 if Present
(Nod
) then
7891 Label
:= End_Label
(Nod
);
7893 if Present
(Label
) then
7894 return Sloc
(Label
);
7906 Owner
: Node_Id
:= Empty
;
7908 -- Start of processing for End_Keyword_Location
7911 if Nkind
(N
) in N_Block_Statement
7917 Owner
:= Handled_Statement_Sequence
(N
);
7919 elsif Nkind
(N
) = N_Package_Declaration
then
7920 Owner
:= Specification
(N
);
7922 elsif Nkind
(N
) = N_Protected_Body
then
7925 elsif Nkind
(N
) in N_Protected_Type_Declaration
7926 | N_Single_Protected_Declaration
7928 Owner
:= Protected_Definition
(N
);
7930 elsif Nkind
(N
) in N_Single_Task_Declaration | N_Task_Type_Declaration
7932 Owner
:= Task_Definition
(N
);
7934 -- This routine should not be called with other contexts
7937 pragma Assert
(False);
7941 return End_Label_Loc
(Owner
);
7942 end End_Keyword_Location
;
7944 ------------------------
7945 -- Ensure_Freeze_Node --
7946 ------------------------
7948 procedure Ensure_Freeze_Node
(E
: Entity_Id
) is
7951 if No
(Freeze_Node
(E
)) then
7952 FN
:= Make_Freeze_Entity
(Sloc
(E
));
7953 Set_Has_Delayed_Freeze
(E
);
7954 Set_Freeze_Node
(E
, FN
);
7955 Set_Access_Types_To_Process
(FN
, No_Elist
);
7956 Set_TSS_Elist
(FN
, No_Elist
);
7959 end Ensure_Freeze_Node
;
7965 procedure Enter_Name
(Def_Id
: Entity_Id
) is
7966 C
: constant Entity_Id
:= Current_Entity
(Def_Id
);
7967 E
: constant Entity_Id
:= Current_Entity_In_Scope
(Def_Id
);
7968 S
: constant Entity_Id
:= Current_Scope
;
7971 Generate_Definition
(Def_Id
);
7973 -- Add new name to current scope declarations. Check for duplicate
7974 -- declaration, which may or may not be a genuine error.
7978 -- Case of previous entity entered because of a missing declaration
7979 -- or else a bad subtype indication. Best is to use the new entity,
7980 -- and make the previous one invisible.
7982 if Etype
(E
) = Any_Type
then
7983 Set_Is_Immediately_Visible
(E
, False);
7985 -- Case of renaming declaration constructed for package instances.
7986 -- if there is an explicit declaration with the same identifier,
7987 -- the renaming is not immediately visible any longer, but remains
7988 -- visible through selected component notation.
7990 elsif Nkind
(Parent
(E
)) = N_Package_Renaming_Declaration
7991 and then not Comes_From_Source
(E
)
7993 Set_Is_Immediately_Visible
(E
, False);
7995 -- The new entity may be the package renaming, which has the same
7996 -- same name as a generic formal which has been seen already.
7998 elsif Nkind
(Parent
(Def_Id
)) = N_Package_Renaming_Declaration
7999 and then not Comes_From_Source
(Def_Id
)
8001 Set_Is_Immediately_Visible
(E
, False);
8003 -- For a fat pointer corresponding to a remote access to subprogram,
8004 -- we use the same identifier as the RAS type, so that the proper
8005 -- name appears in the stub. This type is only retrieved through
8006 -- the RAS type and never by visibility, and is not added to the
8007 -- visibility list (see below).
8009 elsif Nkind
(Parent
(Def_Id
)) = N_Full_Type_Declaration
8010 and then Ekind
(Def_Id
) = E_Record_Type
8011 and then Present
(Corresponding_Remote_Type
(Def_Id
))
8015 -- Case of an implicit operation or derived literal. The new entity
8016 -- hides the implicit one, which is removed from all visibility,
8017 -- i.e. the entity list of its scope, and homonym chain of its name.
8019 elsif (Is_Overloadable
(E
) and then Is_Inherited_Operation
(E
))
8020 or else Is_Internal
(E
)
8023 Decl
: constant Node_Id
:= Parent
(E
);
8025 Prev_Vis
: Entity_Id
;
8028 -- If E is an implicit declaration, it cannot be the first
8029 -- entity in the scope.
8031 Prev
:= First_Entity
(Current_Scope
);
8032 while Present
(Prev
) and then Next_Entity
(Prev
) /= E
loop
8038 -- If E is not on the entity chain of the current scope,
8039 -- it is an implicit declaration in the generic formal
8040 -- part of a generic subprogram. When analyzing the body,
8041 -- the generic formals are visible but not on the entity
8042 -- chain of the subprogram. The new entity will become
8043 -- the visible one in the body.
8046 (Nkind
(Parent
(Decl
)) = N_Generic_Subprogram_Declaration
);
8050 Link_Entities
(Prev
, Next_Entity
(E
));
8052 if No
(Next_Entity
(Prev
)) then
8053 Set_Last_Entity
(Current_Scope
, Prev
);
8056 if E
= Current_Entity
(E
) then
8060 Prev_Vis
:= Current_Entity
(E
);
8061 while Homonym
(Prev_Vis
) /= E
loop
8062 Prev_Vis
:= Homonym
(Prev_Vis
);
8066 if Present
(Prev_Vis
) then
8068 -- Skip E in the visibility chain
8070 Set_Homonym
(Prev_Vis
, Homonym
(E
));
8073 Set_Name_Entity_Id
(Chars
(E
), Homonym
(E
));
8076 -- The inherited operation cannot be retrieved
8077 -- by name, even though it may remain accesssible
8078 -- in some cases involving subprogram bodies without
8079 -- specs appearing in with_clauses..
8081 Set_Is_Immediately_Visible
(E
, False);
8085 -- This section of code could use a comment ???
8087 elsif Present
(Etype
(E
))
8088 and then Is_Concurrent_Type
(Etype
(E
))
8093 -- If the homograph is a protected component renaming, it should not
8094 -- be hiding the current entity. Such renamings are treated as weak
8097 elsif Is_Prival
(E
) then
8098 Set_Is_Immediately_Visible
(E
, False);
8100 -- In this case the current entity is a protected component renaming.
8101 -- Perform minimal decoration by setting the scope and return since
8102 -- the prival should not be hiding other visible entities.
8104 elsif Is_Prival
(Def_Id
) then
8105 Set_Scope
(Def_Id
, Current_Scope
);
8108 -- Analogous to privals, the discriminal generated for an entry index
8109 -- parameter acts as a weak declaration. Perform minimal decoration
8110 -- to avoid bogus errors.
8112 elsif Is_Discriminal
(Def_Id
)
8113 and then Ekind
(Discriminal_Link
(Def_Id
)) = E_Entry_Index_Parameter
8115 Set_Scope
(Def_Id
, Current_Scope
);
8118 -- In the body or private part of an instance, a type extension may
8119 -- introduce a component with the same name as that of an actual. The
8120 -- legality rule is not enforced, but the semantics of the full type
8121 -- with two components of same name are not clear at this point???
8123 elsif In_Instance_Not_Visible
then
8126 -- When compiling a package body, some child units may have become
8127 -- visible. They cannot conflict with local entities that hide them.
8129 elsif Is_Child_Unit
(E
)
8130 and then In_Open_Scopes
(Scope
(E
))
8131 and then not Is_Immediately_Visible
(E
)
8135 -- Conversely, with front-end inlining we may compile the parent body
8136 -- first, and a child unit subsequently. The context is now the
8137 -- parent spec, and body entities are not visible.
8139 elsif Is_Child_Unit
(Def_Id
)
8140 and then Is_Package_Body_Entity
(E
)
8141 and then not In_Package_Body
(Current_Scope
)
8145 -- Case of genuine duplicate declaration
8148 Error_Msg_Sloc
:= Sloc
(E
);
8150 -- If the previous declaration is an incomplete type declaration
8151 -- this may be an attempt to complete it with a private type. The
8152 -- following avoids confusing cascaded errors.
8154 if Nkind
(Parent
(E
)) = N_Incomplete_Type_Declaration
8155 and then Nkind
(Parent
(Def_Id
)) = N_Private_Type_Declaration
8158 ("incomplete type cannot be completed with a private " &
8159 "declaration", Parent
(Def_Id
));
8160 Set_Is_Immediately_Visible
(E
, False);
8161 Set_Full_View
(E
, Def_Id
);
8163 -- An inherited component of a record conflicts with a new
8164 -- discriminant. The discriminant is inserted first in the scope,
8165 -- but the error should be posted on it, not on the component.
8167 elsif Ekind
(E
) = E_Discriminant
8168 and then Present
(Scope
(Def_Id
))
8169 and then Scope
(Def_Id
) /= Current_Scope
8171 Error_Msg_Sloc
:= Sloc
(Def_Id
);
8172 Error_Msg_N
("& conflicts with declaration#", E
);
8175 -- If the name of the unit appears in its own context clause, a
8176 -- dummy package with the name has already been created, and the
8177 -- error emitted. Try to continue quietly.
8179 elsif Error_Posted
(E
)
8180 and then Sloc
(E
) = No_Location
8181 and then Nkind
(Parent
(E
)) = N_Package_Specification
8182 and then Current_Scope
= Standard_Standard
8184 Set_Scope
(Def_Id
, Current_Scope
);
8188 Error_Msg_N
("& conflicts with declaration#", Def_Id
);
8190 -- Avoid cascaded messages with duplicate components in
8193 if Ekind
(E
) in E_Component | E_Discriminant
then
8198 if Nkind
(Parent
(Parent
(Def_Id
))) =
8199 N_Generic_Subprogram_Declaration
8201 Defining_Entity
(Specification
(Parent
(Parent
(Def_Id
))))
8203 Error_Msg_N
("\generic units cannot be overloaded", Def_Id
);
8206 -- If entity is in standard, then we are in trouble, because it
8207 -- means that we have a library package with a duplicated name.
8208 -- That's hard to recover from, so abort.
8210 if S
= Standard_Standard
then
8211 raise Unrecoverable_Error
;
8213 -- Otherwise we continue with the declaration. Having two
8214 -- identical declarations should not cause us too much trouble.
8222 -- If we fall through, declaration is OK, at least OK enough to continue
8224 -- If Def_Id is a discriminant or a record component we are in the midst
8225 -- of inheriting components in a derived record definition. Preserve
8226 -- their Ekind and Etype.
8228 if Ekind
(Def_Id
) in E_Discriminant | E_Component
then
8231 -- If a type is already set, leave it alone (happens when a type
8232 -- declaration is reanalyzed following a call to the optimizer).
8234 elsif Present
(Etype
(Def_Id
)) then
8238 Set_Etype
(Def_Id
, Any_Type
); -- avoid cascaded errors
8241 -- All entities except Itypes are immediately visible
8243 if not Is_Itype
(Def_Id
) then
8244 Set_Is_Immediately_Visible
(Def_Id
);
8245 Set_Current_Entity
(Def_Id
);
8248 Set_Homonym
(Def_Id
, C
);
8249 Append_Entity
(Def_Id
, S
);
8250 Set_Public_Status
(Def_Id
);
8252 -- Warn if new entity hides an old one
8254 if Warn_On_Hiding
and then Present
(C
) then
8255 Warn_On_Hiding_Entity
(Def_Id
, Hidden
=> C
, Visible
=> Def_Id
,
8256 On_Use_Clause
=> False);
8264 function Entity_Of
(N
: Node_Id
) return Entity_Id
is
8269 -- Assume that the arbitrary node does not have an entity
8273 if Is_Entity_Name
(N
) then
8276 -- Follow a possible chain of renamings to reach the earliest renamed
8280 and then Is_Object
(Id
)
8281 and then Present
(Renamed_Object
(Id
))
8283 Ren
:= Renamed_Object
(Id
);
8285 -- The reference renames an abstract state or a whole object
8288 -- Ren : ... renames Obj;
8290 if Is_Entity_Name
(Ren
) then
8292 -- Do not follow a renaming that goes through a generic formal,
8293 -- because these entities are hidden and must not be referenced
8294 -- from outside the generic.
8296 if Is_Hidden
(Entity
(Ren
)) then
8303 -- The reference renames a function result. Check the original
8304 -- node in case expansion relocates the function call.
8306 -- Ren : ... renames Func_Call;
8308 elsif Nkind
(Original_Node
(Ren
)) = N_Function_Call
then
8311 -- Otherwise the reference renames something which does not yield
8312 -- an abstract state or a whole object. Treat the reference as not
8313 -- having a proper entity for SPARK legality purposes.
8325 --------------------------
8326 -- Examine_Array_Bounds --
8327 --------------------------
8329 procedure Examine_Array_Bounds
8331 All_Static
: out Boolean;
8332 Has_Empty
: out Boolean)
8334 function Is_OK_Static_Bound
(Bound
: Node_Id
) return Boolean;
8335 -- Determine whether bound Bound is a suitable static bound
8337 ------------------------
8338 -- Is_OK_Static_Bound --
8339 ------------------------
8341 function Is_OK_Static_Bound
(Bound
: Node_Id
) return Boolean is
8344 not Error_Posted
(Bound
)
8345 and then Is_OK_Static_Expression
(Bound
);
8346 end Is_OK_Static_Bound
;
8354 -- Start of processing for Examine_Array_Bounds
8357 -- An unconstrained array type does not have static bounds, and it is
8358 -- not known whether they are empty or not.
8360 if not Is_Constrained
(Typ
) then
8361 All_Static
:= False;
8364 -- A string literal has static bounds, and is not empty as long as it
8365 -- contains at least one character.
8367 elsif Ekind
(Typ
) = E_String_Literal_Subtype
then
8369 Has_Empty
:= String_Literal_Length
(Typ
) > 0;
8372 -- Assume that all bounds are static and not empty
8377 -- Examine each index
8379 Index
:= First_Index
(Typ
);
8380 while Present
(Index
) loop
8381 if Is_Discrete_Type
(Etype
(Index
)) then
8382 Get_Index_Bounds
(Index
, Lo_Bound
, Hi_Bound
);
8384 if Is_OK_Static_Bound
(Lo_Bound
)
8386 Is_OK_Static_Bound
(Hi_Bound
)
8388 -- The static bounds produce an empty range
8390 if Is_Null_Range
(Lo_Bound
, Hi_Bound
) then
8394 -- Otherwise at least one of the bounds is not static
8397 All_Static
:= False;
8400 -- Otherwise the index is non-discrete, therefore not static
8403 All_Static
:= False;
8408 end Examine_Array_Bounds
;
8414 function Exceptions_OK
return Boolean is
8417 not (Restriction_Active
(No_Exception_Handlers
) or else
8418 Restriction_Active
(No_Exception_Propagation
) or else
8419 Restriction_Active
(No_Exceptions
));
8422 --------------------------
8423 -- Explain_Limited_Type --
8424 --------------------------
8426 procedure Explain_Limited_Type
(T
: Entity_Id
; N
: Node_Id
) is
8430 -- For array, component type must be limited
8432 if Is_Array_Type
(T
) then
8433 Error_Msg_Node_2
:= T
;
8435 ("\component type& of type& is limited", N
, Component_Type
(T
));
8436 Explain_Limited_Type
(Component_Type
(T
), N
);
8438 elsif Is_Record_Type
(T
) then
8440 -- No need for extra messages if explicit limited record
8442 if Is_Limited_Record
(Base_Type
(T
)) then
8446 -- Otherwise find a limited component. Check only components that
8447 -- come from source, or inherited components that appear in the
8448 -- source of the ancestor.
8450 C
:= First_Component
(T
);
8451 while Present
(C
) loop
8452 if Is_Limited_Type
(Etype
(C
))
8454 (Comes_From_Source
(C
)
8456 (Present
(Original_Record_Component
(C
))
8458 Comes_From_Source
(Original_Record_Component
(C
))))
8460 Error_Msg_Node_2
:= T
;
8461 Error_Msg_NE
("\component& of type& has limited type", N
, C
);
8462 Explain_Limited_Type
(Etype
(C
), N
);
8469 -- The type may be declared explicitly limited, even if no component
8470 -- of it is limited, in which case we fall out of the loop.
8473 end Explain_Limited_Type
;
8475 ---------------------------------------
8476 -- Expression_Of_Expression_Function --
8477 ---------------------------------------
8479 function Expression_Of_Expression_Function
8480 (Subp
: Entity_Id
) return Node_Id
8482 Expr_Func
: Node_Id
:= Empty
;
8485 pragma Assert
(Is_Expression_Function_Or_Completion
(Subp
));
8487 if Nkind
(Original_Node
(Subprogram_Spec
(Subp
))) =
8488 N_Expression_Function
8490 Expr_Func
:= Original_Node
(Subprogram_Spec
(Subp
));
8492 elsif Nkind
(Original_Node
(Subprogram_Body
(Subp
))) =
8493 N_Expression_Function
8495 Expr_Func
:= Original_Node
(Subprogram_Body
(Subp
));
8498 pragma Assert
(False);
8502 return Original_Node
(Expression
(Expr_Func
));
8503 end Expression_Of_Expression_Function
;
8505 -------------------------------
8506 -- Extensions_Visible_Status --
8507 -------------------------------
8509 function Extensions_Visible_Status
8510 (Id
: Entity_Id
) return Extensions_Visible_Mode
8519 -- When a formal parameter is subject to Extensions_Visible, the pragma
8520 -- is stored in the contract of related subprogram.
8522 if Is_Formal
(Id
) then
8525 elsif Is_Subprogram_Or_Generic_Subprogram
(Id
) then
8528 -- No other construct carries this pragma
8531 return Extensions_Visible_None
;
8534 Prag
:= Get_Pragma
(Subp
, Pragma_Extensions_Visible
);
8536 -- In certain cases analysis may request the Extensions_Visible status
8537 -- of an expression function before the pragma has been analyzed yet.
8538 -- Inspect the declarative items after the expression function looking
8539 -- for the pragma (if any).
8541 if No
(Prag
) and then Is_Expression_Function
(Subp
) then
8542 Decl
:= Next
(Unit_Declaration_Node
(Subp
));
8543 while Present
(Decl
) loop
8544 if Nkind
(Decl
) = N_Pragma
8545 and then Pragma_Name
(Decl
) = Name_Extensions_Visible
8550 -- A source construct ends the region where Extensions_Visible may
8551 -- appear, stop the traversal. An expanded expression function is
8552 -- no longer a source construct, but it must still be recognized.
8554 elsif Comes_From_Source
(Decl
)
8556 (Nkind
(Decl
) in N_Subprogram_Body | N_Subprogram_Declaration
8557 and then Is_Expression_Function
(Defining_Entity
(Decl
)))
8566 -- Extract the value from the Boolean expression (if any)
8568 if Present
(Prag
) then
8569 Arg
:= First
(Pragma_Argument_Associations
(Prag
));
8571 if Present
(Arg
) then
8572 Expr
:= Get_Pragma_Arg
(Arg
);
8574 -- When the associated subprogram is an expression function, the
8575 -- argument of the pragma may not have been analyzed.
8577 if not Analyzed
(Expr
) then
8578 Preanalyze_And_Resolve
(Expr
, Standard_Boolean
);
8581 -- Guard against cascading errors when the argument of pragma
8582 -- Extensions_Visible is not a valid static Boolean expression.
8584 if Error_Posted
(Expr
) then
8585 return Extensions_Visible_None
;
8587 elsif Is_True
(Expr_Value
(Expr
)) then
8588 return Extensions_Visible_True
;
8591 return Extensions_Visible_False
;
8594 -- Otherwise the aspect or pragma defaults to True
8597 return Extensions_Visible_True
;
8600 -- Otherwise aspect or pragma Extensions_Visible is not inherited or
8601 -- directly specified. In SPARK code, its value defaults to "False".
8603 elsif SPARK_Mode
= On
then
8604 return Extensions_Visible_False
;
8606 -- In non-SPARK code, aspect or pragma Extensions_Visible defaults to
8610 return Extensions_Visible_True
;
8612 end Extensions_Visible_Status
;
8618 procedure Find_Actual
8620 Formal
: out Entity_Id
;
8623 Context
: constant Node_Id
:= Parent
(N
);
8626 Call_Ent
: Node_Id
:= Empty
;
8629 if Nkind
(Context
) in N_Indexed_Component | N_Selected_Component
8630 and then N
= Prefix
(Context
)
8632 Find_Actual
(Context
, Formal
, Call
);
8635 elsif Nkind
(Context
) = N_Parameter_Association
8636 and then N
= Explicit_Actual_Parameter
(Context
)
8638 Call
:= Parent
(Context
);
8640 elsif Nkind
(Context
) in N_Entry_Call_Statement
8642 | N_Procedure_Call_Statement
8652 -- If we have a call to a subprogram look for the parameter. Note that
8653 -- we exclude overloaded calls, since we don't know enough to be sure
8654 -- of giving the right answer in this case.
8656 if Nkind
(Call
) in N_Entry_Call_Statement
8658 | N_Procedure_Call_Statement
8660 Call_Nam
:= Name
(Call
);
8662 -- A call to an entry family may appear as an indexed component
8664 if Nkind
(Call_Nam
) = N_Indexed_Component
then
8665 Call_Nam
:= Prefix
(Call_Nam
);
8668 -- A call to a protected or task entry appears as a selected
8669 -- component rather than an expanded name.
8671 if Nkind
(Call_Nam
) = N_Selected_Component
then
8672 Call_Nam
:= Selector_Name
(Call_Nam
);
8675 -- If Call_Nam is an entity name, get its entity
8677 if Is_Entity_Name
(Call_Nam
) then
8678 Call_Ent
:= Entity
(Call_Nam
);
8680 -- If it is a dereference, get the designated subprogram type
8682 elsif Nkind
(Call_Nam
) = N_Explicit_Dereference
then
8684 Typ
: Entity_Id
:= Etype
(Prefix
(Call_Nam
));
8686 if Present
(Full_View
(Typ
)) then
8687 Typ
:= Full_View
(Typ
);
8688 elsif Is_Private_Type
(Typ
)
8689 and then Present
(Underlying_Full_View
(Typ
))
8691 Typ
:= Underlying_Full_View
(Typ
);
8694 if Is_Access_Type
(Typ
) then
8695 Call_Ent
:= Directly_Designated_Type
(Typ
);
8697 pragma Assert
(Has_Implicit_Dereference
(Typ
));
8705 if Present
(Call_Ent
)
8706 and then (Is_Generic_Subprogram
(Call_Ent
)
8707 or else Is_Overloadable
(Call_Ent
)
8708 or else Ekind
(Call_Ent
) in E_Entry_Family
8710 | E_Subprogram_Type
)
8711 and then not Is_Overloaded
(Call_Nam
)
8713 -- If node is name in call it is not an actual
8715 if N
= Call_Nam
then
8721 -- Fall here if we are definitely a parameter
8723 Actual
:= First_Actual
(Call
);
8724 Formal
:= First_Formal
(Call_Ent
);
8725 while Present
(Formal
) and then Present
(Actual
) loop
8729 -- An actual that is the prefix in a prefixed call may have
8730 -- been rewritten in the call. Check if sloc and kinds and
8733 elsif Sloc
(Actual
) = Sloc
(N
)
8734 and then Nkind
(Actual
) = N_Identifier
8735 and then Nkind
(Actual
) = Nkind
(N
)
8736 and then Chars
(Actual
) = Chars
(N
)
8741 Next_Actual
(Actual
);
8742 Next_Formal
(Formal
);
8748 -- Fall through here if we did not find matching actual
8754 ---------------------------
8755 -- Find_Body_Discriminal --
8756 ---------------------------
8758 function Find_Body_Discriminal
8759 (Spec_Discriminant
: Entity_Id
) return Entity_Id
8765 -- If expansion is suppressed, then the scope can be the concurrent type
8766 -- itself rather than a corresponding concurrent record type.
8768 if Is_Concurrent_Type
(Scope
(Spec_Discriminant
)) then
8769 Tsk
:= Scope
(Spec_Discriminant
);
8772 pragma Assert
(Is_Concurrent_Record_Type
(Scope
(Spec_Discriminant
)));
8774 Tsk
:= Corresponding_Concurrent_Type
(Scope
(Spec_Discriminant
));
8777 -- Find discriminant of original concurrent type, and use its current
8778 -- discriminal, which is the renaming within the task/protected body.
8780 Disc
:= First_Discriminant
(Tsk
);
8781 while Present
(Disc
) loop
8782 if Chars
(Disc
) = Chars
(Spec_Discriminant
) then
8783 return Discriminal
(Disc
);
8786 Next_Discriminant
(Disc
);
8789 -- That loop should always succeed in finding a matching entry and
8790 -- returning. Fatal error if not.
8792 raise Program_Error
;
8793 end Find_Body_Discriminal
;
8795 -------------------------------------
8796 -- Find_Corresponding_Discriminant --
8797 -------------------------------------
8799 function Find_Corresponding_Discriminant
8801 Typ
: Entity_Id
) return Entity_Id
8803 Par_Disc
: Entity_Id
;
8804 Old_Disc
: Entity_Id
;
8805 New_Disc
: Entity_Id
;
8808 Par_Disc
:= Original_Record_Component
(Original_Discriminant
(Id
));
8810 -- The original type may currently be private, and the discriminant
8811 -- only appear on its full view.
8813 if Is_Private_Type
(Scope
(Par_Disc
))
8814 and then not Has_Discriminants
(Scope
(Par_Disc
))
8815 and then Present
(Full_View
(Scope
(Par_Disc
)))
8817 Old_Disc
:= First_Discriminant
(Full_View
(Scope
(Par_Disc
)));
8819 Old_Disc
:= First_Discriminant
(Scope
(Par_Disc
));
8822 if Is_Class_Wide_Type
(Typ
) then
8823 New_Disc
:= First_Discriminant
(Root_Type
(Typ
));
8825 New_Disc
:= First_Discriminant
(Typ
);
8828 while Present
(Old_Disc
) and then Present
(New_Disc
) loop
8829 if Old_Disc
= Par_Disc
then
8833 Next_Discriminant
(Old_Disc
);
8834 Next_Discriminant
(New_Disc
);
8837 -- Should always find it
8839 raise Program_Error
;
8840 end Find_Corresponding_Discriminant
;
8846 function Find_DIC_Type
(Typ
: Entity_Id
) return Entity_Id
is
8847 Curr_Typ
: Entity_Id
;
8848 -- The current type being examined in the parent hierarchy traversal
8850 DIC_Typ
: Entity_Id
;
8851 -- The type which carries the DIC pragma. This variable denotes the
8852 -- partial view when private types are involved.
8854 Par_Typ
: Entity_Id
;
8855 -- The parent type of the current type. This variable denotes the full
8856 -- view when private types are involved.
8859 -- The input type defines its own DIC pragma, therefore it is the owner
8861 if Has_Own_DIC
(Typ
) then
8864 -- Otherwise the DIC pragma is inherited from a parent type
8867 pragma Assert
(Has_Inherited_DIC
(Typ
));
8869 -- Climb the parent chain
8873 -- Inspect the parent type. Do not consider subtypes as they
8874 -- inherit the DIC attributes from their base types.
8876 DIC_Typ
:= Base_Type
(Etype
(Curr_Typ
));
8878 -- Look at the full view of a private type because the type may
8879 -- have a hidden parent introduced in the full view.
8883 if Is_Private_Type
(Par_Typ
)
8884 and then Present
(Full_View
(Par_Typ
))
8886 Par_Typ
:= Full_View
(Par_Typ
);
8889 -- Stop the climb once the nearest parent type which defines a DIC
8890 -- pragma of its own is encountered or when the root of the parent
8891 -- chain is reached.
8893 exit when Has_Own_DIC
(DIC_Typ
) or else Curr_Typ
= Par_Typ
;
8895 Curr_Typ
:= Par_Typ
;
8902 ----------------------------------
8903 -- Find_Enclosing_Iterator_Loop --
8904 ----------------------------------
8906 function Find_Enclosing_Iterator_Loop
(Id
: Entity_Id
) return Entity_Id
is
8911 -- Traverse the scope chain looking for an iterator loop. Such loops are
8912 -- usually transformed into blocks, hence the use of Original_Node.
8915 while Present
(S
) and then S
/= Standard_Standard
loop
8916 if Ekind
(S
) = E_Loop
8917 and then Nkind
(Parent
(S
)) = N_Implicit_Label_Declaration
8919 Constr
:= Original_Node
(Label_Construct
(Parent
(S
)));
8921 if Nkind
(Constr
) = N_Loop_Statement
8922 and then Present
(Iteration_Scheme
(Constr
))
8923 and then Nkind
(Iterator_Specification
8924 (Iteration_Scheme
(Constr
))) =
8925 N_Iterator_Specification
8935 end Find_Enclosing_Iterator_Loop
;
8937 --------------------------
8938 -- Find_Enclosing_Scope --
8939 --------------------------
8941 function Find_Enclosing_Scope
(N
: Node_Id
) return Scope_Kind_Id
is
8945 -- If N is an entity, simply return its Scope
8947 if Nkind
(N
) in N_Entity
then
8951 -- Examine the parent chain looking for a construct which defines a
8955 while Present
(Par
) loop
8958 -- The construct denotes a declaration, the proper scope is its
8961 when N_Entry_Declaration
8962 | N_Expression_Function
8963 | N_Full_Type_Declaration
8964 | N_Generic_Package_Declaration
8965 | N_Generic_Subprogram_Declaration
8966 | N_Package_Declaration
8967 | N_Private_Extension_Declaration
8968 | N_Protected_Type_Declaration
8969 | N_Single_Protected_Declaration
8970 | N_Single_Task_Declaration
8971 | N_Subprogram_Declaration
8972 | N_Task_Type_Declaration
8974 return Defining_Entity
(Par
);
8976 -- The construct denotes a body, the proper scope is the entity of
8977 -- the corresponding spec or that of the body if the body does not
8978 -- complete a previous declaration.
8986 return Unique_Defining_Entity
(Par
);
8990 -- Blocks carry either a source or an internally-generated scope,
8991 -- unless the block is a byproduct of exception handling.
8993 when N_Block_Statement
=>
8994 if not Exception_Junk
(Par
) then
8995 return Entity
(Identifier
(Par
));
8998 -- Loops carry an internally-generated scope
9000 when N_Loop_Statement
=>
9001 return Entity
(Identifier
(Par
));
9003 -- Extended return statements carry an internally-generated scope
9005 when N_Extended_Return_Statement
=>
9006 return Return_Statement_Entity
(Par
);
9008 -- A traversal from a subunit continues via the corresponding stub
9011 Par
:= Corresponding_Stub
(Par
);
9017 Par
:= Parent
(Par
);
9020 return Standard_Standard
;
9021 end Find_Enclosing_Scope
;
9023 ------------------------------------
9024 -- Find_Loop_In_Conditional_Block --
9025 ------------------------------------
9027 function Find_Loop_In_Conditional_Block
(N
: Node_Id
) return Node_Id
is
9033 if Nkind
(Stmt
) = N_If_Statement
then
9034 Stmt
:= First
(Then_Statements
(Stmt
));
9037 pragma Assert
(Nkind
(Stmt
) = N_Block_Statement
);
9039 -- Inspect the statements of the conditional block. In general the loop
9040 -- should be the first statement in the statement sequence of the block,
9041 -- but the finalization machinery may have introduced extra object
9044 Stmt
:= First
(Statements
(Handled_Statement_Sequence
(Stmt
)));
9045 while Present
(Stmt
) loop
9046 if Nkind
(Stmt
) = N_Loop_Statement
then
9053 -- The expansion of attribute 'Loop_Entry produced a malformed block
9055 raise Program_Error
;
9056 end Find_Loop_In_Conditional_Block
;
9058 --------------------------
9059 -- Find_Overlaid_Entity --
9060 --------------------------
9062 procedure Find_Overlaid_Entity
9064 Ent
: out Entity_Id
;
9068 (Nkind
(N
) = N_Attribute_Definition_Clause
9069 and then Chars
(N
) = Name_Address
);
9074 -- We are looking for one of the two following forms:
9076 -- for X'Address use Y'Address
9080 -- Const : constant Address := expr;
9082 -- for X'Address use Const;
9084 -- In the second case, the expr is either Y'Address, or recursively a
9085 -- constant that eventually references Y'Address.
9090 Expr
:= Expression
(N
);
9092 -- This loop checks the form of the expression for Y'Address, using
9093 -- recursion to deal with intermediate constants.
9096 -- Check for Y'Address
9098 if Nkind
(Expr
) = N_Attribute_Reference
9099 and then Attribute_Name
(Expr
) = Name_Address
9101 Expr
:= Prefix
(Expr
);
9104 -- Check for Const where Const is a constant entity
9106 elsif Is_Entity_Name
(Expr
)
9107 and then Ekind
(Entity
(Expr
)) = E_Constant
9109 Expr
:= Constant_Value
(Entity
(Expr
));
9111 -- Anything else does not need checking
9118 -- This loop checks the form of the prefix for an entity, using
9119 -- recursion to deal with intermediate components.
9122 -- Check for Y where Y is an entity
9124 if Is_Entity_Name
(Expr
) then
9125 Ent
:= Entity
(Expr
);
9127 -- If expansion is disabled, then we might see an entity of a
9128 -- protected component or of a discriminant of a concurrent unit.
9129 -- Ignore such entities, because further warnings for overlays
9130 -- expect this routine to only collect entities of entire objects.
9132 if Ekind
(Ent
) in E_Component | E_Discriminant
then
9134 (not Expander_Active
9135 and then Is_Concurrent_Type
(Scope
(Ent
)));
9140 -- Check for components
9142 elsif Nkind
(Expr
) in N_Selected_Component | N_Indexed_Component
then
9143 Expr
:= Prefix
(Expr
);
9146 -- Anything else does not need checking
9152 end Find_Overlaid_Entity
;
9154 -------------------------
9155 -- Find_Parameter_Type --
9156 -------------------------
9158 function Find_Parameter_Type
(Param
: Node_Id
) return Entity_Id
is
9160 if Nkind
(Param
) /= N_Parameter_Specification
then
9163 -- For an access parameter, obtain the type from the formal entity
9164 -- itself, because access to subprogram nodes do not carry a type.
9165 -- Shouldn't we always use the formal entity ???
9167 elsif Nkind
(Parameter_Type
(Param
)) = N_Access_Definition
then
9168 return Etype
(Defining_Identifier
(Param
));
9171 return Etype
(Parameter_Type
(Param
));
9173 end Find_Parameter_Type
;
9175 -----------------------------------
9176 -- Find_Placement_In_State_Space --
9177 -----------------------------------
9179 procedure Find_Placement_In_State_Space
9180 (Item_Id
: Entity_Id
;
9181 Placement
: out State_Space_Kind
;
9182 Pack_Id
: out Entity_Id
)
9184 function Inside_Package_Body
(Id
: Entity_Id
) return Boolean;
9185 function Inside_Private_Part
(Id
: Entity_Id
) return Boolean;
9186 -- Return True if Id is declared directly within the package body
9187 -- and the package private parts, respectively. We cannot use
9188 -- In_Private_Part/In_Body_Part flags, as these are only set during the
9189 -- analysis of the package itself, while Find_Placement_In_State_Space
9190 -- can be called on an entity of another package.
9192 ------------------------
9193 -- Inside_Package_Body --
9194 ------------------------
9196 function Inside_Package_Body
(Id
: Entity_Id
) return Boolean is
9197 Spec_Id
: constant Entity_Id
:= Scope
(Id
);
9198 Body_Decl
: constant Opt_N_Package_Body_Id
:= Package_Body
(Spec_Id
);
9199 Decl
: constant Node_Id
:= Enclosing_Declaration
(Id
);
9201 if Present
(Body_Decl
)
9202 and then Is_List_Member
(Decl
)
9203 and then List_Containing
(Decl
) = Declarations
(Body_Decl
)
9209 end Inside_Package_Body
;
9211 -------------------------
9212 -- Inside_Private_Part --
9213 -------------------------
9215 function Inside_Private_Part
(Id
: Entity_Id
) return Boolean is
9216 Spec_Id
: constant Entity_Id
:= Scope
(Id
);
9217 Private_Decls
: constant List_Id
:=
9218 Private_Declarations
(Package_Specification
(Spec_Id
));
9219 Decl
: constant Node_Id
:= Enclosing_Declaration
(Id
);
9221 if Is_List_Member
(Decl
)
9222 and then List_Containing
(Decl
) = Private_Decls
9226 elsif Ekind
(Id
) = E_Package
9227 and then Is_Private_Library_Unit
(Id
)
9234 end Inside_Private_Part
;
9238 Context
: Entity_Id
;
9240 -- Start of processing for Find_Placement_In_State_Space
9243 -- Assume that the item does not appear in the state space of a package
9245 Placement
:= Not_In_Package
;
9247 -- Climb the scope stack and examine the enclosing context
9250 Pack_Id
:= Scope
(Context
);
9251 while Present
(Pack_Id
) and then Pack_Id
/= Standard_Standard
loop
9252 if Is_Package_Or_Generic_Package
(Pack_Id
) then
9254 -- A package body is a cut off point for the traversal as the
9255 -- item cannot be visible to the outside from this point on.
9257 if Inside_Package_Body
(Context
) then
9258 Placement
:= Body_State_Space
;
9261 -- The private part of a package is a cut off point for the
9262 -- traversal as the item cannot be visible to the outside
9263 -- from this point on.
9265 elsif Inside_Private_Part
(Context
) then
9266 Placement
:= Private_State_Space
;
9269 -- When the item appears in the visible state space of a package,
9270 -- continue to climb the scope stack as this may not be the final
9274 Placement
:= Visible_State_Space
;
9276 -- The visible state space of a child unit acts as the proper
9277 -- placement of an item, unless this is a private child unit.
9279 if Is_Child_Unit
(Pack_Id
)
9280 and then not Is_Private_Library_Unit
(Pack_Id
)
9286 -- The item or its enclosing package appear in a construct that has
9290 Placement
:= Not_In_Package
;
9295 Context
:= Scope
(Context
);
9296 Pack_Id
:= Scope
(Context
);
9298 end Find_Placement_In_State_Space
;
9300 -----------------------
9301 -- Find_Primitive_Eq --
9302 -----------------------
9304 function Find_Primitive_Eq
(Typ
: Entity_Id
) return Entity_Id
is
9305 function Find_Eq_Prim
(Prims_List
: Elist_Id
) return Entity_Id
;
9306 -- Search for the equality primitive; return Empty if the primitive is
9313 function Find_Eq_Prim
(Prims_List
: Elist_Id
) return Entity_Id
is
9315 Prim_Elmt
: Elmt_Id
;
9318 Prim_Elmt
:= First_Elmt
(Prims_List
);
9319 while Present
(Prim_Elmt
) loop
9320 Prim
:= Node
(Prim_Elmt
);
9322 -- Locate primitive equality with the right signature
9324 if Chars
(Prim
) = Name_Op_Eq
9325 and then Etype
(First_Formal
(Prim
)) =
9326 Etype
(Next_Formal
(First_Formal
(Prim
)))
9327 and then Base_Type
(Etype
(Prim
)) = Standard_Boolean
9332 Next_Elmt
(Prim_Elmt
);
9340 Eq_Prim
: Entity_Id
;
9341 Full_Type
: Entity_Id
;
9343 -- Start of processing for Find_Primitive_Eq
9346 if Is_Private_Type
(Typ
) then
9347 Full_Type
:= Underlying_Type
(Typ
);
9352 if No
(Full_Type
) then
9356 Full_Type
:= Base_Type
(Full_Type
);
9358 -- When the base type itself is private, use the full view
9360 if Is_Private_Type
(Full_Type
) then
9361 Full_Type
:= Underlying_Type
(Full_Type
);
9364 if Is_Class_Wide_Type
(Full_Type
) then
9365 Full_Type
:= Root_Type
(Full_Type
);
9368 if not Is_Tagged_Type
(Full_Type
) then
9369 Eq_Prim
:= Find_Eq_Prim
(Collect_Primitive_Operations
(Typ
));
9371 -- If this is an untagged private type completed with a derivation of
9372 -- an untagged private type whose full view is a tagged type, we use
9373 -- the primitive operations of the private parent type (since it does
9374 -- not have a full view, and also because its equality primitive may
9375 -- have been overridden in its untagged full view). If no equality was
9376 -- defined for it then take its dispatching equality primitive.
9378 elsif Inherits_From_Tagged_Full_View
(Typ
) then
9379 Eq_Prim
:= Find_Eq_Prim
(Collect_Primitive_Operations
(Typ
));
9381 if No
(Eq_Prim
) then
9382 Eq_Prim
:= Find_Eq_Prim
(Primitive_Operations
(Full_Type
));
9386 Eq_Prim
:= Find_Eq_Prim
(Primitive_Operations
(Full_Type
));
9390 end Find_Primitive_Eq
;
9392 ------------------------
9393 -- Find_Specific_Type --
9394 ------------------------
9396 function Find_Specific_Type
(CW
: Entity_Id
) return Entity_Id
is
9397 Typ
: Entity_Id
:= Root_Type
(CW
);
9400 if Ekind
(Typ
) = E_Incomplete_Type
then
9401 if From_Limited_With
(Typ
) then
9402 Typ
:= Non_Limited_View
(Typ
);
9404 Typ
:= Full_View
(Typ
);
9408 if Is_Private_Type
(Typ
)
9409 and then not Is_Tagged_Type
(Typ
)
9410 and then Present
(Full_View
(Typ
))
9412 return Full_View
(Typ
);
9416 end Find_Specific_Type
;
9418 -----------------------------
9419 -- Find_Static_Alternative --
9420 -----------------------------
9422 function Find_Static_Alternative
(N
: Node_Id
) return Node_Id
is
9423 Expr
: constant Node_Id
:= Expression
(N
);
9424 Val
: constant Uint
:= Expr_Value
(Expr
);
9429 Alt
:= First
(Alternatives
(N
));
9432 if Nkind
(Alt
) /= N_Pragma
then
9433 Choice
:= First
(Discrete_Choices
(Alt
));
9434 while Present
(Choice
) loop
9436 -- Others choice, always matches
9438 if Nkind
(Choice
) = N_Others_Choice
then
9441 -- Range, check if value is in the range
9443 elsif Nkind
(Choice
) = N_Range
then
9445 Val
>= Expr_Value
(Low_Bound
(Choice
))
9447 Val
<= Expr_Value
(High_Bound
(Choice
));
9449 -- Choice is a subtype name. Note that we know it must
9450 -- be a static subtype, since otherwise it would have
9451 -- been diagnosed as illegal.
9453 elsif Is_Entity_Name
(Choice
)
9454 and then Is_Type
(Entity
(Choice
))
9456 exit Search
when Is_In_Range
(Expr
, Etype
(Choice
),
9457 Assume_Valid
=> False);
9459 -- Choice is a subtype indication
9461 elsif Nkind
(Choice
) = N_Subtype_Indication
then
9463 C
: constant Node_Id
:= Constraint
(Choice
);
9464 R
: constant Node_Id
:= Range_Expression
(C
);
9468 Val
>= Expr_Value
(Low_Bound
(R
))
9470 Val
<= Expr_Value
(High_Bound
(R
));
9473 -- Choice is a simple expression
9476 exit Search
when Val
= Expr_Value
(Choice
);
9484 pragma Assert
(Present
(Alt
));
9487 -- The above loop *must* terminate by finding a match, since we know the
9488 -- case statement is valid, and the value of the expression is known at
9489 -- compile time. When we fall out of the loop, Alt points to the
9490 -- alternative that we know will be selected at run time.
9493 end Find_Static_Alternative
;
9499 function First_Actual
(Node
: Node_Id
) return Node_Id
is
9503 if No
(Parameter_Associations
(Node
)) then
9507 N
:= First
(Parameter_Associations
(Node
));
9509 if Nkind
(N
) = N_Parameter_Association
then
9510 return First_Named_Actual
(Node
);
9520 function First_Global
9522 Global_Mode
: Name_Id
;
9523 Refined
: Boolean := False) return Node_Id
9525 function First_From_Global_List
9527 Global_Mode
: Name_Id
:= Name_Input
) return Entity_Id
;
9528 -- Get the first item with suitable mode from List
9530 ----------------------------
9531 -- First_From_Global_List --
9532 ----------------------------
9534 function First_From_Global_List
9536 Global_Mode
: Name_Id
:= Name_Input
) return Entity_Id
9541 -- Empty list (no global items)
9543 if Nkind
(List
) = N_Null
then
9546 -- Single global item declaration (only input items)
9548 elsif Nkind
(List
) in N_Expanded_Name | N_Identifier
then
9549 if Global_Mode
= Name_Input
then
9555 -- Simple global list (only input items) or moded global list
9558 elsif Nkind
(List
) = N_Aggregate
then
9559 if Present
(Expressions
(List
)) then
9560 if Global_Mode
= Name_Input
then
9561 return First
(Expressions
(List
));
9567 Assoc
:= First
(Component_Associations
(List
));
9568 while Present
(Assoc
) loop
9570 -- When we find the desired mode in an association, call
9571 -- recursively First_From_Global_List as if the mode was
9572 -- Name_Input, in order to reuse the existing machinery
9573 -- for the other cases.
9575 if Chars
(First
(Choices
(Assoc
))) = Global_Mode
then
9576 return First_From_Global_List
(Expression
(Assoc
));
9585 -- To accommodate partial decoration of disabled SPARK features,
9586 -- this routine may be called with illegal input. If this is the
9587 -- case, do not raise Program_Error.
9592 end First_From_Global_List
;
9596 Global
: Node_Id
:= Empty
;
9597 Body_Id
: Entity_Id
;
9599 -- Start of processing for First_Global
9602 pragma Assert
(Global_Mode
in Name_In_Out
9607 -- Retrieve the suitable pragma Global or Refined_Global. In the second
9608 -- case, it can only be located on the body entity.
9611 if Is_Subprogram_Or_Generic_Subprogram
(Subp
) then
9612 Body_Id
:= Subprogram_Body_Entity
(Subp
);
9614 elsif Is_Entry
(Subp
) or else Is_Task_Type
(Subp
) then
9615 Body_Id
:= Corresponding_Body
(Parent
(Subp
));
9617 -- ??? It should be possible to retrieve the Refined_Global on the
9618 -- task body associated to the task object. This is not yet possible.
9620 elsif Is_Single_Task_Object
(Subp
) then
9627 if Present
(Body_Id
) then
9628 Global
:= Get_Pragma
(Body_Id
, Pragma_Refined_Global
);
9631 Global
:= Get_Pragma
(Subp
, Pragma_Global
);
9634 -- No corresponding global if pragma is not present
9639 -- Otherwise retrieve the corresponding list of items depending on the
9643 return First_From_Global_List
9644 (Expression
(Get_Argument
(Global
, Subp
)), Global_Mode
);
9652 function Fix_Msg
(Id
: Entity_Id
; Msg
: String) return String is
9653 Is_Task
: constant Boolean :=
9654 Ekind
(Id
) in E_Task_Body | E_Task_Type
9655 or else Is_Single_Task_Object
(Id
);
9656 Msg_Last
: constant Natural := Msg
'Last;
9657 Msg_Index
: Natural;
9658 Res
: String (Msg
'Range) := (others => ' ');
9659 Res_Index
: Natural;
9662 -- Copy all characters from the input message Msg to result Res with
9663 -- suitable replacements.
9665 Msg_Index
:= Msg
'First;
9666 Res_Index
:= Res
'First;
9667 while Msg_Index
<= Msg_Last
loop
9669 -- Replace "subprogram" with a different word
9671 if Msg_Index
<= Msg_Last
- 10
9672 and then Msg
(Msg_Index
.. Msg_Index
+ 9) = "subprogram"
9674 if Is_Entry
(Id
) then
9675 Res
(Res_Index
.. Res_Index
+ 4) := "entry";
9676 Res_Index
:= Res_Index
+ 5;
9679 Res
(Res_Index
.. Res_Index
+ 8) := "task type";
9680 Res_Index
:= Res_Index
+ 9;
9683 Res
(Res_Index
.. Res_Index
+ 9) := "subprogram";
9684 Res_Index
:= Res_Index
+ 10;
9687 Msg_Index
:= Msg_Index
+ 10;
9689 -- Replace "protected" with a different word
9691 elsif Msg_Index
<= Msg_Last
- 9
9692 and then Msg
(Msg_Index
.. Msg_Index
+ 8) = "protected"
9695 Res
(Res_Index
.. Res_Index
+ 3) := "task";
9696 Res_Index
:= Res_Index
+ 4;
9697 Msg_Index
:= Msg_Index
+ 9;
9699 -- Otherwise copy the character
9702 Res
(Res_Index
) := Msg
(Msg_Index
);
9703 Msg_Index
:= Msg_Index
+ 1;
9704 Res_Index
:= Res_Index
+ 1;
9708 return Res
(Res
'First .. Res_Index
- 1);
9711 -------------------------
9712 -- From_Nested_Package --
9713 -------------------------
9715 function From_Nested_Package
(T
: Entity_Id
) return Boolean is
9716 Pack
: constant Entity_Id
:= Scope
(T
);
9720 Ekind
(Pack
) = E_Package
9721 and then not Is_Frozen
(Pack
)
9722 and then not Scope_Within_Or_Same
(Current_Scope
, Pack
)
9723 and then In_Open_Scopes
(Scope
(Pack
));
9724 end From_Nested_Package
;
9726 -----------------------
9727 -- Gather_Components --
9728 -----------------------
9730 procedure Gather_Components
9732 Comp_List
: Node_Id
;
9733 Governed_By
: List_Id
;
9735 Report_Errors
: out Boolean;
9736 Allow_Compile_Time
: Boolean := False;
9737 Include_Interface_Tag
: Boolean := False)
9741 Discrete_Choice
: Node_Id
;
9742 Comp_Item
: Node_Id
;
9743 Discrim
: Entity_Id
;
9744 Discrim_Name
: Node_Id
;
9746 type Discriminant_Value_Status
is
9747 (Static_Expr
, Static_Subtype
, Bad
);
9748 subtype Good_Discrim_Value_Status
is Discriminant_Value_Status
9749 range Static_Expr
.. Static_Subtype
; -- range excludes Bad
9751 Discrim_Value
: Node_Id
;
9752 Discrim_Value_Subtype
: Node_Id
;
9753 Discrim_Value_Status
: Discriminant_Value_Status
:= Bad
;
9755 function OK_Scope_For_Discrim_Value_Error_Messages
return Boolean is
9756 (Scope
(Original_Record_Component
9757 (Entity
(First
(Choices
(Assoc
))))) = Typ
);
9758 -- Used to avoid generating error messages having a source position
9759 -- which refers to somewhere (e.g., a discriminant value in a derived
9760 -- tagged type declaration) unrelated to the offending construct. This
9761 -- is required for correctness - clients of Gather_Components such as
9762 -- Sem_Ch3.Create_Constrained_Components depend on this function
9763 -- returning True while processing semantically correct examples;
9764 -- generating an error message in this case would be wrong.
9767 Report_Errors
:= False;
9769 if No
(Comp_List
) or else Null_Present
(Comp_List
) then
9773 Comp_Item
:= First
(Component_Items
(Comp_List
));
9774 while Present
(Comp_Item
) loop
9776 -- Skip the tag of a tagged record, as well as all items that are not
9777 -- user components (anonymous types, rep clauses, Parent field,
9778 -- controller field).
9780 if Nkind
(Comp_Item
) = N_Component_Declaration
then
9782 Comp
: constant Entity_Id
:= Defining_Identifier
(Comp_Item
);
9784 if not (Is_Tag
(Comp
)
9786 (Include_Interface_Tag
9787 and then Etype
(Comp
) = RTE
(RE_Interface_Tag
)))
9788 and then Chars
(Comp
) /= Name_uParent
9790 Append_Elmt
(Comp
, Into
);
9798 if No
(Variant_Part
(Comp_List
)) then
9801 Discrim_Name
:= Name
(Variant_Part
(Comp_List
));
9802 Variant
:= First_Non_Pragma
(Variants
(Variant_Part
(Comp_List
)));
9805 -- Look for the discriminant that governs this variant part.
9806 -- The discriminant *must* be in the Governed_By List
9808 Assoc
:= First
(Governed_By
);
9809 Find_Constraint
: loop
9810 Discrim
:= First
(Choices
(Assoc
));
9811 pragma Assert
(No
(Next
(Discrim
)));
9813 exit Find_Constraint
when
9814 Chars
(Discrim_Name
) = Chars
(Discrim
)
9816 (Present
(Corresponding_Discriminant
(Entity
(Discrim
)))
9817 and then Chars
(Corresponding_Discriminant
9818 (Entity
(Discrim
))) = Chars
(Discrim_Name
))
9820 Chars
(Original_Record_Component
(Entity
(Discrim
))) =
9821 Chars
(Discrim_Name
);
9823 if No
(Next
(Assoc
)) then
9824 if not Is_Constrained
(Typ
) and then Is_Derived_Type
(Typ
) then
9826 -- If the type is a tagged type with inherited discriminants,
9827 -- use the stored constraint on the parent in order to find
9828 -- the values of discriminants that are otherwise hidden by an
9829 -- explicit constraint. Renamed discriminants are handled in
9832 -- If several parent discriminants are renamed by a single
9833 -- discriminant of the derived type, the call to obtain the
9834 -- Corresponding_Discriminant field only retrieves the last
9835 -- of them. We recover the constraint on the others from the
9836 -- Stored_Constraint as well.
9838 -- An inherited discriminant may have been constrained in a
9839 -- later ancestor (not the immediate parent) so we must examine
9840 -- the stored constraint of all of them to locate the inherited
9846 T
: Entity_Id
:= Typ
;
9849 while Is_Derived_Type
(T
) loop
9850 if Present
(Stored_Constraint
(T
)) then
9851 D
:= First_Discriminant
(Etype
(T
));
9852 C
:= First_Elmt
(Stored_Constraint
(T
));
9853 while Present
(D
) and then Present
(C
) loop
9854 if Chars
(Discrim_Name
) = Chars
(D
) then
9855 if Is_Entity_Name
(Node
(C
))
9856 and then Entity
(Node
(C
)) = Entity
(Discrim
)
9858 -- D is renamed by Discrim, whose value is
9865 Make_Component_Association
(Sloc
(Typ
),
9867 (New_Occurrence_Of
(D
, Sloc
(Typ
))),
9868 Duplicate_Subexpr_No_Checks
(Node
(C
)));
9871 exit Find_Constraint
;
9874 Next_Discriminant
(D
);
9879 -- Discriminant may be inherited from ancestor
9891 ("missing value for discriminant&",
9892 First
(Governed_By
), Discrim_Name
);
9894 Report_Errors
:= True;
9897 end loop Find_Constraint
;
9899 Discrim_Value
:= Expression
(Assoc
);
9901 if Is_OK_Static_Expression
(Discrim_Value
)
9902 or else (Allow_Compile_Time
9903 and then Compile_Time_Known_Value
(Discrim_Value
))
9905 Discrim_Value_Status
:= Static_Expr
;
9907 if Ada_Version
>= Ada_2022
then
9908 if Is_Rewrite_Substitution
(Discrim_Value
)
9909 and then Nkind
(Discrim_Value
) = N_Type_Conversion
9910 and then Etype
(Original_Node
(Discrim_Value
))
9911 = Etype
(Expression
(Discrim_Value
))
9913 Discrim_Value_Subtype
:= Etype
(Original_Node
(Discrim_Value
));
9914 -- An unhelpful (for this code) type conversion may be
9915 -- introduced in some cases; deal with it.
9917 Discrim_Value_Subtype
:= Etype
(Discrim_Value
);
9920 if Is_OK_Static_Subtype
(Discrim_Value_Subtype
) and then
9921 not Is_Null_Range
(Type_Low_Bound
(Discrim_Value_Subtype
),
9922 Type_High_Bound
(Discrim_Value_Subtype
))
9924 -- Is_Null_Range test doesn't account for predicates, as in
9925 -- subtype Null_By_Predicate is Natural
9926 -- with Static_Predicate => Null_By_Predicate < 0;
9927 -- so test for that null case separately.
9929 if not Has_Static_Predicate
(Discrim_Value_Subtype
)
9930 or else Present
(First
(Static_Discrete_Predicate
9931 (Discrim_Value_Subtype
)))
9933 Discrim_Value_Status
:= Static_Subtype
;
9938 if Discrim_Value_Status
= Bad
then
9940 -- If the variant part is governed by a discriminant of the type
9941 -- this is an error. If the variant part and the discriminant are
9942 -- inherited from an ancestor this is legal (AI05-220) unless the
9943 -- components are being gathered for an aggregate, in which case
9944 -- the caller must check Report_Errors.
9946 -- In Ada 2022 the above rules are relaxed. A nonstatic governing
9947 -- discriminant is OK as long as it has a static subtype and
9948 -- every value of that subtype (and there must be at least one)
9949 -- selects the same variant.
9951 if OK_Scope_For_Discrim_Value_Error_Messages
then
9952 if Ada_Version
>= Ada_2022
then
9954 ("value for discriminant & must be static or " &
9955 "discriminant's nominal subtype must be static " &
9957 Discrim_Value
, Discrim
);
9960 ("value for discriminant & must be static!",
9961 Discrim_Value
, Discrim
);
9963 Why_Not_Static
(Discrim_Value
);
9966 Report_Errors
:= True;
9971 Search_For_Discriminant_Value
: declare
9977 UI_Discrim_Value
: Uint
;
9980 case Good_Discrim_Value_Status
'(Discrim_Value_Status) is
9982 UI_Discrim_Value := Expr_Value (Discrim_Value);
9983 when Static_Subtype =>
9984 -- Arbitrarily pick one value of the subtype and look
9985 -- for the variant associated with that value; we will
9986 -- check later that the same variant is associated with
9987 -- all of the other values of the subtype.
9988 if Has_Static_Predicate (Discrim_Value_Subtype) then
9990 Range_Or_Expr : constant Node_Id :=
9991 First (Static_Discrete_Predicate
9992 (Discrim_Value_Subtype));
9994 if Nkind (Range_Or_Expr) = N_Range then
9996 Expr_Value (Low_Bound (Range_Or_Expr));
9998 UI_Discrim_Value := Expr_Value (Range_Or_Expr);
10003 := Expr_Value (Type_Low_Bound (Discrim_Value_Subtype));
10007 Find_Discrete_Value : while Present (Variant) loop
10009 -- If a choice is a subtype with a static predicate, it must
10010 -- be rewritten as an explicit list of non-predicated choices.
10012 Expand_Static_Predicates_In_Choices (Variant);
10014 Discrete_Choice := First (Discrete_Choices (Variant));
10015 while Present (Discrete_Choice) loop
10016 exit Find_Discrete_Value when
10017 Nkind (Discrete_Choice) = N_Others_Choice;
10019 Get_Index_Bounds (Discrete_Choice, Low, High);
10021 UI_Low := Expr_Value (Low);
10022 UI_High := Expr_Value (High);
10024 exit Find_Discrete_Value when
10025 UI_Low <= UI_Discrim_Value
10027 UI_High >= UI_Discrim_Value;
10029 Next (Discrete_Choice);
10032 Next_Non_Pragma (Variant);
10033 end loop Find_Discrete_Value;
10034 end Search_For_Discriminant_Value;
10036 -- The case statement must include a variant that corresponds to the
10037 -- value of the discriminant, unless the discriminant type has a
10038 -- static predicate. In that case the absence of an others_choice that
10039 -- would cover this value becomes a run-time error (3.8.1 (21.1/2)).
10042 and then not Has_Static_Predicate (Etype (Discrim_Name))
10045 ("value of discriminant & is out of range", Discrim_Value, Discrim);
10046 Report_Errors := True;
10050 -- If we have found the corresponding choice, recursively add its
10051 -- components to the Into list. The nested components are part of
10052 -- the same record type.
10054 if Present (Variant) then
10055 if Discrim_Value_Status = Static_Subtype then
10057 Discrim_Value_Subtype_Intervals
10058 : constant Interval_Lists.Discrete_Interval_List
10059 := Interval_Lists.Type_Intervals (Discrim_Value_Subtype);
10062 : constant Interval_Lists.Discrete_Interval_List
10063 := Interval_Lists.Choice_List_Intervals
10064 (Discrete_Choices => Discrete_Choices (Variant));
10066 if not Interval_Lists.Is_Subset
10067 (Subset => Discrim_Value_Subtype_Intervals,
10068 Of_Set => Variant_Intervals)
10070 if OK_Scope_For_Discrim_Value_Error_Messages then
10072 ("no single variant is associated with all values of " &
10073 "the subtype of discriminant value &",
10074 Discrim_Value, Discrim);
10076 Report_Errors := True;
10083 (Typ, Component_List (Variant), Governed_By, Into,
10084 Report_Errors, Allow_Compile_Time);
10086 end Gather_Components;
10088 ------------------------
10089 -- Get_Actual_Subtype --
10090 ------------------------
10092 function Get_Actual_Subtype (N : Node_Id) return Entity_Id is
10093 Typ : constant Entity_Id := Etype (N);
10094 Utyp : Entity_Id := Underlying_Type (Typ);
10103 -- If what we have is an identifier that references a subprogram
10104 -- formal, or a variable or constant object, then we get the actual
10105 -- subtype from the referenced entity if one has been built.
10107 if Nkind (N) = N_Identifier
10109 (Is_Formal (Entity (N))
10110 or else Ekind (Entity (N)) = E_Constant
10111 or else Ekind (Entity (N)) = E_Variable)
10112 and then Present (Actual_Subtype (Entity (N)))
10114 return Actual_Subtype (Entity (N));
10116 -- Similarly, if we have an explicit dereference, then we get the
10117 -- actual subtype from the node itself if one has been built.
10119 elsif Nkind (N) = N_Explicit_Dereference
10120 and then Present (Actual_Designated_Subtype (N))
10122 return Actual_Designated_Subtype (N);
10124 -- Actual subtype of unchecked union is always itself. We never need
10125 -- the "real" actual subtype. If we did, we couldn't get it anyway
10126 -- because the discriminant is not available. The restrictions on
10127 -- Unchecked_Union are designed to make sure that this is OK.
10129 elsif Is_Unchecked_Union (Base_Type (Utyp)) then
10132 -- Here for the unconstrained case, we must find actual subtype
10133 -- No actual subtype is available, so we must build it on the fly.
10135 -- Checking the type, not the underlying type, for constrainedness
10136 -- seems to be necessary. Maybe all the tests should be on the type???
10138 elsif not Is_Constrained (Typ)
10139 and then (Is_Array_Type (Utyp)
10140 or else (Is_Record_Type (Utyp)
10141 and then Has_Discriminants (Utyp)))
10142 and then not Has_Unknown_Discriminants (Utyp)
10143 and then not (Ekind (Utyp) = E_String_Literal_Subtype)
10145 -- Nothing to do if in spec expression (why not???)
10147 if In_Spec_Expression then
10150 elsif Is_Private_Type (Typ) and then not Has_Discriminants (Typ) then
10152 -- If the type has no discriminants, there is no subtype to
10153 -- build, even if the underlying type is discriminated.
10157 -- Else build the actual subtype
10160 Decl := Build_Actual_Subtype (Typ, N);
10162 -- The call may yield a declaration, or just return the entity
10168 Atyp := Defining_Identifier (Decl);
10170 -- If Build_Actual_Subtype generated a new declaration then use it
10172 if Atyp /= Typ then
10174 -- The actual subtype is an Itype, so analyze the declaration,
10175 -- but do not attach it to the tree, to get the type defined.
10177 Set_Parent (Decl, N);
10178 Set_Is_Itype (Atyp);
10179 Analyze (Decl, Suppress => All_Checks);
10180 Set_Associated_Node_For_Itype (Atyp, N);
10181 if Expander_Active then
10182 Set_Has_Delayed_Freeze (Atyp, False);
10184 -- We need to freeze the actual subtype immediately. This is
10185 -- needed because otherwise this Itype will not get frozen
10186 -- at all; it is always safe to freeze on creation because
10187 -- any associated types must be frozen at this point.
10189 -- On the other hand, if we are performing preanalysis on
10190 -- a conjured-up copy of a name (see calls to
10191 -- Preanalyze_Range in sem_ch5.adb) then we don't want
10192 -- to freeze Atyp, now or ever. In this case, the tree
10193 -- we eventually pass to the back end should contain no
10194 -- references to Atyp (and a freeze node would contain
10195 -- such a reference). That's why Expander_Active is tested.
10197 Freeze_Itype (Atyp, N);
10201 -- Otherwise we did not build a declaration, so return original
10208 -- For all remaining cases, the actual subtype is the same as
10209 -- the nominal type.
10214 end Get_Actual_Subtype;
10216 -------------------------------------
10217 -- Get_Actual_Subtype_If_Available --
10218 -------------------------------------
10220 function Get_Actual_Subtype_If_Available (N : Node_Id) return Entity_Id is
10221 Typ : constant Entity_Id := Etype (N);
10224 -- If what we have is an identifier that references a subprogram
10225 -- formal, or a variable or constant object, then we get the actual
10226 -- subtype from the referenced entity if one has been built.
10228 if Nkind (N) = N_Identifier
10230 (Is_Formal (Entity (N))
10231 or else Ekind (Entity (N)) = E_Constant
10232 or else Ekind (Entity (N)) = E_Variable)
10233 and then Present (Actual_Subtype (Entity (N)))
10235 return Actual_Subtype (Entity (N));
10237 -- Similarly, if we have an explicit dereference, then we get the
10238 -- actual subtype from the node itself if one has been built.
10240 elsif Nkind (N) = N_Explicit_Dereference
10241 and then Present (Actual_Designated_Subtype (N))
10243 return Actual_Designated_Subtype (N);
10245 -- Otherwise the Etype of N is returned unchanged
10250 end Get_Actual_Subtype_If_Available;
10252 ------------------------
10253 -- Get_Body_From_Stub --
10254 ------------------------
10256 function Get_Body_From_Stub (N : Node_Id) return Node_Id is
10258 return Proper_Body (Unit (Library_Unit (N)));
10259 end Get_Body_From_Stub;
10261 ---------------------
10262 -- Get_Cursor_Type --
10263 ---------------------
10265 function Get_Cursor_Type
10267 Typ : Entity_Id) return Entity_Id
10271 First_Op : Entity_Id;
10272 Cursor : Entity_Id;
10275 -- If error already detected, return
10277 if Error_Posted (Aspect) then
10281 -- The cursor type for an Iterable aspect is the return type of a
10282 -- non-overloaded First primitive operation. Locate association for
10285 Assoc := First (Component_Associations (Expression (Aspect)));
10286 First_Op := Any_Id;
10287 while Present (Assoc) loop
10288 if Chars (First (Choices (Assoc))) = Name_First then
10289 First_Op := Expression (Assoc);
10296 if First_Op = Any_Id then
10297 Error_Msg_N ("aspect Iterable must specify First operation", Aspect);
10300 elsif not Analyzed (First_Op) then
10301 Analyze (First_Op);
10304 Cursor := Any_Type;
10306 -- Locate function with desired name and profile in scope of type
10307 -- In the rare case where the type is an integer type, a base type
10308 -- is created for it, check that the base type of the first formal
10309 -- of First matches the base type of the domain.
10311 Func := First_Entity (Scope (Typ));
10312 while Present (Func) loop
10313 if Chars (Func) = Chars (First_Op)
10314 and then Ekind (Func) = E_Function
10315 and then Present (First_Formal (Func))
10316 and then Base_Type (Etype (First_Formal (Func))) = Base_Type (Typ)
10317 and then No (Next_Formal (First_Formal (Func)))
10319 if Cursor /= Any_Type then
10321 ("operation First for iterable type must be unique", Aspect);
10324 Cursor := Etype (Func);
10328 Next_Entity (Func);
10331 -- If not found, no way to resolve remaining primitives
10333 if Cursor = Any_Type then
10335 ("primitive operation for Iterable type must appear in the same "
10336 & "list of declarations as the type", Aspect);
10340 end Get_Cursor_Type;
10342 function Get_Cursor_Type (Typ : Entity_Id) return Entity_Id is
10344 return Etype (Get_Iterable_Type_Primitive (Typ, Name_First));
10345 end Get_Cursor_Type;
10347 -------------------------------
10348 -- Get_Default_External_Name --
10349 -------------------------------
10351 function Get_Default_External_Name (E : Node_Or_Entity_Id) return Node_Id is
10353 Get_Decoded_Name_String (Chars (E));
10355 if Opt.External_Name_Imp_Casing = Uppercase then
10356 Set_Casing (All_Upper_Case);
10358 Set_Casing (All_Lower_Case);
10362 Make_String_Literal (Sloc (E),
10363 Strval => String_From_Name_Buffer);
10364 end Get_Default_External_Name;
10366 --------------------------
10367 -- Get_Enclosing_Object --
10368 --------------------------
10370 function Get_Enclosing_Object (N : Node_Id) return Entity_Id is
10372 if Is_Entity_Name (N) then
10376 when N_Indexed_Component
10377 | N_Selected_Component
10380 -- If not generating code, a dereference may be left implicit.
10381 -- In thoses cases, return Empty.
10383 if Is_Access_Type (Etype (Prefix (N))) then
10386 return Get_Enclosing_Object (Prefix (N));
10389 when N_Type_Conversion =>
10390 return Get_Enclosing_Object (Expression (N));
10396 end Get_Enclosing_Object;
10398 -------------------------------
10399 -- Get_Enclosing_Deep_Object --
10400 -------------------------------
10402 function Get_Enclosing_Deep_Object (N : Node_Id) return Entity_Id is
10404 if Is_Entity_Name (N) then
10408 when N_Explicit_Dereference
10409 | N_Indexed_Component
10410 | N_Selected_Component
10413 return Get_Enclosing_Deep_Object (Prefix (N));
10415 when N_Type_Conversion =>
10416 return Get_Enclosing_Deep_Object (Expression (N));
10422 end Get_Enclosing_Deep_Object;
10424 ---------------------------
10425 -- Get_Enum_Lit_From_Pos --
10426 ---------------------------
10428 function Get_Enum_Lit_From_Pos
10431 Loc : Source_Ptr) return Node_Id
10433 Btyp : Entity_Id := Base_Type (T);
10438 -- In the case where the literal is of type Character, Wide_Character
10439 -- or Wide_Wide_Character or of a type derived from them, there needs
10440 -- to be some special handling since there is no explicit chain of
10441 -- literals to search. Instead, an N_Character_Literal node is created
10442 -- with the appropriate Char_Code and Chars fields.
10444 if Is_Standard_Character_Type (T) then
10445 Set_Character_Literal_Name (UI_To_CC (Pos));
10448 Make_Character_Literal (Loc,
10449 Chars => Name_Find,
10450 Char_Literal_Value => Pos);
10452 -- For all other cases, we have a complete table of literals, and
10453 -- we simply iterate through the chain of literal until the one
10454 -- with the desired position value is found.
10457 if Is_Private_Type (Btyp) and then Present (Full_View (Btyp)) then
10458 Btyp := Full_View (Btyp);
10461 Lit := First_Literal (Btyp);
10463 -- Position in the enumeration type starts at 0
10466 raise Constraint_Error;
10469 for J in 1 .. UI_To_Int (Pos) loop
10470 Next_Literal (Lit);
10472 -- If Lit is Empty, Pos is not in range, so raise Constraint_Error
10473 -- inside the loop to avoid calling Next_Literal on Empty.
10476 raise Constraint_Error;
10480 -- Create a new node from Lit, with source location provided by Loc
10481 -- if not equal to No_Location, or by copying the source location of
10486 if LLoc = No_Location then
10487 LLoc := Sloc (Lit);
10490 return New_Occurrence_Of (Lit, LLoc);
10492 end Get_Enum_Lit_From_Pos;
10494 ----------------------
10495 -- Get_Fullest_View --
10496 ----------------------
10498 function Get_Fullest_View
10500 Include_PAT : Boolean := True;
10501 Recurse : Boolean := True) return Entity_Id
10503 New_E : Entity_Id := Empty;
10506 -- Prevent cascaded errors
10512 -- Look at each kind of entity to see where we may need to go deeper.
10515 when Incomplete_Kind =>
10516 if From_Limited_With (E) then
10517 New_E := Non_Limited_View (E);
10518 elsif Present (Full_View (E)) then
10519 New_E := Full_View (E);
10520 elsif Ekind (E) = E_Incomplete_Subtype then
10521 New_E := Etype (E);
10524 when Private_Kind =>
10525 if Present (Underlying_Full_View (E)) then
10526 New_E := Underlying_Full_View (E);
10527 elsif Present (Full_View (E)) then
10528 New_E := Full_View (E);
10529 elsif Etype (E) /= E then
10530 New_E := Etype (E);
10534 if Include_PAT and then Present (Packed_Array_Impl_Type (E)) then
10535 New_E := Packed_Array_Impl_Type (E);
10538 when E_Record_Subtype =>
10539 if Present (Cloned_Subtype (E)) then
10540 New_E := Cloned_Subtype (E);
10543 when E_Class_Wide_Type =>
10544 New_E := Root_Type (E);
10546 when E_Class_Wide_Subtype =>
10547 if Present (Equivalent_Type (E)) then
10548 New_E := Equivalent_Type (E);
10549 elsif Present (Cloned_Subtype (E)) then
10550 New_E := Cloned_Subtype (E);
10553 when E_Protected_Subtype
10558 if Present (Corresponding_Record_Type (E)) then
10559 New_E := Corresponding_Record_Type (E);
10562 when E_Access_Protected_Subprogram_Type
10563 | E_Anonymous_Access_Protected_Subprogram_Type
10565 if Present (Equivalent_Type (E)) then
10566 New_E := Equivalent_Type (E);
10569 when E_Access_Subtype =>
10570 New_E := Base_Type (E);
10576 -- If we found a fuller view, either return it or recurse. Otherwise,
10577 -- return our input.
10579 return (if No (New_E) then E
10580 elsif Recurse then Get_Fullest_View (New_E, Include_PAT, Recurse)
10582 end Get_Fullest_View;
10584 ------------------------
10585 -- Get_Generic_Entity --
10586 ------------------------
10588 function Get_Generic_Entity (N : Node_Id) return Entity_Id is
10589 Ent : constant Entity_Id := Entity (Name (N));
10591 if Present (Renamed_Entity (Ent)) then
10592 return Renamed_Entity (Ent);
10596 end Get_Generic_Entity;
10598 -------------------------------------
10599 -- Get_Incomplete_View_Of_Ancestor --
10600 -------------------------------------
10602 function Get_Incomplete_View_Of_Ancestor (E : Entity_Id) return Entity_Id is
10603 Cur_Unit : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
10604 Par_Scope : Entity_Id;
10605 Par_Type : Entity_Id;
10608 -- The incomplete view of an ancestor is only relevant for private
10609 -- derived types in child units.
10611 if not Is_Derived_Type (E)
10612 or else not Is_Child_Unit (Cur_Unit)
10617 Par_Scope := Scope (Cur_Unit);
10618 if No (Par_Scope) then
10622 Par_Type := Etype (Base_Type (E));
10624 -- Traverse list of ancestor types until we find one declared in
10625 -- a parent or grandparent unit (two levels seem sufficient).
10627 while Present (Par_Type) loop
10628 if Scope (Par_Type) = Par_Scope
10629 or else Scope (Par_Type) = Scope (Par_Scope)
10633 elsif not Is_Derived_Type (Par_Type) then
10637 Par_Type := Etype (Base_Type (Par_Type));
10641 -- If none found, there is no relevant ancestor type.
10645 end Get_Incomplete_View_Of_Ancestor;
10647 ----------------------
10648 -- Get_Index_Bounds --
10649 ----------------------
10651 procedure Get_Index_Bounds
10655 Use_Full_View : Boolean := False)
10657 function Scalar_Range_Of_Type (Typ : Entity_Id) return Node_Id;
10658 -- Obtain the scalar range of type Typ. If flag Use_Full_View is set and
10659 -- Typ qualifies, the scalar range is obtained from the full view of the
10662 --------------------------
10663 -- Scalar_Range_Of_Type --
10664 --------------------------
10666 function Scalar_Range_Of_Type (Typ : Entity_Id) return Node_Id is
10667 T : Entity_Id := Typ;
10670 if Use_Full_View and then Present (Full_View (T)) then
10671 T := Full_View (T);
10674 return Scalar_Range (T);
10675 end Scalar_Range_Of_Type;
10679 Kind : constant Node_Kind := Nkind (N);
10682 -- Start of processing for Get_Index_Bounds
10685 if Kind = N_Range then
10686 L := Low_Bound (N);
10687 H := High_Bound (N);
10689 elsif Kind = N_Subtype_Indication then
10690 Rng := Range_Expression (Constraint (N));
10692 if Rng = Error then
10698 L := Low_Bound (Range_Expression (Constraint (N)));
10699 H := High_Bound (Range_Expression (Constraint (N)));
10702 elsif Is_Entity_Name (N) and then Is_Type (Entity (N)) then
10703 Rng := Scalar_Range_Of_Type (Entity (N));
10705 if Error_Posted (Rng) then
10709 elsif Nkind (Rng) = N_Subtype_Indication then
10710 Get_Index_Bounds (Rng, L, H);
10713 L := Low_Bound (Rng);
10714 H := High_Bound (Rng);
10718 -- N is an expression, indicating a range with one value
10723 end Get_Index_Bounds;
10725 function Get_Index_Bounds
10727 Use_Full_View : Boolean := False) return Range_Nodes is
10728 Result : Range_Nodes;
10730 Get_Index_Bounds (N, Result.First, Result.Last, Use_Full_View);
10732 end Get_Index_Bounds;
10734 function Get_Index_Bounds
10736 Use_Full_View : Boolean := False) return Range_Values is
10737 Nodes : constant Range_Nodes := Get_Index_Bounds (N, Use_Full_View);
10739 return (Expr_Value (Nodes.First), Expr_Value (Nodes.Last));
10740 end Get_Index_Bounds;
10742 -----------------------------
10743 -- Get_Interfacing_Aspects --
10744 -----------------------------
10746 procedure Get_Interfacing_Aspects
10747 (Iface_Asp : Node_Id;
10748 Conv_Asp : out Node_Id;
10749 EN_Asp : out Node_Id;
10750 Expo_Asp : out Node_Id;
10751 Imp_Asp : out Node_Id;
10752 LN_Asp : out Node_Id;
10753 Do_Checks : Boolean := False)
10755 procedure Save_Or_Duplication_Error
10757 To : in out Node_Id);
10758 -- Save the value of aspect Asp in node To. If To already has a value,
10759 -- then this is considered a duplicate use of aspect. Emit an error if
10760 -- flag Do_Checks is set.
10762 -------------------------------
10763 -- Save_Or_Duplication_Error --
10764 -------------------------------
10766 procedure Save_Or_Duplication_Error
10768 To : in out Node_Id)
10771 -- Detect an extra aspect and issue an error
10773 if Present (To) then
10775 Error_Msg_Name_1 := Chars (Identifier (Asp));
10776 Error_Msg_Sloc := Sloc (To);
10777 Error_Msg_N ("aspect % previously given #", Asp);
10780 -- Otherwise capture the aspect
10785 end Save_Or_Duplication_Error;
10790 Asp_Id : Aspect_Id;
10792 -- The following variables capture each individual aspect
10794 Conv : Node_Id := Empty;
10795 EN : Node_Id := Empty;
10796 Expo : Node_Id := Empty;
10797 Imp : Node_Id := Empty;
10798 LN : Node_Id := Empty;
10800 -- Start of processing for Get_Interfacing_Aspects
10803 -- The input interfacing aspect should reside in an aspect specification
10806 pragma Assert (Is_List_Member (Iface_Asp));
10808 -- Examine the aspect specifications of the related entity. Find and
10809 -- capture all interfacing aspects. Detect duplicates and emit errors
10812 Asp := First (List_Containing (Iface_Asp));
10813 while Present (Asp) loop
10814 Asp_Id := Get_Aspect_Id (Asp);
10816 if Asp_Id = Aspect_Convention then
10817 Save_Or_Duplication_Error (Asp, Conv);
10819 elsif Asp_Id = Aspect_External_Name then
10820 Save_Or_Duplication_Error (Asp, EN);
10822 elsif Asp_Id = Aspect_Export then
10823 Save_Or_Duplication_Error (Asp, Expo);
10825 elsif Asp_Id = Aspect_Import then
10826 Save_Or_Duplication_Error (Asp, Imp);
10828 elsif Asp_Id = Aspect_Link_Name then
10829 Save_Or_Duplication_Error (Asp, LN);
10840 end Get_Interfacing_Aspects;
10842 ---------------------------------
10843 -- Get_Iterable_Type_Primitive --
10844 ---------------------------------
10846 function Get_Iterable_Type_Primitive
10848 Nam : Name_Id) return Entity_Id
10853 Nam in Name_Element
10860 Funcs : constant Node_Id := Find_Value_Of_Aspect (Typ, Aspect_Iterable);
10868 Assoc := First (Component_Associations (Funcs));
10869 while Present (Assoc) loop
10870 if Chars (First (Choices (Assoc))) = Nam then
10871 return Entity (Expression (Assoc));
10879 end Get_Iterable_Type_Primitive;
10881 ---------------------------
10882 -- Get_Library_Unit_Name --
10883 ---------------------------
10885 function Get_Library_Unit_Name (Decl_Node : Node_Id) return String_Id is
10886 Unit_Name_Id : constant Unit_Name_Type := Get_Unit_Name (Decl_Node);
10887 Buf : Bounded_String;
10889 Get_Unit_Name_String (Buf, Unit_Name_Id);
10891 -- Remove the last seven characters (" (spec)" or " (body)")
10893 Buf.Length := Buf.Length - 7;
10894 pragma Assert (Buf.Chars (Buf.Length + 1) = ' ');
10896 return String_From_Name_Buffer (Buf);
10897 end Get_Library_Unit_Name;
10899 --------------------------
10900 -- Get_Max_Queue_Length --
10901 --------------------------
10903 function Get_Max_Queue_Length (Id : Entity_Id) return Uint is
10904 pragma Assert (Is_Entry (Id));
10905 Prag : constant Entity_Id := Get_Pragma (Id, Pragma_Max_Queue_Length);
10909 -- A value of 0 or -1 represents no maximum specified, and entries and
10910 -- entry families with no Max_Queue_Length aspect or pragma default to
10918 (Expression (First (Pragma_Argument_Associations (Prag))));
10920 -- Since -1 and 0 are equivalent, return 0 for instances of -1 for
10928 end Get_Max_Queue_Length;
10930 ------------------------
10931 -- Get_Name_Entity_Id --
10932 ------------------------
10934 function Get_Name_Entity_Id (Id : Name_Id) return Entity_Id is
10936 return Entity_Id (Get_Name_Table_Int (Id));
10937 end Get_Name_Entity_Id;
10939 ------------------------------
10940 -- Get_Name_From_CTC_Pragma --
10941 ------------------------------
10943 function Get_Name_From_CTC_Pragma (N : Node_Id) return String_Id is
10944 Arg : constant Node_Id :=
10945 Get_Pragma_Arg (First (Pragma_Argument_Associations (N)));
10947 return Strval (Expr_Value_S (Arg));
10948 end Get_Name_From_CTC_Pragma;
10950 -----------------------
10951 -- Get_Parent_Entity --
10952 -----------------------
10954 function Get_Parent_Entity (Unit : Node_Id) return Entity_Id is
10956 if Nkind (Unit) = N_Package_Body
10957 and then Nkind (Original_Node (Unit)) = N_Package_Instantiation
10959 return Defining_Entity
10960 (Specification (Instance_Spec (Original_Node (Unit))));
10961 elsif Nkind (Unit) = N_Package_Instantiation then
10962 return Defining_Entity (Specification (Instance_Spec (Unit)));
10964 return Defining_Entity (Unit);
10966 end Get_Parent_Entity;
10968 -------------------
10969 -- Get_Pragma_Id --
10970 -------------------
10972 function Get_Pragma_Id (N : Node_Id) return Pragma_Id is
10974 return Get_Pragma_Id (Pragma_Name_Unmapped (N));
10977 ------------------------
10978 -- Get_Qualified_Name --
10979 ------------------------
10981 function Get_Qualified_Name
10983 Suffix : Entity_Id := Empty) return Name_Id
10985 Suffix_Nam : Name_Id := No_Name;
10988 if Present (Suffix) then
10989 Suffix_Nam := Chars (Suffix);
10992 return Get_Qualified_Name (Chars (Id), Suffix_Nam, Scope (Id));
10993 end Get_Qualified_Name;
10995 function Get_Qualified_Name
10997 Suffix : Name_Id := No_Name;
10998 Scop : Entity_Id := Current_Scope) return Name_Id
11000 procedure Add_Scope (S : Entity_Id);
11001 -- Add the fully qualified form of scope S to the name buffer. The
11009 procedure Add_Scope (S : Entity_Id) is
11014 elsif S = Standard_Standard then
11018 Add_Scope (Scope (S));
11019 Get_Name_String_And_Append (Chars (S));
11020 Add_Str_To_Name_Buffer ("__");
11024 -- Start of processing for Get_Qualified_Name
11030 -- Append the base name after all scopes have been chained
11032 Get_Name_String_And_Append (Nam);
11034 -- Append the suffix (if present)
11036 if Suffix /= No_Name then
11037 Add_Str_To_Name_Buffer ("__");
11038 Get_Name_String_And_Append (Suffix);
11042 end Get_Qualified_Name;
11044 -----------------------
11045 -- Get_Reason_String --
11046 -----------------------
11048 procedure Get_Reason_String (N : Node_Id) is
11050 if Nkind (N) = N_String_Literal then
11051 Store_String_Chars (Strval (N));
11053 elsif Nkind (N) = N_Op_Concat then
11054 Get_Reason_String (Left_Opnd (N));
11055 Get_Reason_String (Right_Opnd (N));
11057 -- If not of required form, error
11061 ("Reason for pragma Warnings has wrong form", N);
11063 ("\must be string literal or concatenation of string literals", N);
11066 end Get_Reason_String;
11068 --------------------------------
11069 -- Get_Reference_Discriminant --
11070 --------------------------------
11072 function Get_Reference_Discriminant (Typ : Entity_Id) return Entity_Id is
11076 D := First_Discriminant (Typ);
11077 while Present (D) loop
11078 if Has_Implicit_Dereference (D) then
11081 Next_Discriminant (D);
11085 end Get_Reference_Discriminant;
11087 ---------------------------
11088 -- Get_Referenced_Object --
11089 ---------------------------
11091 function Get_Referenced_Object (N : Node_Id) return Node_Id is
11096 while Is_Entity_Name (R)
11097 and then Is_Object (Entity (R))
11098 and then Present (Renamed_Object (Entity (R)))
11100 R := Renamed_Object (Entity (R));
11104 end Get_Referenced_Object;
11106 ------------------------
11107 -- Get_Renamed_Entity --
11108 ------------------------
11110 function Get_Renamed_Entity (E : Entity_Id) return Entity_Id is
11111 R : Entity_Id := E;
11113 while Present (Renamed_Entity (R)) loop
11114 R := Renamed_Entity (R);
11118 end Get_Renamed_Entity;
11120 -----------------------
11121 -- Get_Return_Object --
11122 -----------------------
11124 function Get_Return_Object (N : Node_Id) return Entity_Id is
11128 Decl := First (Return_Object_Declarations (N));
11129 while Present (Decl) loop
11130 exit when Nkind (Decl) = N_Object_Declaration
11131 and then Is_Return_Object (Defining_Identifier (Decl));
11135 pragma Assert (Present (Decl));
11136 return Defining_Identifier (Decl);
11137 end Get_Return_Object;
11139 ---------------------------
11140 -- Get_Subprogram_Entity --
11141 ---------------------------
11143 function Get_Subprogram_Entity (Nod : Node_Id) return Entity_Id is
11145 Subp_Id : Entity_Id;
11148 if Nkind (Nod) = N_Accept_Statement then
11149 Subp := Entry_Direct_Name (Nod);
11151 elsif Nkind (Nod) = N_Slice then
11152 Subp := Prefix (Nod);
11155 Subp := Name (Nod);
11158 -- Strip the subprogram call
11161 if Nkind (Subp) in N_Explicit_Dereference
11162 | N_Indexed_Component
11163 | N_Selected_Component
11165 Subp := Prefix (Subp);
11167 elsif Nkind (Subp) in N_Type_Conversion
11168 | N_Unchecked_Type_Conversion
11170 Subp := Expression (Subp);
11177 -- Extract the entity of the subprogram call
11179 if Is_Entity_Name (Subp) then
11180 Subp_Id := Entity (Subp);
11182 if Ekind (Subp_Id) = E_Access_Subprogram_Type then
11183 Subp_Id := Directly_Designated_Type (Subp_Id);
11186 if Is_Subprogram (Subp_Id) then
11192 -- The search did not find a construct that denotes a subprogram
11197 end Get_Subprogram_Entity;
11199 -----------------------------
11200 -- Get_Task_Body_Procedure --
11201 -----------------------------
11203 function Get_Task_Body_Procedure (E : Entity_Id) return Entity_Id is
11205 -- Note: A task type may be the completion of a private type with
11206 -- discriminants. When performing elaboration checks on a task
11207 -- declaration, the current view of the type may be the private one,
11208 -- and the procedure that holds the body of the task is held in its
11209 -- underlying type.
11211 -- This is an odd function, why not have Task_Body_Procedure do
11212 -- the following digging???
11214 return Task_Body_Procedure (Underlying_Type (Root_Type (E)));
11215 end Get_Task_Body_Procedure;
11217 -------------------------------
11218 -- Get_User_Defined_Equality --
11219 -------------------------------
11221 function Get_User_Defined_Equality (E : Entity_Id) return Entity_Id is
11225 Prim := First_Elmt (Collect_Primitive_Operations (E));
11226 while Present (Prim) loop
11227 if Is_User_Defined_Equality (Node (Prim)) then
11228 return Node (Prim);
11235 end Get_User_Defined_Equality;
11241 procedure Get_Views
11243 Priv_Typ : out Entity_Id;
11244 Full_Typ : out Entity_Id;
11245 UFull_Typ : out Entity_Id;
11246 CRec_Typ : out Entity_Id)
11248 IP_View : Entity_Id;
11251 -- Assume that none of the views can be recovered
11255 UFull_Typ := Empty;
11258 -- The input type is the corresponding record type of a protected or a
11261 if Ekind (Typ) = E_Record_Type
11262 and then Is_Concurrent_Record_Type (Typ)
11265 Full_Typ := Corresponding_Concurrent_Type (CRec_Typ);
11266 Priv_Typ := Incomplete_Or_Partial_View (Full_Typ);
11268 -- Otherwise the input type denotes an arbitrary type
11271 IP_View := Incomplete_Or_Partial_View (Typ);
11273 -- The input type denotes the full view of a private type
11275 if Present (IP_View) then
11276 Priv_Typ := IP_View;
11279 -- The input type is a private type
11281 elsif Is_Private_Type (Typ) then
11283 Full_Typ := Full_View (Priv_Typ);
11285 -- Otherwise the input type does not have any views
11291 if Present (Full_Typ) and then Is_Private_Type (Full_Typ) then
11292 UFull_Typ := Underlying_Full_View (Full_Typ);
11294 if Present (UFull_Typ)
11295 and then Ekind (UFull_Typ) in E_Protected_Type | E_Task_Type
11297 CRec_Typ := Corresponding_Record_Type (UFull_Typ);
11301 if Present (Full_Typ)
11302 and then Ekind (Full_Typ) in E_Protected_Type | E_Task_Type
11304 CRec_Typ := Corresponding_Record_Type (Full_Typ);
11310 ------------------------------
11311 -- Has_Compatible_Alignment --
11312 ------------------------------
11314 function Has_Compatible_Alignment
11317 Layout_Done : Boolean) return Alignment_Result
11319 function Has_Compatible_Alignment_Internal
11322 Layout_Done : Boolean;
11323 Default : Alignment_Result) return Alignment_Result;
11324 -- This is the internal recursive function that actually does the work.
11325 -- There is one additional parameter, which says what the result should
11326 -- be if no alignment information is found, and there is no definite
11327 -- indication of compatible alignments. At the outer level, this is set
11328 -- to Unknown, but for internal recursive calls in the case where types
11329 -- are known to be correct, it is set to Known_Compatible.
11331 ---------------------------------------
11332 -- Has_Compatible_Alignment_Internal --
11333 ---------------------------------------
11335 function Has_Compatible_Alignment_Internal
11338 Layout_Done : Boolean;
11339 Default : Alignment_Result) return Alignment_Result
11341 Result : Alignment_Result := Known_Compatible;
11342 -- Holds the current status of the result. Note that once a value of
11343 -- Known_Incompatible is set, it is sticky and does not get changed
11344 -- to Unknown (the value in Result only gets worse as we go along,
11347 Offs : Uint := No_Uint;
11348 -- Set to a factor of the offset from the base object when Expr is a
11349 -- selected or indexed component, based on Component_Bit_Offset and
11350 -- Component_Size respectively. A negative value is used to represent
11351 -- a value that is not known at compile time.
11353 procedure Check_Prefix;
11354 -- Checks the prefix recursively in the case where the expression
11355 -- is an indexed or selected component.
11357 procedure Set_Result (R : Alignment_Result);
11358 -- If R represents a worse outcome (unknown instead of known
11359 -- compatible, or known incompatible), then set Result to R.
11365 procedure Check_Prefix is
11367 -- The subtlety here is that in doing a recursive call to check
11368 -- the prefix, we have to decide what to do in the case where we
11369 -- don't find any specific indication of an alignment problem.
11371 -- At the outer level, we normally set Unknown as the result in
11372 -- this case, since we can only set Known_Compatible if we really
11373 -- know that the alignment value is OK, but for the recursive
11374 -- call, in the case where the types match, and we have not
11375 -- specified a peculiar alignment for the object, we are only
11376 -- concerned about suspicious rep clauses, the default case does
11377 -- not affect us, since the compiler will, in the absence of such
11378 -- rep clauses, ensure that the alignment is correct.
11380 if Default = Known_Compatible
11382 (Etype (Obj) = Etype (Expr)
11383 and then (not Known_Alignment (Obj)
11385 Alignment (Obj) = Alignment (Etype (Obj))))
11388 (Has_Compatible_Alignment_Internal
11389 (Obj, Prefix (Expr), Layout_Done, Known_Compatible));
11391 -- In all other cases, we need a full check on the prefix
11395 (Has_Compatible_Alignment_Internal
11396 (Obj, Prefix (Expr), Layout_Done, Unknown));
11404 procedure Set_Result (R : Alignment_Result) is
11411 -- Start of processing for Has_Compatible_Alignment_Internal
11414 -- If Expr is a selected component, we must make sure there is no
11415 -- potentially troublesome component clause and that the record is
11416 -- not packed if the layout is not done.
11418 if Nkind (Expr) = N_Selected_Component then
11420 -- Packing generates unknown alignment if layout is not done
11422 if Is_Packed (Etype (Prefix (Expr))) and then not Layout_Done then
11423 Set_Result (Unknown);
11426 -- Check prefix and component offset
11429 Offs := Component_Bit_Offset (Entity (Selector_Name (Expr)));
11431 -- If Expr is an indexed component, we must make sure there is no
11432 -- potentially troublesome Component_Size clause and that the array
11433 -- is not bit-packed if the layout is not done.
11435 elsif Nkind (Expr) = N_Indexed_Component then
11437 Typ : constant Entity_Id := Etype (Prefix (Expr));
11440 -- Packing generates unknown alignment if layout is not done
11442 if Is_Bit_Packed_Array (Typ) and then not Layout_Done then
11443 Set_Result (Unknown);
11446 -- Check prefix and component offset (or at least size)
11449 Offs := Indexed_Component_Bit_Offset (Expr);
11451 Offs := Component_Size (Typ);
11456 -- If we have a null offset, the result is entirely determined by
11457 -- the base object and has already been computed recursively.
11459 if Present (Offs) and then Offs = Uint_0 then
11462 -- Case where we know the alignment of the object
11464 elsif Known_Alignment (Obj) then
11466 ObjA : constant Uint := Alignment (Obj);
11467 ExpA : Uint := No_Uint;
11468 SizA : Uint := No_Uint;
11471 -- If alignment of Obj is 1, then we are always OK
11474 Set_Result (Known_Compatible);
11476 -- Alignment of Obj is greater than 1, so we need to check
11479 -- If we have an offset, see if it is compatible
11481 if Present (Offs) and then Offs > Uint_0 then
11482 if Offs mod (System_Storage_Unit * ObjA) /= 0 then
11483 Set_Result (Known_Incompatible);
11486 -- See if Expr is an object with known alignment
11488 elsif Is_Entity_Name (Expr)
11489 and then Known_Alignment (Entity (Expr))
11492 ExpA := Alignment (Entity (Expr));
11494 -- Otherwise, we can use the alignment of the type of Expr
11495 -- given that we already checked for discombobulating rep
11496 -- clauses for the cases of indexed and selected components
11499 elsif Known_Alignment (Etype (Expr)) then
11500 ExpA := Alignment (Etype (Expr));
11502 -- Otherwise the alignment is unknown
11505 Set_Result (Default);
11508 -- If we got an alignment, see if it is acceptable
11510 if Present (ExpA) and then ExpA < ObjA then
11511 Set_Result (Known_Incompatible);
11514 -- If Expr is a component or an entire object with a known
11515 -- alignment, then we are fine. Otherwise, if its size is
11516 -- known, it must be big enough for the required alignment.
11518 if Present (Offs) then
11521 -- See if Expr is an object with known size
11523 elsif Is_Entity_Name (Expr)
11524 and then Known_Static_Esize (Entity (Expr))
11526 SizA := Esize (Entity (Expr));
11528 -- Otherwise, we check the object size of the Expr type
11530 elsif Known_Static_Esize (Etype (Expr)) then
11531 SizA := Esize (Etype (Expr));
11534 -- If we got a size, see if it is a multiple of the Obj
11535 -- alignment; if not, then the alignment cannot be
11536 -- acceptable, since the size is always a multiple of the
11539 if Present (SizA) then
11540 if SizA mod (ObjA * Ttypes.System_Storage_Unit) /= 0 then
11541 Set_Result (Known_Incompatible);
11547 -- If we do not know required alignment, any non-zero offset is a
11548 -- potential problem (but certainly may be OK, so result is unknown).
11550 elsif Present (Offs) then
11551 Set_Result (Unknown);
11553 -- If we can't find the result by direct comparison of alignment
11554 -- values, then there is still one case that we can determine known
11555 -- result, and that is when we can determine that the types are the
11556 -- same, and no alignments are specified. Then we known that the
11557 -- alignments are compatible, even if we don't know the alignment
11558 -- value in the front end.
11560 elsif Etype (Obj) = Etype (Expr) then
11562 -- Types are the same, but we have to check for possible size
11563 -- and alignments on the Expr object that may make the alignment
11564 -- different, even though the types are the same.
11566 if Is_Entity_Name (Expr) then
11568 -- First check alignment of the Expr object. Any alignment less
11569 -- than Maximum_Alignment is worrisome since this is the case
11570 -- where we do not know the alignment of Obj.
11572 if Known_Alignment (Entity (Expr))
11573 and then Alignment (Entity (Expr)) < Ttypes.Maximum_Alignment
11575 Set_Result (Unknown);
11577 -- Now check size of Expr object. Any size that is not an even
11578 -- multiple of Maximum_Alignment is also worrisome since it
11579 -- may cause the alignment of the object to be less than the
11580 -- alignment of the type.
11582 elsif Known_Static_Esize (Entity (Expr))
11584 Esize (Entity (Expr)) mod
11585 (Ttypes.Maximum_Alignment * Ttypes.System_Storage_Unit)
11588 Set_Result (Unknown);
11590 -- Otherwise same type is decisive
11593 Set_Result (Known_Compatible);
11597 -- Another case to deal with is when there is an explicit size or
11598 -- alignment clause when the types are not the same. If so, then the
11599 -- result is Unknown. We don't need to do this test if the Default is
11600 -- Unknown, since that result will be set in any case.
11602 elsif Default /= Unknown
11603 and then (Has_Size_Clause (Etype (Expr))
11605 Has_Alignment_Clause (Etype (Expr)))
11607 Set_Result (Unknown);
11609 -- If no indication found, set default
11612 Set_Result (Default);
11615 -- Return worst result found
11618 end Has_Compatible_Alignment_Internal;
11620 -- Start of processing for Has_Compatible_Alignment
11623 -- If Obj has no specified alignment, then set alignment from the type
11624 -- alignment. Perhaps we should always do this, but for sure we should
11625 -- do it when there is an address clause since we can do more if the
11626 -- alignment is known.
11628 if not Known_Alignment (Obj) and then Known_Alignment (Etype (Obj)) then
11629 Set_Alignment (Obj, Alignment (Etype (Obj)));
11632 -- Now do the internal call that does all the work
11635 Has_Compatible_Alignment_Internal (Obj, Expr, Layout_Done, Unknown);
11636 end Has_Compatible_Alignment;
11638 ----------------------
11639 -- Has_Declarations --
11640 ----------------------
11642 function Has_Declarations (N : Node_Id) return Boolean is
11644 return Nkind (N) in N_Accept_Statement
11645 | N_Block_Statement
11646 | N_Compilation_Unit_Aux
11650 | N_Subprogram_Body
11652 | N_Package_Specification;
11653 end Has_Declarations;
11655 ---------------------------------
11656 -- Has_Defaulted_Discriminants --
11657 ---------------------------------
11659 function Has_Defaulted_Discriminants (Typ : Entity_Id) return Boolean is
11661 return Has_Discriminants (Typ)
11662 and then Present (Discriminant_Default_Value
11663 (First_Discriminant (Typ)));
11664 end Has_Defaulted_Discriminants;
11666 -------------------
11667 -- Has_Denormals --
11668 -------------------
11670 function Has_Denormals (E : Entity_Id) return Boolean is
11672 return Is_Floating_Point_Type (E) and then Denorm_On_Target;
11675 -------------------------------------------
11676 -- Has_Discriminant_Dependent_Constraint --
11677 -------------------------------------------
11679 function Has_Discriminant_Dependent_Constraint
11680 (Comp : Entity_Id) return Boolean
11682 Comp_Decl : constant Node_Id := Parent (Comp);
11683 Subt_Indic : Node_Id;
11688 -- Discriminants can't depend on discriminants
11690 if Ekind (Comp) = E_Discriminant then
11694 Subt_Indic := Subtype_Indication (Component_Definition (Comp_Decl));
11696 if Nkind (Subt_Indic) = N_Subtype_Indication then
11697 Constr := Constraint (Subt_Indic);
11699 if Nkind (Constr) = N_Index_Or_Discriminant_Constraint then
11700 Assn := First (Constraints (Constr));
11701 while Present (Assn) loop
11702 case Nkind (Assn) is
11705 | N_Subtype_Indication
11707 if Depends_On_Discriminant (Assn) then
11711 when N_Discriminant_Association =>
11712 if Depends_On_Discriminant (Expression (Assn)) then
11727 end Has_Discriminant_Dependent_Constraint;
11729 --------------------------------------
11730 -- Has_Effectively_Volatile_Profile --
11731 --------------------------------------
11733 function Has_Effectively_Volatile_Profile
11734 (Subp_Id : Entity_Id) return Boolean
11736 Formal : Entity_Id;
11739 -- Inspect the formal parameters looking for an effectively volatile
11740 -- type for reading.
11742 Formal := First_Formal (Subp_Id);
11743 while Present (Formal) loop
11744 if Is_Effectively_Volatile_For_Reading (Etype (Formal)) then
11748 Next_Formal (Formal);
11751 -- Inspect the return type of functions
11753 if Ekind (Subp_Id) in E_Function | E_Generic_Function
11754 and then Is_Effectively_Volatile_For_Reading (Etype (Subp_Id))
11760 end Has_Effectively_Volatile_Profile;
11762 --------------------------
11763 -- Has_Enabled_Property --
11764 --------------------------
11766 function Has_Enabled_Property
11767 (Item_Id : Entity_Id;
11768 Property : Name_Id) return Boolean
11770 function Protected_Type_Or_Variable_Has_Enabled_Property return Boolean;
11771 -- Determine whether a protected type or variable denoted by Item_Id
11772 -- has the property enabled.
11774 function State_Has_Enabled_Property return Boolean;
11775 -- Determine whether a state denoted by Item_Id has the property enabled
11777 function Type_Or_Variable_Has_Enabled_Property
11778 (Item_Id : Entity_Id) return Boolean;
11779 -- Determine whether type or variable denoted by Item_Id has the
11780 -- property enabled.
11782 -----------------------------------------------------
11783 -- Protected_Type_Or_Variable_Has_Enabled_Property --
11784 -----------------------------------------------------
11786 function Protected_Type_Or_Variable_Has_Enabled_Property return Boolean
11789 -- Protected entities always have the properties Async_Readers and
11790 -- Async_Writers (SPARK RM 7.1.2(16)).
11792 if Property = Name_Async_Readers
11793 or else Property = Name_Async_Writers
11797 -- Protected objects that have Part_Of components also inherit their
11798 -- properties Effective_Reads and Effective_Writes
11799 -- (SPARK RM 7.1.2(16)).
11801 elsif Is_Single_Protected_Object (Item_Id) then
11803 Constit_Elmt : Elmt_Id;
11804 Constit_Id : Entity_Id;
11805 Constits : constant Elist_Id
11806 := Part_Of_Constituents (Item_Id);
11808 if Present (Constits) then
11809 Constit_Elmt := First_Elmt (Constits);
11810 while Present (Constit_Elmt) loop
11811 Constit_Id := Node (Constit_Elmt);
11813 if Has_Enabled_Property (Constit_Id, Property) then
11817 Next_Elmt (Constit_Elmt);
11824 end Protected_Type_Or_Variable_Has_Enabled_Property;
11826 --------------------------------
11827 -- State_Has_Enabled_Property --
11828 --------------------------------
11830 function State_Has_Enabled_Property return Boolean is
11831 Decl : constant Node_Id := Parent (Item_Id);
11833 procedure Find_Simple_Properties
11834 (Has_External : out Boolean;
11835 Has_Synchronous : out Boolean);
11836 -- Extract the simple properties associated with declaration Decl
11838 function Is_Enabled_External_Property return Boolean;
11839 -- Determine whether property Property appears within the external
11840 -- property list of declaration Decl, and return its status.
11842 ----------------------------
11843 -- Find_Simple_Properties --
11844 ----------------------------
11846 procedure Find_Simple_Properties
11847 (Has_External : out Boolean;
11848 Has_Synchronous : out Boolean)
11853 -- Assume that none of the properties are available
11855 Has_External := False;
11856 Has_Synchronous := False;
11858 Opt := First (Expressions (Decl));
11859 while Present (Opt) loop
11860 if Nkind (Opt) = N_Identifier then
11861 if Chars (Opt) = Name_External then
11862 Has_External := True;
11864 elsif Chars (Opt) = Name_Synchronous then
11865 Has_Synchronous := True;
11871 end Find_Simple_Properties;
11873 ----------------------------------
11874 -- Is_Enabled_External_Property --
11875 ----------------------------------
11877 function Is_Enabled_External_Property return Boolean is
11881 Prop_Nam : Node_Id;
11885 Opt := First (Component_Associations (Decl));
11886 while Present (Opt) loop
11887 Opt_Nam := First (Choices (Opt));
11889 if Nkind (Opt_Nam) = N_Identifier
11890 and then Chars (Opt_Nam) = Name_External
11892 Props := Expression (Opt);
11894 -- Multiple properties appear as an aggregate
11896 if Nkind (Props) = N_Aggregate then
11898 -- Simple property form
11900 Prop := First (Expressions (Props));
11901 while Present (Prop) loop
11902 if Chars (Prop) = Property then
11909 -- Property with expression form
11911 Prop := First (Component_Associations (Props));
11912 while Present (Prop) loop
11913 Prop_Nam := First (Choices (Prop));
11915 -- The property can be represented in two ways:
11916 -- others => <value>
11917 -- <property> => <value>
11919 if Nkind (Prop_Nam) = N_Others_Choice
11920 or else (Nkind (Prop_Nam) = N_Identifier
11921 and then Chars (Prop_Nam) = Property)
11923 return Is_True (Expr_Value (Expression (Prop)));
11932 return Chars (Props) = Property;
11940 end Is_Enabled_External_Property;
11944 Has_External : Boolean;
11945 Has_Synchronous : Boolean;
11947 -- Start of processing for State_Has_Enabled_Property
11950 -- The declaration of an external abstract state appears as an
11951 -- extension aggregate. If this is not the case, properties can
11954 if Nkind (Decl) /= N_Extension_Aggregate then
11958 Find_Simple_Properties (Has_External, Has_Synchronous);
11960 -- Simple option External enables all properties (SPARK RM 7.1.2(2))
11962 if Has_External then
11965 -- Option External may enable or disable specific properties
11967 elsif Is_Enabled_External_Property then
11970 -- Simple option Synchronous
11972 -- enables disables
11973 -- Async_Readers Effective_Reads
11974 -- Async_Writers Effective_Writes
11976 -- Note that both forms of External have higher precedence than
11977 -- Synchronous (SPARK RM 7.1.4(9)).
11979 elsif Has_Synchronous then
11980 return Property in Name_Async_Readers | Name_Async_Writers;
11984 end State_Has_Enabled_Property;
11986 -------------------------------------------
11987 -- Type_Or_Variable_Has_Enabled_Property --
11988 -------------------------------------------
11990 function Type_Or_Variable_Has_Enabled_Property
11991 (Item_Id : Entity_Id) return Boolean
11993 AR : constant Node_Id :=
11994 Get_Pragma (Item_Id, Pragma_Async_Readers);
11995 AW : constant Node_Id :=
11996 Get_Pragma (Item_Id, Pragma_Async_Writers);
11997 ER : constant Node_Id :=
11998 Get_Pragma (Item_Id, Pragma_Effective_Reads);
11999 EW : constant Node_Id :=
12000 Get_Pragma (Item_Id, Pragma_Effective_Writes);
12002 Is_Derived_Type_With_Volatile_Parent_Type : constant Boolean :=
12003 Is_Derived_Type (Item_Id)
12004 and then Is_Effectively_Volatile (Etype (Base_Type (Item_Id)));
12007 -- A non-effectively volatile object can never possess external
12010 if not Is_Effectively_Volatile (Item_Id) then
12013 -- External properties related to variables come in two flavors -
12014 -- explicit and implicit. The explicit case is characterized by the
12015 -- presence of a property pragma with an optional Boolean flag. The
12016 -- property is enabled when the flag evaluates to True or the flag is
12017 -- missing altogether.
12019 elsif Property = Name_Async_Readers and then Present (AR) then
12020 return Is_Enabled_Pragma (AR);
12022 elsif Property = Name_Async_Writers and then Present (AW) then
12023 return Is_Enabled_Pragma (AW);
12025 elsif Property = Name_Effective_Reads and then Present (ER) then
12026 return Is_Enabled_Pragma (ER);
12028 elsif Property = Name_Effective_Writes and then Present (EW) then
12029 return Is_Enabled_Pragma (EW);
12031 -- If other properties are set explicitly, then this one is set
12032 -- implicitly to False, except in the case of a derived type
12033 -- whose parent type is volatile (in that case, we will inherit
12034 -- from the parent type, below).
12036 elsif (Present (AR)
12037 or else Present (AW)
12038 or else Present (ER)
12039 or else Present (EW))
12040 and then not Is_Derived_Type_With_Volatile_Parent_Type
12044 -- For a private type (including subtype of a private types), look at
12047 elsif Is_Private_Type (Item_Id) and then Present (Full_View (Item_Id))
12049 return Type_Or_Variable_Has_Enabled_Property (Full_View (Item_Id));
12051 -- For a derived type whose parent type is volatile, the
12052 -- property may be inherited (but ignore a non-volatile parent).
12054 elsif Is_Derived_Type_With_Volatile_Parent_Type then
12055 return Type_Or_Variable_Has_Enabled_Property
12056 (First_Subtype (Etype (Base_Type (Item_Id))));
12058 -- For a subtype, the property will be inherited from its base type.
12060 elsif Is_Type (Item_Id)
12061 and then not Is_Base_Type (Item_Id)
12063 return Type_Or_Variable_Has_Enabled_Property (Etype (Item_Id));
12065 -- If not specified explicitly for an object and its type
12066 -- is effectively volatile, then take result from the type.
12068 elsif Is_Object (Item_Id)
12069 and then Is_Effectively_Volatile (Etype (Item_Id))
12071 return Has_Enabled_Property (Etype (Item_Id), Property);
12073 -- The implicit case lacks all property pragmas
12075 elsif No (AR) and then No (AW) and then No (ER) and then No (EW) then
12076 if Is_Protected_Type (Etype (Item_Id)) then
12077 return Protected_Type_Or_Variable_Has_Enabled_Property;
12085 end Type_Or_Variable_Has_Enabled_Property;
12087 -- Start of processing for Has_Enabled_Property
12090 -- Abstract states and variables have a flexible scheme of specifying
12091 -- external properties.
12093 if Ekind (Item_Id) = E_Abstract_State then
12094 return State_Has_Enabled_Property;
12096 elsif Ekind (Item_Id) in E_Variable | E_Constant then
12097 return Type_Or_Variable_Has_Enabled_Property (Item_Id);
12099 -- Other objects can only inherit properties through their type. We
12100 -- cannot call directly Type_Or_Variable_Has_Enabled_Property on
12101 -- these as they don't have contracts attached, which is expected by
12104 elsif Is_Object (Item_Id) then
12105 return Type_Or_Variable_Has_Enabled_Property (Etype (Item_Id));
12107 elsif Is_Type (Item_Id) then
12108 return Type_Or_Variable_Has_Enabled_Property
12109 (Item_Id => First_Subtype (Item_Id));
12111 -- Otherwise a property is enabled when the related item is effectively
12115 return Is_Effectively_Volatile (Item_Id);
12117 end Has_Enabled_Property;
12119 -------------------------------------
12120 -- Has_Full_Default_Initialization --
12121 -------------------------------------
12123 function Has_Full_Default_Initialization (Typ : Entity_Id) return Boolean is
12127 -- A type subject to pragma Default_Initial_Condition may be fully
12128 -- default initialized depending on inheritance and the argument of
12129 -- the pragma. Since any type may act as the full view of a private
12130 -- type, this check must be performed prior to the specialized tests
12133 if Has_Fully_Default_Initializing_DIC_Pragma (Typ) then
12137 -- A scalar type is fully default initialized if it is subject to aspect
12140 if Is_Scalar_Type (Typ) then
12141 return Has_Default_Aspect (Typ);
12143 -- An access type is fully default initialized by default
12145 elsif Is_Access_Type (Typ) then
12148 -- An array type is fully default initialized if its element type is
12149 -- scalar and the array type carries aspect Default_Component_Value or
12150 -- the element type is fully default initialized.
12152 elsif Is_Array_Type (Typ) then
12154 Has_Default_Aspect (Typ)
12155 or else Has_Full_Default_Initialization (Component_Type (Typ));
12157 -- A protected type, record type, or type extension is fully default
12158 -- initialized if all its components either carry an initialization
12159 -- expression or have a type that is fully default initialized. The
12160 -- parent type of a type extension must be fully default initialized.
12162 elsif Is_Record_Type (Typ) or else Is_Protected_Type (Typ) then
12164 -- Inspect all entities defined in the scope of the type, looking for
12165 -- uninitialized components.
12167 Comp := First_Component (Typ);
12168 while Present (Comp) loop
12169 if Comes_From_Source (Comp)
12170 and then No (Expression (Parent (Comp)))
12171 and then not Has_Full_Default_Initialization (Etype (Comp))
12176 Next_Component (Comp);
12179 -- Ensure that the parent type of a type extension is fully default
12182 if Etype (Typ) /= Typ
12183 and then not Has_Full_Default_Initialization (Etype (Typ))
12188 -- If we get here, then all components and parent portion are fully
12189 -- default initialized.
12193 -- A task type is fully default initialized by default
12195 elsif Is_Task_Type (Typ) then
12198 -- Otherwise the type is not fully default initialized
12203 end Has_Full_Default_Initialization;
12205 -----------------------------------------------
12206 -- Has_Fully_Default_Initializing_DIC_Pragma --
12207 -----------------------------------------------
12209 function Has_Fully_Default_Initializing_DIC_Pragma
12210 (Typ : Entity_Id) return Boolean
12216 -- A type that inherits pragma Default_Initial_Condition from a parent
12217 -- type is automatically fully default initialized.
12219 if Has_Inherited_DIC (Typ) then
12222 -- Otherwise the type is fully default initialized only when the pragma
12223 -- appears without an argument, or the argument is non-null.
12225 elsif Has_Own_DIC (Typ) then
12226 Prag := Get_Pragma (Typ, Pragma_Default_Initial_Condition);
12227 pragma Assert (Present (Prag));
12228 Args := Pragma_Argument_Associations (Prag);
12230 -- The pragma appears without an argument in which case it defaults
12236 -- The pragma appears with a non-null expression
12238 elsif Nkind (Get_Pragma_Arg (First (Args))) /= N_Null then
12244 end Has_Fully_Default_Initializing_DIC_Pragma;
12246 ---------------------------------
12247 -- Has_Inferable_Discriminants --
12248 ---------------------------------
12250 function Has_Inferable_Discriminants (N : Node_Id) return Boolean is
12252 function Prefix_Is_Formal_Parameter (N : Node_Id) return Boolean;
12253 -- Determines whether the left-most prefix of a selected component is a
12254 -- formal parameter in a subprogram. Assumes N is a selected component.
12256 --------------------------------
12257 -- Prefix_Is_Formal_Parameter --
12258 --------------------------------
12260 function Prefix_Is_Formal_Parameter (N : Node_Id) return Boolean is
12261 Sel_Comp : Node_Id;
12264 -- Move to the left-most prefix by climbing up the tree
12267 while Present (Parent (Sel_Comp))
12268 and then Nkind (Parent (Sel_Comp)) = N_Selected_Component
12270 Sel_Comp := Parent (Sel_Comp);
12273 return Is_Formal (Entity (Prefix (Sel_Comp)));
12274 end Prefix_Is_Formal_Parameter;
12276 -- Start of processing for Has_Inferable_Discriminants
12279 -- For selected components, the subtype of the selector must be a
12280 -- constrained Unchecked_Union. If the component is subject to a
12281 -- per-object constraint, then the enclosing object must either be
12282 -- a regular discriminated type or must have inferable discriminants.
12284 if Nkind (N) = N_Selected_Component then
12285 -- The call to Has_Inferable_Discriminants will determine whether
12286 -- the selector has a constrained Unchecked_Union nominal type.
12288 if not Has_Inferable_Discriminants (Selector_Name (N)) then
12292 -- A small hack. If we have a per-object constrained selected
12293 -- component of a formal parameter, return True since we do not
12294 -- know the actual parameter association yet.
12296 return not Has_Per_Object_Constraint (Entity (Selector_Name (N)))
12297 or else not Is_Unchecked_Union (Etype (Prefix (N)))
12298 or else Has_Inferable_Discriminants (Prefix (N))
12299 or else Prefix_Is_Formal_Parameter (N);
12301 -- A qualified expression has inferable discriminants if its subtype
12302 -- mark is a constrained Unchecked_Union subtype.
12304 elsif Nkind (N) = N_Qualified_Expression then
12305 return Is_Unchecked_Union (Etype (Subtype_Mark (N)))
12306 and then Is_Constrained (Etype (Subtype_Mark (N)));
12308 -- For all other names, it is sufficient to have a constrained
12309 -- Unchecked_Union nominal subtype.
12312 return Is_Unchecked_Union (Etype (N))
12313 and then Is_Constrained (Etype (N));
12315 end Has_Inferable_Discriminants;
12317 --------------------
12318 -- Has_Infinities --
12319 --------------------
12321 function Has_Infinities (E : Entity_Id) return Boolean is
12324 Is_Floating_Point_Type (E)
12325 and then Nkind (Scalar_Range (E)) = N_Range
12326 and then Includes_Infinities (Scalar_Range (E));
12327 end Has_Infinities;
12329 --------------------
12330 -- Has_Interfaces --
12331 --------------------
12333 function Has_Interfaces
12335 Use_Full_View : Boolean := True) return Boolean
12337 Typ : Entity_Id := Base_Type (T);
12340 -- Handle concurrent types
12342 if Is_Concurrent_Type (Typ) then
12343 Typ := Corresponding_Record_Type (Typ);
12347 or else not Is_Record_Type (Typ)
12348 or else not Is_Tagged_Type (Typ)
12353 -- Handle private types
12355 if Use_Full_View and then Present (Full_View (Typ)) then
12356 Typ := Full_View (Typ);
12359 -- Handle concurrent record types
12361 if Is_Concurrent_Record_Type (Typ)
12362 and then Is_Non_Empty_List (Abstract_Interface_List (Typ))
12368 if Is_Interface (Typ)
12370 (Is_Record_Type (Typ)
12371 and then Present (Interfaces (Typ))
12372 and then not Is_Empty_Elmt_List (Interfaces (Typ)))
12377 exit when Etype (Typ) = Typ
12379 -- Handle private types
12381 or else (Present (Full_View (Etype (Typ)))
12382 and then Full_View (Etype (Typ)) = Typ)
12384 -- Protect frontend against wrong sources with cyclic derivations
12386 or else Etype (Typ) = T;
12388 -- Climb to the ancestor type handling private types
12390 if Present (Full_View (Etype (Typ))) then
12391 Typ := Full_View (Etype (Typ));
12393 Typ := Etype (Typ);
12398 end Has_Interfaces;
12400 --------------------------
12401 -- Has_Max_Queue_Length --
12402 --------------------------
12404 function Has_Max_Queue_Length (Id : Entity_Id) return Boolean is
12407 Ekind (Id) = E_Entry
12408 and then Present (Get_Pragma (Id, Pragma_Max_Queue_Length));
12409 end Has_Max_Queue_Length;
12411 ---------------------------------
12412 -- Has_No_Obvious_Side_Effects --
12413 ---------------------------------
12415 function Has_No_Obvious_Side_Effects (N : Node_Id) return Boolean is
12417 -- For now handle literals, constants, and non-volatile variables and
12418 -- expressions combining these with operators or short circuit forms.
12420 if Nkind (N) in N_Numeric_Or_String_Literal then
12423 elsif Nkind (N) = N_Character_Literal then
12426 elsif Nkind (N) in N_Unary_Op then
12427 return Has_No_Obvious_Side_Effects (Right_Opnd (N));
12429 elsif Nkind (N) in N_Binary_Op or else Nkind (N) in N_Short_Circuit then
12430 return Has_No_Obvious_Side_Effects (Left_Opnd (N))
12432 Has_No_Obvious_Side_Effects (Right_Opnd (N));
12434 elsif Nkind (N) = N_Expression_With_Actions
12435 and then Is_Empty_List (Actions (N))
12437 return Has_No_Obvious_Side_Effects (Expression (N));
12439 elsif Nkind (N) in N_Has_Entity then
12440 return Present (Entity (N))
12442 Ekind (Entity (N)) in
12443 E_Variable | E_Constant | E_Enumeration_Literal |
12444 E_In_Parameter | E_Out_Parameter | E_In_Out_Parameter
12445 and then not Is_Volatile (Entity (N));
12450 end Has_No_Obvious_Side_Effects;
12452 -----------------------------
12453 -- Has_Non_Null_Refinement --
12454 -----------------------------
12456 function Has_Non_Null_Refinement (Id : Entity_Id) return Boolean is
12457 Constits : Elist_Id;
12460 pragma Assert (Ekind (Id) = E_Abstract_State);
12461 Constits := Refinement_Constituents (Id);
12463 -- For a refinement to be non-null, the first constituent must be
12464 -- anything other than null.
12468 and then Nkind (Node (First_Elmt (Constits))) /= N_Null;
12469 end Has_Non_Null_Refinement;
12471 -----------------------------
12472 -- Has_Non_Null_Statements --
12473 -----------------------------
12475 function Has_Non_Null_Statements (L : List_Id) return Boolean is
12481 while Present (Node) loop
12482 if Nkind (Node) not in N_Null_Statement | N_Call_Marker then
12490 end Has_Non_Null_Statements;
12492 ----------------------------------
12493 -- Is_Access_Subprogram_Wrapper --
12494 ----------------------------------
12496 function Is_Access_Subprogram_Wrapper (E : Entity_Id) return Boolean is
12497 Formal : constant Entity_Id := Last_Formal (E);
12499 return Present (Formal)
12500 and then Ekind (Etype (Formal)) in Access_Subprogram_Kind
12501 and then Access_Subprogram_Wrapper
12502 (Directly_Designated_Type (Etype (Formal))) = E;
12503 end Is_Access_Subprogram_Wrapper;
12505 ---------------------------
12506 -- Is_Explicitly_Aliased --
12507 ---------------------------
12509 function Is_Explicitly_Aliased (N : Node_Id) return Boolean is
12511 return Is_Formal (N)
12512 and then Present (Parent (N))
12513 and then Nkind (Parent (N)) = N_Parameter_Specification
12514 and then Aliased_Present (Parent (N));
12515 end Is_Explicitly_Aliased;
12517 ----------------------------
12518 -- Is_Container_Aggregate --
12519 ----------------------------
12521 function Is_Container_Aggregate (Exp : Node_Id) return Boolean is
12523 function Is_Record_Aggregate return Boolean is (False);
12524 -- ??? Unimplemented. Given an aggregate whose type is a
12525 -- record type with specified Aggregate aspect, how do we
12526 -- determine whether it is a record aggregate or a container
12527 -- aggregate? If the code where the aggregate occurs can see only
12528 -- a partial view of the aggregate's type then the aggregate
12529 -- cannot be a record type; an aggregate of a private type has to
12530 -- be a container aggregate.
12533 return Nkind (Exp) = N_Aggregate
12534 and then Has_Aspect (Etype (Exp), Aspect_Aggregate)
12535 and then not Is_Record_Aggregate;
12536 end Is_Container_Aggregate;
12538 ---------------------------------
12539 -- Side_Effect_Free_Statements --
12540 ---------------------------------
12542 function Side_Effect_Free_Statements (L : List_Id) return Boolean is
12548 while Present (Node) loop
12549 case Nkind (Node) is
12550 when N_Null_Statement | N_Call_Marker | N_Raise_xxx_Error =>
12553 when N_Object_Declaration =>
12554 if Present (Expression (Node))
12555 and then not Side_Effect_Free (Expression (Node))
12568 end Side_Effect_Free_Statements;
12570 ---------------------------
12571 -- Side_Effect_Free_Loop --
12572 ---------------------------
12574 function Side_Effect_Free_Loop (N : Node_Id) return Boolean is
12580 -- If this is not a loop (e.g. because the loop has been rewritten),
12581 -- then return false.
12583 if Nkind (N) /= N_Loop_Statement then
12587 -- First check the statements
12589 if Side_Effect_Free_Statements (Statements (N)) then
12591 -- Then check the loop condition/indexes
12593 if Present (Iteration_Scheme (N)) then
12594 Scheme := Iteration_Scheme (N);
12596 if Present (Condition (Scheme))
12597 or else Present (Iterator_Specification (Scheme))
12600 elsif Present (Loop_Parameter_Specification (Scheme)) then
12601 Spec := Loop_Parameter_Specification (Scheme);
12602 Subt := Discrete_Subtype_Definition (Spec);
12604 if Present (Subt) then
12605 if Nkind (Subt) = N_Range then
12606 return Side_Effect_Free (Low_Bound (Subt))
12607 and then Side_Effect_Free (High_Bound (Subt));
12609 -- subtype indication
12619 end Side_Effect_Free_Loop;
12621 ----------------------------------
12622 -- Has_Non_Trivial_Precondition --
12623 ----------------------------------
12625 function Has_Non_Trivial_Precondition (Subp : Entity_Id) return Boolean is
12626 Pre : constant Node_Id := Find_Aspect (Subp, Aspect_Pre,
12627 Class_Present => True);
12631 and then not Is_Entity_Name (Expression (Pre));
12632 end Has_Non_Trivial_Precondition;
12634 -------------------
12635 -- Has_Null_Body --
12636 -------------------
12638 function Has_Null_Body (Proc_Id : Entity_Id) return Boolean is
12639 Body_Id : Entity_Id;
12646 Spec := Parent (Proc_Id);
12647 Decl := Parent (Spec);
12649 -- Retrieve the entity of the procedure body (e.g. invariant proc).
12651 if Nkind (Spec) = N_Procedure_Specification
12652 and then Nkind (Decl) = N_Subprogram_Declaration
12654 Body_Id := Corresponding_Body (Decl);
12656 -- The body acts as a spec
12659 Body_Id := Proc_Id;
12662 -- The body will be generated later
12664 if No (Body_Id) then
12668 Spec := Parent (Body_Id);
12669 Decl := Parent (Spec);
12672 (Nkind (Spec) = N_Procedure_Specification
12673 and then Nkind (Decl) = N_Subprogram_Body);
12675 Stmt1 := First (Statements (Handled_Statement_Sequence (Decl)));
12677 -- Look for a null statement followed by an optional return
12680 if Nkind (Stmt1) = N_Null_Statement then
12681 Stmt2 := Next (Stmt1);
12683 if Present (Stmt2) then
12684 return Nkind (Stmt2) = N_Simple_Return_Statement;
12693 ------------------------
12694 -- Has_Null_Exclusion --
12695 ------------------------
12697 function Has_Null_Exclusion (N : Node_Id) return Boolean is
12700 when N_Access_Definition
12701 | N_Access_Function_Definition
12702 | N_Access_Procedure_Definition
12703 | N_Access_To_Object_Definition
12705 | N_Derived_Type_Definition
12706 | N_Function_Specification
12707 | N_Subtype_Declaration
12709 return Null_Exclusion_Present (N);
12711 when N_Component_Definition
12712 | N_Formal_Object_Declaration
12714 if Present (Subtype_Mark (N)) then
12715 return Null_Exclusion_Present (N);
12716 else pragma Assert (Present (Access_Definition (N)));
12717 return Null_Exclusion_Present (Access_Definition (N));
12720 when N_Object_Renaming_Declaration =>
12721 if Present (Subtype_Mark (N)) then
12722 return Null_Exclusion_Present (N);
12723 elsif Present (Access_Definition (N)) then
12724 return Null_Exclusion_Present (Access_Definition (N));
12726 return False; -- Case of no subtype in renaming (AI12-0275)
12729 when N_Discriminant_Specification =>
12730 if Nkind (Discriminant_Type (N)) = N_Access_Definition then
12731 return Null_Exclusion_Present (Discriminant_Type (N));
12733 return Null_Exclusion_Present (N);
12736 when N_Object_Declaration =>
12737 if Nkind (Object_Definition (N)) = N_Access_Definition then
12738 return Null_Exclusion_Present (Object_Definition (N));
12740 return Null_Exclusion_Present (N);
12743 when N_Parameter_Specification =>
12744 if Nkind (Parameter_Type (N)) = N_Access_Definition then
12745 return Null_Exclusion_Present (Parameter_Type (N))
12746 or else Null_Exclusion_Present (N);
12748 return Null_Exclusion_Present (N);
12754 end Has_Null_Exclusion;
12756 ------------------------
12757 -- Has_Null_Extension --
12758 ------------------------
12760 function Has_Null_Extension (T : Entity_Id) return Boolean is
12761 B : constant Entity_Id := Base_Type (T);
12766 if Nkind (Parent (B)) = N_Full_Type_Declaration
12767 and then Present (Record_Extension_Part (Type_Definition (Parent (B))))
12769 Ext := Record_Extension_Part (Type_Definition (Parent (B)));
12771 if Present (Ext) then
12772 if Null_Present (Ext) then
12775 Comps := Component_List (Ext);
12777 -- The null component list is rewritten during analysis to
12778 -- include the parent component. Any other component indicates
12779 -- that the extension was not originally null.
12781 return Null_Present (Comps)
12782 or else No (Next (First (Component_Items (Comps))));
12791 end Has_Null_Extension;
12793 -------------------------
12794 -- Has_Null_Refinement --
12795 -------------------------
12797 function Has_Null_Refinement (Id : Entity_Id) return Boolean is
12798 Constits : Elist_Id;
12801 pragma Assert (Ekind (Id) = E_Abstract_State);
12802 Constits := Refinement_Constituents (Id);
12804 -- For a refinement to be null, the state's sole constituent must be a
12809 and then Nkind (Node (First_Elmt (Constits))) = N_Null;
12810 end Has_Null_Refinement;
12812 ------------------------------------------
12813 -- Has_Nonstatic_Class_Wide_Pre_Or_Post --
12814 ------------------------------------------
12816 function Is_Prim_Of_Abst_Type_With_Nonstatic_CW_Pre_Post
12817 (Subp : Entity_Id) return Boolean
12819 Disp_Type : constant Entity_Id := Find_Dispatching_Type (Subp);
12821 Pragma_Arg : Node_Id;
12824 if Present (Disp_Type)
12825 and then Is_Abstract_Type (Disp_Type)
12826 and then Present (Contract (Subp))
12828 Prag := Pre_Post_Conditions (Contract (Subp));
12830 while Present (Prag) loop
12831 if Pragma_Name (Prag) in Name_Precondition | Name_Postcondition
12832 and then Class_Present (Prag)
12836 (Pragma_Argument_Associations (Prag));
12838 if not Is_Static_Expression (Expression (Pragma_Arg)) then
12843 Prag := Next_Pragma (Prag);
12848 end Is_Prim_Of_Abst_Type_With_Nonstatic_CW_Pre_Post;
12850 -------------------------------
12851 -- Has_Overriding_Initialize --
12852 -------------------------------
12854 function Has_Overriding_Initialize (T : Entity_Id) return Boolean is
12855 BT : constant Entity_Id := Base_Type (T);
12859 if Is_Controlled (BT) then
12860 if Is_RTU (Scope (BT), Ada_Finalization) then
12863 elsif Present (Primitive_Operations (BT)) then
12864 P := First_Elmt (Primitive_Operations (BT));
12865 while Present (P) loop
12867 Init : constant Entity_Id := Node (P);
12868 Formal : constant Entity_Id := First_Formal (Init);
12870 if Ekind (Init) = E_Procedure
12871 and then Chars (Init) = Name_Initialize
12872 and then Comes_From_Source (Init)
12873 and then Present (Formal)
12874 and then Etype (Formal) = BT
12875 and then No (Next_Formal (Formal))
12876 and then (Ada_Version < Ada_2012
12877 or else not Null_Present (Parent (Init)))
12887 -- Here if type itself does not have a non-null Initialize operation:
12888 -- check immediate ancestor.
12890 if Is_Derived_Type (BT)
12891 and then Has_Overriding_Initialize (Etype (BT))
12898 end Has_Overriding_Initialize;
12900 --------------------------------------
12901 -- Has_Preelaborable_Initialization --
12902 --------------------------------------
12904 function Has_Preelaborable_Initialization
12906 Preelab_Init_Expr : Node_Id := Empty) return Boolean
12910 procedure Check_Components (E : Entity_Id);
12911 -- Check component/discriminant chain, sets Has_PE False if a component
12912 -- or discriminant does not meet the preelaborable initialization rules.
12914 function Type_Named_In_Preelab_Init_Expression
12916 Expr : Node_Id) return Boolean;
12917 -- Returns True iff Typ'Preelaborable_Initialization occurs in Expr
12918 -- (where Expr may be a conjunction of one or more P_I attributes).
12920 ----------------------
12921 -- Check_Components --
12922 ----------------------
12924 procedure Check_Components (E : Entity_Id) is
12929 -- Loop through components and discriminants of record or protected
12932 Ent := First_Component_Or_Discriminant (E);
12933 while Present (Ent) loop
12935 case Ekind (Ent) is
12936 when E_Component =>
12938 -- Get default expression if any. If there is no declaration
12939 -- node, it means we have an internal entity. The parent and
12940 -- tag fields are examples of such entities. For such cases,
12941 -- we just test the type of the entity.
12943 if Present (Declaration_Node (Ent)) then
12944 Exp := Expression (Declaration_Node (Ent));
12949 when E_Discriminant =>
12951 -- Note: for a renamed discriminant, the Declaration_Node
12952 -- may point to the one from the ancestor, and have a
12953 -- different expression, so use the proper attribute to
12954 -- retrieve the expression from the derived constraint.
12956 Exp := Discriminant_Default_Value (Ent);
12959 raise Program_Error;
12962 -- A component has PI if it has no default expression and the
12963 -- component type has PI.
12966 if not Has_Preelaborable_Initialization
12967 (Etype (Ent), Preelab_Init_Expr)
12973 -- Require the default expression to be preelaborable
12975 elsif not Is_Preelaborable_Construct (Exp) then
12980 Next_Component_Or_Discriminant (Ent);
12982 end Check_Components;
12984 --------------------------------------
12985 -- Type_Named_In_Preelab_Expression --
12986 --------------------------------------
12988 function Type_Named_In_Preelab_Init_Expression
12990 Expr : Node_Id) return Boolean
12993 -- Return True if Expr is a Preelaborable_Initialization attribute
12994 -- and the prefix is a subtype that has the same type as Typ.
12996 if Nkind (Expr) = N_Attribute_Reference
12997 and then Attribute_Name (Expr) = Name_Preelaborable_Initialization
12998 and then Is_Entity_Name (Prefix (Expr))
12999 and then Base_Type (Entity (Prefix (Expr))) = Base_Type (Typ)
13003 -- In the case where Expr is a conjunction, test whether either
13004 -- operand is a Preelaborable_Initialization attribute whose prefix
13005 -- has the same type as Typ, and return True if so.
13007 elsif Nkind (Expr) = N_Op_And
13009 (Type_Named_In_Preelab_Init_Expression (Typ, Left_Opnd (Expr))
13011 Type_Named_In_Preelab_Init_Expression (Typ, Right_Opnd (Expr)))
13015 -- Typ not named in a Preelaborable_Initialization attribute of Expr
13020 end Type_Named_In_Preelab_Init_Expression;
13022 -- Start of processing for Has_Preelaborable_Initialization
13025 -- Immediate return if already marked as known preelaborable init. This
13026 -- covers types for which this function has already been called once
13027 -- and returned True (in which case the result is cached), and also
13028 -- types to which a pragma Preelaborable_Initialization applies.
13030 if Known_To_Have_Preelab_Init (E) then
13034 -- If the type is a subtype representing a generic actual type, then
13035 -- test whether its base type has preelaborable initialization since
13036 -- the subtype representing the actual does not inherit this attribute
13037 -- from the actual or formal. (but maybe it should???)
13039 if Is_Generic_Actual_Type (E) then
13040 return Has_Preelaborable_Initialization (Base_Type (E));
13043 -- All elementary types have preelaborable initialization
13045 if Is_Elementary_Type (E) then
13048 -- Array types have PI if the component type has PI
13050 elsif Is_Array_Type (E) then
13051 Has_PE := Has_Preelaborable_Initialization
13052 (Component_Type (E), Preelab_Init_Expr);
13054 -- A derived type has preelaborable initialization if its parent type
13055 -- has preelaborable initialization and (in the case of a derived record
13056 -- extension) if the non-inherited components all have preelaborable
13057 -- initialization. However, a user-defined controlled type with an
13058 -- overriding Initialize procedure does not have preelaborable
13061 elsif Is_Derived_Type (E) then
13063 -- When the rule of RM 10.2.1(11.8/5) applies, we presume a component
13064 -- of a generic formal derived type has preelaborable initialization.
13065 -- (See comment on spec of Has_Preelaborable_Initialization.)
13067 if Is_Generic_Type (E)
13068 and then Present (Preelab_Init_Expr)
13070 Type_Named_In_Preelab_Init_Expression (E, Preelab_Init_Expr)
13075 -- If the derived type is a private extension then it doesn't have
13076 -- preelaborable initialization.
13078 if Ekind (Base_Type (E)) = E_Record_Type_With_Private then
13082 -- First check whether ancestor type has preelaborable initialization
13084 Has_PE := Has_Preelaborable_Initialization
13085 (Etype (Base_Type (E)), Preelab_Init_Expr);
13087 -- If OK, check extension components (if any)
13089 if Has_PE and then Is_Record_Type (E) then
13090 Check_Components (E);
13093 -- Check specifically for 10.2.1(11.4/2) exception: a controlled type
13094 -- with a user defined Initialize procedure does not have PI. If
13095 -- the type is untagged, the control primitives come from a component
13096 -- that has already been checked.
13099 and then Is_Controlled (E)
13100 and then Is_Tagged_Type (E)
13101 and then Has_Overriding_Initialize (E)
13106 -- Private types not derived from a type having preelaborable init and
13107 -- that are not marked with pragma Preelaborable_Initialization do not
13108 -- have preelaborable initialization.
13110 elsif Is_Private_Type (E) then
13112 -- When the rule of RM 10.2.1(11.8/5) applies, we presume a component
13113 -- of a generic formal private type has preelaborable initialization.
13114 -- (See comment on spec of Has_Preelaborable_Initialization.)
13116 if Is_Generic_Type (E)
13117 and then Present (Preelab_Init_Expr)
13119 Type_Named_In_Preelab_Init_Expression (E, Preelab_Init_Expr)
13126 -- Record type has PI if it is non private and all components have PI
13128 elsif Is_Record_Type (E) then
13130 Check_Components (E);
13132 -- Protected types must not have entries, and components must meet
13133 -- same set of rules as for record components.
13135 elsif Is_Protected_Type (E) then
13136 if Has_Entries (E) then
13140 Check_Components (E);
13143 -- Type System.Address always has preelaborable initialization
13145 elsif Is_RTE (E, RE_Address) then
13148 -- In all other cases, type does not have preelaborable initialization
13154 -- If type has preelaborable initialization, cache result
13157 Set_Known_To_Have_Preelab_Init (E);
13161 end Has_Preelaborable_Initialization;
13167 function Has_Prefix (N : Node_Id) return Boolean is
13169 return Nkind (N) in
13170 N_Attribute_Reference | N_Expanded_Name | N_Explicit_Dereference |
13171 N_Indexed_Component | N_Reference | N_Selected_Component |
13175 ---------------------------
13176 -- Has_Private_Component --
13177 ---------------------------
13179 function Has_Private_Component (Type_Id : Entity_Id) return Boolean is
13180 Btype : Entity_Id := Base_Type (Type_Id);
13181 Component : Entity_Id;
13184 if Error_Posted (Type_Id)
13185 or else Error_Posted (Btype)
13190 if Is_Class_Wide_Type (Btype) then
13191 Btype := Root_Type (Btype);
13194 if Is_Private_Type (Btype) then
13196 UT : constant Entity_Id := Underlying_Type (Btype);
13199 if No (Full_View (Btype)) then
13200 return not Is_Generic_Type (Btype)
13202 not Is_Generic_Type (Root_Type (Btype));
13204 return not Is_Generic_Type (Root_Type (Full_View (Btype)));
13207 return not Is_Frozen (UT) and then Has_Private_Component (UT);
13211 elsif Is_Array_Type (Btype) then
13212 return Has_Private_Component (Component_Type (Btype));
13214 elsif Is_Record_Type (Btype) then
13215 Component := First_Component (Btype);
13216 while Present (Component) loop
13217 if Has_Private_Component (Etype (Component)) then
13221 Next_Component (Component);
13226 elsif Is_Protected_Type (Btype)
13227 and then Present (Corresponding_Record_Type (Btype))
13229 return Has_Private_Component (Corresponding_Record_Type (Btype));
13234 end Has_Private_Component;
13236 --------------------------------
13237 -- Has_Relaxed_Initialization --
13238 --------------------------------
13240 function Has_Relaxed_Initialization (E : Entity_Id) return Boolean is
13242 function Denotes_Relaxed_Parameter
13246 -- Returns True iff expression Expr denotes a formal parameter or
13247 -- function Param (through its attribute Result).
13249 -------------------------------
13250 -- Denotes_Relaxed_Parameter --
13251 -------------------------------
13253 function Denotes_Relaxed_Parameter
13255 Param : Entity_Id) return Boolean is
13257 if Nkind (Expr) in N_Identifier | N_Expanded_Name then
13258 return Entity (Expr) = Param;
13260 pragma Assert (Is_Attribute_Result (Expr));
13261 return Entity (Prefix (Expr)) = Param;
13263 end Denotes_Relaxed_Parameter;
13265 -- Start of processing for Has_Relaxed_Initialization
13268 -- When analyzing, we checked all syntax legality rules for the aspect
13269 -- Relaxed_Initialization, but didn't store the property anywhere (e.g.
13270 -- as an Einfo flag). To query the property we look directly at the AST,
13271 -- but now without any syntactic checks.
13274 -- Abstract states have option Relaxed_Initialization
13276 when E_Abstract_State =>
13277 return Is_Relaxed_Initialization_State (E);
13279 -- Constants have this aspect attached directly; for deferred
13280 -- constants, the aspect is attached to the partial view.
13283 return Has_Aspect (E, Aspect_Relaxed_Initialization);
13285 -- Variables have this aspect attached directly
13288 return Has_Aspect (E, Aspect_Relaxed_Initialization);
13290 -- Types have this aspect attached directly (though we only allow it
13291 -- to be specified for the first subtype). For private types, the
13292 -- aspect is attached to the partial view.
13295 pragma Assert (Is_First_Subtype (E));
13296 return Has_Aspect (E, Aspect_Relaxed_Initialization);
13298 -- Formal parameters and functions have the Relaxed_Initialization
13299 -- aspect attached to the subprogram entity and must be listed in
13300 -- the aspect expression.
13306 Subp_Id : Entity_Id;
13307 Aspect_Expr : Node_Id;
13308 Param_Expr : Node_Id;
13312 if Is_Formal (E) then
13313 Subp_Id := Scope (E);
13318 if Has_Aspect (Subp_Id, Aspect_Relaxed_Initialization) then
13320 Find_Value_Of_Aspect
13321 (Subp_Id, Aspect_Relaxed_Initialization);
13323 -- Aspect expression is either an aggregate with an optional
13324 -- Boolean expression (which defaults to True), e.g.:
13326 -- function F (X : Integer) return Integer
13327 -- with Relaxed_Initialization => (X => True, F'Result);
13329 if Nkind (Aspect_Expr) = N_Aggregate then
13331 if Present (Component_Associations (Aspect_Expr)) then
13332 Assoc := First (Component_Associations (Aspect_Expr));
13334 while Present (Assoc) loop
13335 if Denotes_Relaxed_Parameter
13336 (First (Choices (Assoc)), E)
13340 (Static_Boolean (Expression (Assoc)));
13347 Param_Expr := First (Expressions (Aspect_Expr));
13349 while Present (Param_Expr) loop
13350 if Denotes_Relaxed_Parameter (Param_Expr, E) then
13359 -- or it is a single identifier, e.g.:
13361 -- function F (X : Integer) return Integer
13362 -- with Relaxed_Initialization => X;
13365 return Denotes_Relaxed_Parameter (Aspect_Expr, E);
13373 raise Program_Error;
13375 end Has_Relaxed_Initialization;
13377 ----------------------
13378 -- Has_Signed_Zeros --
13379 ----------------------
13381 function Has_Signed_Zeros (E : Entity_Id) return Boolean is
13383 return Is_Floating_Point_Type (E) and then Signed_Zeros_On_Target;
13384 end Has_Signed_Zeros;
13386 ------------------------------
13387 -- Has_Significant_Contract --
13388 ------------------------------
13390 function Has_Significant_Contract (Subp_Id : Entity_Id) return Boolean is
13391 Subp_Nam : constant Name_Id := Chars (Subp_Id);
13394 -- _Finalizer procedure
13396 if Subp_Nam = Name_uFinalizer then
13399 -- _Wrapped_Statements procedure which gets generated as part of the
13400 -- expansion of postconditions.
13402 elsif Subp_Nam = Name_uWrapped_Statements then
13405 -- Predicate function
13407 elsif Ekind (Subp_Id) = E_Function
13408 and then Is_Predicate_Function (Subp_Id)
13414 elsif Get_TSS_Name (Subp_Id) /= TSS_Null then
13420 end Has_Significant_Contract;
13422 -----------------------------
13423 -- Has_Static_Array_Bounds --
13424 -----------------------------
13426 function Has_Static_Array_Bounds (Typ : Node_Id) return Boolean is
13427 All_Static : Boolean;
13431 Examine_Array_Bounds (Typ, All_Static, Dummy);
13434 end Has_Static_Array_Bounds;
13436 ---------------------------------------
13437 -- Has_Static_Non_Empty_Array_Bounds --
13438 ---------------------------------------
13440 function Has_Static_Non_Empty_Array_Bounds (Typ : Node_Id) return Boolean is
13441 All_Static : Boolean;
13442 Has_Empty : Boolean;
13445 Examine_Array_Bounds (Typ, All_Static, Has_Empty);
13447 return All_Static and not Has_Empty;
13448 end Has_Static_Non_Empty_Array_Bounds;
13454 function Has_Stream (T : Entity_Id) return Boolean is
13461 elsif Is_RTE (Root_Type (T), RE_Root_Stream_Type) then
13464 elsif Is_Array_Type (T) then
13465 return Has_Stream (Component_Type (T));
13467 elsif Is_Record_Type (T) then
13468 E := First_Component (T);
13469 while Present (E) loop
13470 if Has_Stream (Etype (E)) then
13473 Next_Component (E);
13479 elsif Is_Private_Type (T) then
13480 return Has_Stream (Underlying_Type (T));
13491 function Has_Suffix (E : Entity_Id; Suffix : Character) return Boolean is
13493 Get_Name_String (Chars (E));
13494 return Name_Buffer (Name_Len) = Suffix;
13501 function Add_Suffix (E : Entity_Id; Suffix : Character) return Name_Id is
13503 Get_Name_String (Chars (E));
13504 Add_Char_To_Name_Buffer (Suffix);
13508 -------------------
13509 -- Remove_Suffix --
13510 -------------------
13512 function Remove_Suffix (E : Entity_Id; Suffix : Character) return Name_Id is
13514 pragma Assert (Has_Suffix (E, Suffix));
13515 Get_Name_String (Chars (E));
13516 Name_Len := Name_Len - 1;
13520 ----------------------------------
13521 -- Replace_Null_By_Null_Address --
13522 ----------------------------------
13524 procedure Replace_Null_By_Null_Address (N : Node_Id) is
13525 procedure Replace_Null_Operand (Op : Node_Id; Other_Op : Node_Id);
13526 -- Replace operand Op with a reference to Null_Address when the operand
13527 -- denotes a null Address. Other_Op denotes the other operand.
13529 --------------------------
13530 -- Replace_Null_Operand --
13531 --------------------------
13533 procedure Replace_Null_Operand (Op : Node_Id; Other_Op : Node_Id) is
13535 -- Check the type of the complementary operand since the N_Null node
13536 -- has not been decorated yet.
13538 if Nkind (Op) = N_Null
13539 and then Is_Descendant_Of_Address (Etype (Other_Op))
13541 Rewrite (Op, New_Occurrence_Of (RTE (RE_Null_Address), Sloc (Op)));
13543 end Replace_Null_Operand;
13545 -- Start of processing for Replace_Null_By_Null_Address
13548 pragma Assert (Relaxed_RM_Semantics);
13549 pragma Assert (Nkind (N) in N_Null | N_Op_Compare);
13551 if Nkind (N) = N_Null then
13552 Rewrite (N, New_Occurrence_Of (RTE (RE_Null_Address), Sloc (N)));
13556 L : constant Node_Id := Left_Opnd (N);
13557 R : constant Node_Id := Right_Opnd (N);
13560 Replace_Null_Operand (L, Other_Op => R);
13561 Replace_Null_Operand (R, Other_Op => L);
13564 end Replace_Null_By_Null_Address;
13566 --------------------------
13567 -- Has_Tagged_Component --
13568 --------------------------
13570 function Has_Tagged_Component (Typ : Entity_Id) return Boolean is
13574 if Is_Private_Type (Typ) and then Present (Underlying_Type (Typ)) then
13575 return Has_Tagged_Component (Underlying_Type (Typ));
13577 elsif Is_Array_Type (Typ) then
13578 return Has_Tagged_Component (Component_Type (Typ));
13580 elsif Is_Tagged_Type (Typ) then
13583 elsif Is_Record_Type (Typ) then
13584 Comp := First_Component (Typ);
13585 while Present (Comp) loop
13586 if Has_Tagged_Component (Etype (Comp)) then
13590 Next_Component (Comp);
13598 end Has_Tagged_Component;
13600 -----------------------------
13601 -- Has_Undefined_Reference --
13602 -----------------------------
13604 function Has_Undefined_Reference (Expr : Node_Id) return Boolean is
13605 Has_Undef_Ref : Boolean := False;
13606 -- Flag set when expression Expr contains at least one undefined
13609 function Is_Undefined_Reference (N : Node_Id) return Traverse_Result;
13610 -- Determine whether N denotes a reference and if it does, whether it is
13613 ----------------------------
13614 -- Is_Undefined_Reference --
13615 ----------------------------
13617 function Is_Undefined_Reference (N : Node_Id) return Traverse_Result is
13619 if Is_Entity_Name (N)
13620 and then Present (Entity (N))
13621 and then Entity (N) = Any_Id
13623 Has_Undef_Ref := True;
13628 end Is_Undefined_Reference;
13630 procedure Find_Undefined_References is
13631 new Traverse_Proc (Is_Undefined_Reference);
13633 -- Start of processing for Has_Undefined_Reference
13636 Find_Undefined_References (Expr);
13638 return Has_Undef_Ref;
13639 end Has_Undefined_Reference;
13641 ----------------------------------------
13642 -- Has_Effectively_Volatile_Component --
13643 ----------------------------------------
13645 function Has_Effectively_Volatile_Component
13646 (Typ : Entity_Id) return Boolean
13651 if Has_Volatile_Components (Typ) then
13654 elsif Is_Array_Type (Typ) then
13655 return Is_Effectively_Volatile (Component_Type (Typ));
13657 elsif Is_Record_Type (Typ) then
13658 Comp := First_Component (Typ);
13659 while Present (Comp) loop
13660 if Is_Effectively_Volatile (Etype (Comp)) then
13664 Next_Component (Comp);
13669 end Has_Effectively_Volatile_Component;
13671 ----------------------------
13672 -- Has_Volatile_Component --
13673 ----------------------------
13675 function Has_Volatile_Component (Typ : Entity_Id) return Boolean is
13679 if Has_Volatile_Components (Typ) then
13682 elsif Is_Array_Type (Typ) then
13683 return Is_Volatile (Component_Type (Typ));
13685 elsif Is_Record_Type (Typ) then
13686 Comp := First_Component (Typ);
13687 while Present (Comp) loop
13688 if Is_Volatile_Object_Ref (Comp) then
13692 Next_Component (Comp);
13697 end Has_Volatile_Component;
13699 -------------------------
13700 -- Implementation_Kind --
13701 -------------------------
13703 function Implementation_Kind (Subp : Entity_Id) return Name_Id is
13704 Impl_Prag : constant Node_Id := Get_Rep_Pragma (Subp, Name_Implemented);
13707 pragma Assert (Present (Impl_Prag));
13708 Arg := Last (Pragma_Argument_Associations (Impl_Prag));
13709 return Chars (Get_Pragma_Arg (Arg));
13710 end Implementation_Kind;
13712 --------------------------
13713 -- Implements_Interface --
13714 --------------------------
13716 function Implements_Interface
13717 (Typ_Ent : Entity_Id;
13718 Iface_Ent : Entity_Id;
13719 Exclude_Parents : Boolean := False) return Boolean
13721 Ifaces_List : Elist_Id;
13723 Iface : Entity_Id := Base_Type (Iface_Ent);
13724 Typ : Entity_Id := Base_Type (Typ_Ent);
13727 if Is_Class_Wide_Type (Typ) then
13728 Typ := Root_Type (Typ);
13731 if not Has_Interfaces (Typ) then
13735 if Is_Class_Wide_Type (Iface) then
13736 Iface := Root_Type (Iface);
13739 Collect_Interfaces (Typ, Ifaces_List);
13741 Elmt := First_Elmt (Ifaces_List);
13742 while Present (Elmt) loop
13743 if Is_Ancestor (Node (Elmt), Typ, Use_Full_View => True)
13744 and then Exclude_Parents
13748 elsif Node (Elmt) = Iface then
13756 end Implements_Interface;
13758 --------------------------------
13759 -- Implicitly_Designated_Type --
13760 --------------------------------
13762 function Implicitly_Designated_Type (Typ : Entity_Id) return Entity_Id is
13763 Desig : constant Entity_Id := Designated_Type (Typ);
13766 -- An implicit dereference is a legal occurrence of an incomplete type
13767 -- imported through a limited_with clause, if the full view is visible.
13769 if Is_Incomplete_Type (Desig)
13770 and then From_Limited_With (Desig)
13771 and then not From_Limited_With (Scope (Desig))
13773 (Is_Immediately_Visible (Scope (Desig))
13775 (Is_Child_Unit (Scope (Desig))
13776 and then Is_Visible_Lib_Unit (Scope (Desig))))
13778 return Available_View (Desig);
13782 end Implicitly_Designated_Type;
13784 ------------------------------------
13785 -- In_Assertion_Expression_Pragma --
13786 ------------------------------------
13788 function In_Assertion_Expression_Pragma (N : Node_Id) return Boolean is
13790 Prag : Node_Id := Empty;
13793 -- Climb the parent chain looking for an enclosing pragma
13796 while Present (Par) loop
13797 if Nkind (Par) = N_Pragma then
13801 -- Precondition-like pragmas are expanded into if statements, check
13802 -- the original node instead.
13804 elsif Nkind (Original_Node (Par)) = N_Pragma then
13805 Prag := Original_Node (Par);
13808 -- The expansion of attribute 'Old generates a
constant to capture
13809 -- the result of the prefix. If the parent traversal reaches
13810 -- one of these constants, then the node technically came from a
13811 -- postcondition-like pragma. Note that the Ekind is not tested here
13812 -- because N may be the expression of an object declaration which is
13813 -- currently being analyzed. Such objects carry Ekind of E_Void.
13815 elsif Nkind
(Par
) = N_Object_Declaration
13816 and then Constant_Present
(Par
)
13817 and then Stores_Attribute_Old_Prefix
(Defining_Entity
(Par
))
13821 -- Prevent the search from going too far
13823 elsif Is_Body_Or_Package_Declaration
(Par
) then
13827 Par
:= Parent
(Par
);
13832 and then Assertion_Expression_Pragma
(Get_Pragma_Id
(Prag
));
13833 end In_Assertion_Expression_Pragma
;
13835 -------------------
13836 -- In_Check_Node --
13837 -------------------
13839 function In_Check_Node
(N
: Node_Id
) return Boolean is
13840 Par
: Node_Id
:= Parent
(N
);
13842 while Present
(Par
) loop
13843 if Nkind
(Par
) in N_Raise_xxx_Error
then
13846 -- Prevent the search from going too far
13848 elsif Is_Body_Or_Package_Declaration
(Par
) then
13852 Par
:= Parent
(Par
);
13859 -------------------------------
13860 -- In_Generic_Formal_Package --
13861 -------------------------------
13863 function In_Generic_Formal_Package
(E
: Entity_Id
) return Boolean is
13868 while Present
(Par
) loop
13869 if Nkind
(Par
) = N_Formal_Package_Declaration
13870 or else Nkind
(Original_Node
(Par
)) = N_Formal_Package_Declaration
13875 Par
:= Parent
(Par
);
13879 end In_Generic_Formal_Package
;
13881 ----------------------
13882 -- In_Generic_Scope --
13883 ----------------------
13885 function In_Generic_Scope
(E
: Entity_Id
) return Boolean is
13890 while Present
(S
) and then S
/= Standard_Standard
loop
13891 if Is_Generic_Unit
(S
) then
13899 end In_Generic_Scope
;
13905 function In_Instance
return Boolean is
13906 Curr_Unit
: constant Entity_Id
:= Cunit_Entity
(Current_Sem_Unit
);
13910 S
:= Current_Scope
;
13911 while Present
(S
) and then S
/= Standard_Standard
loop
13912 if Is_Generic_Instance
(S
) then
13914 -- A child instance is always compiled in the context of a parent
13915 -- instance. Nevertheless, its actuals must not be analyzed in an
13916 -- instance context. We detect this case by examining the current
13917 -- compilation unit, which must be a child instance, and checking
13918 -- that it has not been analyzed yet.
13920 if Is_Child_Unit
(Curr_Unit
)
13921 and then Nkind
(Unit
(Cunit
(Current_Sem_Unit
))) =
13922 N_Package_Instantiation
13923 and then Ekind
(Curr_Unit
) = E_Void
13937 ----------------------
13938 -- In_Instance_Body --
13939 ----------------------
13941 function In_Instance_Body
return Boolean is
13945 S
:= Current_Scope
;
13946 while Present
(S
) and then S
/= Standard_Standard
loop
13947 if Ekind
(S
) in E_Function | E_Procedure
13948 and then Is_Generic_Instance
(S
)
13952 elsif Ekind
(S
) = E_Package
13953 and then In_Package_Body
(S
)
13954 and then Is_Generic_Instance
(S
)
13963 end In_Instance_Body
;
13965 -----------------------------
13966 -- In_Instance_Not_Visible --
13967 -----------------------------
13969 function In_Instance_Not_Visible
return Boolean is
13973 S
:= Current_Scope
;
13974 while Present
(S
) and then S
/= Standard_Standard
loop
13975 if Ekind
(S
) in E_Function | E_Procedure
13976 and then Is_Generic_Instance
(S
)
13980 elsif Ekind
(S
) = E_Package
13981 and then (In_Package_Body
(S
) or else In_Private_Part
(S
))
13982 and then Is_Generic_Instance
(S
)
13991 end In_Instance_Not_Visible
;
13993 ------------------------------
13994 -- In_Instance_Visible_Part --
13995 ------------------------------
13997 function In_Instance_Visible_Part
13998 (Id
: Entity_Id
:= Current_Scope
) return Boolean
14004 while Present
(Inst
) and then Inst
/= Standard_Standard
loop
14005 if Ekind
(Inst
) = E_Package
14006 and then Is_Generic_Instance
(Inst
)
14007 and then not In_Package_Body
(Inst
)
14008 and then not In_Private_Part
(Inst
)
14013 Inst
:= Scope
(Inst
);
14017 end In_Instance_Visible_Part
;
14019 ---------------------
14020 -- In_Package_Body --
14021 ---------------------
14023 function In_Package_Body
return Boolean is
14027 S
:= Current_Scope
;
14028 while Present
(S
) and then S
/= Standard_Standard
loop
14029 if Ekind
(S
) = E_Package
and then In_Package_Body
(S
) then
14037 end In_Package_Body
;
14039 --------------------------
14040 -- In_Pragma_Expression --
14041 --------------------------
14043 function In_Pragma_Expression
(N
: Node_Id
; Nam
: Name_Id
) return Boolean is
14051 -- Prevent the search from going too far
14053 elsif Is_Body_Or_Package_Declaration
(P
) then
14056 elsif Nkind
(P
) = N_Pragma
and then Pragma_Name
(P
) = Nam
then
14063 end In_Pragma_Expression
;
14065 ---------------------------
14066 -- In_Pre_Post_Condition --
14067 ---------------------------
14069 function In_Pre_Post_Condition
14070 (N
: Node_Id
; Class_Wide_Only
: Boolean := False) return Boolean
14073 Prag
: Node_Id
:= Empty
;
14074 Prag_Id
: Pragma_Id
;
14077 -- Climb the parent chain looking for an enclosing pragma
14080 while Present
(Par
) loop
14081 if Nkind
(Par
) = N_Pragma
then
14085 -- Prevent the search from going too far
14087 elsif Is_Body_Or_Package_Declaration
(Par
) then
14091 Par
:= Parent
(Par
);
14094 if Present
(Prag
) then
14095 Prag_Id
:= Get_Pragma_Id
(Prag
);
14097 if Class_Wide_Only
then
14099 Prag_Id
= Pragma_Post_Class
14100 or else Prag_Id
= Pragma_Pre_Class
14101 or else (Class_Present
(Prag
)
14102 and then (Prag_Id
= Pragma_Post
14103 or else Prag_Id
= Pragma_Postcondition
14104 or else Prag_Id
= Pragma_Pre
14105 or else Prag_Id
= Pragma_Precondition
));
14108 Prag_Id
= Pragma_Post
14109 or else Prag_Id
= Pragma_Post_Class
14110 or else Prag_Id
= Pragma_Postcondition
14111 or else Prag_Id
= Pragma_Pre
14112 or else Prag_Id
= Pragma_Pre_Class
14113 or else Prag_Id
= Pragma_Precondition
;
14116 -- Otherwise the node is not enclosed by a pre/postcondition pragma
14121 end In_Pre_Post_Condition
;
14123 ------------------------------
14124 -- In_Quantified_Expression --
14125 ------------------------------
14127 function In_Quantified_Expression
(N
: Node_Id
) return Boolean is
14135 -- Prevent the search from going too far
14137 elsif Is_Body_Or_Package_Declaration
(P
) then
14140 elsif Nkind
(P
) = N_Quantified_Expression
then
14146 end In_Quantified_Expression
;
14148 -------------------------------------
14149 -- In_Reverse_Storage_Order_Object --
14150 -------------------------------------
14152 function In_Reverse_Storage_Order_Object
(N
: Node_Id
) return Boolean is
14154 Btyp
: Entity_Id
:= Empty
;
14157 -- Climb up indexed components
14161 case Nkind
(Pref
) is
14162 when N_Selected_Component
=>
14163 Pref
:= Prefix
(Pref
);
14166 when N_Indexed_Component
=>
14167 Pref
:= Prefix
(Pref
);
14175 if Present
(Pref
) then
14176 Btyp
:= Base_Type
(Etype
(Pref
));
14179 return Present
(Btyp
)
14180 and then (Is_Record_Type
(Btyp
) or else Is_Array_Type
(Btyp
))
14181 and then Reverse_Storage_Order
(Btyp
);
14182 end In_Reverse_Storage_Order_Object
;
14184 ------------------------------
14185 -- In_Same_Declarative_Part --
14186 ------------------------------
14188 function In_Same_Declarative_Part
14189 (Context
: Node_Id
;
14190 N
: Node_Id
) return Boolean
14192 Cont
: Node_Id
:= Context
;
14196 if Nkind
(Cont
) = N_Compilation_Unit_Aux
then
14197 Cont
:= Parent
(Cont
);
14201 while Present
(Nod
) loop
14205 elsif Nkind
(Nod
) in N_Accept_Statement
14206 | N_Block_Statement
14207 | N_Compilation_Unit
14210 | N_Package_Declaration
14212 | N_Subprogram_Body
14217 elsif Nkind
(Nod
) = N_Subunit
then
14218 Nod
:= Corresponding_Stub
(Nod
);
14221 Nod
:= Parent
(Nod
);
14226 end In_Same_Declarative_Part
;
14228 --------------------------------------
14229 -- In_Subprogram_Or_Concurrent_Unit --
14230 --------------------------------------
14232 function In_Subprogram_Or_Concurrent_Unit
return Boolean is
14237 -- Use scope chain to check successively outer scopes
14239 E
:= Current_Scope
;
14243 if K
in Subprogram_Kind
14244 or else K
in Concurrent_Kind
14245 or else K
in Generic_Subprogram_Kind
14249 elsif E
= Standard_Standard
then
14255 end In_Subprogram_Or_Concurrent_Unit
;
14261 function In_Subtree
(N
: Node_Id
; Root
: Node_Id
) return Boolean is
14266 while Present
(Curr
) loop
14267 if Curr
= Root
then
14271 Curr
:= Parent
(Curr
);
14281 function In_Subtree
14284 Root2
: Node_Id
) return Boolean
14290 while Present
(Curr
) loop
14291 if Curr
= Root1
or else Curr
= Root2
then
14295 Curr
:= Parent
(Curr
);
14301 ---------------------
14302 -- In_Return_Value --
14303 ---------------------
14305 function In_Return_Value
(Expr
: Node_Id
) return Boolean is
14307 Prev_Par
: Node_Id
;
14309 In_Function_Call
: Boolean := False;
14312 -- Move through parent nodes to determine if Expr contributes to the
14313 -- return value of the current subprogram.
14317 while Present
(Par
) loop
14319 case Nkind
(Par
) is
14320 -- Ignore ranges and they don't contribute to the result
14325 -- An object declaration whose parent is an extended return
14326 -- statement is a return object.
14328 when N_Object_Declaration
=>
14329 if Present
(Parent
(Par
))
14330 and then Nkind
(Parent
(Par
)) = N_Extended_Return_Statement
14335 -- We hit a simple return statement, so we know we are in one
14337 when N_Simple_Return_Statement
=>
14340 -- Only include one nexting level of function calls
14342 when N_Function_Call
=>
14343 if not In_Function_Call
then
14344 In_Function_Call
:= True;
14346 -- When the function return type has implicit dereference
14347 -- specified we know it cannot directly contribute to the
14350 if Present
(Etype
(Par
))
14351 and then Has_Implicit_Dereference
14352 (Get_Full_View
(Etype
(Par
)))
14360 -- Check if we are on the right-hand side of an assignment
14361 -- statement to a return object.
14363 -- This is not specified in the RM ???
14365 when N_Assignment_Statement
=>
14366 if Prev_Par
= Name
(Par
) then
14371 while Present
(Pre
) loop
14372 if Is_Entity_Name
(Pre
)
14373 and then Is_Return_Object
(Entity
(Pre
))
14378 exit when Nkind
(Pre
) not in N_Selected_Component
14379 | N_Indexed_Component
14382 Pre
:= Prefix
(Pre
);
14385 -- Otherwise, we hit a master which was not relevant
14388 if Is_Master
(Par
) then
14393 -- Iterate up to the next parent, keeping track of the previous one
14396 Par
:= Parent
(Par
);
14400 end In_Return_Value
;
14402 -----------------------------------------
14403 -- In_Statement_Condition_With_Actions --
14404 -----------------------------------------
14406 function In_Statement_Condition_With_Actions
(N
: Node_Id
) return Boolean is
14407 Prev
: Node_Id
:= N
;
14408 P
: Node_Id
:= Parent
(N
);
14409 -- P and Prev will be used for traversing the AST, while maintaining an
14410 -- invariant that P = Parent (Prev).
14412 while Present
(P
) loop
14413 if Nkind
(P
) = N_Iteration_Scheme
14414 and then Prev
= Condition
(P
)
14418 elsif Nkind
(P
) = N_Elsif_Part
14419 and then Prev
= Condition
(P
)
14423 -- No point in going beyond statements
14425 elsif Nkind
(N
) in N_Statement_Other_Than_Procedure_Call
14426 | N_Procedure_Call_Statement
14430 -- Prevent the search from going too far
14432 elsif Is_Body_Or_Package_Declaration
(P
) then
14441 end In_Statement_Condition_With_Actions
;
14443 ---------------------
14444 -- In_Visible_Part --
14445 ---------------------
14447 function In_Visible_Part
(Scope_Id
: Entity_Id
) return Boolean is
14449 return Is_Package_Or_Generic_Package
(Scope_Id
)
14450 and then In_Open_Scopes
(Scope_Id
)
14451 and then not In_Package_Body
(Scope_Id
)
14452 and then not In_Private_Part
(Scope_Id
);
14453 end In_Visible_Part
;
14455 --------------------------------
14456 -- Incomplete_Or_Partial_View --
14457 --------------------------------
14459 function Incomplete_Or_Partial_View
(Id
: Entity_Id
) return Entity_Id
is
14460 S
: constant Entity_Id
:= Scope
(Id
);
14462 function Inspect_Decls
14464 Taft
: Boolean := False) return Entity_Id
;
14465 -- Check whether a declarative region contains the incomplete or partial
14468 -------------------
14469 -- Inspect_Decls --
14470 -------------------
14472 function Inspect_Decls
14474 Taft
: Boolean := False) return Entity_Id
14480 Decl
:= First
(Decls
);
14481 while Present
(Decl
) loop
14484 -- The partial view of a Taft-amendment type is an incomplete
14488 if Nkind
(Decl
) = N_Incomplete_Type_Declaration
then
14489 Match
:= Defining_Identifier
(Decl
);
14492 -- Otherwise look for a private type whose full view matches the
14493 -- input type. Note that this checks full_type_declaration nodes
14494 -- to account for derivations from a private type where the type
14495 -- declaration hold the partial view and the full view is an
14498 elsif Nkind
(Decl
) in N_Full_Type_Declaration
14499 | N_Private_Extension_Declaration
14500 | N_Private_Type_Declaration
14502 Match
:= Defining_Identifier
(Decl
);
14505 -- Guard against unanalyzed entities
14508 and then Is_Type
(Match
)
14509 and then Present
(Full_View
(Match
))
14510 and then Full_View
(Match
) = Id
14525 -- Start of processing for Incomplete_Or_Partial_View
14528 -- Deferred constant or incomplete type case
14530 Prev
:= Current_Entity
(Id
);
14532 while Present
(Prev
) loop
14533 exit when Scope
(Prev
) = S
;
14535 Prev
:= Homonym
(Prev
);
14539 and then (Is_Incomplete_Type
(Prev
) or else Ekind
(Prev
) = E_Constant
)
14540 and then Present
(Full_View
(Prev
))
14541 and then Full_View
(Prev
) = Id
14546 -- Private or Taft amendment type case
14548 if Present
(S
) and then Is_Package_Or_Generic_Package
(S
) then
14550 Pkg_Decl
: constant Node_Id
:= Package_Specification
(S
);
14553 -- It is knows that Typ has a private view, look for it in the
14554 -- visible declarations of the enclosing scope. A special case
14555 -- of this is when the two views have been exchanged - the full
14556 -- appears earlier than the private.
14558 if Has_Private_Declaration
(Id
) then
14559 Prev
:= Inspect_Decls
(Visible_Declarations
(Pkg_Decl
));
14561 -- Exchanged view case, look in the private declarations
14564 Prev
:= Inspect_Decls
(Private_Declarations
(Pkg_Decl
));
14569 -- Otherwise if this is the package body, then Typ is a potential
14570 -- Taft amendment type. The incomplete view should be located in
14571 -- the private declarations of the enclosing scope.
14573 elsif In_Package_Body
(S
) then
14574 return Inspect_Decls
(Private_Declarations
(Pkg_Decl
), True);
14579 -- The type has no incomplete or private view
14582 end Incomplete_Or_Partial_View
;
14584 ---------------------------------------
14585 -- Incomplete_View_From_Limited_With --
14586 ---------------------------------------
14588 function Incomplete_View_From_Limited_With
14589 (Typ
: Entity_Id
) return Entity_Id
14592 -- It might make sense to make this an attribute in Einfo, and set it
14593 -- in Sem_Ch10 in Build_Shadow_Entity. However, we're running short on
14594 -- slots for new attributes, and it seems a bit simpler to just search
14595 -- the Limited_View (if it exists) for an incomplete type whose
14596 -- Non_Limited_View is Typ.
14598 if Ekind
(Scope
(Typ
)) = E_Package
14599 and then Present
(Limited_View
(Scope
(Typ
)))
14602 Ent
: Entity_Id
:= First_Entity
(Limited_View
(Scope
(Typ
)));
14604 while Present
(Ent
) loop
14605 if Is_Incomplete_Type
(Ent
)
14606 and then Non_Limited_View
(Ent
) = Typ
14617 end Incomplete_View_From_Limited_With
;
14619 ----------------------------------
14620 -- Indexed_Component_Bit_Offset --
14621 ----------------------------------
14623 function Indexed_Component_Bit_Offset
(N
: Node_Id
) return Uint
is
14624 Exp
: constant Node_Id
:= First
(Expressions
(N
));
14625 Typ
: constant Entity_Id
:= Etype
(Prefix
(N
));
14626 Off
: constant Uint
:= Component_Size
(Typ
);
14630 -- Return early if the component size is not known or variable
14632 if No
(Off
) or else Off
< Uint_0
then
14636 -- Deal with the degenerate case of an empty component
14638 if Off
= Uint_0
then
14642 -- Check that both the index value and the low bound are known
14644 if not Compile_Time_Known_Value
(Exp
) then
14648 Ind
:= First_Index
(Typ
);
14653 -- Do not attempt to compute offsets within multi-dimensional arrays
14655 if Present
(Next_Index
(Ind
)) then
14659 if Nkind
(Ind
) = N_Subtype_Indication
then
14660 Ind
:= Constraint
(Ind
);
14662 if Nkind
(Ind
) = N_Range_Constraint
then
14663 Ind
:= Range_Expression
(Ind
);
14667 if Nkind
(Ind
) /= N_Range
14668 or else not Compile_Time_Known_Value
(Low_Bound
(Ind
))
14673 -- Return the scaled offset
14675 return Off
* (Expr_Value
(Exp
) - Expr_Value
(Low_Bound
(Ind
)));
14676 end Indexed_Component_Bit_Offset
;
14678 -----------------------------
14679 -- Inherit_Predicate_Flags --
14680 -----------------------------
14682 procedure Inherit_Predicate_Flags
14683 (Subt
, Par
: Entity_Id
;
14684 Only_Flags
: Boolean := False)
14687 if Ada_Version
< Ada_2012
14688 or else Present
(Predicate_Function
(Subt
))
14693 Set_Has_Predicates
(Subt
, Has_Predicates
(Par
));
14694 Set_Has_Static_Predicate_Aspect
14695 (Subt
, Has_Static_Predicate_Aspect
(Par
));
14696 Set_Has_Dynamic_Predicate_Aspect
14697 (Subt
, Has_Dynamic_Predicate_Aspect
(Par
));
14698 Set_Has_Ghost_Predicate_Aspect
14699 (Subt
, Has_Ghost_Predicate_Aspect
(Par
));
14701 -- A named subtype does not inherit the predicate function of its
14702 -- parent but an itype declared for a loop index needs the discrete
14703 -- predicate information of its parent to execute the loop properly.
14704 -- A non-discrete type may has a static predicate (for example True)
14705 -- but has no static_discrete_predicate.
14708 and then Is_Itype
(Subt
)
14709 and then Present
(Predicate_Function
(Par
))
14711 Set_Subprograms_For_Type
(Subt
, Subprograms_For_Type
(Par
));
14713 if Has_Static_Predicate
(Par
) and then Is_Discrete_Type
(Par
) then
14714 Set_Static_Discrete_Predicate
14715 (Subt
, Static_Discrete_Predicate
(Par
));
14718 end Inherit_Predicate_Flags
;
14720 ----------------------------
14721 -- Inherit_Rep_Item_Chain --
14722 ----------------------------
14724 procedure Inherit_Rep_Item_Chain
(Typ
: Entity_Id
; From_Typ
: Entity_Id
) is
14726 Next_Item
: Node_Id
;
14729 -- There are several inheritance scenarios to consider depending on
14730 -- whether both types have rep item chains and whether the destination
14731 -- type already inherits part of the source type's rep item chain.
14733 -- 1) The source type lacks a rep item chain
14734 -- From_Typ ---> Empty
14736 -- Typ --------> Item (or Empty)
14738 -- In this case inheritance cannot take place because there are no items
14741 -- 2) The destination type lacks a rep item chain
14742 -- From_Typ ---> Item ---> ...
14744 -- Typ --------> Empty
14746 -- Inheritance takes place by setting the First_Rep_Item of the
14747 -- destination type to the First_Rep_Item of the source type.
14748 -- From_Typ ---> Item ---> ...
14750 -- Typ -----------+
14752 -- 3.1) Both source and destination types have at least one rep item.
14753 -- The destination type does NOT inherit a rep item from the source
14755 -- From_Typ ---> Item ---> Item
14757 -- Typ --------> Item ---> Item
14759 -- Inheritance takes place by setting the Next_Rep_Item of the last item
14760 -- of the destination type to the First_Rep_Item of the source type.
14761 -- From_Typ -------------------> Item ---> Item
14763 -- Typ --------> Item ---> Item --+
14765 -- 3.2) Both source and destination types have at least one rep item.
14766 -- The destination type DOES inherit part of the rep item chain of the
14768 -- From_Typ ---> Item ---> Item ---> Item
14770 -- Typ --------> Item ------+
14772 -- This rare case arises when the full view of a private extension must
14773 -- inherit the rep item chain from the full view of its parent type and
14774 -- the full view of the parent type contains extra rep items. Currently
14775 -- only invariants may lead to such form of inheritance.
14777 -- type From_Typ is tagged private
14778 -- with Type_Invariant'Class => Item_2;
14780 -- type Typ is new From_Typ with private
14781 -- with Type_Invariant => Item_4;
14783 -- At this point the rep item chains contain the following items
14785 -- From_Typ -----------> Item_2 ---> Item_3
14787 -- Typ --------> Item_4 --+
14789 -- The full views of both types may introduce extra invariants
14791 -- type From_Typ is tagged null record
14792 -- with Type_Invariant => Item_1;
14794 -- type Typ is new From_Typ with null record;
14796 -- The full view of Typ would have to inherit any new rep items added to
14797 -- the full view of From_Typ.
14799 -- From_Typ -----------> Item_1 ---> Item_2 ---> Item_3
14801 -- Typ --------> Item_4 --+
14803 -- To achieve this form of inheritance, the destination type must first
14804 -- sever the link between its own rep chain and that of the source type,
14805 -- then inheritance 3.1 takes place.
14807 -- Case 1: The source type lacks a rep item chain
14809 if No
(First_Rep_Item
(From_Typ
)) then
14812 -- Case 2: The destination type lacks a rep item chain
14814 elsif No
(First_Rep_Item
(Typ
)) then
14815 Set_First_Rep_Item
(Typ
, First_Rep_Item
(From_Typ
));
14817 -- Case 3: Both the source and destination types have at least one rep
14818 -- item. Traverse the rep item chain of the destination type to find the
14823 Next_Item
:= First_Rep_Item
(Typ
);
14824 while Present
(Next_Item
) loop
14826 -- Detect a link between the destination type's rep chain and that
14827 -- of the source type. There are two possibilities:
14832 -- From_Typ ---> Item_1 --->
14834 -- Typ -----------+
14841 -- From_Typ ---> Item_1 ---> Item_2 --->
14843 -- Typ --------> Item_3 ------+
14847 if Present_In_Rep_Item
(From_Typ
, Next_Item
) then
14852 Next_Item
:= Next_Rep_Item
(Next_Item
);
14855 -- Inherit the source type's rep item chain
14857 if Present
(Item
) then
14858 Set_Next_Rep_Item
(Item
, First_Rep_Item
(From_Typ
));
14860 Set_First_Rep_Item
(Typ
, First_Rep_Item
(From_Typ
));
14863 end Inherit_Rep_Item_Chain
;
14865 ------------------------------------
14866 -- Inherits_From_Tagged_Full_View --
14867 ------------------------------------
14869 function Inherits_From_Tagged_Full_View
(Typ
: Entity_Id
) return Boolean is
14871 return Is_Private_Type
(Typ
)
14872 and then Present
(Full_View
(Typ
))
14873 and then Is_Private_Type
(Full_View
(Typ
))
14874 and then not Is_Tagged_Type
(Full_View
(Typ
))
14875 and then Present
(Underlying_Type
(Full_View
(Typ
)))
14876 and then Is_Tagged_Type
(Underlying_Type
(Full_View
(Typ
)));
14877 end Inherits_From_Tagged_Full_View
;
14879 ---------------------------------
14880 -- Insert_Explicit_Dereference --
14881 ---------------------------------
14883 procedure Insert_Explicit_Dereference
(N
: Node_Id
) is
14884 New_Prefix
: constant Node_Id
:= Relocate_Node
(N
);
14885 Ent
: Entity_Id
:= Empty
;
14886 Pref
: Node_Id
:= Empty
;
14892 Save_Interps
(N
, New_Prefix
);
14895 Make_Explicit_Dereference
(Sloc
(Parent
(N
)),
14896 Prefix
=> New_Prefix
));
14898 Set_Etype
(N
, Designated_Type
(Etype
(New_Prefix
)));
14900 if Is_Overloaded
(New_Prefix
) then
14902 -- The dereference is also overloaded, and its interpretations are
14903 -- the designated types of the interpretations of the original node.
14905 Set_Etype
(N
, Any_Type
);
14907 Get_First_Interp
(New_Prefix
, I
, It
);
14908 while Present
(It
.Nam
) loop
14911 if Is_Access_Type
(T
) then
14912 Add_One_Interp
(N
, Designated_Type
(T
), Designated_Type
(T
));
14915 Get_Next_Interp
(I
, It
);
14919 -- Prefix is unambiguous: mark the original prefix (which might
14920 -- Come_From_Source) as a reference, since the new (relocated) one
14921 -- won't be taken into account.
14923 if Is_Entity_Name
(New_Prefix
) then
14924 Ent
:= Entity
(New_Prefix
);
14925 Pref
:= New_Prefix
;
14927 -- For a retrieval of a subcomponent of some composite object,
14928 -- retrieve the ultimate entity if there is one.
14930 elsif Nkind
(New_Prefix
) in N_Selected_Component | N_Indexed_Component
14932 Pref
:= Prefix
(New_Prefix
);
14933 while Present
(Pref
)
14934 and then Nkind
(Pref
) in
14935 N_Selected_Component | N_Indexed_Component
14937 Pref
:= Prefix
(Pref
);
14940 if Present
(Pref
) and then Is_Entity_Name
(Pref
) then
14941 Ent
:= Entity
(Pref
);
14945 -- Place the reference on the entity node
14947 if Present
(Ent
) then
14948 Generate_Reference
(Ent
, Pref
);
14951 end Insert_Explicit_Dereference
;
14953 ------------------------------------------
14954 -- Inspect_Deferred_Constant_Completion --
14955 ------------------------------------------
14957 procedure Inspect_Deferred_Constant_Completion
(Decls
: List_Id
) is
14961 Decl
:= First
(Decls
);
14962 while Present
(Decl
) loop
14964 -- Deferred constant signature
14966 if Nkind
(Decl
) = N_Object_Declaration
14967 and then Constant_Present
(Decl
)
14968 and then No
(Expression
(Decl
))
14970 -- No need to check internally generated constants
14972 and then Comes_From_Source
(Decl
)
14974 -- The constant is not completed. A full object declaration or a
14975 -- pragma Import complete a deferred constant.
14977 and then not Has_Completion
(Defining_Identifier
(Decl
))
14980 ("constant declaration requires initialization expression",
14981 Defining_Identifier
(Decl
));
14986 end Inspect_Deferred_Constant_Completion
;
14988 -------------------------------
14989 -- Install_Elaboration_Model --
14990 -------------------------------
14992 procedure Install_Elaboration_Model
(Unit_Id
: Entity_Id
) is
14993 function Find_Elaboration_Checks_Pragma
(L
: List_Id
) return Node_Id
;
14994 -- Try to find pragma Elaboration_Checks in arbitrary list L. Return
14995 -- Empty if there is no such pragma.
14997 ------------------------------------
14998 -- Find_Elaboration_Checks_Pragma --
14999 ------------------------------------
15001 function Find_Elaboration_Checks_Pragma
(L
: List_Id
) return Node_Id
is
15006 while Present
(Item
) loop
15007 if Nkind
(Item
) = N_Pragma
15008 and then Pragma_Name
(Item
) = Name_Elaboration_Checks
15017 end Find_Elaboration_Checks_Pragma
;
15026 -- Start of processing for Install_Elaboration_Model
15029 -- Nothing to do when the unit does not exist
15031 if No
(Unit_Id
) then
15035 Unit
:= Parent
(Unit_Declaration_Node
(Unit_Id
));
15037 -- Nothing to do when the unit is not a library unit
15039 if Nkind
(Unit
) /= N_Compilation_Unit
then
15043 Prag
:= Find_Elaboration_Checks_Pragma
(Context_Items
(Unit
));
15045 -- The compilation unit is subject to pragma Elaboration_Checks. Set the
15046 -- elaboration model as specified by the pragma.
15048 if Present
(Prag
) then
15049 Args
:= Pragma_Argument_Associations
(Prag
);
15051 -- Guard against an illegal pragma. The sole argument must be an
15052 -- identifier which specifies either Dynamic or Static model.
15054 if Present
(Args
) then
15055 Model
:= Get_Pragma_Arg
(First
(Args
));
15057 if Nkind
(Model
) = N_Identifier
then
15058 Dynamic_Elaboration_Checks
:= Chars
(Model
) = Name_Dynamic
;
15062 end Install_Elaboration_Model
;
15064 -----------------------------
15065 -- Install_Generic_Formals --
15066 -----------------------------
15068 procedure Install_Generic_Formals
(Subp_Id
: Entity_Id
) is
15072 pragma Assert
(Is_Generic_Subprogram
(Subp_Id
));
15074 E
:= First_Entity
(Subp_Id
);
15075 while Present
(E
) loop
15076 Install_Entity
(E
);
15079 end Install_Generic_Formals
;
15081 ------------------------
15082 -- Install_SPARK_Mode --
15083 ------------------------
15085 procedure Install_SPARK_Mode
(Mode
: SPARK_Mode_Type
; Prag
: Node_Id
) is
15087 SPARK_Mode
:= Mode
;
15088 SPARK_Mode_Pragma
:= Prag
;
15089 end Install_SPARK_Mode
;
15091 --------------------------
15092 -- Invalid_Scalar_Value --
15093 --------------------------
15095 function Invalid_Scalar_Value
15097 Scal_Typ
: Scalar_Id
) return Node_Id
15099 function Invalid_Binder_Value
return Node_Id
;
15100 -- Return a reference to the corresponding invalid value for type
15101 -- Scal_Typ as defined in unit System.Scalar_Values.
15103 function Invalid_Float_Value
return Node_Id
;
15104 -- Return the invalid value of float type Scal_Typ
15106 function Invalid_Integer_Value
return Node_Id
;
15107 -- Return the invalid value of integer type Scal_Typ
15109 procedure Set_Invalid_Binder_Values
;
15110 -- Set the contents of collection Invalid_Binder_Values
15112 --------------------------
15113 -- Invalid_Binder_Value --
15114 --------------------------
15116 function Invalid_Binder_Value
return Node_Id
is
15117 Val_Id
: Entity_Id
;
15120 -- Initialize the collection of invalid binder values the first time
15123 Set_Invalid_Binder_Values
;
15125 -- Obtain the corresponding variable from System.Scalar_Values which
15126 -- holds the invalid value for this type.
15128 Val_Id
:= Invalid_Binder_Values
(Scal_Typ
);
15129 pragma Assert
(Present
(Val_Id
));
15131 return New_Occurrence_Of
(Val_Id
, Loc
);
15132 end Invalid_Binder_Value
;
15134 -------------------------
15135 -- Invalid_Float_Value --
15136 -------------------------
15138 function Invalid_Float_Value
return Node_Id
is
15139 Value
: constant Ureal
:= Invalid_Floats
(Scal_Typ
);
15142 -- Pragma Invalid_Scalars did not specify an invalid value for this
15143 -- type. Fall back to the value provided by the binder.
15145 if Value
= No_Ureal
then
15146 return Invalid_Binder_Value
;
15148 return Make_Real_Literal
(Loc
, Realval
=> Value
);
15150 end Invalid_Float_Value
;
15152 ---------------------------
15153 -- Invalid_Integer_Value --
15154 ---------------------------
15156 function Invalid_Integer_Value
return Node_Id
is
15157 Value
: constant Uint
:= Invalid_Integers
(Scal_Typ
);
15160 -- Pragma Invalid_Scalars did not specify an invalid value for this
15161 -- type. Fall back to the value provided by the binder.
15164 return Invalid_Binder_Value
;
15166 return Make_Integer_Literal
(Loc
, Intval
=> Value
);
15168 end Invalid_Integer_Value
;
15170 -------------------------------
15171 -- Set_Invalid_Binder_Values --
15172 -------------------------------
15174 procedure Set_Invalid_Binder_Values
is
15176 if not Invalid_Binder_Values_Set
then
15177 Invalid_Binder_Values_Set
:= True;
15179 -- Initialize the contents of the collection once since RTE calls
15182 Invalid_Binder_Values
:=
15183 (Name_Short_Float
=> RTE
(RE_IS_Isf
),
15184 Name_Float
=> RTE
(RE_IS_Ifl
),
15185 Name_Long_Float
=> RTE
(RE_IS_Ilf
),
15186 Name_Long_Long_Float
=> RTE
(RE_IS_Ill
),
15187 Name_Signed_8
=> RTE
(RE_IS_Is1
),
15188 Name_Signed_16
=> RTE
(RE_IS_Is2
),
15189 Name_Signed_32
=> RTE
(RE_IS_Is4
),
15190 Name_Signed_64
=> RTE
(RE_IS_Is8
),
15191 Name_Signed_128
=> Empty
,
15192 Name_Unsigned_8
=> RTE
(RE_IS_Iu1
),
15193 Name_Unsigned_16
=> RTE
(RE_IS_Iu2
),
15194 Name_Unsigned_32
=> RTE
(RE_IS_Iu4
),
15195 Name_Unsigned_64
=> RTE
(RE_IS_Iu8
),
15196 Name_Unsigned_128
=> Empty
);
15198 if System_Max_Integer_Size
< 128 then
15199 Invalid_Binder_Values
(Name_Signed_128
) := RTE
(RE_IS_Is8
);
15200 Invalid_Binder_Values
(Name_Unsigned_128
) := RTE
(RE_IS_Iu8
);
15202 Invalid_Binder_Values
(Name_Signed_128
) := RTE
(RE_IS_Is16
);
15203 Invalid_Binder_Values
(Name_Unsigned_128
) := RTE
(RE_IS_Iu16
);
15206 end Set_Invalid_Binder_Values
;
15208 -- Start of processing for Invalid_Scalar_Value
15211 if Scal_Typ
in Float_Scalar_Id
then
15212 return Invalid_Float_Value
;
15214 else pragma Assert
(Scal_Typ
in Integer_Scalar_Id
);
15215 return Invalid_Integer_Value
;
15217 end Invalid_Scalar_Value
;
15219 ------------------------
15220 -- Is_Access_Variable --
15221 ------------------------
15223 function Is_Access_Variable
(E
: Entity_Id
) return Boolean is
15225 return Is_Access_Type
(E
)
15226 and then not Is_Access_Constant
(E
)
15227 and then Ekind
(Directly_Designated_Type
(E
)) /= E_Subprogram_Type
;
15228 end Is_Access_Variable
;
15230 -----------------------------
15231 -- Is_Actual_Out_Parameter --
15232 -----------------------------
15234 function Is_Actual_Out_Parameter
(N
: Node_Id
) return Boolean is
15235 Formal
: Entity_Id
;
15238 Find_Actual
(N
, Formal
, Call
);
15239 return Present
(Formal
) and then Ekind
(Formal
) = E_Out_Parameter
;
15240 end Is_Actual_Out_Parameter
;
15242 --------------------------------
15243 -- Is_Actual_In_Out_Parameter --
15244 --------------------------------
15246 function Is_Actual_In_Out_Parameter
(N
: Node_Id
) return Boolean is
15247 Formal
: Entity_Id
;
15250 Find_Actual
(N
, Formal
, Call
);
15251 return Present
(Formal
) and then Ekind
(Formal
) = E_In_Out_Parameter
;
15252 end Is_Actual_In_Out_Parameter
;
15254 ---------------------------------------
15255 -- Is_Actual_Out_Or_In_Out_Parameter --
15256 ---------------------------------------
15258 function Is_Actual_Out_Or_In_Out_Parameter
(N
: Node_Id
) return Boolean is
15259 Formal
: Entity_Id
;
15262 Find_Actual
(N
, Formal
, Call
);
15263 return Present
(Formal
)
15264 and then Ekind
(Formal
) in E_Out_Parameter | E_In_Out_Parameter
;
15265 end Is_Actual_Out_Or_In_Out_Parameter
;
15267 -------------------------
15268 -- Is_Actual_Parameter --
15269 -------------------------
15271 function Is_Actual_Parameter
(N
: Node_Id
) return Boolean is
15272 PK
: constant Node_Kind
:= Nkind
(Parent
(N
));
15276 when N_Parameter_Association
=>
15277 return N
= Explicit_Actual_Parameter
(Parent
(N
));
15279 when N_Entry_Call_Statement
15280 | N_Subprogram_Call
15282 return Is_List_Member
(N
)
15284 List_Containing
(N
) = Parameter_Associations
(Parent
(N
));
15289 end Is_Actual_Parameter
;
15291 ---------------------
15292 -- Is_Aliased_View --
15293 ---------------------
15295 function Is_Aliased_View
(Obj
: Node_Id
) return Boolean is
15299 if Is_Entity_Name
(Obj
) then
15306 or else (Present
(Renamed_Object
(E
))
15307 and then Is_Aliased_View
(Renamed_Object
(E
)))))
15309 or else ((Is_Formal
(E
) or else Is_Formal_Object
(E
))
15310 and then Is_Tagged_Type
(Etype
(E
)))
15312 or else (Is_Concurrent_Type
(E
) and then In_Open_Scopes
(E
))
15314 -- Current instance of type, either directly or as rewritten
15315 -- reference to the current object.
15317 or else (Is_Entity_Name
(Original_Node
(Obj
))
15318 and then Present
(Entity
(Original_Node
(Obj
)))
15319 and then Is_Type
(Entity
(Original_Node
(Obj
))))
15321 or else (Is_Type
(E
) and then E
= Current_Scope
)
15323 or else (Is_Incomplete_Or_Private_Type
(E
)
15324 and then Full_View
(E
) = Current_Scope
)
15326 -- Ada 2012 AI05-0053: the return object of an extended return
15327 -- statement is aliased if its type is immutably limited.
15329 or else (Is_Return_Object
(E
)
15330 and then Is_Limited_View
(Etype
(E
)))
15332 -- The current instance of a limited type is aliased, so
15333 -- we want to allow uses of T'Access in the init proc for
15334 -- a limited type T. However, we don't want to mark the formal
15335 -- parameter as being aliased since that could impact callers.
15337 or else (Is_Formal
(E
)
15338 and then Chars
(E
) = Name_uInit
15339 and then Is_Limited_View
(Etype
(E
)));
15341 elsif Nkind
(Obj
) = N_Selected_Component
then
15342 return Is_Aliased
(Entity
(Selector_Name
(Obj
)));
15344 elsif Nkind
(Obj
) = N_Indexed_Component
then
15345 return Has_Aliased_Components
(Etype
(Prefix
(Obj
)))
15347 (Is_Access_Type
(Etype
(Prefix
(Obj
)))
15348 and then Has_Aliased_Components
15349 (Designated_Type
(Etype
(Prefix
(Obj
)))));
15351 elsif Nkind
(Obj
) in N_Unchecked_Type_Conversion | N_Type_Conversion
then
15352 return Is_Tagged_Type
(Etype
(Obj
))
15353 and then Is_Aliased_View
(Expression
(Obj
));
15355 -- Ada 2022 AI12-0228
15357 elsif Nkind
(Obj
) = N_Qualified_Expression
15358 and then Ada_Version
>= Ada_2012
15360 return Is_Aliased_View
(Expression
(Obj
));
15362 -- The dereference of an access-to-object value denotes an aliased view,
15363 -- but this routine uses the rules of the language so we need to exclude
15364 -- rewritten constructs that introduce artificial dereferences.
15366 elsif Nkind
(Obj
) = N_Explicit_Dereference
then
15367 return not Is_Captured_Function_Call
(Obj
)
15369 (Nkind
(Parent
(Obj
)) = N_Object_Renaming_Declaration
15370 and then Is_Return_Object
(Defining_Entity
(Parent
(Obj
))));
15375 end Is_Aliased_View
;
15377 -------------------------
15378 -- Is_Ancestor_Package --
15379 -------------------------
15381 function Is_Ancestor_Package
15383 E2
: Entity_Id
) return Boolean
15389 while Present
(Par
) and then Par
/= Standard_Standard
loop
15394 Par
:= Scope
(Par
);
15398 end Is_Ancestor_Package
;
15400 ----------------------
15401 -- Is_Atomic_Object --
15402 ----------------------
15404 function Is_Atomic_Object
(N
: Node_Id
) return Boolean is
15405 function Prefix_Has_Atomic_Components
(P
: Node_Id
) return Boolean;
15406 -- Determine whether prefix P has atomic components. This requires the
15407 -- presence of an Atomic_Components aspect/pragma.
15409 ---------------------------------
15410 -- Prefix_Has_Atomic_Components --
15411 ---------------------------------
15413 function Prefix_Has_Atomic_Components
(P
: Node_Id
) return Boolean is
15414 Typ
: constant Entity_Id
:= Etype
(P
);
15417 if Is_Access_Type
(Typ
) then
15418 return Has_Atomic_Components
(Designated_Type
(Typ
));
15420 elsif Has_Atomic_Components
(Typ
) then
15423 elsif Is_Entity_Name
(P
)
15424 and then Has_Atomic_Components
(Entity
(P
))
15431 end Prefix_Has_Atomic_Components
;
15433 -- Start of processing for Is_Atomic_Object
15436 if Is_Entity_Name
(N
) then
15437 return Is_Atomic_Object_Entity
(Entity
(N
));
15439 elsif Is_Atomic
(Etype
(N
)) then
15442 elsif Nkind
(N
) = N_Indexed_Component
then
15443 return Prefix_Has_Atomic_Components
(Prefix
(N
));
15445 elsif Nkind
(N
) = N_Selected_Component
then
15446 return Is_Atomic
(Entity
(Selector_Name
(N
)));
15451 end Is_Atomic_Object
;
15453 -----------------------------
15454 -- Is_Atomic_Object_Entity --
15455 -----------------------------
15457 function Is_Atomic_Object_Entity
(Id
: Entity_Id
) return Boolean is
15461 and then (Is_Atomic
(Id
) or else Is_Atomic
(Etype
(Id
)));
15462 end Is_Atomic_Object_Entity
;
15464 -----------------------------
15465 -- Is_Attribute_Loop_Entry --
15466 -----------------------------
15468 function Is_Attribute_Loop_Entry
(N
: Node_Id
) return Boolean is
15470 return Nkind
(N
) = N_Attribute_Reference
15471 and then Attribute_Name
(N
) = Name_Loop_Entry
;
15472 end Is_Attribute_Loop_Entry
;
15474 ----------------------
15475 -- Is_Attribute_Old --
15476 ----------------------
15478 function Is_Attribute_Old
(N
: Node_Id
) return Boolean is
15480 return Nkind
(N
) = N_Attribute_Reference
15481 and then Attribute_Name
(N
) = Name_Old
;
15482 end Is_Attribute_Old
;
15484 -------------------------
15485 -- Is_Attribute_Result --
15486 -------------------------
15488 function Is_Attribute_Result
(N
: Node_Id
) return Boolean is
15490 return Nkind
(N
) = N_Attribute_Reference
15491 and then Attribute_Name
(N
) = Name_Result
;
15492 end Is_Attribute_Result
;
15494 -------------------------
15495 -- Is_Attribute_Update --
15496 -------------------------
15498 function Is_Attribute_Update
(N
: Node_Id
) return Boolean is
15500 return Nkind
(N
) = N_Attribute_Reference
15501 and then Attribute_Name
(N
) = Name_Update
;
15502 end Is_Attribute_Update
;
15504 ------------------------------------
15505 -- Is_Body_Or_Package_Declaration --
15506 ------------------------------------
15508 function Is_Body_Or_Package_Declaration
(N
: Node_Id
) return Boolean is
15510 return Is_Body
(N
) or else Nkind
(N
) = N_Package_Declaration
;
15511 end Is_Body_Or_Package_Declaration
;
15513 -----------------------
15514 -- Is_Bounded_String --
15515 -----------------------
15517 function Is_Bounded_String
(T
: Entity_Id
) return Boolean is
15518 Under
: constant Entity_Id
:= Underlying_Type
(Root_Type
(T
));
15521 -- Check whether T is ultimately derived from Ada.Strings.Superbounded.
15522 -- Super_String, or one of the [Wide_]Wide_ versions. This will
15523 -- be True for all the Bounded_String types in instances of the
15524 -- Generic_Bounded_Length generics, and for types derived from those.
15526 return Present
(Under
)
15527 and then (Is_RTE
(Root_Type
(Under
), RO_SU_Super_String
) or else
15528 Is_RTE
(Root_Type
(Under
), RO_WI_Super_String
) or else
15529 Is_RTE
(Root_Type
(Under
), RO_WW_Super_String
));
15530 end Is_Bounded_String
;
15532 -------------------------------
15533 -- Is_By_Protected_Procedure --
15534 -------------------------------
15536 function Is_By_Protected_Procedure
(Id
: Entity_Id
) return Boolean is
15538 return Ekind
(Id
) = E_Procedure
15539 and then Present
(Get_Rep_Pragma
(Id
, Name_Implemented
))
15540 and then Implementation_Kind
(Id
) = Name_By_Protected_Procedure
;
15541 end Is_By_Protected_Procedure
;
15543 ---------------------
15544 -- Is_CCT_Instance --
15545 ---------------------
15547 function Is_CCT_Instance
15548 (Ref_Id
: Entity_Id
;
15549 Context_Id
: Entity_Id
) return Boolean
15552 pragma Assert
(Ekind
(Ref_Id
) in E_Protected_Type | E_Task_Type
);
15554 if Is_Single_Task_Object
(Context_Id
) then
15555 return Scope_Within_Or_Same
(Etype
(Context_Id
), Ref_Id
);
15559 (Ekind
(Context_Id
) in
15560 E_Entry | E_Entry_Family | E_Function | E_Package |
15561 E_Procedure | E_Protected_Type | E_Task_Type
15562 or else Is_Record_Type
(Context_Id
));
15563 return Scope_Within_Or_Same
(Context_Id
, Ref_Id
);
15565 end Is_CCT_Instance
;
15567 -------------------------
15568 -- Is_Child_Or_Sibling --
15569 -------------------------
15571 function Is_Child_Or_Sibling
15572 (Pack_1
: Entity_Id
;
15573 Pack_2
: Entity_Id
) return Boolean
15575 function Distance_From_Standard
(Pack
: Entity_Id
) return Nat
;
15576 -- Given an arbitrary package, return the number of "climbs" necessary
15577 -- to reach scope Standard_Standard.
15579 procedure Equalize_Depths
15580 (Pack
: in out Entity_Id
;
15581 Depth
: in out Nat
;
15582 Depth_To_Reach
: Nat
);
15583 -- Given an arbitrary package, its depth and a target depth to reach,
15584 -- climb the scope chain until the said depth is reached. The pointer
15585 -- to the package and its depth a modified during the climb.
15587 ----------------------------
15588 -- Distance_From_Standard --
15589 ----------------------------
15591 function Distance_From_Standard
(Pack
: Entity_Id
) return Nat
is
15598 while Present
(Scop
) and then Scop
/= Standard_Standard
loop
15600 Scop
:= Scope
(Scop
);
15604 end Distance_From_Standard
;
15606 ---------------------
15607 -- Equalize_Depths --
15608 ---------------------
15610 procedure Equalize_Depths
15611 (Pack
: in out Entity_Id
;
15612 Depth
: in out Nat
;
15613 Depth_To_Reach
: Nat
)
15616 -- The package must be at a greater or equal depth
15618 if Depth
< Depth_To_Reach
then
15619 raise Program_Error
;
15622 -- Climb the scope chain until the desired depth is reached
15624 while Present
(Pack
) and then Depth
/= Depth_To_Reach
loop
15625 Pack
:= Scope
(Pack
);
15626 Depth
:= Depth
- 1;
15628 end Equalize_Depths
;
15632 P_1
: Entity_Id
:= Pack_1
;
15633 P_1_Child
: Boolean := False;
15634 P_1_Depth
: Nat
:= Distance_From_Standard
(P_1
);
15635 P_2
: Entity_Id
:= Pack_2
;
15636 P_2_Child
: Boolean := False;
15637 P_2_Depth
: Nat
:= Distance_From_Standard
(P_2
);
15639 -- Start of processing for Is_Child_Or_Sibling
15643 (Ekind
(Pack_1
) = E_Package
and then Ekind
(Pack_2
) = E_Package
);
15645 -- Both packages denote the same entity, therefore they cannot be
15646 -- children or siblings.
15651 -- One of the packages is at a deeper level than the other. Note that
15652 -- both may still come from different hierarchies.
15660 elsif P_1_Depth
> P_2_Depth
then
15663 Depth
=> P_1_Depth
,
15664 Depth_To_Reach
=> P_2_Depth
);
15673 elsif P_2_Depth
> P_1_Depth
then
15676 Depth
=> P_2_Depth
,
15677 Depth_To_Reach
=> P_1_Depth
);
15681 -- At this stage the package pointers have been elevated to the same
15682 -- depth. If the related entities are the same, then one package is a
15683 -- potential child of the other:
15687 -- X became P_1 P_2 or vice versa
15693 return Is_Child_Unit
(Pack_1
);
15695 else pragma Assert
(P_2_Child
);
15696 return Is_Child_Unit
(Pack_2
);
15699 -- The packages may come from the same package chain or from entirely
15700 -- different hierarchies. To determine this, climb the scope stack until
15701 -- a common root is found.
15703 -- (root) (root 1) (root 2)
15708 while Present
(P_1
) and then Present
(P_2
) loop
15710 -- The two packages may be siblings
15713 return Is_Child_Unit
(Pack_1
) and then Is_Child_Unit
(Pack_2
);
15716 P_1
:= Scope
(P_1
);
15717 P_2
:= Scope
(P_2
);
15722 end Is_Child_Or_Sibling
;
15724 -------------------
15725 -- Is_Confirming --
15726 -------------------
15728 function Is_Confirming
(Aspect
: Nonoverridable_Aspect_Id
;
15729 Aspect_Spec_1
, Aspect_Spec_2
: Node_Id
)
15731 function Names_Match
(Nm1
, Nm2
: Node_Id
) return Boolean;
15737 function Names_Match
(Nm1
, Nm2
: Node_Id
) return Boolean is
15739 if Nkind
(Nm1
) /= Nkind
(Nm2
) then
15741 -- This may be too restrictive given that visibility
15742 -- may allow an identifier in one case and an expanded
15743 -- name in the other.
15745 case Nkind
(Nm1
) is
15746 when N_Identifier
=>
15747 return Name_Equals
(Chars
(Nm1
), Chars
(Nm2
));
15749 when N_Expanded_Name
=>
15750 -- An inherited operation has the same name as its
15751 -- ancestor, but they may have different scopes.
15752 -- This may be too permissive for Iterator_Element, which
15753 -- is intended to be identical in parent and derived type.
15755 return Names_Match
(Selector_Name
(Nm1
),
15756 Selector_Name
(Nm2
));
15759 return True; -- needed for Aggregate aspect checking
15762 -- e.g., 'Class attribute references
15763 if Is_Entity_Name
(Nm1
) and Is_Entity_Name
(Nm2
) then
15764 return Entity
(Nm1
) = Entity
(Nm2
);
15767 raise Program_Error
;
15771 -- allow users to disable "shall be confirming" check, at least for now
15772 if Relaxed_RM_Semantics
then
15776 -- ??? Type conversion here (along with "when others =>" below) is a
15777 -- workaround for a bootstrapping problem related to casing on a
15778 -- static-predicate-bearing subtype.
15780 case Aspect_Id
(Aspect
) is
15781 -- name-valued aspects; compare text of names, not resolution.
15782 when Aspect_Default_Iterator
15783 | Aspect_Iterator_Element
15784 | Aspect_Constant_Indexing
15785 | Aspect_Variable_Indexing
=>
15787 Item_1
: constant Node_Id
:= Aspect_Rep_Item
(Aspect_Spec_1
);
15788 Item_2
: constant Node_Id
:= Aspect_Rep_Item
(Aspect_Spec_2
);
15790 if Nkind
(Item_1
) /= N_Attribute_Definition_Clause
15791 or Nkind
(Item_2
) /= N_Attribute_Definition_Clause
15793 pragma Assert
(Serious_Errors_Detected
> 0);
15797 return Names_Match
(Expression
(Item_1
),
15798 Expression
(Item_2
));
15801 -- A confirming aspect for Implicit_Derenfence on a derived type
15802 -- has already been checked in Analyze_Aspect_Implicit_Dereference,
15803 -- including the presence of renamed discriminants.
15805 when Aspect_Implicit_Dereference
=>
15809 when Aspect_Aggregate
=>
15820 Assign_Indexed_2
: Node_Id
:= Empty
;
15822 Parse_Aspect_Aggregate
15823 (N
=> Expression
(Aspect_Spec_1
),
15824 Empty_Subp
=> Empty_1
,
15825 Add_Named_Subp
=> Add_Named_1
,
15826 Add_Unnamed_Subp
=> Add_Unnamed_1
,
15827 New_Indexed_Subp
=> New_Indexed_1
,
15828 Assign_Indexed_Subp
=> Assign_Indexed_1
);
15829 Parse_Aspect_Aggregate
15830 (N
=> Expression
(Aspect_Spec_2
),
15831 Empty_Subp
=> Empty_2
,
15832 Add_Named_Subp
=> Add_Named_2
,
15833 Add_Unnamed_Subp
=> Add_Unnamed_2
,
15834 New_Indexed_Subp
=> New_Indexed_2
,
15835 Assign_Indexed_Subp
=> Assign_Indexed_2
);
15837 Names_Match
(Empty_1
, Empty_2
) and then
15838 Names_Match
(Add_Named_1
, Add_Named_2
) and then
15839 Names_Match
(Add_Unnamed_1
, Add_Unnamed_2
) and then
15840 Names_Match
(New_Indexed_1
, New_Indexed_2
) and then
15841 Names_Match
(Assign_Indexed_1
, Assign_Indexed_2
);
15844 -- Checking for this aspect is performed elsewhere during freezing
15845 when Aspect_No_Controlled_Parts
=>
15848 -- scalar-valued aspects; compare (static) values.
15849 when Aspect_Max_Entry_Queue_Length
=>
15850 -- This should be unreachable. Max_Entry_Queue_Length is
15851 -- supported only for protected entries, not for types.
15852 pragma Assert
(Serious_Errors_Detected
/= 0);
15856 raise Program_Error
;
15860 -----------------------------
15861 -- Is_Concurrent_Interface --
15862 -----------------------------
15864 function Is_Concurrent_Interface
(T
: Entity_Id
) return Boolean is
15866 return Is_Protected_Interface
(T
)
15867 or else Is_Synchronized_Interface
(T
)
15868 or else Is_Task_Interface
(T
);
15869 end Is_Concurrent_Interface
;
15871 ------------------------------------------------------
15872 -- Is_Conjunction_Of_Formal_Preelab_Init_Attributes --
15873 ------------------------------------------------------
15875 function Is_Conjunction_Of_Formal_Preelab_Init_Attributes
15876 (Expr
: Node_Id
) return Boolean
15879 function Is_Formal_Preelab_Init_Attribute
15880 (N
: Node_Id
) return Boolean;
15881 -- Returns True if N is a Preelaborable_Initialization attribute
15882 -- applied to a generic formal type, or N's Original_Node is such
15885 --------------------------------------
15886 -- Is_Formal_Preelab_Init_Attribute --
15887 --------------------------------------
15889 function Is_Formal_Preelab_Init_Attribute
15890 (N
: Node_Id
) return Boolean
15892 Orig_N
: constant Node_Id
:= Original_Node
(N
);
15895 return Nkind
(Orig_N
) = N_Attribute_Reference
15896 and then Attribute_Name
(Orig_N
) = Name_Preelaborable_Initialization
15897 and then Is_Entity_Name
(Prefix
(Orig_N
))
15898 and then Is_Generic_Type
(Entity
(Prefix
(Orig_N
)));
15899 end Is_Formal_Preelab_Init_Attribute
;
15901 -- Start of Is_Conjunction_Of_Formal_Preelab_Init_Attributes
15904 return Is_Formal_Preelab_Init_Attribute
(Expr
)
15905 or else (Nkind
(Expr
) = N_Op_And
15907 Is_Conjunction_Of_Formal_Preelab_Init_Attributes
15910 Is_Conjunction_Of_Formal_Preelab_Init_Attributes
15911 (Right_Opnd
(Expr
)));
15912 end Is_Conjunction_Of_Formal_Preelab_Init_Attributes
;
15914 -----------------------
15915 -- Is_Constant_Bound --
15916 -----------------------
15918 function Is_Constant_Bound
(Exp
: Node_Id
) return Boolean is
15920 if Compile_Time_Known_Value
(Exp
) then
15923 elsif Is_Entity_Name
(Exp
) and then Present
(Entity
(Exp
)) then
15924 return Is_Constant_Object
(Entity
(Exp
))
15925 or else Ekind
(Entity
(Exp
)) = E_Enumeration_Literal
;
15927 elsif Nkind
(Exp
) in N_Binary_Op
then
15928 return Is_Constant_Bound
(Left_Opnd
(Exp
))
15929 and then Is_Constant_Bound
(Right_Opnd
(Exp
))
15930 and then Scope
(Entity
(Exp
)) = Standard_Standard
;
15935 end Is_Constant_Bound
;
15937 ---------------------------
15938 -- Is_Container_Element --
15939 ---------------------------
15941 function Is_Container_Element
(Exp
: Node_Id
) return Boolean is
15942 Loc
: constant Source_Ptr
:= Sloc
(Exp
);
15943 Pref
: constant Node_Id
:= Prefix
(Exp
);
15946 -- Call to an indexing aspect
15948 Cont_Typ
: Entity_Id
;
15949 -- The type of the container being accessed
15951 Elem_Typ
: Entity_Id
;
15952 -- Its element type
15954 Indexing
: Entity_Id
;
15955 Is_Const
: Boolean;
15956 -- Indicates that constant indexing is used, and the element is thus
15959 Ref_Typ
: Entity_Id
;
15960 -- The reference type returned by the indexing operation
15963 -- If C is a container, in a context that imposes the element type of
15964 -- that container, the indexing notation C (X) is rewritten as:
15966 -- Indexing (C, X).Discr.all
15968 -- where Indexing is one of the indexing aspects of the container.
15969 -- If the context does not require a reference, the construct can be
15974 -- First, verify that the construct has the proper form
15976 if not Expander_Active
then
15979 elsif Nkind
(Pref
) /= N_Selected_Component
then
15982 elsif Nkind
(Prefix
(Pref
)) /= N_Function_Call
then
15986 Call
:= Prefix
(Pref
);
15987 Ref_Typ
:= Etype
(Call
);
15990 if not Has_Implicit_Dereference
(Ref_Typ
)
15991 or else No
(First
(Parameter_Associations
(Call
)))
15992 or else not Is_Entity_Name
(Name
(Call
))
15997 -- Retrieve type of container object, and its iterator aspects
15999 Cont_Typ
:= Etype
(First
(Parameter_Associations
(Call
)));
16000 Indexing
:= Find_Value_Of_Aspect
(Cont_Typ
, Aspect_Constant_Indexing
);
16003 if No
(Indexing
) then
16005 -- Container should have at least one indexing operation
16009 elsif Entity
(Name
(Call
)) /= Entity
(Indexing
) then
16011 -- This may be a variable indexing operation
16013 Indexing
:= Find_Value_Of_Aspect
(Cont_Typ
, Aspect_Variable_Indexing
);
16016 or else Entity
(Name
(Call
)) /= Entity
(Indexing
)
16025 Elem_Typ
:= Find_Value_Of_Aspect
(Cont_Typ
, Aspect_Iterator_Element
);
16027 if No
(Elem_Typ
) or else Entity
(Elem_Typ
) /= Etype
(Exp
) then
16031 -- Check that the expression is not the target of an assignment, in
16032 -- which case the rewriting is not possible.
16034 if not Is_Const
then
16040 while Present
(Par
)
16042 if Nkind
(Parent
(Par
)) = N_Assignment_Statement
16043 and then Par
= Name
(Parent
(Par
))
16047 -- A renaming produces a reference, and the transformation
16050 elsif Nkind
(Parent
(Par
)) = N_Object_Renaming_Declaration
then
16053 elsif Nkind
(Parent
(Par
)) in
16055 N_Procedure_Call_Statement |
16056 N_Entry_Call_Statement
16058 -- Check that the element is not part of an actual for an
16059 -- in-out parameter.
16066 F
:= First_Formal
(Entity
(Name
(Parent
(Par
))));
16067 A
:= First
(Parameter_Associations
(Parent
(Par
)));
16068 while Present
(F
) loop
16069 if A
= Par
and then Ekind
(F
) /= E_In_Parameter
then
16078 -- E_In_Parameter in a call: element is not modified.
16083 Par
:= Parent
(Par
);
16088 -- The expression has the proper form and the context requires the
16089 -- element type. Retrieve the Element function of the container and
16090 -- rewrite the construct as a call to it.
16096 Op
:= First_Elmt
(Primitive_Operations
(Cont_Typ
));
16097 while Present
(Op
) loop
16098 exit when Chars
(Node
(Op
)) = Name_Element
;
16107 Make_Function_Call
(Loc
,
16108 Name
=> New_Occurrence_Of
(Node
(Op
), Loc
),
16109 Parameter_Associations
=> Parameter_Associations
(Call
)));
16110 Analyze_And_Resolve
(Exp
, Entity
(Elem_Typ
));
16114 end Is_Container_Element
;
16116 ----------------------------
16117 -- Is_Contract_Annotation --
16118 ----------------------------
16120 function Is_Contract_Annotation
(Item
: Node_Id
) return Boolean is
16122 return Is_Package_Contract_Annotation
(Item
)
16124 Is_Subprogram_Contract_Annotation
(Item
);
16125 end Is_Contract_Annotation
;
16127 --------------------------------------
16128 -- Is_Controlling_Limited_Procedure --
16129 --------------------------------------
16131 function Is_Controlling_Limited_Procedure
16132 (Proc_Nam
: Entity_Id
) return Boolean
16135 Param_Typ
: Entity_Id
:= Empty
;
16138 if Ekind
(Proc_Nam
) = E_Procedure
16139 and then Present
(Parameter_Specifications
(Parent
(Proc_Nam
)))
16143 (First
(Parameter_Specifications
(Parent
(Proc_Nam
))));
16145 -- The formal may be an anonymous access type
16147 if Nkind
(Param
) = N_Access_Definition
then
16148 Param_Typ
:= Entity
(Subtype_Mark
(Param
));
16150 Param_Typ
:= Etype
(Param
);
16153 -- In the case where an Itype was created for a dispatchin call, the
16154 -- procedure call has been rewritten. The actual may be an access to
16155 -- interface type in which case it is the designated type that is the
16156 -- controlling type.
16158 elsif Present
(Associated_Node_For_Itype
(Proc_Nam
))
16159 and then Present
(Original_Node
(Associated_Node_For_Itype
(Proc_Nam
)))
16161 Present
(Parameter_Associations
16162 (Associated_Node_For_Itype
(Proc_Nam
)))
16165 Etype
(First
(Parameter_Associations
16166 (Associated_Node_For_Itype
(Proc_Nam
))));
16168 if Ekind
(Param_Typ
) = E_Anonymous_Access_Type
then
16169 Param_Typ
:= Directly_Designated_Type
(Param_Typ
);
16173 if Present
(Param_Typ
) then
16175 Is_Interface
(Param_Typ
)
16176 and then Is_Limited_Record
(Param_Typ
);
16180 end Is_Controlling_Limited_Procedure
;
16182 -----------------------------
16183 -- Is_CPP_Constructor_Call --
16184 -----------------------------
16186 function Is_CPP_Constructor_Call
(N
: Node_Id
) return Boolean is
16187 Ret_Typ
: Entity_Id
;
16190 if Nkind
(N
) /= N_Function_Call
then
16194 Ret_Typ
:= Base_Type
(Etype
(N
));
16196 if Is_Class_Wide_Type
(Ret_Typ
) then
16197 Ret_Typ
:= Root_Type
(Ret_Typ
);
16200 if Is_Private_Type
(Ret_Typ
) then
16201 Ret_Typ
:= Underlying_Type
(Ret_Typ
);
16204 return Present
(Ret_Typ
)
16205 and then Is_CPP_Class
(Ret_Typ
)
16206 and then Is_Constructor
(Entity
(Name
(N
)))
16207 and then Is_Imported
(Entity
(Name
(N
)));
16208 end Is_CPP_Constructor_Call
;
16210 -------------------------
16211 -- Is_Current_Instance --
16212 -------------------------
16214 function Is_Current_Instance
(N
: Node_Id
) return Boolean is
16215 Typ
: constant Entity_Id
:= Entity
(N
);
16219 -- Simplest case: entity is a concurrent type and we are currently
16220 -- inside the body. This will eventually be expanded into a call to
16221 -- Self (for tasks) or _object (for protected objects).
16223 if Is_Concurrent_Type
(Typ
) and then In_Open_Scopes
(Typ
) then
16227 -- Check whether the context is a (sub)type declaration for the
16231 while Present
(P
) loop
16232 if Nkind
(P
) in N_Full_Type_Declaration
16233 | N_Private_Type_Declaration
16234 | N_Subtype_Declaration
16235 and then Comes_From_Source
(P
)
16237 -- If the type has a previous incomplete declaration, the
16238 -- reference in the type definition may have the incomplete
16239 -- view. So, here we detect if this incomplete view is a current
16240 -- instance by checking if its full view is the entity of the
16241 -- full declaration begin analyzed.
16244 (Defining_Entity
(P
) = Typ
16246 (Ekind
(Typ
) = E_Incomplete_Type
16247 and then Full_View
(Typ
) = Defining_Entity
(P
)))
16251 -- A subtype name may appear in an aspect specification for a
16252 -- Predicate_Failure aspect, for which we do not construct a
16253 -- wrapper procedure. The subtype will be replaced by the
16254 -- expression being tested when the corresponding predicate
16255 -- check is expanded. It may also appear in the pragma Predicate
16256 -- expression during legality checking.
16258 elsif Nkind
(P
) = N_Aspect_Specification
16259 and then Nkind
(Parent
(P
)) = N_Subtype_Declaration
16260 and then Underlying_Type
(Defining_Identifier
(Parent
(P
))) =
16261 Underlying_Type
(Typ
)
16265 elsif Nkind
(P
) = N_Pragma
16266 and then Get_Pragma_Id
(P
) in Pragma_Predicate
16267 | Pragma_Predicate_Failure
16270 Arg
: constant Entity_Id
:=
16271 Entity
(Expression
(Get_Argument
(P
)));
16273 if Underlying_Type
(Arg
) = Underlying_Type
(Typ
) then
16283 -- In any other context this is not a current occurrence
16286 end Is_Current_Instance
;
16288 --------------------------------------------------
16289 -- Is_Current_Instance_Reference_In_Type_Aspect --
16290 --------------------------------------------------
16292 function Is_Current_Instance_Reference_In_Type_Aspect
16293 (N
: Node_Id
) return Boolean
16296 -- When a current_instance is referenced within an aspect_specification
16297 -- of a type or subtype, it will show up as a reference to the formal
16298 -- parameter of the aspect's associated subprogram rather than as a
16299 -- reference to the type or subtype itself (in fact, the original name
16300 -- is never even analyzed). We check for predicate, invariant, and
16301 -- Default_Initial_Condition subprograms (in theory there could be
16302 -- other cases added, in which case this function will need updating).
16304 if Is_Entity_Name
(N
) then
16305 return Present
(Entity
(N
))
16306 and then Ekind
(Entity
(N
)) = E_In_Parameter
16307 and then Ekind
(Scope
(Entity
(N
))) in E_Function | E_Procedure
16309 (Is_Predicate_Function
(Scope
(Entity
(N
)))
16310 or else Is_Invariant_Procedure
(Scope
(Entity
(N
)))
16311 or else Is_Partial_Invariant_Procedure
(Scope
(Entity
(N
)))
16312 or else Is_DIC_Procedure
(Scope
(Entity
(N
))));
16316 when N_Indexed_Component
16320 Is_Current_Instance_Reference_In_Type_Aspect
(Prefix
(N
));
16322 when N_Selected_Component
=>
16324 Is_Current_Instance_Reference_In_Type_Aspect
(Prefix
(N
));
16326 when N_Type_Conversion
=>
16327 return Is_Current_Instance_Reference_In_Type_Aspect
16330 when N_Qualified_Expression
=>
16331 return Is_Current_Instance_Reference_In_Type_Aspect
16338 end Is_Current_Instance_Reference_In_Type_Aspect
;
16340 --------------------
16341 -- Is_Declaration --
16342 --------------------
16344 function Is_Declaration
16346 Body_OK
: Boolean := True;
16347 Concurrent_OK
: Boolean := True;
16348 Formal_OK
: Boolean := True;
16349 Generic_OK
: Boolean := True;
16350 Instantiation_OK
: Boolean := True;
16351 Renaming_OK
: Boolean := True;
16352 Stub_OK
: Boolean := True;
16353 Subprogram_OK
: Boolean := True;
16354 Type_OK
: Boolean := True) return Boolean
16359 -- Body declarations
16361 when N_Proper_Body
=>
16364 -- Concurrent type declarations
16366 when N_Protected_Type_Declaration
16367 | N_Single_Protected_Declaration
16368 | N_Single_Task_Declaration
16369 | N_Task_Type_Declaration
16371 return Concurrent_OK
or Type_OK
;
16373 -- Formal declarations
16375 when N_Formal_Abstract_Subprogram_Declaration
16376 | N_Formal_Concrete_Subprogram_Declaration
16377 | N_Formal_Object_Declaration
16378 | N_Formal_Package_Declaration
16379 | N_Formal_Type_Declaration
16383 -- Generic declarations
16385 when N_Generic_Package_Declaration
16386 | N_Generic_Subprogram_Declaration
16390 -- Generic instantiations
16392 when N_Function_Instantiation
16393 | N_Package_Instantiation
16394 | N_Procedure_Instantiation
16396 return Instantiation_OK
;
16398 -- Generic renaming declarations
16400 when N_Generic_Renaming_Declaration
=>
16401 return Generic_OK
or Renaming_OK
;
16403 -- Renaming declarations
16405 when N_Exception_Renaming_Declaration
16406 | N_Object_Renaming_Declaration
16407 | N_Package_Renaming_Declaration
16408 | N_Subprogram_Renaming_Declaration
16410 return Renaming_OK
;
16412 -- Stub declarations
16414 when N_Body_Stub
=>
16417 -- Subprogram declarations
16419 when N_Abstract_Subprogram_Declaration
16420 | N_Entry_Declaration
16421 | N_Expression_Function
16422 | N_Subprogram_Declaration
16424 return Subprogram_OK
;
16426 -- Type declarations
16428 when N_Full_Type_Declaration
16429 | N_Incomplete_Type_Declaration
16430 | N_Private_Extension_Declaration
16431 | N_Private_Type_Declaration
16432 | N_Subtype_Declaration
16438 when N_Component_Declaration
16439 | N_Exception_Declaration
16440 | N_Implicit_Label_Declaration
16441 | N_Number_Declaration
16442 | N_Object_Declaration
16443 | N_Package_Declaration
16450 end Is_Declaration
;
16452 --------------------------------
16453 -- Is_Declared_Within_Variant --
16454 --------------------------------
16456 function Is_Declared_Within_Variant
(Comp
: Entity_Id
) return Boolean is
16457 Comp_Decl
: constant Node_Id
:= Parent
(Comp
);
16458 Comp_List
: constant Node_Id
:= Parent
(Comp_Decl
);
16460 return Nkind
(Parent
(Comp_List
)) = N_Variant
;
16461 end Is_Declared_Within_Variant
;
16463 ----------------------------------------------
16464 -- Is_Dependent_Component_Of_Mutable_Object --
16465 ----------------------------------------------
16467 function Is_Dependent_Component_Of_Mutable_Object
16468 (Object
: Node_Id
) return Boolean
16471 Prefix_Type
: Entity_Id
;
16472 P_Aliased
: Boolean := False;
16475 Deref
: Node_Id
:= Original_Node
(Object
);
16476 -- Dereference node, in something like X.all.Y(2)
16478 -- Start of processing for Is_Dependent_Component_Of_Mutable_Object
16481 -- Find the dereference node if any
16483 while Nkind
(Deref
) in
16484 N_Indexed_Component | N_Selected_Component | N_Slice
16486 Deref
:= Original_Node
(Prefix
(Deref
));
16489 -- If the prefix is a qualified expression of a variable, then function
16490 -- Is_Variable will return False for that because a qualified expression
16491 -- denotes a constant view, so we need to get the name being qualified
16492 -- so we can test below whether that's a variable (or a dereference).
16494 if Nkind
(Deref
) = N_Qualified_Expression
then
16495 Deref
:= Expression
(Deref
);
16498 -- Ada 2005: If we have a component or slice of a dereference, something
16499 -- like X.all.Y (2) and the type of X is access-to-constant, Is_Variable
16500 -- will return False, because it is indeed a constant view. But it might
16501 -- be a view of a variable object, so we want the following condition to
16502 -- be True in that case.
16504 if Is_Variable
(Object
)
16505 or else Is_Variable
(Deref
)
16507 (Ada_Version
>= Ada_2005
16508 and then (Nkind
(Deref
) = N_Explicit_Dereference
16509 or else (Present
(Etype
(Deref
))
16510 and then Is_Access_Type
(Etype
(Deref
)))))
16512 if Nkind
(Object
) = N_Selected_Component
then
16514 -- If the selector is not a component, then we definitely return
16515 -- False (it could be a function selector in a prefix form call
16516 -- occurring in an iterator specification).
16518 if (Present
(Entity
(Selector_Name
(Object
)))
16519 and then Ekind
(Entity
(Selector_Name
(Object
))) not in
16520 E_Component | E_Discriminant
)
16523 and then Nkind
(Parent
(Selector_Name
(Object
)))
16529 -- Get the original node of the prefix in case it has been
16530 -- rewritten, which can occur, for example, in qualified
16531 -- expression cases. Also, a discriminant check on a selected
16532 -- component may be expanded into a dereference when removing
16533 -- side effects, and the subtype of the original node may be
16536 P
:= Original_Node
(Prefix
(Object
));
16537 Prefix_Type
:= Etype
(P
);
16539 -- If the prefix is a qualified expression, we want to look at its
16542 if Nkind
(P
) = N_Qualified_Expression
then
16543 P
:= Expression
(P
);
16544 Prefix_Type
:= Etype
(P
);
16547 if Is_Entity_Name
(P
) then
16548 -- The Etype may not be set on P (which is wrong) in certain
16549 -- corner cases involving the deprecated front-end inlining of
16550 -- subprograms (via -gnatN), so use the Etype set on the
16551 -- the entity for these instances since we know it is present.
16553 if No
(Prefix_Type
) then
16554 Prefix_Type
:= Etype
(Entity
(P
));
16557 if Ekind
(Entity
(P
)) = E_Generic_In_Out_Parameter
then
16558 Prefix_Type
:= Base_Type
(Prefix_Type
);
16561 if Is_Aliased
(Entity
(P
)) then
16565 -- For explicit dereferences we get the access prefix so we can
16566 -- treat this similarly to implicit dereferences and examine the
16567 -- kind of the access type and its designated subtype further
16570 elsif Nkind
(P
) = N_Explicit_Dereference
then
16572 Prefix_Type
:= Etype
(P
);
16575 -- Check for prefix being an aliased component???
16580 -- A heap object is constrained by its initial value
16582 -- Ada 2005 (AI-363): Always assume the object could be mutable in
16583 -- the dereferenced case, since the access value might denote an
16584 -- unconstrained aliased object, whereas in Ada 95 the designated
16585 -- object is guaranteed to be constrained. A worst-case assumption
16586 -- has to apply in Ada 2005 because we can't tell at compile
16587 -- time whether the object is "constrained by its initial value",
16588 -- despite the fact that 3.10.2(26/2) and 8.5.1(5/2) are semantic
16589 -- rules (these rules are acknowledged to need fixing). We don't
16590 -- impose this more stringent checking for earlier Ada versions or
16591 -- when Relaxed_RM_Semantics applies (the latter for CodePeer's
16592 -- benefit, though it's unclear on why using -gnat95 would not be
16595 if Ada_Version
< Ada_2005
or else Relaxed_RM_Semantics
then
16596 if Is_Access_Type
(Prefix_Type
)
16597 or else Nkind
(P
) = N_Explicit_Dereference
16602 else pragma Assert
(Ada_Version
>= Ada_2005
);
16603 if Is_Access_Type
(Prefix_Type
) then
16604 -- We need to make sure we have the base subtype, in case
16605 -- this is actually an access subtype (whose Ekind will be
16606 -- E_Access_Subtype).
16608 Prefix_Type
:= Etype
(Prefix_Type
);
16610 -- If the access type is pool-specific, and there is no
16611 -- constrained partial view of the designated type, then the
16612 -- designated object is known to be constrained. If it's a
16613 -- formal access type and the renaming is in the generic
16614 -- spec, we also treat it as pool-specific (known to be
16615 -- constrained), but assume the worst if in the generic body
16616 -- (see RM 3.3(23.3/3)).
16618 if Ekind
(Prefix_Type
) = E_Access_Type
16619 and then (not Is_Generic_Type
(Prefix_Type
)
16620 or else not In_Generic_Body
(Current_Scope
))
16621 and then not Object_Type_Has_Constrained_Partial_View
16622 (Typ
=> Designated_Type
(Prefix_Type
),
16623 Scop
=> Current_Scope
)
16627 -- Otherwise (general access type, or there is a constrained
16628 -- partial view of the designated type), we need to check
16629 -- based on the designated type.
16632 Prefix_Type
:= Designated_Type
(Prefix_Type
);
16638 Original_Record_Component
(Entity
(Selector_Name
(Object
)));
16640 -- As per AI-0017, the renaming is illegal in a generic body, even
16641 -- if the subtype is indefinite (only applies to prefixes of an
16642 -- untagged formal type, see RM 3.3 (23.11/3)).
16644 -- Ada 2005 (AI-363): In Ada 2005 an aliased object can be mutable
16646 if not Is_Constrained
(Prefix_Type
)
16647 and then (Is_Definite_Subtype
(Prefix_Type
)
16649 (not Is_Tagged_Type
(Prefix_Type
)
16650 and then Is_Generic_Type
(Prefix_Type
)
16651 and then In_Generic_Body
(Current_Scope
)))
16653 and then (Is_Declared_Within_Variant
(Comp
)
16654 or else Has_Discriminant_Dependent_Constraint
(Comp
))
16655 and then (not P_Aliased
or else Ada_Version
>= Ada_2005
)
16659 -- If the prefix is of an access type at this point, then we want
16660 -- to return False, rather than calling this function recursively
16661 -- on the access object (which itself might be a discriminant-
16662 -- dependent component of some other object, but that isn't
16663 -- relevant to checking the object passed to us). This avoids
16664 -- issuing wrong errors when compiling with -gnatc, where there
16665 -- can be implicit dereferences that have not been expanded.
16667 elsif Is_Access_Type
(Etype
(Prefix
(Object
))) then
16672 Is_Dependent_Component_Of_Mutable_Object
(Prefix
(Object
));
16675 elsif Nkind
(Object
) = N_Indexed_Component
16676 or else Nkind
(Object
) = N_Slice
16678 return Is_Dependent_Component_Of_Mutable_Object
16679 (Original_Node
(Prefix
(Object
)));
16681 -- A type conversion that Is_Variable is a view conversion:
16682 -- go back to the denoted object.
16684 elsif Nkind
(Object
) = N_Type_Conversion
then
16686 Is_Dependent_Component_Of_Mutable_Object
16687 (Original_Node
(Expression
(Object
)));
16692 end Is_Dependent_Component_Of_Mutable_Object
;
16694 ---------------------
16695 -- Is_Dereferenced --
16696 ---------------------
16698 function Is_Dereferenced
(N
: Node_Id
) return Boolean is
16699 P
: constant Node_Id
:= Parent
(N
);
16701 return Nkind
(P
) in N_Selected_Component
16702 | N_Explicit_Dereference
16703 | N_Indexed_Component
16705 and then Prefix
(P
) = N
;
16706 end Is_Dereferenced
;
16708 ----------------------
16709 -- Is_Descendant_Of --
16710 ----------------------
16712 function Is_Descendant_Of
(T1
: Entity_Id
; T2
: Entity_Id
) return Boolean is
16717 pragma Assert
(Nkind
(T1
) in N_Entity
);
16718 pragma Assert
(Nkind
(T2
) in N_Entity
);
16720 T
:= Base_Type
(T1
);
16722 -- Immediate return if the types match
16727 -- Comment needed here ???
16729 elsif Ekind
(T
) = E_Class_Wide_Type
then
16730 return Etype
(T
) = T2
;
16738 -- Done if we found the type we are looking for
16743 -- Done if no more derivations to check
16750 -- Following test catches error cases resulting from prev errors
16752 elsif No
(Etyp
) then
16755 elsif Is_Private_Type
(T
) and then Etyp
= Full_View
(T
) then
16758 elsif Is_Private_Type
(Etyp
) and then Full_View
(Etyp
) = T
then
16762 T
:= Base_Type
(Etyp
);
16765 end Is_Descendant_Of
;
16767 ----------------------------------------
16768 -- Is_Descendant_Of_Suspension_Object --
16769 ----------------------------------------
16771 function Is_Descendant_Of_Suspension_Object
16772 (Typ
: Entity_Id
) return Boolean
16774 Cur_Typ
: Entity_Id
;
16775 Par_Typ
: Entity_Id
;
16778 -- Climb the type derivation chain checking each parent type against
16779 -- Suspension_Object.
16781 Cur_Typ
:= Base_Type
(Typ
);
16782 while Present
(Cur_Typ
) loop
16783 Par_Typ
:= Etype
(Cur_Typ
);
16785 -- The current type is a match
16787 if Is_RTE
(Cur_Typ
, RE_Suspension_Object
) then
16790 -- Stop the traversal once the root of the derivation chain has been
16791 -- reached. In that case the current type is its own base type.
16793 elsif Cur_Typ
= Par_Typ
then
16797 Cur_Typ
:= Base_Type
(Par_Typ
);
16801 end Is_Descendant_Of_Suspension_Object
;
16803 ---------------------------------------------
16804 -- Is_Double_Precision_Floating_Point_Type --
16805 ---------------------------------------------
16807 function Is_Double_Precision_Floating_Point_Type
16808 (E
: Entity_Id
) return Boolean is
16810 return Is_Floating_Point_Type
(E
)
16811 and then Machine_Radix_Value
(E
) = Uint_2
16812 and then Machine_Mantissa_Value
(E
) = UI_From_Int
(53)
16813 and then Machine_Emax_Value
(E
) = Uint_2
** Uint_10
16814 and then Machine_Emin_Value
(E
) = Uint_3
- (Uint_2
** Uint_10
);
16815 end Is_Double_Precision_Floating_Point_Type
;
16817 -----------------------------
16818 -- Is_Effectively_Volatile --
16819 -----------------------------
16821 function Is_Effectively_Volatile
16823 Ignore_Protected
: Boolean := False) return Boolean is
16825 if Is_Type
(Id
) then
16827 -- An arbitrary type is effectively volatile when it is subject to
16828 -- pragma Atomic or Volatile, unless No_Caching is enabled.
16830 if Is_Volatile
(Id
)
16831 and then not No_Caching_Enabled
(Id
)
16835 -- An array type is effectively volatile when it is subject to pragma
16836 -- Atomic_Components or Volatile_Components or its component type is
16837 -- effectively volatile.
16839 elsif Is_Array_Type
(Id
) then
16840 if Has_Volatile_Components
(Id
) then
16844 Anc
: Entity_Id
:= Base_Type
(Id
);
16846 if Is_Private_Type
(Anc
) then
16847 Anc
:= Full_View
(Anc
);
16850 -- Test for presence of ancestor, as the full view of a
16851 -- private type may be missing in case of error.
16853 return Present
(Anc
)
16854 and then Is_Effectively_Volatile
16855 (Component_Type
(Anc
), Ignore_Protected
);
16859 -- A protected type is always volatile unless Ignore_Protected is
16862 elsif Is_Protected_Type
(Id
) and then not Ignore_Protected
then
16865 -- A descendant of Ada.Synchronous_Task_Control.Suspension_Object is
16866 -- automatically volatile.
16868 elsif Is_Descendant_Of_Suspension_Object
(Id
) then
16871 -- Otherwise the type is not effectively volatile
16877 -- Otherwise Id denotes an object
16879 else pragma Assert
(Is_Object
(Id
));
16880 -- A volatile object for which No_Caching is enabled is not
16881 -- effectively volatile.
16886 (Ekind
(Id
) = E_Variable
and then No_Caching_Enabled
(Id
)))
16887 or else Has_Volatile_Components
(Id
)
16888 or else Is_Effectively_Volatile
(Etype
(Id
), Ignore_Protected
);
16890 end Is_Effectively_Volatile
;
16892 -----------------------------------------
16893 -- Is_Effectively_Volatile_For_Reading --
16894 -----------------------------------------
16896 function Is_Effectively_Volatile_For_Reading
16898 Ignore_Protected
: Boolean := False) return Boolean
16901 -- A concurrent type is effectively volatile for reading, except for a
16902 -- protected type when Ignore_Protected is True.
16904 if Is_Task_Type
(Id
)
16905 or else (Is_Protected_Type
(Id
) and then not Ignore_Protected
)
16909 elsif Is_Effectively_Volatile
(Id
, Ignore_Protected
) then
16911 -- Other volatile types and objects are effectively volatile for
16912 -- reading when they have property Async_Writers or Effective_Reads
16913 -- set to True. This includes the case of an array type whose
16914 -- Volatile_Components aspect is True (hence it is effectively
16915 -- volatile) which does not have the properties Async_Writers
16916 -- and Effective_Reads set to False.
16918 if Async_Writers_Enabled
(Id
)
16919 or else Effective_Reads_Enabled
(Id
)
16923 -- In addition, an array type is effectively volatile for reading
16924 -- when its component type is effectively volatile for reading.
16926 elsif Is_Array_Type
(Id
) then
16928 Anc
: Entity_Id
:= Base_Type
(Id
);
16930 if Is_Private_Type
(Anc
) then
16931 Anc
:= Full_View
(Anc
);
16934 -- Test for presence of ancestor, as the full view of a
16935 -- private type may be missing in case of error.
16937 return Present
(Anc
)
16938 and then Is_Effectively_Volatile_For_Reading
16939 (Component_Type
(Anc
), Ignore_Protected
);
16946 end Is_Effectively_Volatile_For_Reading
;
16948 ------------------------------------
16949 -- Is_Effectively_Volatile_Object --
16950 ------------------------------------
16952 function Is_Effectively_Volatile_Object
(N
: Node_Id
) return Boolean is
16953 function Is_Effectively_Volatile
(E
: Entity_Id
) return Boolean is
16954 (Is_Effectively_Volatile
(E
, Ignore_Protected
=> False));
16956 function Is_Effectively_Volatile_Object_Inst
16957 is new Is_Effectively_Volatile_Object_Shared
(Is_Effectively_Volatile
);
16959 return Is_Effectively_Volatile_Object_Inst
(N
);
16960 end Is_Effectively_Volatile_Object
;
16962 ------------------------------------------------
16963 -- Is_Effectively_Volatile_Object_For_Reading --
16964 ------------------------------------------------
16966 function Is_Effectively_Volatile_Object_For_Reading
16967 (N
: Node_Id
) return Boolean
16969 function Is_Effectively_Volatile_For_Reading
16970 (E
: Entity_Id
) return Boolean
16971 is (Is_Effectively_Volatile_For_Reading
(E
, Ignore_Protected
=> False));
16973 function Is_Effectively_Volatile_Object_For_Reading_Inst
16974 is new Is_Effectively_Volatile_Object_Shared
16975 (Is_Effectively_Volatile_For_Reading
);
16977 return Is_Effectively_Volatile_Object_For_Reading_Inst
(N
);
16978 end Is_Effectively_Volatile_Object_For_Reading
;
16980 -------------------------------------------
16981 -- Is_Effectively_Volatile_Object_Shared --
16982 -------------------------------------------
16984 function Is_Effectively_Volatile_Object_Shared
16985 (N
: Node_Id
) return Boolean
16988 if Is_Entity_Name
(N
) then
16989 return Is_Object
(Entity
(N
))
16990 and then Is_Effectively_Volatile_Entity
(Entity
(N
));
16992 elsif Nkind
(N
) in N_Indexed_Component | N_Slice
then
16993 return Is_Effectively_Volatile_Object_Shared
(Prefix
(N
));
16995 elsif Nkind
(N
) = N_Selected_Component
then
16997 Is_Effectively_Volatile_Object_Shared
(Prefix
(N
))
16999 Is_Effectively_Volatile_Object_Shared
(Selector_Name
(N
));
17001 elsif Nkind
(N
) in N_Qualified_Expression
17002 | N_Unchecked_Type_Conversion
17003 | N_Type_Conversion
17005 return Is_Effectively_Volatile_Object_Shared
(Expression
(N
));
17010 end Is_Effectively_Volatile_Object_Shared
;
17012 ----------------------------------------
17013 -- Is_Entity_Of_Quantified_Expression --
17014 ----------------------------------------
17016 function Is_Entity_Of_Quantified_Expression
(Id
: Entity_Id
) return Boolean
17018 Par
: constant Node_Id
:= Parent
(Id
);
17021 return (Nkind
(Par
) = N_Loop_Parameter_Specification
17022 or else Nkind
(Par
) = N_Iterator_Specification
)
17023 and then Defining_Identifier
(Par
) = Id
17024 and then Nkind
(Parent
(Par
)) = N_Quantified_Expression
;
17025 end Is_Entity_Of_Quantified_Expression
;
17027 -------------------
17028 -- Is_Entry_Body --
17029 -------------------
17031 function Is_Entry_Body
(Id
: Entity_Id
) return Boolean is
17035 and then Nkind
(Unit_Declaration_Node
(Id
)) = N_Entry_Body
;
17038 --------------------------
17039 -- Is_Entry_Declaration --
17040 --------------------------
17042 function Is_Entry_Declaration
(Id
: Entity_Id
) return Boolean is
17046 and then Nkind
(Unit_Declaration_Node
(Id
)) = N_Entry_Declaration
;
17047 end Is_Entry_Declaration
;
17049 ------------------------------------
17050 -- Is_Expanded_Priority_Attribute --
17051 ------------------------------------
17053 function Is_Expanded_Priority_Attribute
(E
: Entity_Id
) return Boolean is
17056 Nkind
(E
) = N_Function_Call
17057 and then not Configurable_Run_Time_Mode
17058 and then Nkind
(Original_Node
(E
)) = N_Attribute_Reference
17059 and then (Is_RTE
(Entity
(Name
(E
)), RE_Get_Ceiling
)
17060 or else Is_RTE
(Entity
(Name
(E
)), RO_PE_Get_Ceiling
));
17061 end Is_Expanded_Priority_Attribute
;
17063 ----------------------------
17064 -- Is_Expression_Function --
17065 ----------------------------
17067 function Is_Expression_Function
(Subp
: Entity_Id
) return Boolean is
17069 if Ekind
(Subp
) in E_Function | E_Subprogram_Body
then
17071 Nkind
(Original_Node
(Unit_Declaration_Node
(Subp
))) =
17072 N_Expression_Function
;
17076 end Is_Expression_Function
;
17078 ------------------------------------------
17079 -- Is_Expression_Function_Or_Completion --
17080 ------------------------------------------
17082 function Is_Expression_Function_Or_Completion
17083 (Subp
: Entity_Id
) return Boolean
17085 Subp_Decl
: Node_Id
;
17088 if Ekind
(Subp
) = E_Function
then
17089 Subp_Decl
:= Unit_Declaration_Node
(Subp
);
17091 -- The function declaration is either an expression function or is
17092 -- completed by an expression function body.
17095 Is_Expression_Function
(Subp
)
17096 or else (Nkind
(Subp_Decl
) = N_Subprogram_Declaration
17097 and then Present
(Corresponding_Body
(Subp_Decl
))
17098 and then Is_Expression_Function
17099 (Corresponding_Body
(Subp_Decl
)));
17101 elsif Ekind
(Subp
) = E_Subprogram_Body
then
17102 return Is_Expression_Function
(Subp
);
17107 end Is_Expression_Function_Or_Completion
;
17109 -----------------------------------------------
17110 -- Is_Extended_Precision_Floating_Point_Type --
17111 -----------------------------------------------
17113 function Is_Extended_Precision_Floating_Point_Type
17114 (E
: Entity_Id
) return Boolean is
17116 return Is_Floating_Point_Type
(E
)
17117 and then Machine_Radix_Value
(E
) = Uint_2
17118 and then Machine_Mantissa_Value
(E
) = Uint_64
17119 and then Machine_Emax_Value
(E
) = Uint_2
** Uint_14
17120 and then Machine_Emin_Value
(E
) = Uint_3
- (Uint_2
** Uint_14
);
17121 end Is_Extended_Precision_Floating_Point_Type
;
17123 -----------------------
17124 -- Is_EVF_Expression --
17125 -----------------------
17127 function Is_EVF_Expression
(N
: Node_Id
) return Boolean is
17128 Orig_N
: constant Node_Id
:= Original_Node
(N
);
17134 -- Detect a reference to a formal parameter of a specific tagged type
17135 -- whose related subprogram is subject to pragma Expresions_Visible with
17138 if Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
17143 and then Is_Specific_Tagged_Type
(Etype
(Id
))
17144 and then Extensions_Visible_Status
(Id
) =
17145 Extensions_Visible_False
;
17147 -- A case expression is an EVF expression when it contains at least one
17148 -- EVF dependent_expression. Note that a case expression may have been
17149 -- expanded, hence the use of Original_Node.
17151 elsif Nkind
(Orig_N
) = N_Case_Expression
then
17152 Alt
:= First
(Alternatives
(Orig_N
));
17153 while Present
(Alt
) loop
17154 if Is_EVF_Expression
(Expression
(Alt
)) then
17161 -- An if expression is an EVF expression when it contains at least one
17162 -- EVF dependent_expression. Note that an if expression may have been
17163 -- expanded, hence the use of Original_Node.
17165 elsif Nkind
(Orig_N
) = N_If_Expression
then
17166 Expr
:= Next
(First
(Expressions
(Orig_N
)));
17167 while Present
(Expr
) loop
17168 if Is_EVF_Expression
(Expr
) then
17175 -- A qualified expression or a type conversion is an EVF expression when
17176 -- its operand is an EVF expression.
17178 elsif Nkind
(N
) in N_Qualified_Expression
17179 | N_Unchecked_Type_Conversion
17180 | N_Type_Conversion
17182 return Is_EVF_Expression
(Expression
(N
));
17184 -- Attributes 'Loop_Entry, 'Old, and 'Update are EVF expressions when
17185 -- their prefix denotes an EVF expression.
17187 elsif Nkind
(N
) = N_Attribute_Reference
17188 and then Attribute_Name
(N
) in Name_Loop_Entry
17192 return Is_EVF_Expression
(Prefix
(N
));
17196 end Is_EVF_Expression
;
17202 function Is_False
(U
: Opt_Ubool
) return Boolean is
17204 return not Is_True
(U
);
17207 ---------------------------
17208 -- Is_Fixed_Model_Number --
17209 ---------------------------
17211 function Is_Fixed_Model_Number
(U
: Ureal
; T
: Entity_Id
) return Boolean is
17212 S
: constant Ureal
:= Small_Value
(T
);
17213 M
: Urealp
.Save_Mark
;
17218 R
:= (U
= UR_Trunc
(U
/ S
) * S
);
17219 Urealp
.Release
(M
);
17221 end Is_Fixed_Model_Number
;
17223 -----------------------------
17224 -- Is_Full_Access_Object --
17225 -----------------------------
17227 function Is_Full_Access_Object
(N
: Node_Id
) return Boolean is
17229 return Is_Atomic_Object
(N
)
17230 or else Is_Volatile_Full_Access_Object_Ref
(N
);
17231 end Is_Full_Access_Object
;
17233 -------------------------------
17234 -- Is_Fully_Initialized_Type --
17235 -------------------------------
17237 function Is_Fully_Initialized_Type
(Typ
: Entity_Id
) return Boolean is
17241 if Is_Scalar_Type
(Typ
) then
17243 -- A scalar type with an aspect Default_Value is fully initialized
17245 -- Note: Iniitalize/Normalize_Scalars also ensure full initialization
17246 -- of a scalar type, but we don't take that into account here, since
17247 -- we don't want these to affect warnings.
17249 return Has_Default_Aspect
(Typ
);
17251 elsif Is_Access_Type
(Typ
) then
17254 elsif Is_Array_Type
(Typ
) then
17255 if Is_Fully_Initialized_Type
(Component_Type
(Typ
))
17256 or else (Ada_Version
>= Ada_2012
and then Has_Default_Aspect
(Typ
))
17261 -- An interesting case, if we have a constrained type one of whose
17262 -- bounds is known to be null, then there are no elements to be
17263 -- initialized, so all the elements are initialized.
17265 if Is_Constrained
(Typ
) then
17268 Indx_Typ
: Entity_Id
;
17269 Lbd
, Hbd
: Node_Id
;
17272 Indx
:= First_Index
(Typ
);
17273 while Present
(Indx
) loop
17274 if Etype
(Indx
) = Any_Type
then
17277 -- If index is a range, use directly
17279 elsif Nkind
(Indx
) = N_Range
then
17280 Lbd
:= Low_Bound
(Indx
);
17281 Hbd
:= High_Bound
(Indx
);
17284 Indx_Typ
:= Etype
(Indx
);
17286 if Is_Private_Type
(Indx_Typ
) then
17287 Indx_Typ
:= Full_View
(Indx_Typ
);
17290 if No
(Indx_Typ
) or else Etype
(Indx_Typ
) = Any_Type
then
17293 Lbd
:= Type_Low_Bound
(Indx_Typ
);
17294 Hbd
:= Type_High_Bound
(Indx_Typ
);
17298 if Compile_Time_Known_Value
(Lbd
)
17300 Compile_Time_Known_Value
(Hbd
)
17302 if Expr_Value
(Hbd
) < Expr_Value
(Lbd
) then
17312 -- If no null indexes, then type is not fully initialized
17318 elsif Is_Record_Type
(Typ
) then
17319 if Has_Defaulted_Discriminants
(Typ
)
17320 and then Is_Fully_Initialized_Variant
(Typ
)
17325 -- We consider bounded string types to be fully initialized, because
17326 -- otherwise we get false alarms when the Data component is not
17327 -- default-initialized.
17329 if Is_Bounded_String
(Typ
) then
17333 -- Controlled records are considered to be fully initialized if
17334 -- there is a user defined Initialize routine. This may not be
17335 -- entirely correct, but as the spec notes, we are guessing here
17336 -- what is best from the point of view of issuing warnings.
17338 if Is_Controlled
(Typ
) then
17340 Utyp
: constant Entity_Id
:= Underlying_Type
(Typ
);
17343 if Present
(Utyp
) then
17345 Init
: constant Entity_Id
:=
17346 (Find_Optional_Prim_Op
17347 (Utyp
, Name_Initialize
));
17351 and then Comes_From_Source
(Init
)
17352 and then not In_Predefined_Unit
(Init
)
17356 elsif Has_Null_Extension
(Typ
)
17358 Is_Fully_Initialized_Type
17359 (Etype
(Base_Type
(Typ
)))
17368 -- Otherwise see if all record components are initialized
17374 Comp
:= First_Component
(Typ
);
17375 while Present
(Comp
) loop
17376 if (No
(Parent
(Comp
))
17377 or else No
(Expression
(Parent
(Comp
))))
17378 and then not Is_Fully_Initialized_Type
(Etype
(Comp
))
17380 -- Special VM case for tag components, which need to be
17381 -- defined in this case, but are never initialized as VMs
17382 -- are using other dispatching mechanisms. Ignore this
17383 -- uninitialized case. Note that this applies both to the
17384 -- uTag entry and the main vtable pointer (CPP_Class case).
17386 and then (Tagged_Type_Expansion
or else not Is_Tag
(Comp
))
17391 Next_Component
(Comp
);
17395 -- No uninitialized components, so type is fully initialized.
17396 -- Note that this catches the case of no components as well.
17400 elsif Is_Concurrent_Type
(Typ
) then
17403 elsif Is_Private_Type
(Typ
) then
17405 U
: constant Entity_Id
:= Underlying_Type
(Typ
);
17411 return Is_Fully_Initialized_Type
(U
);
17418 end Is_Fully_Initialized_Type
;
17420 ----------------------------------
17421 -- Is_Fully_Initialized_Variant --
17422 ----------------------------------
17424 function Is_Fully_Initialized_Variant
(Typ
: Entity_Id
) return Boolean is
17425 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
17426 Constraints
: constant List_Id
:= New_List
;
17427 Components
: constant Elist_Id
:= New_Elmt_List
;
17428 Comp_Elmt
: Elmt_Id
;
17430 Comp_List
: Node_Id
;
17432 Discr_Val
: Node_Id
;
17434 Report_Errors
: Boolean;
17435 pragma Warnings
(Off
, Report_Errors
);
17438 if Serious_Errors_Detected
> 0 then
17442 if Is_Record_Type
(Typ
)
17443 and then Nkind
(Parent
(Typ
)) = N_Full_Type_Declaration
17444 and then Nkind
(Type_Definition
(Parent
(Typ
))) = N_Record_Definition
17446 Comp_List
:= Component_List
(Type_Definition
(Parent
(Typ
)));
17448 Discr
:= First_Discriminant
(Typ
);
17449 while Present
(Discr
) loop
17450 if Nkind
(Parent
(Discr
)) = N_Discriminant_Specification
then
17451 Discr_Val
:= Expression
(Parent
(Discr
));
17453 if Present
(Discr_Val
)
17454 and then Is_OK_Static_Expression
(Discr_Val
)
17456 Append_To
(Constraints
,
17457 Make_Component_Association
(Loc
,
17458 Choices
=> New_List
(New_Occurrence_Of
(Discr
, Loc
)),
17459 Expression
=> New_Copy
(Discr_Val
)));
17467 Next_Discriminant
(Discr
);
17472 Comp_List
=> Comp_List
,
17473 Governed_By
=> Constraints
,
17474 Into
=> Components
,
17475 Report_Errors
=> Report_Errors
);
17477 -- Check that each component present is fully initialized
17479 Comp_Elmt
:= First_Elmt
(Components
);
17480 while Present
(Comp_Elmt
) loop
17481 Comp_Id
:= Node
(Comp_Elmt
);
17483 if Ekind
(Comp_Id
) = E_Component
17484 and then (No
(Parent
(Comp_Id
))
17485 or else No
(Expression
(Parent
(Comp_Id
))))
17486 and then not Is_Fully_Initialized_Type
(Etype
(Comp_Id
))
17491 Next_Elmt
(Comp_Elmt
);
17496 elsif Is_Private_Type
(Typ
) then
17498 U
: constant Entity_Id
:= Underlying_Type
(Typ
);
17504 return Is_Fully_Initialized_Variant
(U
);
17511 end Is_Fully_Initialized_Variant
;
17513 ------------------------------------
17514 -- Is_Generic_Declaration_Or_Body --
17515 ------------------------------------
17517 function Is_Generic_Declaration_Or_Body
(Decl
: Node_Id
) return Boolean is
17518 Spec_Decl
: Node_Id
;
17521 -- Package/subprogram body
17523 if Nkind
(Decl
) in N_Package_Body | N_Subprogram_Body
17524 and then Present
(Corresponding_Spec
(Decl
))
17526 Spec_Decl
:= Unit_Declaration_Node
(Corresponding_Spec
(Decl
));
17528 -- Package/subprogram body stub
17530 elsif Nkind
(Decl
) in N_Package_Body_Stub | N_Subprogram_Body_Stub
17531 and then Present
(Corresponding_Spec_Of_Stub
(Decl
))
17534 Unit_Declaration_Node
(Corresponding_Spec_Of_Stub
(Decl
));
17542 -- Rather than inspecting the defining entity of the spec declaration,
17543 -- look at its Nkind. This takes care of the case where the analysis of
17544 -- a generic body modifies the Ekind of its spec to allow for recursive
17547 return Nkind
(Spec_Decl
) in N_Generic_Declaration
;
17548 end Is_Generic_Declaration_Or_Body
;
17550 ---------------------------
17551 -- Is_Independent_Object --
17552 ---------------------------
17554 function Is_Independent_Object
(N
: Node_Id
) return Boolean is
17555 function Is_Independent_Object_Entity
(Id
: Entity_Id
) return Boolean;
17556 -- Determine whether arbitrary entity Id denotes an object that is
17559 function Prefix_Has_Independent_Components
(P
: Node_Id
) return Boolean;
17560 -- Determine whether prefix P has independent components. This requires
17561 -- the presence of an Independent_Components aspect/pragma.
17563 ------------------------------------
17564 -- Is_Independent_Object_Entity --
17565 ------------------------------------
17567 function Is_Independent_Object_Entity
(Id
: Entity_Id
) return Boolean is
17571 and then (Is_Independent
(Id
)
17573 Is_Independent
(Etype
(Id
)));
17574 end Is_Independent_Object_Entity
;
17576 -------------------------------------
17577 -- Prefix_Has_Independent_Components --
17578 -------------------------------------
17580 function Prefix_Has_Independent_Components
(P
: Node_Id
) return Boolean
17582 Typ
: constant Entity_Id
:= Etype
(P
);
17585 if Is_Access_Type
(Typ
) then
17586 return Has_Independent_Components
(Designated_Type
(Typ
));
17588 elsif Has_Independent_Components
(Typ
) then
17591 elsif Is_Entity_Name
(P
)
17592 and then Has_Independent_Components
(Entity
(P
))
17599 end Prefix_Has_Independent_Components
;
17601 -- Start of processing for Is_Independent_Object
17604 if Is_Entity_Name
(N
) then
17605 return Is_Independent_Object_Entity
(Entity
(N
));
17607 elsif Is_Independent
(Etype
(N
)) then
17610 elsif Nkind
(N
) = N_Indexed_Component
then
17611 return Prefix_Has_Independent_Components
(Prefix
(N
));
17613 elsif Nkind
(N
) = N_Selected_Component
then
17614 return Prefix_Has_Independent_Components
(Prefix
(N
))
17615 or else Is_Independent
(Entity
(Selector_Name
(N
)));
17620 end Is_Independent_Object
;
17622 ----------------------------
17623 -- Is_Inherited_Operation --
17624 ----------------------------
17626 function Is_Inherited_Operation
(E
: Entity_Id
) return Boolean is
17627 pragma Assert
(Is_Overloadable
(E
));
17628 Kind
: constant Node_Kind
:= Nkind
(Parent
(E
));
17630 return Kind
= N_Full_Type_Declaration
17631 or else Kind
= N_Private_Extension_Declaration
17632 or else Kind
= N_Subtype_Declaration
17633 or else (Ekind
(E
) = E_Enumeration_Literal
17634 and then Is_Derived_Type
(Etype
(E
)));
17635 end Is_Inherited_Operation
;
17637 --------------------------------------
17638 -- Is_Inlinable_Expression_Function --
17639 --------------------------------------
17641 function Is_Inlinable_Expression_Function
17642 (Subp
: Entity_Id
) return Boolean
17644 Return_Expr
: Node_Id
;
17647 if Is_Expression_Function_Or_Completion
(Subp
)
17648 and then Has_Pragma_Inline_Always
(Subp
)
17649 and then Needs_No_Actuals
(Subp
)
17650 and then No
(Contract
(Subp
))
17651 and then not Is_Dispatching_Operation
(Subp
)
17652 and then Needs_Finalization
(Etype
(Subp
))
17653 and then not Is_Class_Wide_Type
(Etype
(Subp
))
17654 and then not Has_Invariants
(Etype
(Subp
))
17655 and then Present
(Subprogram_Body
(Subp
))
17656 and then Was_Expression_Function
(Subprogram_Body
(Subp
))
17658 Return_Expr
:= Expression_Of_Expression_Function
(Subp
);
17660 -- The returned object must not have a qualified expression and its
17661 -- nominal subtype must be statically compatible with the result
17662 -- subtype of the expression function.
17665 Nkind
(Return_Expr
) = N_Identifier
17666 and then Etype
(Return_Expr
) = Etype
(Subp
);
17670 end Is_Inlinable_Expression_Function
;
17672 -----------------------
17673 -- Is_Internal_Block --
17674 -----------------------
17676 function Is_Internal_Block
(N
: Node_Id
) return Boolean is
17678 return Nkind
(N
) = N_Block_Statement
17679 and then Is_Internal
(Entity
(Identifier
(N
)));
17680 end Is_Internal_Block
;
17686 function Is_Iterator
(Typ
: Entity_Id
) return Boolean is
17687 function Denotes_Iterator
(Iter_Typ
: Entity_Id
) return Boolean;
17688 -- Determine whether type Iter_Typ is a predefined forward or reversible
17691 ----------------------
17692 -- Denotes_Iterator --
17693 ----------------------
17695 function Denotes_Iterator
(Iter_Typ
: Entity_Id
) return Boolean is
17697 -- Check that the name matches, and that the ultimate ancestor is in
17698 -- a predefined unit, i.e the one that declares iterator interfaces.
17701 Chars
(Iter_Typ
) in Name_Forward_Iterator | Name_Reversible_Iterator
17702 and then In_Predefined_Unit
(Root_Type
(Iter_Typ
));
17703 end Denotes_Iterator
;
17707 Iface_Elmt
: Elmt_Id
;
17710 -- Start of processing for Is_Iterator
17713 -- The type may be a subtype of a descendant of the proper instance of
17714 -- the predefined interface type, so we must use the root type of the
17715 -- given type. The same is done for Is_Reversible_Iterator.
17717 if Is_Class_Wide_Type
(Typ
)
17718 and then Denotes_Iterator
(Root_Type
(Typ
))
17722 elsif not Is_Tagged_Type
(Typ
) or else not Is_Derived_Type
(Typ
) then
17725 elsif Present
(Find_Value_Of_Aspect
(Typ
, Aspect_Iterable
)) then
17729 Collect_Interfaces
(Typ
, Ifaces
);
17731 Iface_Elmt
:= First_Elmt
(Ifaces
);
17732 while Present
(Iface_Elmt
) loop
17733 if Denotes_Iterator
(Node
(Iface_Elmt
)) then
17737 Next_Elmt
(Iface_Elmt
);
17744 ----------------------------
17745 -- Is_Iterator_Over_Array --
17746 ----------------------------
17748 function Is_Iterator_Over_Array
(N
: Node_Id
) return Boolean is
17749 Container
: constant Node_Id
:= Name
(N
);
17750 Container_Typ
: constant Entity_Id
:= Base_Type
(Etype
(Container
));
17752 return Is_Array_Type
(Container_Typ
);
17753 end Is_Iterator_Over_Array
;
17755 --------------------------
17756 -- Known_To_Be_Assigned --
17757 --------------------------
17759 function Known_To_Be_Assigned
17761 Only_LHS
: Boolean := False) return Boolean
17763 function Known_Assn
(N
: Node_Id
) return Boolean is
17764 (Known_To_Be_Assigned
(N
, Only_LHS
));
17765 -- Local function to simplify the passing of parameters for recursive
17768 P
: constant Node_Id
:= Parent
(N
);
17769 Form
: Entity_Id
:= Empty
;
17770 Call
: Node_Id
:= Empty
;
17772 -- Start of processing for Known_To_Be_Assigned
17775 -- Check for out parameters
17777 Find_Actual
(N
, Form
, Call
);
17779 if Present
(Form
) then
17780 return Ekind
(Form
) /= E_In_Parameter
and then not Only_LHS
;
17783 -- Otherwise look at the parent
17787 -- Test left side of assignment
17789 when N_Assignment_Statement
=>
17790 return N
= Name
(P
);
17792 -- Test prefix of component or attribute. Note that the prefix of an
17793 -- explicit or implicit dereference cannot be an l-value. In the case
17794 -- of a 'Read attribute, the reference can be an actual in the
17795 -- argument list of the attribute.
17797 when N_Attribute_Reference
=>
17799 not Only_LHS
and then
17801 and then Name_Implies_Lvalue_Prefix
(Attribute_Name
(P
)))
17803 Attribute_Name
(P
) = Name_Read
);
17805 -- For an expanded name, the name is an lvalue if the expanded name
17806 -- is an lvalue, but the prefix is never an lvalue, since it is just
17807 -- the scope where the name is found.
17809 when N_Expanded_Name
=>
17810 if N
= Prefix
(P
) then
17811 return Known_Assn
(P
);
17816 -- For a selected component A.B, A is certainly an lvalue if A.B is.
17817 -- B is a little interesting, if we have A.B := 3, there is some
17818 -- discussion as to whether B is an lvalue or not, we choose to say
17819 -- it is. Note however that A is not an lvalue if it is of an access
17820 -- type since this is an implicit dereference.
17822 when N_Selected_Component
=>
17824 and then Present
(Etype
(N
))
17825 and then Is_Access_Type
(Etype
(N
))
17829 return Known_Assn
(P
);
17832 -- For an indexed component or slice, the index or slice bounds is
17833 -- never an lvalue. The prefix is an lvalue if the indexed component
17834 -- or slice is an lvalue, except if it is an access type, where we
17835 -- have an implicit dereference.
17837 when N_Indexed_Component | N_Slice
=>
17839 or else (Present
(Etype
(N
)) and then Is_Access_Type
(Etype
(N
)))
17843 return Known_Assn
(P
);
17846 -- Prefix of a reference is an lvalue if the reference is an lvalue
17848 when N_Reference
=>
17849 return Known_Assn
(P
);
17851 -- Prefix of explicit dereference is never an lvalue
17853 when N_Explicit_Dereference
=>
17856 -- Test for appearing in a conversion that itself appears in an
17857 -- lvalue context, since this should be an lvalue.
17859 when N_Type_Conversion
=>
17860 return Known_Assn
(P
);
17862 -- Test for appearance in object renaming declaration
17864 when N_Object_Renaming_Declaration
=>
17865 return not Only_LHS
;
17867 -- All other references are definitely not lvalues
17872 end Known_To_Be_Assigned
;
17874 -----------------------------
17875 -- Is_Library_Level_Entity --
17876 -----------------------------
17878 function Is_Library_Level_Entity
(E
: Entity_Id
) return Boolean is
17880 -- The following is a small optimization, and it also properly handles
17881 -- discriminals, which in task bodies might appear in expressions before
17882 -- the corresponding procedure has been created, and which therefore do
17883 -- not have an assigned scope.
17885 if Is_Formal
(E
) then
17888 -- If we somehow got an empty value for Scope, the tree must be
17889 -- malformed. Rather than blow up we return True in this case.
17891 elsif No
(Scope
(E
)) then
17894 -- Handle loops since Enclosing_Dynamic_Scope skips them; required to
17895 -- properly handle entities local to quantified expressions in library
17896 -- level specifications.
17898 elsif Ekind
(Scope
(E
)) = E_Loop
then
17902 -- Normal test is simply that the enclosing dynamic scope is Standard
17904 return Enclosing_Dynamic_Scope
(E
) = Standard_Standard
;
17905 end Is_Library_Level_Entity
;
17907 --------------------------------
17908 -- Is_Limited_Class_Wide_Type --
17909 --------------------------------
17911 function Is_Limited_Class_Wide_Type
(Typ
: Entity_Id
) return Boolean is
17914 Is_Class_Wide_Type
(Typ
)
17915 and then (Is_Limited_Type
(Typ
) or else From_Limited_With
(Typ
));
17916 end Is_Limited_Class_Wide_Type
;
17918 ---------------------------------
17919 -- Is_Local_Variable_Reference --
17920 ---------------------------------
17922 function Is_Local_Variable_Reference
(Expr
: Node_Id
) return Boolean is
17924 if not Is_Entity_Name
(Expr
) then
17929 Ent
: constant Entity_Id
:= Entity
(Expr
);
17930 Sub
: constant Entity_Id
:= Enclosing_Subprogram
(Ent
);
17933 not in E_Variable | E_In_Out_Parameter | E_Out_Parameter
17937 return Present
(Sub
) and then Sub
= Current_Subprogram
;
17941 end Is_Local_Variable_Reference
;
17947 function Is_Master
(N
: Node_Id
) return Boolean is
17948 Disable_Subexpression_Masters
: constant Boolean := True;
17951 if Nkind
(N
) in N_Subprogram_Body | N_Task_Body | N_Entry_Body
17952 or else Is_Statement
(N
)
17957 -- We avoid returning True when the master is a subexpression described
17958 -- in RM 7.6.1(3/2) for the proposes of accessibility level calculation
17959 -- in Accessibility_Level_Helper.Innermost_Master_Scope_Depth ???
17961 if not Disable_Subexpression_Masters
17962 and then Nkind
(N
) in N_Subexpr
17965 Par
: Node_Id
:= N
;
17967 subtype N_Simple_Statement_Other_Than_Simple_Return
17968 is Node_Kind
with Static_Predicate
=>
17969 N_Simple_Statement_Other_Than_Simple_Return
17970 in N_Abort_Statement
17971 | N_Assignment_Statement
17973 | N_Delay_Statement
17974 | N_Entry_Call_Statement
17978 | N_Raise_Statement
17979 | N_Requeue_Statement
17981 | N_Procedure_Call_Statement
;
17983 while Present
(Par
) loop
17984 Par
:= Parent
(Par
);
17985 if Nkind
(Par
) in N_Subexpr |
17986 N_Simple_Statement_Other_Than_Simple_Return
17999 -----------------------
18000 -- Is_Name_Reference --
18001 -----------------------
18003 function Is_Name_Reference
(N
: Node_Id
) return Boolean is
18005 if Is_Entity_Name
(N
) then
18006 return Present
(Entity
(N
)) and then Is_Object
(Entity
(N
));
18010 when N_Indexed_Component
18014 Is_Name_Reference
(Prefix
(N
))
18015 or else Is_Access_Type
(Etype
(Prefix
(N
)));
18017 -- Attributes 'Input, 'Old and 'Result produce objects
18019 when N_Attribute_Reference
=>
18020 return Attribute_Name
(N
) in Name_Input | Name_Old | Name_Result
;
18022 when N_Selected_Component
=>
18024 Is_Name_Reference
(Selector_Name
(N
))
18026 (Is_Name_Reference
(Prefix
(N
))
18027 or else Is_Access_Type
(Etype
(Prefix
(N
))));
18029 when N_Explicit_Dereference
=>
18032 -- A view conversion of a tagged name is a name reference
18034 when N_Type_Conversion
=>
18036 Is_Tagged_Type
(Etype
(Subtype_Mark
(N
)))
18037 and then Is_Tagged_Type
(Etype
(Expression
(N
)))
18038 and then Is_Name_Reference
(Expression
(N
));
18040 -- An unchecked type conversion is considered to be a name if the
18041 -- operand is a name (this construction arises only as a result of
18042 -- expansion activities).
18044 when N_Unchecked_Type_Conversion
=>
18045 return Is_Name_Reference
(Expression
(N
));
18050 end Is_Name_Reference
;
18052 --------------------------
18053 -- Is_Newly_Constructed --
18054 --------------------------
18056 function Is_Newly_Constructed
18057 (Exp
: Node_Id
; Context_Requires_NC
: Boolean) return Boolean
18059 Original_Exp
: constant Node_Id
:= Original_Node
(Exp
);
18061 function Is_NC
(Exp
: Node_Id
) return Boolean is
18062 (Is_Newly_Constructed
(Exp
, Context_Requires_NC
));
18064 -- If the context requires that the expression shall be newly
18065 -- constructed, then "True" is a good result in the sense that the
18066 -- expression satisfies the requirements of the context (and "False"
18067 -- is analogously a bad result). If the context requires that the
18068 -- expression shall *not* be newly constructed, then things are
18069 -- reversed: "False" is the good value and "True" is the bad value.
18071 Good_Result
: constant Boolean := Context_Requires_NC
;
18072 Bad_Result
: constant Boolean := not Good_Result
;
18074 case Nkind
(Original_Exp
) is
18076 | N_Extension_Aggregate
18082 when N_Identifier
=>
18083 return Present
(Entity
(Original_Exp
))
18084 and then Ekind
(Entity
(Original_Exp
)) = E_Function
;
18086 when N_Qualified_Expression
=>
18087 return Is_NC
(Expression
(Original_Exp
));
18089 when N_Type_Conversion
18090 | N_Unchecked_Type_Conversion
18092 if Is_View_Conversion
(Original_Exp
) then
18093 return Is_NC
(Expression
(Original_Exp
));
18094 elsif not Comes_From_Source
(Exp
) then
18095 if Exp
/= Original_Exp
then
18096 return Is_NC
(Original_Exp
);
18098 return Is_NC
(Expression
(Original_Exp
));
18104 when N_Explicit_Dereference
18105 | N_Indexed_Component
18106 | N_Selected_Component
18108 return Nkind
(Exp
) = N_Function_Call
;
18110 -- A use of 'Input is a function call, hence allowed. Normally the
18111 -- attribute will be changed to a call, but the attribute by itself
18112 -- can occur with -gnatc.
18114 when N_Attribute_Reference
=>
18115 return Attribute_Name
(Original_Exp
) = Name_Input
;
18117 -- "return raise ..." is OK
18119 when N_Raise_Expression
=>
18120 return Good_Result
;
18122 -- For a case expression, all dependent expressions must be legal
18124 when N_Case_Expression
=>
18129 Alt
:= First
(Alternatives
(Original_Exp
));
18130 while Present
(Alt
) loop
18131 if Is_NC
(Expression
(Alt
)) = Bad_Result
then
18138 return Good_Result
;
18141 -- For an if expression, all dependent expressions must be legal
18143 when N_If_Expression
=>
18145 Then_Expr
: constant Node_Id
:=
18146 Next
(First
(Expressions
(Original_Exp
)));
18147 Else_Expr
: constant Node_Id
:= Next
(Then_Expr
);
18149 if Is_NC
(Then_Expr
) = Bad_Result
18150 or else Is_NC
(Else_Expr
) = Bad_Result
18154 return Good_Result
;
18161 end Is_Newly_Constructed
;
18163 ------------------------------------
18164 -- Is_Non_Preelaborable_Construct --
18165 ------------------------------------
18167 function Is_Non_Preelaborable_Construct
(N
: Node_Id
) return Boolean is
18169 -- NOTE: the routines within Is_Non_Preelaborable_Construct are
18170 -- intentionally unnested to avoid deep indentation of code.
18172 Non_Preelaborable
: exception;
18173 -- This exception is raised when the construct violates preelaborability
18174 -- to terminate the recursion.
18176 procedure Visit
(Nod
: Node_Id
);
18177 -- Semantically inspect construct Nod to determine whether it violates
18178 -- preelaborability. This routine raises Non_Preelaborable.
18180 procedure Visit_List
(List
: List_Id
);
18181 pragma Inline
(Visit_List
);
18182 -- Invoke Visit on each element of list List. This routine raises
18183 -- Non_Preelaborable.
18185 procedure Visit_Pragma
(Prag
: Node_Id
);
18186 pragma Inline
(Visit_Pragma
);
18187 -- Semantically inspect pragma Prag to determine whether it violates
18188 -- preelaborability. This routine raises Non_Preelaborable.
18190 procedure Visit_Subexpression
(Expr
: Node_Id
);
18191 pragma Inline
(Visit_Subexpression
);
18192 -- Semantically inspect expression Expr to determine whether it violates
18193 -- preelaborability. This routine raises Non_Preelaborable.
18199 procedure Visit
(Nod
: Node_Id
) is
18201 case Nkind
(Nod
) is
18205 when N_Component_Declaration
=>
18207 -- Defining_Identifier is left out because it is not relevant
18208 -- for preelaborability.
18210 Visit
(Component_Definition
(Nod
));
18211 Visit
(Expression
(Nod
));
18213 when N_Derived_Type_Definition
=>
18215 -- Interface_List is left out because it is not relevant for
18216 -- preelaborability.
18218 Visit
(Record_Extension_Part
(Nod
));
18219 Visit
(Subtype_Indication
(Nod
));
18221 when N_Entry_Declaration
=>
18223 -- A protected type with at leat one entry is not preelaborable
18224 -- while task types are never preelaborable. This renders entry
18225 -- declarations non-preelaborable.
18227 raise Non_Preelaborable
;
18229 when N_Full_Type_Declaration
=>
18231 -- Defining_Identifier and Discriminant_Specifications are left
18232 -- out because they are not relevant for preelaborability.
18234 Visit
(Type_Definition
(Nod
));
18236 when N_Function_Instantiation
18237 | N_Package_Instantiation
18238 | N_Procedure_Instantiation
18240 -- Defining_Unit_Name and Name are left out because they are
18241 -- not relevant for preelaborability.
18243 Visit_List
(Generic_Associations
(Nod
));
18245 when N_Object_Declaration
=>
18247 -- Defining_Identifier is left out because it is not relevant
18248 -- for preelaborability.
18250 Visit
(Object_Definition
(Nod
));
18252 if Has_Init_Expression
(Nod
) then
18253 Visit
(Expression
(Nod
));
18255 elsif not Constant_Present
(Nod
)
18256 and then not Has_Preelaborable_Initialization
18257 (Etype
(Defining_Entity
(Nod
)))
18259 raise Non_Preelaborable
;
18262 when N_Private_Extension_Declaration
18263 | N_Subtype_Declaration
18265 -- Defining_Identifier, Discriminant_Specifications, and
18266 -- Interface_List are left out because they are not relevant
18267 -- for preelaborability.
18269 Visit
(Subtype_Indication
(Nod
));
18271 when N_Protected_Type_Declaration
18272 | N_Single_Protected_Declaration
18274 -- Defining_Identifier, Discriminant_Specifications, and
18275 -- Interface_List are left out because they are not relevant
18276 -- for preelaborability.
18278 Visit
(Protected_Definition
(Nod
));
18280 -- A [single] task type is never preelaborable
18282 when N_Single_Task_Declaration
18283 | N_Task_Type_Declaration
18285 raise Non_Preelaborable
;
18290 Visit_Pragma
(Nod
);
18294 when N_Statement_Other_Than_Procedure_Call
=>
18295 if Nkind
(Nod
) /= N_Null_Statement
then
18296 raise Non_Preelaborable
;
18302 Visit_Subexpression
(Nod
);
18306 when N_Access_To_Object_Definition
=>
18307 Visit
(Subtype_Indication
(Nod
));
18309 when N_Case_Expression_Alternative
=>
18310 Visit
(Expression
(Nod
));
18311 Visit_List
(Discrete_Choices
(Nod
));
18313 when N_Component_Definition
=>
18314 Visit
(Access_Definition
(Nod
));
18315 Visit
(Subtype_Indication
(Nod
));
18317 when N_Component_List
=>
18318 Visit_List
(Component_Items
(Nod
));
18319 Visit
(Variant_Part
(Nod
));
18321 when N_Constrained_Array_Definition
=>
18322 Visit_List
(Discrete_Subtype_Definitions
(Nod
));
18323 Visit
(Component_Definition
(Nod
));
18325 when N_Delta_Constraint
18326 | N_Digits_Constraint
18328 -- Delta_Expression and Digits_Expression are left out because
18329 -- they are not relevant for preelaborability.
18331 Visit
(Range_Constraint
(Nod
));
18333 when N_Discriminant_Specification
=>
18335 -- Defining_Identifier and Expression are left out because they
18336 -- are not relevant for preelaborability.
18338 Visit
(Discriminant_Type
(Nod
));
18340 when N_Generic_Association
=>
18342 -- Selector_Name is left out because it is not relevant for
18343 -- preelaborability.
18345 Visit
(Explicit_Generic_Actual_Parameter
(Nod
));
18347 when N_Index_Or_Discriminant_Constraint
=>
18348 Visit_List
(Constraints
(Nod
));
18350 when N_Iterator_Specification
=>
18352 -- Defining_Identifier is left out because it is not relevant
18353 -- for preelaborability.
18355 Visit
(Name
(Nod
));
18356 Visit
(Subtype_Indication
(Nod
));
18358 when N_Loop_Parameter_Specification
=>
18360 -- Defining_Identifier is left out because it is not relevant
18361 -- for preelaborability.
18363 Visit
(Discrete_Subtype_Definition
(Nod
));
18365 when N_Parameter_Association
=>
18366 Visit
(Explicit_Actual_Parameter
(N
));
18368 when N_Protected_Definition
=>
18370 -- End_Label is left out because it is not relevant for
18371 -- preelaborability.
18373 Visit_List
(Private_Declarations
(Nod
));
18374 Visit_List
(Visible_Declarations
(Nod
));
18376 when N_Range_Constraint
=>
18377 Visit
(Range_Expression
(Nod
));
18379 when N_Record_Definition
18382 -- End_Label, Discrete_Choices, and Interface_List are left out
18383 -- because they are not relevant for preelaborability.
18385 Visit
(Component_List
(Nod
));
18387 when N_Subtype_Indication
=>
18389 -- Subtype_Mark is left out because it is not relevant for
18390 -- preelaborability.
18392 Visit
(Constraint
(Nod
));
18394 when N_Unconstrained_Array_Definition
=>
18396 -- Subtype_Marks is left out because it is not relevant for
18397 -- preelaborability.
18399 Visit
(Component_Definition
(Nod
));
18401 when N_Variant_Part
=>
18403 -- Name is left out because it is not relevant for
18404 -- preelaborability.
18406 Visit_List
(Variants
(Nod
));
18419 procedure Visit_List
(List
: List_Id
) is
18423 Nod
:= First
(List
);
18424 while Present
(Nod
) loop
18434 procedure Visit_Pragma
(Prag
: Node_Id
) is
18436 case Get_Pragma_Id
(Prag
) is
18438 | Pragma_Assert_And_Cut
18440 | Pragma_Async_Readers
18441 | Pragma_Async_Writers
18442 | Pragma_Attribute_Definition
18444 | Pragma_Constant_After_Elaboration
18446 | Pragma_Deadline_Floor
18447 | Pragma_Dispatching_Domain
18448 | Pragma_Effective_Reads
18449 | Pragma_Effective_Writes
18450 | Pragma_Extensions_Visible
18452 | Pragma_Secondary_Stack_Size
18454 | Pragma_Volatile_Function
18456 Visit_List
(Pragma_Argument_Associations
(Prag
));
18465 -------------------------
18466 -- Visit_Subexpression --
18467 -------------------------
18469 procedure Visit_Subexpression
(Expr
: Node_Id
) is
18470 procedure Visit_Aggregate
(Aggr
: Node_Id
);
18471 pragma Inline
(Visit_Aggregate
);
18472 -- Semantically inspect aggregate Aggr to determine whether it
18473 -- violates preelaborability.
18475 ---------------------
18476 -- Visit_Aggregate --
18477 ---------------------
18479 procedure Visit_Aggregate
(Aggr
: Node_Id
) is
18481 if not Is_Preelaborable_Aggregate
(Aggr
) then
18482 raise Non_Preelaborable
;
18484 end Visit_Aggregate
;
18486 -- Start of processing for Visit_Subexpression
18489 case Nkind
(Expr
) is
18491 | N_Qualified_Expression
18492 | N_Type_Conversion
18493 | N_Unchecked_Expression
18494 | N_Unchecked_Type_Conversion
18496 -- Subpool_Handle_Name and Subtype_Mark are left out because
18497 -- they are not relevant for preelaborability.
18499 Visit
(Expression
(Expr
));
18502 | N_Extension_Aggregate
18504 Visit_Aggregate
(Expr
);
18506 when N_Attribute_Reference
18507 | N_Explicit_Dereference
18510 -- Attribute_Name and Expressions are left out because they are
18511 -- not relevant for preelaborability.
18513 Visit
(Prefix
(Expr
));
18515 when N_Case_Expression
=>
18517 -- End_Span is left out because it is not relevant for
18518 -- preelaborability.
18520 Visit_List
(Alternatives
(Expr
));
18521 Visit
(Expression
(Expr
));
18523 when N_Delta_Aggregate
=>
18524 Visit_Aggregate
(Expr
);
18525 Visit
(Expression
(Expr
));
18527 when N_Expression_With_Actions
=>
18528 Visit_List
(Actions
(Expr
));
18529 Visit
(Expression
(Expr
));
18531 when N_Function_Call
=>
18533 -- Ada 2022 (AI12-0175): Calls to certain functions that are
18534 -- essentially unchecked conversions are preelaborable.
18536 if Ada_Version
>= Ada_2022
18537 and then Nkind
(Expr
) = N_Function_Call
18538 and then Is_Entity_Name
(Name
(Expr
))
18539 and then Is_Preelaborable_Function
(Entity
(Name
(Expr
)))
18541 Visit_List
(Parameter_Associations
(Expr
));
18543 raise Non_Preelaborable
;
18546 when N_If_Expression
=>
18547 Visit_List
(Expressions
(Expr
));
18549 when N_Quantified_Expression
=>
18550 Visit
(Condition
(Expr
));
18551 Visit
(Iterator_Specification
(Expr
));
18552 Visit
(Loop_Parameter_Specification
(Expr
));
18555 Visit
(High_Bound
(Expr
));
18556 Visit
(Low_Bound
(Expr
));
18559 Visit
(Discrete_Range
(Expr
));
18560 Visit
(Prefix
(Expr
));
18566 -- The evaluation of an object name is not preelaborable,
18567 -- unless the name is a static expression (checked further
18568 -- below), or statically denotes a discriminant.
18570 if Is_Entity_Name
(Expr
) then
18571 Object_Name
: declare
18572 Id
: constant Entity_Id
:= Entity
(Expr
);
18575 if Is_Object
(Id
) then
18576 if Ekind
(Id
) = E_Discriminant
then
18579 elsif Ekind
(Id
) in E_Constant | E_In_Parameter
18580 and then Present
(Discriminal_Link
(Id
))
18585 raise Non_Preelaborable
;
18590 -- A non-static expression is not preelaborable
18592 elsif not Is_OK_Static_Expression
(Expr
) then
18593 raise Non_Preelaborable
;
18596 end Visit_Subexpression
;
18598 -- Start of processing for Is_Non_Preelaborable_Construct
18603 -- At this point it is known that the construct is preelaborable
18609 -- The elaboration of the construct performs an action which violates
18610 -- preelaborability.
18612 when Non_Preelaborable
=>
18614 end Is_Non_Preelaborable_Construct
;
18616 ---------------------------------
18617 -- Is_Nontrivial_DIC_Procedure --
18618 ---------------------------------
18620 function Is_Nontrivial_DIC_Procedure
(Id
: Entity_Id
) return Boolean is
18621 Body_Decl
: Node_Id
;
18625 if Ekind
(Id
) = E_Procedure
and then Is_DIC_Procedure
(Id
) then
18627 Unit_Declaration_Node
18628 (Corresponding_Body
(Unit_Declaration_Node
(Id
)));
18630 -- The body of the Default_Initial_Condition procedure must contain
18631 -- at least one statement, otherwise the generation of the subprogram
18634 pragma Assert
(Present
(Handled_Statement_Sequence
(Body_Decl
)));
18636 -- To qualify as nontrivial, the first statement of the procedure
18637 -- must be a check in the form of an if statement. If the original
18638 -- Default_Initial_Condition expression was folded, then the first
18639 -- statement is not a check.
18641 Stmt
:= First
(Statements
(Handled_Statement_Sequence
(Body_Decl
)));
18644 Nkind
(Stmt
) = N_If_Statement
18645 and then Nkind
(Original_Node
(Stmt
)) = N_Pragma
;
18649 end Is_Nontrivial_DIC_Procedure
;
18651 -----------------------
18652 -- Is_Null_Extension --
18653 -----------------------
18655 function Is_Null_Extension
18656 (T
: Entity_Id
; Ignore_Privacy
: Boolean := False) return Boolean
18658 Type_Decl
: Node_Id
;
18659 Type_Def
: Node_Id
;
18661 pragma Assert
(not Is_Class_Wide_Type
(T
));
18663 if Ignore_Privacy
then
18664 Type_Decl
:= Parent
(Underlying_Type
(Base_Type
(T
)));
18666 Type_Decl
:= Parent
(Base_Type
(T
));
18667 if Nkind
(Type_Decl
) /= N_Full_Type_Declaration
then
18671 pragma Assert
(Nkind
(Type_Decl
) = N_Full_Type_Declaration
);
18672 Type_Def
:= Type_Definition
(Type_Decl
);
18673 if Present
(Discriminant_Specifications
(Type_Decl
))
18674 or else Nkind
(Type_Def
) /= N_Derived_Type_Definition
18675 or else not Is_Tagged_Type
(T
)
18676 or else No
(Record_Extension_Part
(Type_Def
))
18681 return Is_Null_Record_Definition
(Record_Extension_Part
(Type_Def
));
18682 end Is_Null_Extension
;
18684 --------------------------
18685 -- Is_Null_Extension_Of --
18686 --------------------------
18688 function Is_Null_Extension_Of
18689 (Descendant
, Ancestor
: Entity_Id
) return Boolean
18691 Ancestor_Type
: constant Entity_Id
18692 := Underlying_Type
(Base_Type
(Ancestor
));
18693 Descendant_Type
: Entity_Id
:= Underlying_Type
(Base_Type
(Descendant
));
18695 pragma Assert
(not Is_Class_Wide_Type
(Descendant
));
18696 pragma Assert
(not Is_Class_Wide_Type
(Ancestor
));
18697 pragma Assert
(Descendant_Type
/= Ancestor_Type
);
18699 while Descendant_Type
/= Ancestor_Type
loop
18700 if not Is_Null_Extension
18701 (Descendant_Type
, Ignore_Privacy
=> True)
18705 Descendant_Type
:= Etype
(Subtype_Indication
18706 (Type_Definition
(Parent
(Descendant_Type
))));
18707 Descendant_Type
:= Underlying_Type
(Base_Type
(Descendant_Type
));
18710 end Is_Null_Extension_Of
;
18712 -------------------------------
18713 -- Is_Null_Record_Definition --
18714 -------------------------------
18716 function Is_Null_Record_Definition
(Record_Def
: Node_Id
) return Boolean is
18719 -- Testing Null_Present is just an optimization, not required.
18721 if Null_Present
(Record_Def
) then
18723 elsif Present
(Variant_Part
(Component_List
(Record_Def
))) then
18725 elsif No
(Component_List
(Record_Def
)) then
18729 Item
:= First_Non_Pragma
(Component_Items
(Component_List
(Record_Def
)));
18731 while Present
(Item
) loop
18732 if Nkind
(Item
) = N_Component_Declaration
18733 and then Is_Internal_Name
(Chars
(Defining_Identifier
(Item
)))
18739 Next_Non_Pragma
(Item
);
18743 end Is_Null_Record_Definition
;
18745 -------------------------
18746 -- Is_Null_Record_Type --
18747 -------------------------
18749 function Is_Null_Record_Type
18750 (T
: Entity_Id
; Ignore_Privacy
: Boolean := False) return Boolean
18753 Type_Def
: Node_Id
;
18755 if not Is_Record_Type
(T
) then
18759 if Ignore_Privacy
then
18760 Decl
:= Parent
(Underlying_Type
(Base_Type
(T
)));
18762 Decl
:= Parent
(Base_Type
(T
));
18763 if Nkind
(Decl
) /= N_Full_Type_Declaration
then
18767 pragma Assert
(Nkind
(Decl
) = N_Full_Type_Declaration
);
18768 Type_Def
:= Type_Definition
(Decl
);
18770 if Has_Discriminants
(Defining_Identifier
(Decl
)) then
18774 case Nkind
(Type_Def
) is
18775 when N_Record_Definition
=>
18776 return Is_Null_Record_Definition
(Type_Def
);
18777 when N_Derived_Type_Definition
=>
18778 if not Is_Null_Record_Type
18779 (Etype
(Subtype_Indication
(Type_Def
)),
18780 Ignore_Privacy
=> Ignore_Privacy
)
18783 elsif not Is_Tagged_Type
(T
) then
18786 return Is_Null_Extension
(T
, Ignore_Privacy
=> Ignore_Privacy
);
18791 end Is_Null_Record_Type
;
18793 ---------------------
18794 -- Is_Object_Image --
18795 ---------------------
18797 function Is_Object_Image
(Prefix
: Node_Id
) return Boolean is
18799 -- Here we test for the case that the prefix is not a type and assume
18800 -- if it is not then it must be a named value or an object reference.
18801 -- This is because the parser always checks that prefixes of attributes
18804 return not (Is_Entity_Name
(Prefix
)
18805 and then Is_Type
(Entity
(Prefix
))
18806 and then not Is_Current_Instance
(Prefix
));
18807 end Is_Object_Image
;
18809 -------------------------
18810 -- Is_Object_Reference --
18811 -------------------------
18813 function Is_Object_Reference
(N
: Node_Id
) return Boolean is
18814 function Safe_Prefix
(N
: Node_Id
) return Node_Id
;
18815 -- Return Prefix (N) unless it has been rewritten as an
18816 -- N_Raise_xxx_Error node, in which case return its original node.
18822 function Safe_Prefix
(N
: Node_Id
) return Node_Id
is
18824 if Nkind
(Prefix
(N
)) in N_Raise_xxx_Error
then
18825 return Original_Node
(Prefix
(N
));
18832 -- AI12-0068: Note that a current instance reference in a type or
18833 -- subtype's aspect_specification is considered a value, not an object
18834 -- (see RM 8.6(18/5)).
18836 if Is_Entity_Name
(N
) then
18837 return Present
(Entity
(N
)) and then Is_Object
(Entity
(N
))
18838 and then not Is_Current_Instance_Reference_In_Type_Aspect
(N
);
18842 when N_Indexed_Component
18846 Is_Object_Reference
(Safe_Prefix
(N
))
18847 or else Is_Access_Type
(Etype
(Safe_Prefix
(N
)));
18849 -- In Ada 95, a function call is a constant object; a procedure
18852 -- Note that predefined operators are functions as well, and so
18853 -- are attributes that are (can be renamed as) functions.
18855 when N_Function_Call
18858 return Etype
(N
) /= Standard_Void_Type
;
18860 -- Attributes references 'Loop_Entry, 'Old, 'Priority and 'Result
18861 -- yield objects, even though they are not functions.
18863 when N_Attribute_Reference
=>
18865 Attribute_Name
(N
) in Name_Loop_Entry
18869 or else Is_Function_Attribute_Name
(Attribute_Name
(N
));
18871 when N_Selected_Component
=>
18873 Is_Object_Reference
(Selector_Name
(N
))
18875 (Is_Object_Reference
(Safe_Prefix
(N
))
18876 or else Is_Access_Type
(Etype
(Safe_Prefix
(N
))));
18878 -- An explicit dereference denotes an object, except that a
18879 -- conditional expression gets turned into an explicit dereference
18880 -- in some cases, and conditional expressions are not object
18883 when N_Explicit_Dereference
=>
18884 return Nkind
(Original_Node
(N
)) not in
18885 N_Case_Expression | N_If_Expression
;
18887 -- A view conversion of a tagged object is an object reference
18889 when N_Type_Conversion
=>
18890 if Ada_Version
<= Ada_2012
then
18891 -- A view conversion of a tagged object is an object
18893 return Is_Tagged_Type
(Etype
(Subtype_Mark
(N
)))
18894 and then Is_Tagged_Type
(Etype
(Expression
(N
)))
18895 and then Is_Object_Reference
(Expression
(N
));
18898 -- AI12-0226: In Ada 2022 a value conversion of an object is
18901 return Is_Object_Reference
(Expression
(N
));
18904 -- An unchecked type conversion is considered to be an object if
18905 -- the operand is an object (this construction arises only as a
18906 -- result of expansion activities).
18908 when N_Unchecked_Type_Conversion
=>
18911 -- AI05-0003: In Ada 2012 a qualified expression is a name.
18912 -- This allows disambiguation of function calls and the use
18913 -- of aggregates in more contexts.
18915 when N_Qualified_Expression
=>
18916 return Ada_Version
>= Ada_2012
18917 and then Is_Object_Reference
(Expression
(N
));
18919 -- In Ada 95 an aggregate is an object reference
18922 | N_Delta_Aggregate
18923 | N_Extension_Aggregate
18925 return Ada_Version
>= Ada_95
;
18927 -- A string literal is not an object reference, but it might come
18928 -- from rewriting of an object reference, e.g. from folding of an
18931 when N_String_Literal
=>
18932 return Is_Rewrite_Substitution
(N
)
18933 and then Is_Object_Reference
(Original_Node
(N
));
18935 -- AI12-0125: Target name represents a constant object
18937 when N_Target_Name
=>
18944 end Is_Object_Reference
;
18946 -----------------------------------
18947 -- Is_OK_Variable_For_Out_Formal --
18948 -----------------------------------
18950 function Is_OK_Variable_For_Out_Formal
(AV
: Node_Id
) return Boolean is
18952 Note_Possible_Modification
(AV
, Sure
=> True);
18954 -- We must reject parenthesized variable names. Comes_From_Source is
18955 -- checked because there are currently cases where the compiler violates
18956 -- this rule (e.g. passing a task object to its controlled Initialize
18957 -- routine). This should be properly documented in sinfo???
18959 if Paren_Count
(AV
) > 0 and then Comes_From_Source
(AV
) then
18962 -- A variable is always allowed
18964 elsif Is_Variable
(AV
) then
18967 -- Generalized indexing operations are rewritten as explicit
18968 -- dereferences, and it is only during resolution that we can
18969 -- check whether the context requires an access_to_variable type.
18971 elsif Nkind
(AV
) = N_Explicit_Dereference
18972 and then Present
(Etype
(Original_Node
(AV
)))
18973 and then Has_Implicit_Dereference
(Etype
(Original_Node
(AV
)))
18974 and then Ada_Version
>= Ada_2012
18976 return not Is_Access_Constant
(Etype
(Prefix
(AV
)));
18978 -- Unchecked conversions are allowed only if they come from the
18979 -- generated code, which sometimes uses unchecked conversions for out
18980 -- parameters in cases where code generation is unaffected. We tell
18981 -- source unchecked conversions by seeing if they are rewrites of
18982 -- an original Unchecked_Conversion function call, or of an explicit
18983 -- conversion of a function call or an aggregate (as may happen in the
18984 -- expansion of a packed array aggregate).
18986 elsif Nkind
(AV
) = N_Unchecked_Type_Conversion
then
18987 if Nkind
(Original_Node
(AV
)) in N_Function_Call | N_Aggregate
then
18990 elsif Nkind
(Original_Node
(Expression
(AV
))) = N_Function_Call
then
18993 elsif Nkind
(Original_Node
(AV
)) = N_Type_Conversion
then
18994 return Is_OK_Variable_For_Out_Formal
(Expression
(AV
));
19000 -- Normal type conversions are allowed if argument is a variable
19002 elsif Nkind
(AV
) = N_Type_Conversion
then
19003 if Is_Variable
(Expression
(AV
))
19004 and then Paren_Count
(Expression
(AV
)) = 0
19006 Note_Possible_Modification
(Expression
(AV
), Sure
=> True);
19009 -- We also allow a non-parenthesized expression that raises
19010 -- constraint error if it rewrites what used to be a variable
19012 elsif Raises_Constraint_Error
(Expression
(AV
))
19013 and then Paren_Count
(Expression
(AV
)) = 0
19014 and then Is_Variable
(Original_Node
(Expression
(AV
)))
19018 -- Type conversion of something other than a variable
19024 -- If this node is rewritten, then test the original form, if that is
19025 -- OK, then we consider the rewritten node OK (for example, if the
19026 -- original node is a conversion, then Is_Variable will not be true
19027 -- but we still want to allow the conversion if it converts a variable).
19029 elsif Is_Rewrite_Substitution
(AV
) then
19030 return Is_OK_Variable_For_Out_Formal
(Original_Node
(AV
));
19032 -- All other non-variables are rejected
19037 end Is_OK_Variable_For_Out_Formal
;
19039 ----------------------------
19040 -- Is_OK_Volatile_Context --
19041 ----------------------------
19043 function Is_OK_Volatile_Context
19044 (Context
: Node_Id
;
19046 Check_Actuals
: Boolean) return Boolean
19048 function Is_Protected_Operation_Call
(Nod
: Node_Id
) return Boolean;
19049 -- Determine whether an arbitrary node denotes a call to a protected
19050 -- entry, function, or procedure in prefixed form where the prefix is
19053 function Within_Check
(Nod
: Node_Id
) return Boolean;
19054 -- Determine whether an arbitrary node appears in a check node
19056 function Within_Volatile_Function
(Id
: Entity_Id
) return Boolean;
19057 -- Determine whether an arbitrary entity appears in a volatile function
19059 ---------------------------------
19060 -- Is_Protected_Operation_Call --
19061 ---------------------------------
19063 function Is_Protected_Operation_Call
(Nod
: Node_Id
) return Boolean is
19068 -- A call to a protected operations retains its selected component
19069 -- form as opposed to other prefixed calls that are transformed in
19072 if Nkind
(Nod
) = N_Selected_Component
then
19073 Pref
:= Prefix
(Nod
);
19074 Subp
:= Selector_Name
(Nod
);
19078 and then Present
(Etype
(Pref
))
19079 and then Is_Protected_Type
(Etype
(Pref
))
19080 and then Is_Entity_Name
(Subp
)
19081 and then Present
(Entity
(Subp
))
19082 and then Ekind
(Entity
(Subp
)) in
19083 E_Entry | E_Entry_Family | E_Function | E_Procedure
;
19087 end Is_Protected_Operation_Call
;
19093 function Within_Check
(Nod
: Node_Id
) return Boolean is
19097 -- Climb the parent chain looking for a check node
19100 while Present
(Par
) loop
19101 if Nkind
(Par
) in N_Raise_xxx_Error
then
19104 -- Prevent the search from going too far
19106 elsif Is_Body_Or_Package_Declaration
(Par
) then
19110 Par
:= Parent
(Par
);
19116 ------------------------------
19117 -- Within_Volatile_Function --
19118 ------------------------------
19120 function Within_Volatile_Function
(Id
: Entity_Id
) return Boolean is
19121 pragma Assert
(Ekind
(Id
) = E_Return_Statement
);
19123 Func_Id
: constant Entity_Id
:= Return_Applies_To
(Id
);
19126 pragma Assert
(Ekind
(Func_Id
) in E_Function | E_Generic_Function
);
19128 return Is_Volatile_Function
(Func_Id
);
19129 end Within_Volatile_Function
;
19133 Obj_Id
: Entity_Id
;
19135 -- Start of processing for Is_OK_Volatile_Context
19138 -- Ignore context restriction when doing preanalysis, e.g. on a copy of
19139 -- an expression function, because this copy is not fully decorated and
19140 -- it is not possible to reliably decide the legality of the context.
19141 -- Any violations will be reported anyway when doing the full analysis.
19143 if not Full_Analysis
then
19147 -- For actual parameters within explicit parameter associations switch
19148 -- the context to the corresponding subprogram call.
19150 if Nkind
(Context
) = N_Parameter_Association
then
19151 return Is_OK_Volatile_Context
(Context
=> Parent
(Context
),
19152 Obj_Ref
=> Obj_Ref
,
19153 Check_Actuals
=> Check_Actuals
);
19155 -- The volatile object appears on either side of an assignment
19157 elsif Nkind
(Context
) = N_Assignment_Statement
then
19160 -- The volatile object is part of the initialization expression of
19163 elsif Nkind
(Context
) = N_Object_Declaration
19164 and then Present
(Expression
(Context
))
19165 and then Expression
(Context
) = Obj_Ref
19166 and then Nkind
(Parent
(Context
)) /= N_Expression_With_Actions
19168 Obj_Id
:= Defining_Entity
(Context
);
19170 -- The volatile object acts as the initialization expression of an
19171 -- extended return statement. This is valid context as long as the
19172 -- function is volatile.
19174 if Is_Return_Object
(Obj_Id
) then
19175 return Within_Volatile_Function
(Scope
(Obj_Id
));
19177 -- Otherwise this is a normal object initialization
19183 -- The volatile object acts as the name of a renaming declaration
19185 elsif Nkind
(Context
) = N_Object_Renaming_Declaration
19186 and then Name
(Context
) = Obj_Ref
19190 -- The volatile object appears as an actual parameter in a call to an
19191 -- instance of Unchecked_Conversion whose result is renamed.
19193 elsif Nkind
(Context
) = N_Function_Call
19194 and then Is_Entity_Name
(Name
(Context
))
19195 and then Is_Unchecked_Conversion_Instance
(Entity
(Name
(Context
)))
19196 and then Nkind
(Parent
(Context
)) = N_Object_Renaming_Declaration
19200 -- The volatile object is actually the prefix in a protected entry,
19201 -- function, or procedure call.
19203 elsif Is_Protected_Operation_Call
(Context
) then
19206 -- The volatile object appears as the expression of a simple return
19207 -- statement that applies to a volatile function.
19209 elsif Nkind
(Context
) = N_Simple_Return_Statement
19210 and then Expression
(Context
) = Obj_Ref
19213 Within_Volatile_Function
(Return_Statement_Entity
(Context
));
19215 -- The volatile object appears as the prefix of a name occurring in a
19216 -- non-interfering context.
19218 elsif Nkind
(Context
) in
19219 N_Attribute_Reference |
19220 N_Explicit_Dereference |
19221 N_Indexed_Component |
19222 N_Selected_Component |
19224 and then Prefix
(Context
) = Obj_Ref
19225 and then Is_OK_Volatile_Context
19226 (Context
=> Parent
(Context
),
19227 Obj_Ref
=> Context
,
19228 Check_Actuals
=> Check_Actuals
)
19232 -- The volatile object appears as the prefix of attributes Address,
19233 -- Alignment, Component_Size, First, First_Bit, Last, Last_Bit, Length,
19234 -- Position, Size, Storage_Size.
19236 elsif Nkind
(Context
) = N_Attribute_Reference
19237 and then Prefix
(Context
) = Obj_Ref
19238 and then Attribute_Name
(Context
) in Name_Address
19240 | Name_Component_Size
19248 | Name_Storage_Size
19252 -- The volatile object appears as the expression of a type conversion
19253 -- occurring in a non-interfering context.
19255 elsif Nkind
(Context
) in N_Qualified_Expression
19256 | N_Type_Conversion
19257 | N_Unchecked_Type_Conversion
19258 and then Expression
(Context
) = Obj_Ref
19259 and then Is_OK_Volatile_Context
19260 (Context
=> Parent
(Context
),
19261 Obj_Ref
=> Context
,
19262 Check_Actuals
=> Check_Actuals
)
19266 -- The volatile object appears as the expression in a delay statement
19268 elsif Nkind
(Context
) in N_Delay_Statement
then
19271 -- Allow references to volatile objects in various checks. This is not a
19272 -- direct SPARK 2014 requirement.
19274 elsif Within_Check
(Context
) then
19277 -- References to effectively volatile objects that appear as actual
19278 -- parameters in subprogram calls can be examined only after call itself
19279 -- has been resolved. Before that, assume such references to be legal.
19281 elsif Nkind
(Context
) in N_Subprogram_Call | N_Entry_Call_Statement
then
19282 if Check_Actuals
then
19285 Formal
: Entity_Id
;
19286 Subp
: constant Entity_Id
:= Get_Called_Entity
(Context
);
19288 Find_Actual
(Obj_Ref
, Formal
, Call
);
19289 pragma Assert
(Call
= Context
);
19291 -- An effectively volatile object may act as an actual when the
19292 -- corresponding formal is of a non-scalar effectively volatile
19293 -- type (SPARK RM 7.1.3(10)).
19295 if not Is_Scalar_Type
(Etype
(Formal
))
19296 and then Is_Effectively_Volatile_For_Reading
(Etype
(Formal
))
19300 -- An effectively volatile object may act as an actual in a
19301 -- call to an instance of Unchecked_Conversion. (SPARK RM
19304 elsif Is_Unchecked_Conversion_Instance
(Subp
) then
19317 end Is_OK_Volatile_Context
;
19319 ------------------------------------
19320 -- Is_Package_Contract_Annotation --
19321 ------------------------------------
19323 function Is_Package_Contract_Annotation
(Item
: Node_Id
) return Boolean is
19327 if Nkind
(Item
) = N_Aspect_Specification
then
19328 Nam
:= Chars
(Identifier
(Item
));
19330 else pragma Assert
(Nkind
(Item
) = N_Pragma
);
19331 Nam
:= Pragma_Name
(Item
);
19334 return Nam
= Name_Abstract_State
19335 or else Nam
= Name_Initial_Condition
19336 or else Nam
= Name_Initializes
19337 or else Nam
= Name_Refined_State
;
19338 end Is_Package_Contract_Annotation
;
19340 -----------------------------------
19341 -- Is_Partially_Initialized_Type --
19342 -----------------------------------
19344 function Is_Partially_Initialized_Type
19346 Include_Implicit
: Boolean := True) return Boolean
19349 if Is_Scalar_Type
(Typ
) then
19350 return Has_Default_Aspect
(Base_Type
(Typ
));
19352 elsif Is_Access_Type
(Typ
) then
19353 return Include_Implicit
;
19355 elsif Is_Array_Type
(Typ
) then
19357 -- If component type is partially initialized, so is array type
19359 if Has_Default_Aspect
(Base_Type
(Typ
))
19360 or else Is_Partially_Initialized_Type
19361 (Component_Type
(Typ
), Include_Implicit
)
19365 -- Otherwise we are only partially initialized if we are fully
19366 -- initialized (this is the empty array case, no point in us
19367 -- duplicating that code here).
19370 return Is_Fully_Initialized_Type
(Typ
);
19373 elsif Is_Record_Type
(Typ
) then
19375 -- A discriminated type is always partially initialized if in
19378 if Has_Discriminants
(Typ
) and then Include_Implicit
then
19381 -- A tagged type is always partially initialized
19383 elsif Is_Tagged_Type
(Typ
) then
19386 -- Case of nondiscriminated record
19392 Component_Present
: Boolean := False;
19393 -- Set True if at least one component is present. If no
19394 -- components are present, then record type is fully
19395 -- initialized (another odd case, like the null array).
19398 -- Loop through components
19400 Comp
:= First_Component
(Typ
);
19401 while Present
(Comp
) loop
19402 Component_Present
:= True;
19404 -- If a component has an initialization expression then the
19405 -- enclosing record type is partially initialized
19407 if Present
(Parent
(Comp
))
19408 and then Present
(Expression
(Parent
(Comp
)))
19412 -- If a component is of a type which is itself partially
19413 -- initialized, then the enclosing record type is also.
19415 elsif Is_Partially_Initialized_Type
19416 (Etype
(Comp
), Include_Implicit
)
19421 Next_Component
(Comp
);
19424 -- No initialized components found. If we found any components
19425 -- they were all uninitialized so the result is false.
19427 if Component_Present
then
19430 -- But if we found no components, then all the components are
19431 -- initialized so we consider the type to be initialized.
19439 -- Concurrent types are always fully initialized
19441 elsif Is_Concurrent_Type
(Typ
) then
19444 -- For a private type, go to underlying type. If there is no underlying
19445 -- type then just assume this partially initialized. Not clear if this
19446 -- can happen in a non-error case, but no harm in testing for this.
19448 elsif Is_Private_Type
(Typ
) then
19450 U
: constant Entity_Id
:= Underlying_Type
(Typ
);
19455 return Is_Partially_Initialized_Type
(U
, Include_Implicit
);
19459 -- For any other type (are there any?) assume partially initialized
19464 end Is_Partially_Initialized_Type
;
19466 ------------------------------------
19467 -- Is_Potentially_Persistent_Type --
19468 ------------------------------------
19470 function Is_Potentially_Persistent_Type
(T
: Entity_Id
) return Boolean is
19475 -- For private type, test corresponding full type
19477 if Is_Private_Type
(T
) then
19478 return Is_Potentially_Persistent_Type
(Full_View
(T
));
19480 -- Scalar types are potentially persistent
19482 elsif Is_Scalar_Type
(T
) then
19485 -- Record type is potentially persistent if not tagged and the types of
19486 -- all it components are potentially persistent, and no component has
19487 -- an initialization expression.
19489 elsif Is_Record_Type
(T
)
19490 and then not Is_Tagged_Type
(T
)
19491 and then not Is_Partially_Initialized_Type
(T
)
19493 Comp
:= First_Component
(T
);
19494 while Present
(Comp
) loop
19495 if not Is_Potentially_Persistent_Type
(Etype
(Comp
)) then
19498 Next_Entity
(Comp
);
19504 -- Array type is potentially persistent if its component type is
19505 -- potentially persistent and if all its constraints are static.
19507 elsif Is_Array_Type
(T
) then
19508 if not Is_Potentially_Persistent_Type
(Component_Type
(T
)) then
19512 Indx
:= First_Index
(T
);
19513 while Present
(Indx
) loop
19514 if not Is_OK_Static_Subtype
(Etype
(Indx
)) then
19523 -- All other types are not potentially persistent
19528 end Is_Potentially_Persistent_Type
;
19530 --------------------------------
19531 -- Is_Potentially_Unevaluated --
19532 --------------------------------
19534 function Is_Potentially_Unevaluated
(N
: Node_Id
) return Boolean is
19535 function Has_Null_Others_Choice
(Aggr
: Node_Id
) return Boolean;
19536 -- Aggr is an array aggregate with static bounds and an others clause;
19537 -- return True if the others choice of the given array aggregate does
19538 -- not cover any component (i.e. is null).
19540 function Immediate_Context_Implies_Is_Potentially_Unevaluated
19541 (Expr
: Node_Id
) return Boolean;
19542 -- Return True if the *immediate* context of this expression tells us
19543 -- that it is potentially unevaluated; return False if the *immediate*
19544 -- context doesn't provide an answer to this question and we need to
19547 function Non_Static_Or_Null_Range
(N
: Node_Id
) return Boolean;
19548 -- Return True if the given range is nonstatic or null
19550 ----------------------------
19551 -- Has_Null_Others_Choice --
19552 ----------------------------
19554 function Has_Null_Others_Choice
(Aggr
: Node_Id
) return Boolean is
19555 Idx
: constant Node_Id
:= First_Index
(Etype
(Aggr
));
19556 Hiv
: constant Uint
:= Expr_Value
(Type_High_Bound
(Etype
(Idx
)));
19557 Lov
: constant Uint
:= Expr_Value
(Type_Low_Bound
(Etype
(Idx
)));
19561 Intervals
: constant Interval_Lists
.Discrete_Interval_List
:=
19562 Interval_Lists
.Aggregate_Intervals
(Aggr
);
19565 -- The others choice is null if, after normalization, we
19566 -- have a single interval covering the whole aggregate.
19568 return Intervals
'Length = 1
19570 Intervals
(Intervals
'First).Low
= Lov
19572 Intervals
(Intervals
'First).High
= Hiv
;
19575 -- If the aggregate is malformed (that is, indexes are not disjoint)
19576 -- then no action is needed at this stage; the error will be reported
19577 -- later by the frontend.
19580 when Interval_Lists
.Intervals_Error
=>
19582 end Has_Null_Others_Choice
;
19584 ----------------------------------------------------------
19585 -- Immediate_Context_Implies_Is_Potentially_Unevaluated --
19586 ----------------------------------------------------------
19588 function Immediate_Context_Implies_Is_Potentially_Unevaluated
19589 (Expr
: Node_Id
) return Boolean
19591 Par
: constant Node_Id
:= Parent
(Expr
);
19593 function Aggregate_Type
return Node_Id
is (Etype
(Parent
(Par
)));
19595 if Nkind
(Par
) = N_If_Expression
then
19596 return Is_Elsif
(Par
) or else Expr
/= First
(Expressions
(Par
));
19598 elsif Nkind
(Par
) = N_Case_Expression
then
19599 return Expr
/= Expression
(Par
);
19601 elsif Nkind
(Par
) in N_And_Then | N_Or_Else
then
19602 return Expr
= Right_Opnd
(Par
);
19604 elsif Nkind
(Par
) in N_In | N_Not_In
then
19606 -- If the membership includes several alternatives, only the first
19607 -- is definitely evaluated.
19609 if Present
(Alternatives
(Par
)) then
19610 return Expr
/= First
(Alternatives
(Par
));
19612 -- If this is a range membership both bounds are evaluated
19618 elsif Nkind
(Par
) = N_Quantified_Expression
then
19619 return Expr
= Condition
(Par
);
19621 elsif Nkind
(Par
) in N_Component_Association
19622 | N_Iterated_Component_Association
19623 and then Expr
= Expression
(Par
)
19624 and then Nkind
(Parent
(Par
))
19625 in N_Aggregate | N_Delta_Aggregate | N_Extension_Aggregate
19626 and then Present
(Aggregate_Type
)
19627 and then Aggregate_Type
/= Any_Composite
19629 if Is_Array_Type
(Aggregate_Type
) then
19630 if Ada_Version
>= Ada_2022
then
19631 -- For Ada 2022, this predicate returns True for
19632 -- any "repeatedly evaluated" expression.
19638 In_Others_Choice
: Boolean := False;
19639 Array_Agg
: constant Node_Id
:= Parent
(Par
);
19641 -- The expression of an array_component_association is
19642 -- potentially unevaluated if the associated choice is a
19643 -- subtype_indication or range that defines a nonstatic or
19646 Choice
:= First
(Choices
(Par
));
19647 while Present
(Choice
) loop
19648 if Nkind
(Choice
) = N_Range
19649 and then Non_Static_Or_Null_Range
(Choice
)
19653 elsif Nkind
(Choice
) = N_Identifier
19654 and then Present
(Scalar_Range
(Etype
(Choice
)))
19656 Non_Static_Or_Null_Range
19657 (Scalar_Range
(Etype
(Choice
)))
19661 elsif Nkind
(Choice
) = N_Others_Choice
then
19662 In_Others_Choice
:= True;
19668 -- It is also potentially unevaluated if the associated
19669 -- choice is an others choice and the applicable index
19670 -- constraint is nonstatic or null.
19672 if In_Others_Choice
then
19673 if not Compile_Time_Known_Bounds
(Aggregate_Type
) then
19676 return Has_Null_Others_Choice
(Array_Agg
);
19681 elsif Is_Container_Aggregate
(Parent
(Par
)) then
19682 -- a component of a container aggregate
19691 end Immediate_Context_Implies_Is_Potentially_Unevaluated
;
19693 ------------------------------
19694 -- Non_Static_Or_Null_Range --
19695 ------------------------------
19697 function Non_Static_Or_Null_Range
(N
: Node_Id
) return Boolean is
19698 Low
, High
: Node_Id
;
19701 Get_Index_Bounds
(N
, Low
, High
);
19703 -- Check static bounds
19705 if not Compile_Time_Known_Value
(Low
)
19706 or else not Compile_Time_Known_Value
(High
)
19710 -- Check null range
19712 elsif Expr_Value
(High
) < Expr_Value
(Low
) then
19717 end Non_Static_Or_Null_Range
;
19724 -- Start of processing for Is_Potentially_Unevaluated
19730 -- A postcondition whose expression is a short-circuit is broken down
19731 -- into individual aspects for better exception reporting. The original
19732 -- short-circuit expression is rewritten as the second operand, and an
19733 -- occurrence of 'Old in that operand is potentially unevaluated.
19734 -- See sem_ch13.adb for details of this transformation. The reference
19735 -- to 'Old may appear within an expression, so we must look for the
19736 -- enclosing pragma argument in the tree that contains the reference.
19738 while Present
(Par
)
19739 and then Nkind
(Par
) /= N_Pragma_Argument_Association
19741 if Is_Rewrite_Substitution
(Par
)
19742 and then Nkind
(Original_Node
(Par
)) = N_And_Then
19747 Par
:= Parent
(Par
);
19750 -- Other cases; 'Old appears within other expression (not the top-level
19751 -- conjunct in a postcondition) with a potentially unevaluated operand.
19753 Par
:= Parent
(Expr
);
19755 while Present
(Par
)
19756 and then Nkind
(Par
) /= N_Pragma_Argument_Association
19758 if Comes_From_Source
(Par
)
19760 Immediate_Context_Implies_Is_Potentially_Unevaluated
(Expr
)
19764 -- For component associations continue climbing; it may be part of an
19765 -- array aggregate. For iterated component association we know that
19766 -- it belongs to an array aggreate, but only its expression is
19767 -- potentially unevaluated, not discrete choice list or iterator
19770 elsif Nkind
(Par
) in N_Component_Association
19771 | N_Iterated_Component_Association
19775 -- If the context is not an expression, or if is the result of
19776 -- expansion of an enclosing construct (such as another attribute)
19777 -- the predicate does not apply.
19779 elsif Nkind
(Par
) = N_Case_Expression_Alternative
then
19782 elsif Nkind
(Par
) not in N_Subexpr
19783 or else not Comes_From_Source
(Par
)
19789 Par
:= Parent
(Par
);
19793 end Is_Potentially_Unevaluated
;
19795 -----------------------------------------
19796 -- Is_Predefined_Dispatching_Operation --
19797 -----------------------------------------
19799 function Is_Predefined_Dispatching_Operation
19800 (E
: Entity_Id
) return Boolean
19802 TSS_Name
: TSS_Name_Type
;
19805 if not Is_Dispatching_Operation
(E
) then
19809 Get_Name_String
(Chars
(E
));
19811 -- Most predefined primitives have internally generated names. Equality
19812 -- must be treated differently; the predefined operation is recognized
19813 -- as a homogeneous binary operator that returns Boolean.
19815 if Name_Len
> TSS_Name_Type
'Last then
19818 (Name_Buffer
(Name_Len
- TSS_Name
'Length + 1 .. Name_Len
));
19820 if Chars
(E
) in Name_uAssign | Name_uSize
19822 (Chars
(E
) = Name_Op_Eq
19823 and then Etype
(First_Formal
(E
)) = Etype
(Last_Formal
(E
)))
19824 or else TSS_Name
= TSS_Deep_Adjust
19825 or else TSS_Name
= TSS_Deep_Finalize
19826 or else TSS_Name
= TSS_Stream_Input
19827 or else TSS_Name
= TSS_Stream_Output
19828 or else TSS_Name
= TSS_Stream_Read
19829 or else TSS_Name
= TSS_Stream_Write
19830 or else TSS_Name
= TSS_Put_Image
19831 or else Is_Predefined_Interface_Primitive
(E
)
19838 end Is_Predefined_Dispatching_Operation
;
19840 ---------------------------------------
19841 -- Is_Predefined_Interface_Primitive --
19842 ---------------------------------------
19844 function Is_Predefined_Interface_Primitive
(E
: Entity_Id
) return Boolean is
19846 -- In VM targets we don't restrict the functionality of this test to
19847 -- compiling in Ada 2005 mode since in VM targets any tagged type has
19848 -- these primitives.
19850 return (Ada_Version
>= Ada_2005
or else not Tagged_Type_Expansion
)
19851 and then Chars
(E
) in Name_uDisp_Asynchronous_Select
19852 | Name_uDisp_Conditional_Select
19853 | Name_uDisp_Get_Prim_Op_Kind
19854 | Name_uDisp_Get_Task_Id
19855 | Name_uDisp_Requeue
19856 | Name_uDisp_Timed_Select
;
19857 end Is_Predefined_Interface_Primitive
;
19859 ---------------------------------------
19860 -- Is_Predefined_Internal_Operation --
19861 ---------------------------------------
19863 function Is_Predefined_Internal_Operation
19864 (E
: Entity_Id
) return Boolean
19866 TSS_Name
: TSS_Name_Type
;
19869 if not Is_Dispatching_Operation
(E
) then
19873 Get_Name_String
(Chars
(E
));
19875 -- Most predefined primitives have internally generated names. Equality
19876 -- must be treated differently; the predefined operation is recognized
19877 -- as a homogeneous binary operator that returns Boolean.
19879 if Name_Len
> TSS_Name_Type
'Last then
19882 (Name_Buffer
(Name_Len
- TSS_Name
'Length + 1 .. Name_Len
));
19884 if Chars
(E
) in Name_uSize | Name_uAssign
19886 (Chars
(E
) = Name_Op_Eq
19887 and then Etype
(First_Formal
(E
)) = Etype
(Last_Formal
(E
)))
19888 or else TSS_Name
= TSS_Deep_Adjust
19889 or else TSS_Name
= TSS_Deep_Finalize
19890 or else Is_Predefined_Interface_Primitive
(E
)
19897 end Is_Predefined_Internal_Operation
;
19899 --------------------------------
19900 -- Is_Preelaborable_Aggregate --
19901 --------------------------------
19903 function Is_Preelaborable_Aggregate
(Aggr
: Node_Id
) return Boolean is
19904 Aggr_Typ
: constant Entity_Id
:= Etype
(Aggr
);
19905 Array_Aggr
: constant Boolean := Is_Array_Type
(Aggr_Typ
);
19907 Anc_Part
: Node_Id
;
19910 Comp_Typ
: Entity_Id
:= Empty
; -- init to avoid warning
19915 Comp_Typ
:= Component_Type
(Aggr_Typ
);
19918 -- Inspect the ancestor part
19920 if Nkind
(Aggr
) = N_Extension_Aggregate
then
19921 Anc_Part
:= Ancestor_Part
(Aggr
);
19923 -- The ancestor denotes a subtype mark
19925 if Is_Entity_Name
(Anc_Part
)
19926 and then Is_Type
(Entity
(Anc_Part
))
19928 if not Has_Preelaborable_Initialization
(Entity
(Anc_Part
)) then
19932 -- Otherwise the ancestor denotes an expression
19934 elsif not Is_Preelaborable_Construct
(Anc_Part
) then
19939 -- Inspect the positional associations
19941 Expr
:= First
(Expressions
(Aggr
));
19942 while Present
(Expr
) loop
19943 if not Is_Preelaborable_Construct
(Expr
) then
19950 -- Inspect the named associations
19952 Assoc
:= First
(Component_Associations
(Aggr
));
19953 while Present
(Assoc
) loop
19955 -- Inspect the choices of the current named association
19957 Choice
:= First
(Choices
(Assoc
));
19958 while Present
(Choice
) loop
19961 -- For a choice to be preelaborable, it must denote either a
19962 -- static range or a static expression.
19964 if Nkind
(Choice
) = N_Others_Choice
then
19967 elsif Nkind
(Choice
) = N_Range
then
19968 if not Is_OK_Static_Range
(Choice
) then
19972 elsif not Is_OK_Static_Expression
(Choice
) then
19977 Comp_Typ
:= Etype
(Choice
);
19983 -- The type of the choice must have preelaborable initialization if
19984 -- the association carries a <>.
19986 pragma Assert
(Present
(Comp_Typ
));
19987 if Box_Present
(Assoc
) then
19988 if not Has_Preelaborable_Initialization
(Comp_Typ
) then
19992 -- The type of the expression must have preelaborable initialization
19994 elsif not Is_Preelaborable_Construct
(Expression
(Assoc
)) then
20001 -- At this point the aggregate is preelaborable
20004 end Is_Preelaborable_Aggregate
;
20006 --------------------------------
20007 -- Is_Preelaborable_Construct --
20008 --------------------------------
20010 function Is_Preelaborable_Construct
(N
: Node_Id
) return Boolean is
20014 if Nkind
(N
) in N_Aggregate | N_Extension_Aggregate
then
20015 return Is_Preelaborable_Aggregate
(N
);
20017 -- Attributes are allowed in general, even if their prefix is a formal
20018 -- type. It seems that certain attributes known not to be static might
20019 -- not be allowed, but there are no rules to prevent them.
20021 elsif Nkind
(N
) = N_Attribute_Reference
then
20026 elsif Nkind
(N
) in N_Subexpr
and then Is_OK_Static_Expression
(N
) then
20029 elsif Nkind
(N
) = N_Qualified_Expression
then
20030 return Is_Preelaborable_Construct
(Expression
(N
));
20032 -- Names are preelaborable when they denote a discriminant of an
20033 -- enclosing type. Discriminals are also considered for this check.
20035 elsif Is_Entity_Name
(N
)
20036 and then Present
(Entity
(N
))
20038 (Ekind
(Entity
(N
)) = E_Discriminant
20039 or else (Ekind
(Entity
(N
)) in E_Constant | E_In_Parameter
20040 and then Present
(Discriminal_Link
(Entity
(N
)))))
20046 elsif Nkind
(N
) = N_Null
then
20049 -- Ada 2022 (AI12-0175): Calls to certain functions that are essentially
20050 -- unchecked conversions are preelaborable.
20052 elsif Ada_Version
>= Ada_2022
20053 and then Nkind
(N
) = N_Function_Call
20054 and then Is_Entity_Name
(Name
(N
))
20055 and then Is_Preelaborable_Function
(Entity
(Name
(N
)))
20060 A
:= First_Actual
(N
);
20062 while Present
(A
) loop
20063 if not Is_Preelaborable_Construct
(A
) then
20073 -- Otherwise the construct is not preelaborable
20078 end Is_Preelaborable_Construct
;
20080 -------------------------------
20081 -- Is_Preelaborable_Function --
20082 -------------------------------
20084 function Is_Preelaborable_Function
(Id
: Entity_Id
) return Boolean is
20085 SATAC
: constant Rtsfind
.RTU_Id
:= System_Address_To_Access_Conversions
;
20086 Scop
: constant Entity_Id
:= Scope
(Id
);
20089 -- Small optimization: every allowed function has convention Intrinsic
20090 -- (see Analyze_Subprogram_Instantiation for the subtlety in the test).
20092 if not Is_Intrinsic_Subprogram
(Id
)
20093 and then Convention
(Id
) /= Convention_Intrinsic
20098 -- An instance of Unchecked_Conversion
20100 if Is_Unchecked_Conversion_Instance
(Id
) then
20104 -- A function declared in System.Storage_Elements
20106 if Is_RTU
(Scop
, System_Storage_Elements
) then
20110 -- The functions To_Pointer and To_Address declared in an instance of
20111 -- System.Address_To_Access_Conversions (they are the only ones).
20113 if Ekind
(Scop
) = E_Package
20114 and then Nkind
(Parent
(Scop
)) = N_Package_Specification
20115 and then Present
(Generic_Parent
(Parent
(Scop
)))
20116 and then Is_RTU
(Generic_Parent
(Parent
(Scop
)), SATAC
)
20122 end Is_Preelaborable_Function
;
20124 -----------------------------
20125 -- Is_Private_Library_Unit --
20126 -----------------------------
20128 function Is_Private_Library_Unit
(Unit
: Entity_Id
) return Boolean is
20129 Comp_Unit
: constant Node_Id
:= Parent
(Unit_Declaration_Node
(Unit
));
20131 return Nkind
(Comp_Unit
) = N_Compilation_Unit
20132 and then Private_Present
(Comp_Unit
);
20133 end Is_Private_Library_Unit
;
20135 ---------------------------------
20136 -- Is_Protected_Self_Reference --
20137 ---------------------------------
20139 function Is_Protected_Self_Reference
(N
: Node_Id
) return Boolean is
20141 function In_Access_Definition
(N
: Node_Id
) return Boolean;
20142 -- Returns true if N belongs to an access definition
20144 --------------------------
20145 -- In_Access_Definition --
20146 --------------------------
20148 function In_Access_Definition
(N
: Node_Id
) return Boolean is
20153 while Present
(P
) loop
20154 if Nkind
(P
) = N_Access_Definition
then
20162 end In_Access_Definition
;
20164 -- Start of processing for Is_Protected_Self_Reference
20167 -- Verify that prefix is analyzed and has the proper form. Note that
20168 -- the attributes Elab_Spec, Elab_Body, and Elab_Subp_Body, which also
20169 -- produce the address of an entity, do not analyze their prefix
20170 -- because they denote entities that are not necessarily visible.
20171 -- Neither of them can apply to a protected type.
20173 return Ada_Version
>= Ada_2005
20174 and then Is_Entity_Name
(N
)
20175 and then Present
(Entity
(N
))
20176 and then Is_Protected_Type
(Entity
(N
))
20177 and then In_Open_Scopes
(Entity
(N
))
20178 and then not In_Access_Definition
(N
);
20179 end Is_Protected_Self_Reference
;
20181 -----------------------------
20182 -- Is_RCI_Pkg_Spec_Or_Body --
20183 -----------------------------
20185 function Is_RCI_Pkg_Spec_Or_Body
(Cunit
: Node_Id
) return Boolean is
20187 function Is_RCI_Pkg_Decl_Cunit
(Cunit
: Node_Id
) return Boolean;
20188 -- Return True if the unit of Cunit is an RCI package declaration
20190 ---------------------------
20191 -- Is_RCI_Pkg_Decl_Cunit --
20192 ---------------------------
20194 function Is_RCI_Pkg_Decl_Cunit
(Cunit
: Node_Id
) return Boolean is
20195 The_Unit
: constant Node_Id
:= Unit
(Cunit
);
20198 if Nkind
(The_Unit
) /= N_Package_Declaration
then
20202 return Is_Remote_Call_Interface
(Defining_Entity
(The_Unit
));
20203 end Is_RCI_Pkg_Decl_Cunit
;
20205 -- Start of processing for Is_RCI_Pkg_Spec_Or_Body
20208 return Is_RCI_Pkg_Decl_Cunit
(Cunit
)
20210 (Nkind
(Unit
(Cunit
)) = N_Package_Body
20211 and then Is_RCI_Pkg_Decl_Cunit
(Library_Unit
(Cunit
)));
20212 end Is_RCI_Pkg_Spec_Or_Body
;
20214 -----------------------------------------
20215 -- Is_Remote_Access_To_Class_Wide_Type --
20216 -----------------------------------------
20218 function Is_Remote_Access_To_Class_Wide_Type
20219 (E
: Entity_Id
) return Boolean
20222 -- A remote access to class-wide type is a general access to object type
20223 -- declared in the visible part of a Remote_Types or Remote_Call_
20226 return Ekind
(E
) = E_General_Access_Type
20227 and then (Is_Remote_Call_Interface
(E
) or else Is_Remote_Types
(E
));
20228 end Is_Remote_Access_To_Class_Wide_Type
;
20230 -----------------------------------------
20231 -- Is_Remote_Access_To_Subprogram_Type --
20232 -----------------------------------------
20234 function Is_Remote_Access_To_Subprogram_Type
20235 (E
: Entity_Id
) return Boolean
20238 return (Ekind
(E
) = E_Access_Subprogram_Type
20239 or else (Ekind
(E
) = E_Record_Type
20240 and then Present
(Corresponding_Remote_Type
(E
))))
20241 and then (Is_Remote_Call_Interface
(E
) or else Is_Remote_Types
(E
));
20242 end Is_Remote_Access_To_Subprogram_Type
;
20244 --------------------
20245 -- Is_Remote_Call --
20246 --------------------
20248 function Is_Remote_Call
(N
: Node_Id
) return Boolean is
20250 if Nkind
(N
) not in N_Subprogram_Call
then
20252 -- An entry call cannot be remote
20256 elsif Nkind
(Name
(N
)) in N_Has_Entity
20257 and then Is_Remote_Call_Interface
(Entity
(Name
(N
)))
20259 -- A subprogram declared in the spec of a RCI package is remote
20263 elsif Nkind
(Name
(N
)) = N_Explicit_Dereference
20264 and then Is_Remote_Access_To_Subprogram_Type
20265 (Etype
(Prefix
(Name
(N
))))
20267 -- The dereference of a RAS is a remote call
20271 elsif Present
(Controlling_Argument
(N
))
20272 and then Is_Remote_Access_To_Class_Wide_Type
20273 (Etype
(Controlling_Argument
(N
)))
20275 -- Any primitive operation call with a controlling argument of
20276 -- a RACW type is a remote call.
20281 -- All other calls are local calls
20284 end Is_Remote_Call
;
20286 ----------------------
20287 -- Is_Renamed_Entry --
20288 ----------------------
20290 function Is_Renamed_Entry
(Proc_Nam
: Entity_Id
) return Boolean is
20291 Orig_Node
: Node_Id
:= Empty
;
20292 Subp_Decl
: Node_Id
:=
20293 (if No
(Parent
(Proc_Nam
)) then Empty
else Parent
(Parent
(Proc_Nam
)));
20295 function Is_Entry
(Nam
: Node_Id
) return Boolean;
20296 -- Determine whether Nam is an entry. Traverse selectors if there are
20297 -- nested selected components.
20303 function Is_Entry
(Nam
: Node_Id
) return Boolean is
20305 if Nkind
(Nam
) = N_Selected_Component
then
20306 return Is_Entry
(Selector_Name
(Nam
));
20309 return Ekind
(Entity
(Nam
)) = E_Entry
;
20312 -- Start of processing for Is_Renamed_Entry
20315 if Present
(Alias
(Proc_Nam
)) then
20316 Subp_Decl
:= Parent
(Parent
(Alias
(Proc_Nam
)));
20319 -- Look for a rewritten subprogram renaming declaration
20321 if Nkind
(Subp_Decl
) = N_Subprogram_Declaration
20322 and then Present
(Original_Node
(Subp_Decl
))
20324 Orig_Node
:= Original_Node
(Subp_Decl
);
20327 -- The rewritten subprogram is actually an entry
20329 if Present
(Orig_Node
)
20330 and then Nkind
(Orig_Node
) = N_Subprogram_Renaming_Declaration
20331 and then Is_Entry
(Name
(Orig_Node
))
20337 end Is_Renamed_Entry
;
20339 ----------------------------
20340 -- Is_Reversible_Iterator --
20341 ----------------------------
20343 function Is_Reversible_Iterator
(Typ
: Entity_Id
) return Boolean is
20344 Ifaces_List
: Elist_Id
;
20345 Iface_Elmt
: Elmt_Id
;
20349 if Is_Class_Wide_Type
(Typ
)
20350 and then Chars
(Root_Type
(Typ
)) = Name_Reversible_Iterator
20351 and then In_Predefined_Unit
(Root_Type
(Typ
))
20355 elsif not Is_Tagged_Type
(Typ
) or else not Is_Derived_Type
(Typ
) then
20359 Collect_Interfaces
(Typ
, Ifaces_List
);
20361 Iface_Elmt
:= First_Elmt
(Ifaces_List
);
20362 while Present
(Iface_Elmt
) loop
20363 Iface
:= Node
(Iface_Elmt
);
20364 if Chars
(Iface
) = Name_Reversible_Iterator
20365 and then In_Predefined_Unit
(Iface
)
20370 Next_Elmt
(Iface_Elmt
);
20375 end Is_Reversible_Iterator
;
20377 ---------------------------------
20378 -- Is_Single_Concurrent_Object --
20379 ---------------------------------
20381 function Is_Single_Concurrent_Object
(Id
: Entity_Id
) return Boolean is
20384 Is_Single_Protected_Object
(Id
) or else Is_Single_Task_Object
(Id
);
20385 end Is_Single_Concurrent_Object
;
20387 -------------------------------
20388 -- Is_Single_Concurrent_Type --
20389 -------------------------------
20391 function Is_Single_Concurrent_Type
(Id
: Entity_Id
) return Boolean is
20394 Ekind
(Id
) in E_Protected_Type | E_Task_Type
20395 and then Is_Single_Concurrent_Type_Declaration
20396 (Declaration_Node
(Id
));
20397 end Is_Single_Concurrent_Type
;
20399 -------------------------------------------
20400 -- Is_Single_Concurrent_Type_Declaration --
20401 -------------------------------------------
20403 function Is_Single_Concurrent_Type_Declaration
20404 (N
: Node_Id
) return Boolean
20407 return Nkind
(Original_Node
(N
)) in
20408 N_Single_Protected_Declaration | N_Single_Task_Declaration
;
20409 end Is_Single_Concurrent_Type_Declaration
;
20411 ---------------------------------------------
20412 -- Is_Single_Precision_Floating_Point_Type --
20413 ---------------------------------------------
20415 function Is_Single_Precision_Floating_Point_Type
20416 (E
: Entity_Id
) return Boolean is
20418 return Is_Floating_Point_Type
(E
)
20419 and then Machine_Radix_Value
(E
) = Uint_2
20420 and then Machine_Mantissa_Value
(E
) = Uint_24
20421 and then Machine_Emax_Value
(E
) = Uint_2
** Uint_7
20422 and then Machine_Emin_Value
(E
) = Uint_3
- (Uint_2
** Uint_7
);
20423 end Is_Single_Precision_Floating_Point_Type
;
20425 --------------------------------
20426 -- Is_Single_Protected_Object --
20427 --------------------------------
20429 function Is_Single_Protected_Object
(Id
: Entity_Id
) return Boolean is
20432 Ekind
(Id
) = E_Variable
20433 and then Ekind
(Etype
(Id
)) = E_Protected_Type
20434 and then Is_Single_Concurrent_Type
(Etype
(Id
));
20435 end Is_Single_Protected_Object
;
20437 ---------------------------
20438 -- Is_Single_Task_Object --
20439 ---------------------------
20441 function Is_Single_Task_Object
(Id
: Entity_Id
) return Boolean is
20444 Ekind
(Id
) = E_Variable
20445 and then Ekind
(Etype
(Id
)) = E_Task_Type
20446 and then Is_Single_Concurrent_Type
(Etype
(Id
));
20447 end Is_Single_Task_Object
;
20449 -----------------------------
20450 -- Is_Specific_Tagged_Type --
20451 -----------------------------
20453 function Is_Specific_Tagged_Type
(Typ
: Entity_Id
) return Boolean is
20454 Full_Typ
: Entity_Id
;
20457 -- Handle private types
20459 if Is_Private_Type
(Typ
) and then Present
(Full_View
(Typ
)) then
20460 Full_Typ
:= Full_View
(Typ
);
20465 -- A specific tagged type is a non-class-wide tagged type
20467 return Is_Tagged_Type
(Full_Typ
) and not Is_Class_Wide_Type
(Full_Typ
);
20468 end Is_Specific_Tagged_Type
;
20474 function Is_Statement
(N
: Node_Id
) return Boolean is
20477 Nkind
(N
) in N_Statement_Other_Than_Procedure_Call
20478 or else Nkind
(N
) = N_Procedure_Call_Statement
;
20481 --------------------------------------
20482 -- Is_Static_Discriminant_Component --
20483 --------------------------------------
20485 function Is_Static_Discriminant_Component
(N
: Node_Id
) return Boolean is
20487 return Nkind
(N
) = N_Selected_Component
20488 and then not Is_In_Discriminant_Check
(N
)
20489 and then Present
(Etype
(Prefix
(N
)))
20490 and then Ekind
(Etype
(Prefix
(N
))) = E_Record_Subtype
20491 and then Has_Static_Discriminants
(Etype
(Prefix
(N
)))
20492 and then Present
(Entity
(Selector_Name
(N
)))
20493 and then Ekind
(Entity
(Selector_Name
(N
))) = E_Discriminant
20494 and then not In_Check_Node
(N
);
20495 end Is_Static_Discriminant_Component
;
20497 ------------------------
20498 -- Is_Static_Function --
20499 ------------------------
20501 function Is_Static_Function
(Subp
: Entity_Id
) return Boolean is
20503 -- Always return False for pre Ada 2022 to e.g. ignore the Static
20504 -- aspect in package Interfaces for Ada_Version < 2022 and also
20507 return Ada_Version
>= Ada_2022
20508 and then Has_Aspect
(Subp
, Aspect_Static
)
20510 (No
(Find_Value_Of_Aspect
(Subp
, Aspect_Static
))
20511 or else Is_True
(Static_Boolean
20512 (Find_Value_Of_Aspect
(Subp
, Aspect_Static
))));
20513 end Is_Static_Function
;
20515 -----------------------------
20516 -- Is_Static_Function_Call --
20517 -----------------------------
20519 function Is_Static_Function_Call
(Call
: Node_Id
) return Boolean is
20520 function Has_All_Static_Actuals
(Call
: Node_Id
) return Boolean;
20521 -- Return whether all actual parameters of Call are static expressions
20523 ----------------------------
20524 -- Has_All_Static_Actuals --
20525 ----------------------------
20527 function Has_All_Static_Actuals
(Call
: Node_Id
) return Boolean is
20528 Actual
: Node_Id
:= First_Actual
(Call
);
20529 String_Result
: constant Boolean :=
20530 Is_String_Type
(Etype
(Entity
(Name
(Call
))));
20533 while Present
(Actual
) loop
20534 if not Is_Static_Expression
(Actual
) then
20536 -- ??? In the string-returning case we want to avoid a call
20537 -- being made to Establish_Transient_Scope in Resolve_Call,
20538 -- but at the point where that's tested for (which now includes
20539 -- a call to test Is_Static_Function_Call), the actuals of the
20540 -- call haven't been resolved, so expressions of the actuals
20541 -- may not have been marked Is_Static_Expression yet, so we
20542 -- force them to be resolved here, so we can tell if they're
20543 -- static. Calling Resolve here is admittedly a kludge, and we
20544 -- limit this call to string-returning cases.
20546 if String_Result
then
20550 -- Test flag again in case it's now True due to above Resolve
20552 if not Is_Static_Expression
(Actual
) then
20557 Next_Actual
(Actual
);
20561 end Has_All_Static_Actuals
;
20564 return Nkind
(Call
) = N_Function_Call
20565 and then Is_Entity_Name
(Name
(Call
))
20566 and then Is_Static_Function
(Entity
(Name
(Call
)))
20567 and then Has_All_Static_Actuals
(Call
);
20568 end Is_Static_Function_Call
;
20570 -------------------------------------------
20571 -- Is_Subcomponent_Of_Full_Access_Object --
20572 -------------------------------------------
20574 function Is_Subcomponent_Of_Full_Access_Object
(N
: Node_Id
) return Boolean
20579 R
:= Get_Referenced_Object
(N
);
20581 while Nkind
(R
) in N_Indexed_Component | N_Selected_Component | N_Slice
20583 R
:= Get_Referenced_Object
(Prefix
(R
));
20585 -- If the prefix is an access value, only the designated type matters
20587 if Is_Access_Type
(Etype
(R
)) then
20588 if Is_Full_Access
(Designated_Type
(Etype
(R
))) then
20593 if Is_Full_Access_Object
(R
) then
20600 end Is_Subcomponent_Of_Full_Access_Object
;
20602 ---------------------------------------
20603 -- Is_Subprogram_Contract_Annotation --
20604 ---------------------------------------
20606 function Is_Subprogram_Contract_Annotation
20607 (Item
: Node_Id
) return Boolean
20612 if Nkind
(Item
) = N_Aspect_Specification
then
20613 Nam
:= Chars
(Identifier
(Item
));
20615 else pragma Assert
(Nkind
(Item
) = N_Pragma
);
20616 Nam
:= Pragma_Name
(Item
);
20619 return Nam
= Name_Always_Terminates
20620 or else Nam
= Name_Contract_Cases
20621 or else Nam
= Name_Depends
20622 or else Nam
= Name_Exceptional_Cases
20623 or else Nam
= Name_Extensions_Visible
20624 or else Nam
= Name_Global
20625 or else Nam
= Name_Post
20626 or else Nam
= Name_Post_Class
20627 or else Nam
= Name_Postcondition
20628 or else Nam
= Name_Pre
20629 or else Nam
= Name_Pre_Class
20630 or else Nam
= Name_Precondition
20631 or else Nam
= Name_Refined_Depends
20632 or else Nam
= Name_Refined_Global
20633 or else Nam
= Name_Refined_Post
20634 or else Nam
= Name_Subprogram_Variant
20635 or else Nam
= Name_Test_Case
;
20636 end Is_Subprogram_Contract_Annotation
;
20638 --------------------------------------------------
20639 -- Is_Subprogram_Stub_Without_Prior_Declaration --
20640 --------------------------------------------------
20642 function Is_Subprogram_Stub_Without_Prior_Declaration
20643 (N
: Node_Id
) return Boolean
20646 pragma Assert
(Nkind
(N
) = N_Subprogram_Body_Stub
);
20648 case Ekind
(Defining_Entity
(N
)) is
20650 -- A subprogram stub without prior declaration serves as declaration
20651 -- for the actual subprogram body. As such, it has an attached
20652 -- defining entity of E_Function or E_Procedure.
20659 -- Otherwise, it is completes a [generic] subprogram declaration
20661 when E_Generic_Function
20662 | E_Generic_Procedure
20663 | E_Subprogram_Body
20668 raise Program_Error
;
20670 end Is_Subprogram_Stub_Without_Prior_Declaration
;
20672 ---------------------------
20673 -- Is_Suitable_Primitive --
20674 ---------------------------
20676 function Is_Suitable_Primitive
(Subp_Id
: Entity_Id
) return Boolean is
20678 -- The Default_Initial_Condition and invariant procedures must not be
20679 -- treated as primitive operations even when they apply to a tagged
20680 -- type. These routines must not act as targets of dispatching calls
20681 -- because they already utilize class-wide-precondition semantics to
20682 -- handle inheritance and overriding.
20684 if Ekind
(Subp_Id
) = E_Procedure
20685 and then (Is_DIC_Procedure
(Subp_Id
)
20687 Is_Invariant_Procedure
(Subp_Id
))
20693 end Is_Suitable_Primitive
;
20695 ----------------------------
20696 -- Is_Synchronized_Object --
20697 ----------------------------
20699 function Is_Synchronized_Object
(Id
: Entity_Id
) return Boolean is
20703 if Is_Object
(Id
) then
20705 -- The object is synchronized if it is of a type that yields a
20706 -- synchronized object.
20708 if Yields_Synchronized_Object
(Etype
(Id
)) then
20711 -- The object is synchronized if it is atomic and Async_Writers is
20714 elsif Is_Atomic_Object_Entity
(Id
)
20715 and then Async_Writers_Enabled
(Id
)
20719 -- A constant is a synchronized object by default, unless its type is
20720 -- access-to-variable type.
20722 elsif Ekind
(Id
) = E_Constant
20723 and then not Is_Access_Variable
(Etype
(Id
))
20727 -- A variable is a synchronized object if it is subject to pragma
20728 -- Constant_After_Elaboration.
20730 elsif Ekind
(Id
) = E_Variable
then
20731 Prag
:= Get_Pragma
(Id
, Pragma_Constant_After_Elaboration
);
20733 return Present
(Prag
) and then Is_Enabled_Pragma
(Prag
);
20737 -- Otherwise the input is not an object or it does not qualify as a
20738 -- synchronized object.
20741 end Is_Synchronized_Object
;
20743 ---------------------------------
20744 -- Is_Synchronized_Tagged_Type --
20745 ---------------------------------
20747 function Is_Synchronized_Tagged_Type
(E
: Entity_Id
) return Boolean is
20748 Kind
: constant Entity_Kind
:= Ekind
(Base_Type
(E
));
20751 -- A task or protected type derived from an interface is a tagged type.
20752 -- Such a tagged type is called a synchronized tagged type, as are
20753 -- synchronized interfaces and private extensions whose declaration
20754 -- includes the reserved word synchronized.
20756 return (Is_Tagged_Type
(E
)
20757 and then (Kind
= E_Task_Type
20759 Kind
= E_Protected_Type
))
20762 and then Is_Synchronized_Interface
(E
))
20764 (Ekind
(E
) = E_Record_Type_With_Private
20765 and then Nkind
(Parent
(E
)) = N_Private_Extension_Declaration
20766 and then (Synchronized_Present
(Parent
(E
))
20767 or else Is_Synchronized_Interface
(Etype
(E
))));
20768 end Is_Synchronized_Tagged_Type
;
20774 function Is_Transfer
(N
: Node_Id
) return Boolean is
20775 Kind
: constant Node_Kind
:= Nkind
(N
);
20778 if Kind
in N_Simple_Return_Statement
20779 | N_Extended_Return_Statement
20781 | N_Raise_Statement
20782 | N_Requeue_Statement
20786 elsif Kind
in N_Exit_Statement | N_Raise_xxx_Error
20787 and then No
(Condition
(N
))
20791 elsif Kind
= N_Procedure_Call_Statement
20792 and then Is_Entity_Name
(Name
(N
))
20793 and then Present
(Entity
(Name
(N
)))
20794 and then No_Return
(Entity
(Name
(N
)))
20798 elsif Nkind
(Original_Node
(N
)) = N_Raise_Statement
then
20810 function Is_True
(U
: Opt_Ubool
) return Boolean is
20812 return No
(U
) or else U
= Uint_1
;
20815 ------------------------
20816 -- Is_Trivial_Boolean --
20817 ------------------------
20819 function Is_Trivial_Boolean
(N
: Node_Id
) return Boolean is
20821 return Comes_From_Source
(N
)
20822 and then Nkind
(N
) in N_Identifier | N_Expanded_Name
20823 and then Entity
(N
) in Standard_True | Standard_False
;
20824 end Is_Trivial_Boolean
;
20826 --------------------------------------
20827 -- Is_Unchecked_Conversion_Instance --
20828 --------------------------------------
20830 function Is_Unchecked_Conversion_Instance
(Id
: Entity_Id
) return Boolean is
20834 -- Look for a function whose generic parent is the predefined intrinsic
20835 -- function Unchecked_Conversion, or for one that renames such an
20838 if Ekind
(Id
) = E_Function
then
20839 Par
:= Parent
(Id
);
20841 if Nkind
(Par
) = N_Function_Specification
then
20842 Par
:= Generic_Parent
(Par
);
20844 if Present
(Par
) then
20846 Chars
(Par
) = Name_Unchecked_Conversion
20847 and then Is_Intrinsic_Subprogram
(Par
)
20848 and then In_Predefined_Unit
(Par
);
20851 Present
(Alias
(Id
))
20852 and then Is_Unchecked_Conversion_Instance
(Alias
(Id
));
20858 end Is_Unchecked_Conversion_Instance
;
20860 -------------------------------
20861 -- Is_Universal_Numeric_Type --
20862 -------------------------------
20864 function Is_Universal_Numeric_Type
(T
: Entity_Id
) return Boolean is
20866 return T
= Universal_Integer
or else T
= Universal_Real
;
20867 end Is_Universal_Numeric_Type
;
20869 ------------------------------
20870 -- Is_User_Defined_Equality --
20871 ------------------------------
20873 function Is_User_Defined_Equality
(Id
: Entity_Id
) return Boolean is
20874 F1
, F2
: Entity_Id
;
20877 -- An equality operator is a function that carries the name "=", returns
20878 -- Boolean, and has exactly two formal parameters of an identical type.
20880 if Ekind
(Id
) = E_Function
20881 and then Chars
(Id
) = Name_Op_Eq
20882 and then Base_Type
(Etype
(Id
)) = Standard_Boolean
20884 F1
:= First_Formal
(Id
);
20890 F2
:= Next_Formal
(F1
);
20892 return Present
(F2
)
20893 and then No
(Next_Formal
(F2
))
20894 and then Base_Type
(Etype
(F1
)) = Base_Type
(Etype
(F2
));
20899 end Is_User_Defined_Equality
;
20901 -----------------------------
20902 -- Is_User_Defined_Literal --
20903 -----------------------------
20905 function Is_User_Defined_Literal
20907 Typ
: Entity_Id
) return Boolean
20909 Literal_Aspect_Map
:
20910 constant array (N_Numeric_Or_String_Literal
) of Aspect_Id
:=
20911 (N_Integer_Literal
=> Aspect_Integer_Literal
,
20912 N_Interpolated_String_Literal
=> No_Aspect
,
20913 N_Real_Literal
=> Aspect_Real_Literal
,
20914 N_String_Literal
=> Aspect_String_Literal
);
20917 -- Return True when N is either a literal or a named number and the
20918 -- type has the appropriate user-defined literal aspect.
20920 return (Nkind
(N
) in N_Numeric_Or_String_Literal
20921 and then Has_Aspect
(Typ
, Literal_Aspect_Map
(Nkind
(N
))))
20923 (Is_Entity_Name
(N
)
20924 and then Present
(Entity
(N
))
20926 ((Ekind
(Entity
(N
)) = E_Named_Integer
20927 and then Has_Aspect
(Typ
, Aspect_Integer_Literal
))
20929 (Ekind
(Entity
(N
)) = E_Named_Real
20930 and then Has_Aspect
(Typ
, Aspect_Real_Literal
))));
20931 end Is_User_Defined_Literal
;
20933 --------------------------------------
20934 -- Is_Validation_Variable_Reference --
20935 --------------------------------------
20937 function Is_Validation_Variable_Reference
(N
: Node_Id
) return Boolean is
20938 Var
: constant Node_Id
:= Unqual_Conv
(N
);
20939 Var_Id
: Entity_Id
;
20944 if Is_Entity_Name
(Var
) then
20945 Var_Id
:= Entity
(Var
);
20950 and then Ekind
(Var_Id
) = E_Variable
20951 and then Present
(Validated_Object
(Var_Id
));
20952 end Is_Validation_Variable_Reference
;
20954 ----------------------------
20955 -- Is_Variable_Size_Array --
20956 ----------------------------
20958 function Is_Variable_Size_Array
(E
: Entity_Id
) return Boolean is
20962 pragma Assert
(Is_Array_Type
(E
));
20964 -- Check if some index is initialized with a non-constant value
20966 Idx
:= First_Index
(E
);
20967 while Present
(Idx
) loop
20968 if Nkind
(Idx
) = N_Range
then
20969 if not Is_Constant_Bound
(Low_Bound
(Idx
))
20970 or else not Is_Constant_Bound
(High_Bound
(Idx
))
20980 end Is_Variable_Size_Array
;
20982 -----------------------------
20983 -- Is_Variable_Size_Record --
20984 -----------------------------
20986 function Is_Variable_Size_Record
(E
: Entity_Id
) return Boolean is
20988 Comp_Typ
: Entity_Id
;
20991 pragma Assert
(Is_Record_Type
(E
));
20993 Comp
:= First_Component
(E
);
20994 while Present
(Comp
) loop
20995 Comp_Typ
:= Underlying_Type
(Etype
(Comp
));
20997 -- Recursive call if the record type has discriminants
20999 if Is_Record_Type
(Comp_Typ
)
21000 and then Has_Discriminants
(Comp_Typ
)
21001 and then Is_Variable_Size_Record
(Comp_Typ
)
21005 elsif Is_Array_Type
(Comp_Typ
)
21006 and then Is_Variable_Size_Array
(Comp_Typ
)
21011 Next_Component
(Comp
);
21015 end Is_Variable_Size_Record
;
21021 -- Should Is_Variable be refactored to better handle dereferences and
21022 -- technical debt ???
21024 function Is_Variable
21026 Use_Original_Node
: Boolean := True) return Boolean
21028 Orig_Node
: Node_Id
;
21030 function In_Protected_Function
(E
: Entity_Id
) return Boolean;
21031 -- Within a protected function, the private components of the enclosing
21032 -- protected type are constants. A function nested within a (protected)
21033 -- procedure is not itself protected. Within the body of a protected
21034 -- function the current instance of the protected type is a constant.
21036 function Is_Variable_Prefix
(P
: Node_Id
) return Boolean;
21037 -- Prefixes can involve implicit dereferences, in which case we must
21038 -- test for the case of a reference of a constant access type, which can
21039 -- can never be a variable.
21041 ---------------------------
21042 -- In_Protected_Function --
21043 ---------------------------
21045 function In_Protected_Function
(E
: Entity_Id
) return Boolean is
21050 -- E is the current instance of a type
21052 if Is_Type
(E
) then
21061 if not Is_Protected_Type
(Prot
) then
21065 S
:= Current_Scope
;
21066 while Present
(S
) and then S
/= Prot
loop
21067 if Ekind
(S
) = E_Function
and then Scope
(S
) = Prot
then
21076 end In_Protected_Function
;
21078 ------------------------
21079 -- Is_Variable_Prefix --
21080 ------------------------
21082 function Is_Variable_Prefix
(P
: Node_Id
) return Boolean is
21084 if Is_Access_Type
(Etype
(P
)) then
21085 return not Is_Access_Constant
(Root_Type
(Etype
(P
)));
21087 -- For the case of an indexed component whose prefix has a packed
21088 -- array type, the prefix has been rewritten into a type conversion.
21089 -- Determine variable-ness from the converted expression.
21091 elsif Nkind
(P
) = N_Type_Conversion
21092 and then not Comes_From_Source
(P
)
21093 and then Is_Packed_Array
(Etype
(P
))
21095 return Is_Variable
(Expression
(P
));
21098 return Is_Variable
(P
);
21100 end Is_Variable_Prefix
;
21102 -- Start of processing for Is_Variable
21105 -- Special check, allow x'Deref(expr) as a variable
21107 if Nkind
(N
) = N_Attribute_Reference
21108 and then Attribute_Name
(N
) = Name_Deref
21113 -- Check if we perform the test on the original node since this may be a
21114 -- test of syntactic categories which must not be disturbed by whatever
21115 -- rewriting might have occurred. For example, an aggregate, which is
21116 -- certainly NOT a variable, could be turned into a variable by
21119 if Use_Original_Node
then
21120 Orig_Node
:= Original_Node
(N
);
21125 -- Definitely OK if Assignment_OK is set. Since this is something that
21126 -- only gets set for expanded nodes, the test is on N, not Orig_Node.
21128 if Nkind
(N
) in N_Subexpr
and then Assignment_OK
(N
) then
21131 -- Normally we go to the original node, but there is one exception where
21132 -- we use the rewritten node, namely when it is an explicit dereference.
21133 -- The generated code may rewrite a prefix which is an access type with
21134 -- an explicit dereference. The dereference is a variable, even though
21135 -- the original node may not be (since it could be a constant of the
21138 -- In Ada 2005 we have a further case to consider: the prefix may be a
21139 -- function call given in prefix notation. The original node appears to
21140 -- be a selected component, but we need to examine the call.
21142 elsif Nkind
(N
) = N_Explicit_Dereference
21143 and then Nkind
(Orig_Node
) /= N_Explicit_Dereference
21144 and then Present
(Etype
(Orig_Node
))
21145 and then Is_Access_Type
(Etype
(Orig_Node
))
21147 -- Note that if the prefix is an explicit dereference that does not
21148 -- come from source, we must check for a rewritten function call in
21149 -- prefixed notation before other forms of rewriting, to prevent a
21153 (Nkind
(Orig_Node
) = N_Function_Call
21154 and then not Is_Access_Constant
(Etype
(Prefix
(N
))))
21156 Is_Variable_Prefix
(Original_Node
(Prefix
(N
)));
21158 -- Generalized indexing operations are rewritten as explicit
21159 -- dereferences, and it is only during resolution that we can
21160 -- check whether the context requires an access_to_variable type.
21162 elsif Nkind
(N
) = N_Explicit_Dereference
21163 and then Present
(Etype
(Orig_Node
))
21164 and then Has_Implicit_Dereference
(Etype
(Orig_Node
))
21165 and then Ada_Version
>= Ada_2012
21167 return not Is_Access_Constant
(Etype
(Prefix
(N
)));
21169 -- A function call is never a variable
21171 elsif Nkind
(N
) = N_Function_Call
then
21174 -- All remaining checks use the original node
21176 elsif Is_Entity_Name
(Orig_Node
)
21177 and then Present
(Entity
(Orig_Node
))
21180 E
: constant Entity_Id
:= Entity
(Orig_Node
);
21181 K
: constant Entity_Kind
:= Ekind
(E
);
21184 if Is_Loop_Parameter
(E
) then
21188 return (K
= E_Variable
21189 and then Nkind
(Parent
(E
)) /= N_Exception_Handler
)
21190 or else (K
= E_Component
21191 and then not In_Protected_Function
(E
))
21192 or else (Present
(Etype
(E
))
21193 and then Is_Access_Variable
(Etype
(E
))
21194 and then Is_Dereferenced
(N
))
21195 or else K
= E_Out_Parameter
21196 or else K
= E_In_Out_Parameter
21197 or else K
= E_Generic_In_Out_Parameter
21199 -- Current instance of type. If this is a protected type, check
21200 -- we are not within the body of one of its protected functions.
21202 or else (Is_Type
(E
)
21203 and then In_Open_Scopes
(E
)
21204 and then not In_Protected_Function
(E
))
21206 or else (Is_Incomplete_Or_Private_Type
(E
)
21207 and then In_Open_Scopes
(Full_View
(E
)));
21211 case Nkind
(Orig_Node
) is
21212 when N_Indexed_Component
21215 return Is_Variable_Prefix
(Prefix
(Orig_Node
));
21217 when N_Selected_Component
=>
21218 return Is_Variable
(Selector_Name
(Orig_Node
))
21219 and then Is_Variable_Prefix
(Prefix
(Orig_Node
));
21221 -- For an explicit dereference, the type of the prefix cannot
21222 -- be an access to constant or an access to subprogram.
21224 when N_Explicit_Dereference
=>
21226 Typ
: constant Entity_Id
:= Etype
(Prefix
(Orig_Node
));
21228 return Is_Access_Type
(Typ
)
21229 and then not Is_Access_Constant
(Root_Type
(Typ
))
21230 and then Ekind
(Typ
) /= E_Access_Subprogram_Type
;
21233 -- The type conversion is the case where we do not deal with the
21234 -- context dependent special case of an actual parameter. Thus
21235 -- the type conversion is only considered a variable for the
21236 -- purposes of this routine if the target type is tagged. However,
21237 -- a type conversion is considered to be a variable if it does not
21238 -- come from source (this deals for example with the conversions
21239 -- of expressions to their actual subtypes).
21241 when N_Type_Conversion
=>
21242 return Is_Variable
(Expression
(Orig_Node
))
21244 (not Comes_From_Source
(Orig_Node
)
21246 (Is_Tagged_Type
(Etype
(Subtype_Mark
(Orig_Node
)))
21248 Is_Tagged_Type
(Etype
(Expression
(Orig_Node
)))));
21250 -- GNAT allows an unchecked type conversion as a variable. This
21251 -- only affects the generation of internal expanded code, since
21252 -- calls to instantiations of Unchecked_Conversion are never
21253 -- considered variables (since they are function calls).
21255 when N_Unchecked_Type_Conversion
=>
21256 return Is_Variable
(Expression
(Orig_Node
));
21264 ------------------------
21265 -- Is_View_Conversion --
21266 ------------------------
21268 function Is_View_Conversion
(N
: Node_Id
) return Boolean is
21270 if Nkind
(N
) = N_Type_Conversion
21271 and then Nkind
(Unqual_Conv
(N
)) in N_Has_Etype
21273 if Is_Tagged_Type
(Etype
(N
))
21274 and then Is_Tagged_Type
(Etype
(Unqual_Conv
(N
)))
21278 elsif Is_Actual_Parameter
(N
)
21279 and then (Is_Actual_Out_Parameter
(N
)
21280 or else Is_Actual_In_Out_Parameter
(N
))
21287 end Is_View_Conversion
;
21289 ---------------------------
21290 -- Is_Visibly_Controlled --
21291 ---------------------------
21293 function Is_Visibly_Controlled
(T
: Entity_Id
) return Boolean is
21294 Root
: constant Entity_Id
:= Root_Type
(T
);
21296 return Chars
(Scope
(Root
)) = Name_Finalization
21297 and then Chars
(Scope
(Scope
(Root
))) = Name_Ada
21298 and then Scope
(Scope
(Scope
(Root
))) = Standard_Standard
;
21299 end Is_Visibly_Controlled
;
21301 ----------------------------------------
21302 -- Is_Volatile_Full_Access_Object_Ref --
21303 ----------------------------------------
21305 function Is_Volatile_Full_Access_Object_Ref
(N
: Node_Id
) return Boolean is
21306 function Is_VFA_Object_Entity
(Id
: Entity_Id
) return Boolean;
21307 -- Determine whether arbitrary entity Id denotes an object that is
21308 -- Volatile_Full_Access.
21310 ----------------------------
21311 -- Is_VFA_Object_Entity --
21312 ----------------------------
21314 function Is_VFA_Object_Entity
(Id
: Entity_Id
) return Boolean is
21318 and then (Is_Volatile_Full_Access
(Id
)
21320 Is_Volatile_Full_Access
(Etype
(Id
)));
21321 end Is_VFA_Object_Entity
;
21323 -- Start of processing for Is_Volatile_Full_Access_Object_Ref
21326 if Is_Entity_Name
(N
) then
21327 return Is_VFA_Object_Entity
(Entity
(N
));
21329 elsif Is_Volatile_Full_Access
(Etype
(N
)) then
21332 elsif Nkind
(N
) = N_Selected_Component
then
21333 return Is_Volatile_Full_Access
(Entity
(Selector_Name
(N
)));
21338 end Is_Volatile_Full_Access_Object_Ref
;
21340 --------------------------
21341 -- Is_Volatile_Function --
21342 --------------------------
21344 function Is_Volatile_Function
(Func_Id
: Entity_Id
) return Boolean is
21346 pragma Assert
(Ekind
(Func_Id
) in E_Function | E_Generic_Function
);
21348 -- A protected function is volatile
21350 if Nkind
(Parent
(Unit_Declaration_Node
(Func_Id
))) =
21351 N_Protected_Definition
21355 -- An instance of Ada.Unchecked_Conversion is a volatile function if
21356 -- either the source or the target are effectively volatile.
21358 elsif Is_Unchecked_Conversion_Instance
(Func_Id
)
21359 and then Has_Effectively_Volatile_Profile
(Func_Id
)
21363 -- Otherwise the function is treated as volatile if it is subject to
21364 -- enabled pragma Volatile_Function.
21368 Is_Enabled_Pragma
(Get_Pragma
(Func_Id
, Pragma_Volatile_Function
));
21370 end Is_Volatile_Function
;
21372 ----------------------------
21373 -- Is_Volatile_Object_Ref --
21374 ----------------------------
21376 function Is_Volatile_Object_Ref
(N
: Node_Id
) return Boolean is
21377 function Is_Volatile_Object_Entity
(Id
: Entity_Id
) return Boolean;
21378 -- Determine whether arbitrary entity Id denotes an object that is
21381 function Prefix_Has_Volatile_Components
(P
: Node_Id
) return Boolean;
21382 -- Determine whether prefix P has volatile components. This requires
21383 -- the presence of a Volatile_Components aspect/pragma or that P be
21384 -- itself a volatile object as per RM C.6(8).
21386 ---------------------------------
21387 -- Is_Volatile_Object_Entity --
21388 ---------------------------------
21390 function Is_Volatile_Object_Entity
(Id
: Entity_Id
) return Boolean is
21394 and then (Is_Volatile
(Id
) or else Is_Volatile
(Etype
(Id
)));
21395 end Is_Volatile_Object_Entity
;
21397 ------------------------------------
21398 -- Prefix_Has_Volatile_Components --
21399 ------------------------------------
21401 function Prefix_Has_Volatile_Components
(P
: Node_Id
) return Boolean is
21402 Typ
: constant Entity_Id
:= Etype
(P
);
21405 if Is_Access_Type
(Typ
) then
21407 Dtyp
: constant Entity_Id
:= Designated_Type
(Typ
);
21410 return Has_Volatile_Components
(Dtyp
)
21411 or else Is_Volatile
(Dtyp
);
21414 elsif Has_Volatile_Components
(Typ
) then
21417 elsif Is_Entity_Name
(P
)
21418 and then Has_Volatile_Component
(Entity
(P
))
21422 elsif Is_Volatile_Object_Ref
(P
) then
21428 end Prefix_Has_Volatile_Components
;
21430 -- Start of processing for Is_Volatile_Object_Ref
21433 if Is_Entity_Name
(N
) then
21434 return Is_Volatile_Object_Entity
(Entity
(N
));
21436 elsif Is_Volatile
(Etype
(N
)) then
21439 elsif Nkind
(N
) = N_Indexed_Component
then
21440 return Prefix_Has_Volatile_Components
(Prefix
(N
));
21442 elsif Nkind
(N
) = N_Selected_Component
then
21443 return Prefix_Has_Volatile_Components
(Prefix
(N
))
21444 or else Is_Volatile
(Entity
(Selector_Name
(N
)));
21449 end Is_Volatile_Object_Ref
;
21451 -----------------------------
21452 -- Iterate_Call_Parameters --
21453 -----------------------------
21455 procedure Iterate_Call_Parameters
(Call
: Node_Id
) is
21456 Actual
: Node_Id
:= First_Actual
(Call
);
21457 Formal
: Entity_Id
:= First_Formal
(Get_Called_Entity
(Call
));
21460 while Present
(Formal
) and then Present
(Actual
) loop
21461 Handle_Parameter
(Formal
, Actual
);
21463 Next_Formal
(Formal
);
21464 Next_Actual
(Actual
);
21467 pragma Assert
(No
(Formal
));
21468 pragma Assert
(No
(Actual
));
21469 end Iterate_Call_Parameters
;
21471 -------------------------
21472 -- Kill_Current_Values --
21473 -------------------------
21475 procedure Kill_Current_Values
21477 Last_Assignment_Only
: Boolean := False)
21480 if Is_Assignable
(Ent
) then
21481 Set_Last_Assignment
(Ent
, Empty
);
21484 if Is_Object
(Ent
) then
21485 if not Last_Assignment_Only
then
21487 Set_Current_Value
(Ent
, Empty
);
21489 -- Do not reset the Is_Known_[Non_]Null and Is_Known_Valid flags
21490 -- for a constant. Once the constant is elaborated, its value is
21491 -- not changed, therefore the associated flags that describe the
21492 -- value should not be modified either.
21494 if Ekind
(Ent
) = E_Constant
then
21497 -- Non-constant entities
21500 if not Can_Never_Be_Null
(Ent
) then
21501 Set_Is_Known_Non_Null
(Ent
, False);
21504 Set_Is_Known_Null
(Ent
, False);
21506 -- Reset the Is_Known_Valid flag unless the type is always
21507 -- valid. This does not apply to a loop parameter because its
21508 -- bounds are defined by the loop header and therefore always
21511 if not Is_Known_Valid
(Etype
(Ent
))
21512 and then Ekind
(Ent
) /= E_Loop_Parameter
21514 Set_Is_Known_Valid
(Ent
, False);
21519 end Kill_Current_Values
;
21521 procedure Kill_Current_Values
(Last_Assignment_Only
: Boolean := False) is
21525 -- Kill all saved checks, a special case of killing saved values
21527 if not Last_Assignment_Only
then
21531 -- Loop through relevant scopes, which includes the current scope and
21532 -- any parent scopes if the current scope is a block or a package.
21534 S
:= Current_Scope
;
21537 -- Clear current values of all entities in current scope
21542 Ent
:= First_Entity
(S
);
21543 while Present
(Ent
) loop
21544 Kill_Current_Values
(Ent
, Last_Assignment_Only
);
21549 -- If this is a not a subprogram, deal with parents
21551 if not Is_Subprogram
(S
) then
21553 exit Scope_Loop
when S
= Standard_Standard
;
21557 end loop Scope_Loop
;
21558 end Kill_Current_Values
;
21560 --------------------------
21561 -- Kill_Size_Check_Code --
21562 --------------------------
21564 procedure Kill_Size_Check_Code
(E
: Entity_Id
) is
21566 if (Ekind
(E
) = E_Constant
or else Ekind
(E
) = E_Variable
)
21567 and then Present
(Size_Check_Code
(E
))
21569 Remove
(Size_Check_Code
(E
));
21570 Set_Size_Check_Code
(E
, Empty
);
21572 end Kill_Size_Check_Code
;
21574 --------------------
21575 -- Known_Non_Null --
21576 --------------------
21578 function Known_Non_Null
(N
: Node_Id
) return Boolean is
21579 Status
: constant Null_Status_Kind
:= Null_Status
(N
);
21586 -- The expression yields a non-null value ignoring simple flow analysis
21588 if Status
= Is_Non_Null
then
21591 -- Otherwise check whether N is a reference to an entity that appears
21592 -- within a conditional construct.
21594 elsif Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
21596 -- First check if we are in decisive conditional
21598 Get_Current_Value_Condition
(N
, Op
, Val
);
21600 if Known_Null
(Val
) then
21601 if Op
= N_Op_Eq
then
21603 elsif Op
= N_Op_Ne
then
21608 -- If OK to do replacement, test Is_Known_Non_Null flag
21612 if OK_To_Do_Constant_Replacement
(Id
) then
21613 return Is_Known_Non_Null
(Id
);
21617 -- Otherwise it is not possible to determine whether N yields a non-null
21621 end Known_Non_Null
;
21627 function Known_Null
(N
: Node_Id
) return Boolean is
21628 Status
: constant Null_Status_Kind
:= Null_Status
(N
);
21635 -- The expression yields a null value ignoring simple flow analysis
21637 if Status
= Is_Null
then
21640 -- Otherwise check whether N is a reference to an entity that appears
21641 -- within a conditional construct.
21643 elsif Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
21645 -- First check if we are in decisive conditional
21647 Get_Current_Value_Condition
(N
, Op
, Val
);
21649 -- If Get_Current_Value_Condition were to return Val = N, then the
21650 -- recursion below could be infinite.
21653 raise Program_Error
;
21656 if Known_Null
(Val
) then
21657 if Op
= N_Op_Eq
then
21659 elsif Op
= N_Op_Ne
then
21664 -- If OK to do replacement, test Is_Known_Null flag
21668 if OK_To_Do_Constant_Replacement
(Id
) then
21669 return Is_Known_Null
(Id
);
21673 -- Otherwise it is not possible to determine whether N yields a null
21679 ---------------------------
21680 -- Last_Source_Statement --
21681 ---------------------------
21683 function Last_Source_Statement
(HSS
: Node_Id
) return Node_Id
is
21687 N
:= Last
(Statements
(HSS
));
21688 while Present
(N
) loop
21689 exit when Comes_From_Source
(N
);
21694 end Last_Source_Statement
;
21696 -----------------------
21697 -- Mark_Coextensions --
21698 -----------------------
21700 procedure Mark_Coextensions
(Context_Nod
: Node_Id
; Root_Nod
: Node_Id
) is
21701 Is_Dynamic
: Boolean;
21702 -- Indicates whether the context causes nested coextensions to be
21703 -- dynamic or static
21705 function Mark_Allocator
(N
: Node_Id
) return Traverse_Result
;
21706 -- Recognize an allocator node and label it as a dynamic coextension
21708 --------------------
21709 -- Mark_Allocator --
21710 --------------------
21712 function Mark_Allocator
(N
: Node_Id
) return Traverse_Result
is
21714 if Nkind
(N
) = N_Allocator
then
21716 Set_Is_Static_Coextension
(N
, False);
21717 Set_Is_Dynamic_Coextension
(N
);
21719 -- If the allocator expression is potentially dynamic, it may
21720 -- be expanded out of order and require dynamic allocation
21721 -- anyway, so we treat the coextension itself as dynamic.
21722 -- Potential optimization ???
21724 elsif Nkind
(Expression
(N
)) = N_Qualified_Expression
21725 and then Nkind
(Expression
(Expression
(N
))) = N_Op_Concat
21727 Set_Is_Static_Coextension
(N
, False);
21728 Set_Is_Dynamic_Coextension
(N
);
21730 Set_Is_Dynamic_Coextension
(N
, False);
21731 Set_Is_Static_Coextension
(N
);
21736 end Mark_Allocator
;
21738 procedure Mark_Allocators
is new Traverse_Proc
(Mark_Allocator
);
21740 -- Start of processing for Mark_Coextensions
21743 -- An allocator that appears on the right-hand side of an assignment is
21744 -- treated as a potentially dynamic coextension when the right-hand side
21745 -- is an allocator or a qualified expression.
21747 -- Obj := new ...'(new Coextension ...);
21749 if Nkind
(Context_Nod
) = N_Assignment_Statement
then
21750 Is_Dynamic
:= Nkind
(Expression
(Context_Nod
)) in
21751 N_Allocator | N_Qualified_Expression
;
21753 -- An allocator that appears within the expression of a simple return
21754 -- statement is treated as a potentially dynamic coextension when the
21755 -- expression is either aggregate, allocator, or qualified expression.
21757 -- return (new Coextension ...);
21758 -- return new ...'(new Coextension ...);
21760 elsif Nkind
(Context_Nod
) = N_Simple_Return_Statement
then
21761 Is_Dynamic
:= Nkind
(Expression
(Context_Nod
)) in
21762 N_Aggregate | N_Allocator | N_Qualified_Expression
;
21764 -- An alloctor that appears within the initialization expression of an
21765 -- object declaration is considered a potentially dynamic coextension
21766 -- when the initialization expression is an allocator or a qualified
21769 -- Obj : ... := new ...'(new Coextension ...);
21771 -- A similar case arises when the object declaration is part of an
21772 -- extended return statement.
21774 -- return Obj : ... := new ...'(new Coextension ...);
21775 -- return Obj : ... := (new Coextension ...);
21777 elsif Nkind
(Context_Nod
) = N_Object_Declaration
then
21778 Is_Dynamic
:= Nkind
(Root_Nod
) in N_Allocator | N_Qualified_Expression
21779 or else Nkind
(Parent
(Context_Nod
)) = N_Extended_Return_Statement
;
21781 -- This routine should not be called with constructs that cannot contain
21785 raise Program_Error
;
21788 Mark_Allocators
(Root_Nod
);
21789 end Mark_Coextensions
;
21791 ---------------------------------
21792 -- Mark_Elaboration_Attributes --
21793 ---------------------------------
21795 procedure Mark_Elaboration_Attributes
21796 (N_Id
: Node_Or_Entity_Id
;
21797 Checks
: Boolean := False;
21798 Level
: Boolean := False;
21799 Modes
: Boolean := False;
21800 Warnings
: Boolean := False)
21802 function Elaboration_Checks_OK
21803 (Target_Id
: Entity_Id
;
21804 Context_Id
: Entity_Id
) return Boolean;
21805 -- Determine whether elaboration checks are enabled for target Target_Id
21806 -- which resides within context Context_Id.
21808 procedure Mark_Elaboration_Attributes_Id
(Id
: Entity_Id
);
21809 -- Preserve relevant attributes of the context in arbitrary entity Id
21811 procedure Mark_Elaboration_Attributes_Node
(N
: Node_Id
);
21812 -- Preserve relevant attributes of the context in arbitrary node N
21814 ---------------------------
21815 -- Elaboration_Checks_OK --
21816 ---------------------------
21818 function Elaboration_Checks_OK
21819 (Target_Id
: Entity_Id
;
21820 Context_Id
: Entity_Id
) return Boolean
21822 Encl_Scop
: Entity_Id
;
21825 -- Elaboration checks are suppressed for the target
21827 if Elaboration_Checks_Suppressed
(Target_Id
) then
21831 -- Otherwise elaboration checks are OK for the target, but may be
21832 -- suppressed for the context where the target is declared.
21834 Encl_Scop
:= Context_Id
;
21835 while Present
(Encl_Scop
) and then Encl_Scop
/= Standard_Standard
loop
21836 if Elaboration_Checks_Suppressed
(Encl_Scop
) then
21840 Encl_Scop
:= Scope
(Encl_Scop
);
21843 -- Neither the target nor its declarative context have elaboration
21844 -- checks suppressed.
21847 end Elaboration_Checks_OK
;
21849 ------------------------------------
21850 -- Mark_Elaboration_Attributes_Id --
21851 ------------------------------------
21853 procedure Mark_Elaboration_Attributes_Id
(Id
: Entity_Id
) is
21855 -- Mark the status of elaboration checks in effect. Do not reset the
21856 -- status in case the entity is reanalyzed with checks suppressed.
21858 if Checks
and then not Is_Elaboration_Checks_OK_Id
(Id
) then
21859 Set_Is_Elaboration_Checks_OK_Id
(Id
,
21860 Elaboration_Checks_OK
21862 Context_Id
=> Scope
(Id
)));
21865 -- Mark the status of elaboration warnings in effect. Do not reset
21866 -- the status in case the entity is reanalyzed with warnings off.
21868 if Warnings
and then not Is_Elaboration_Warnings_OK_Id
(Id
) then
21869 Set_Is_Elaboration_Warnings_OK_Id
(Id
, Elab_Warnings
);
21871 end Mark_Elaboration_Attributes_Id
;
21873 --------------------------------------
21874 -- Mark_Elaboration_Attributes_Node --
21875 --------------------------------------
21877 procedure Mark_Elaboration_Attributes_Node
(N
: Node_Id
) is
21878 function Extract_Name
(N
: Node_Id
) return Node_Id
;
21879 -- Obtain the Name attribute of call or instantiation N
21885 function Extract_Name
(N
: Node_Id
) return Node_Id
is
21891 -- A call to an entry family appears in indexed form
21893 if Nkind
(Nam
) = N_Indexed_Component
then
21894 Nam
:= Prefix
(Nam
);
21897 -- The name may also appear in qualified form
21899 if Nkind
(Nam
) = N_Selected_Component
then
21900 Nam
:= Selector_Name
(Nam
);
21908 Context_Id
: Entity_Id
;
21911 -- Start of processing for Mark_Elaboration_Attributes_Node
21914 -- Mark the status of elaboration checks in effect. Do not reset the
21915 -- status in case the node is reanalyzed with checks suppressed.
21917 if Checks
and then not Is_Elaboration_Checks_OK_Node
(N
) then
21919 -- Assignments, attribute references, and variable references do
21920 -- not have a "declarative" context.
21922 Context_Id
:= Empty
;
21924 -- The status of elaboration checks for calls and instantiations
21925 -- depends on the most recent pragma Suppress/Unsuppress, as well
21926 -- as the suppression status of the context where the target is
21930 -- function Func ...;
21934 -- procedure Main is
21935 -- pragma Suppress (Elaboration_Checks, Pack);
21936 -- X : ... := Pack.Func;
21939 -- In the example above, the call to Func has elaboration checks
21940 -- enabled because there is no active general purpose suppression
21941 -- pragma, however the elaboration checks of Pack are explicitly
21942 -- suppressed. As a result the elaboration checks of the call must
21943 -- be disabled in order to preserve this dependency.
21945 if Nkind
(N
) in N_Entry_Call_Statement
21947 | N_Function_Instantiation
21948 | N_Package_Instantiation
21949 | N_Procedure_Call_Statement
21950 | N_Procedure_Instantiation
21952 Nam
:= Extract_Name
(N
);
21954 if Is_Entity_Name
(Nam
) and then Present
(Entity
(Nam
)) then
21955 Context_Id
:= Scope
(Entity
(Nam
));
21959 Set_Is_Elaboration_Checks_OK_Node
(N
,
21960 Elaboration_Checks_OK
21961 (Target_Id
=> Empty
,
21962 Context_Id
=> Context_Id
));
21965 -- Mark the enclosing level of the node. Do not reset the status in
21966 -- case the node is relocated and reanalyzed.
21968 if Level
and then not Is_Declaration_Level_Node
(N
) then
21969 Set_Is_Declaration_Level_Node
(N
,
21970 Find_Enclosing_Level
(N
) = Declaration_Level
);
21973 -- Mark the Ghost and SPARK mode in effect
21976 if Ghost_Mode
= Ignore
then
21977 Set_Is_Ignored_Ghost_Node
(N
);
21980 if SPARK_Mode
= On
then
21981 Set_Is_SPARK_Mode_On_Node
(N
);
21985 -- Mark the status of elaboration warnings in effect. Do not reset
21986 -- the status in case the node is reanalyzed with warnings off.
21988 if Warnings
and then not Is_Elaboration_Warnings_OK_Node
(N
) then
21989 Set_Is_Elaboration_Warnings_OK_Node
(N
, Elab_Warnings
);
21991 end Mark_Elaboration_Attributes_Node
;
21993 -- Start of processing for Mark_Elaboration_Attributes
21996 -- Do not capture any elaboration-related attributes when switch -gnatH
21997 -- (legacy elaboration checking mode enabled) is in effect because the
21998 -- attributes are useless to the legacy model.
22000 if Legacy_Elaboration_Checks
then
22004 if Nkind
(N_Id
) in N_Entity
then
22005 Mark_Elaboration_Attributes_Id
(N_Id
);
22007 Mark_Elaboration_Attributes_Node
(N_Id
);
22009 end Mark_Elaboration_Attributes
;
22011 ----------------------------------------
22012 -- Mark_Save_Invocation_Graph_Of_Body --
22013 ----------------------------------------
22015 procedure Mark_Save_Invocation_Graph_Of_Body
is
22016 Main
: constant Node_Id
:= Cunit
(Main_Unit
);
22017 Main_Unit
: constant Node_Id
:= Unit
(Main
);
22018 Aux_Id
: Entity_Id
;
22021 Set_Save_Invocation_Graph_Of_Body
(Main
);
22023 -- Assume that the main unit does not have a complimentary unit
22027 -- Obtain the complimentary unit of the main unit
22029 if Nkind
(Main_Unit
) in N_Generic_Package_Declaration
22030 | N_Generic_Subprogram_Declaration
22031 | N_Package_Declaration
22032 | N_Subprogram_Declaration
22034 Aux_Id
:= Corresponding_Body
(Main_Unit
);
22036 elsif Nkind
(Main_Unit
) in N_Package_Body
22037 | N_Subprogram_Body
22038 | N_Subprogram_Renaming_Declaration
22040 Aux_Id
:= Corresponding_Spec
(Main_Unit
);
22043 if Present
(Aux_Id
) then
22044 Set_Save_Invocation_Graph_Of_Body
22045 (Parent
(Unit_Declaration_Node
(Aux_Id
)));
22047 end Mark_Save_Invocation_Graph_Of_Body
;
22049 ----------------------------------
22050 -- Matching_Static_Array_Bounds --
22051 ----------------------------------
22053 function Matching_Static_Array_Bounds
22055 R_Typ
: Node_Id
) return Boolean
22057 L_Ndims
: constant Nat
:= Number_Dimensions
(L_Typ
);
22058 R_Ndims
: constant Nat
:= Number_Dimensions
(R_Typ
);
22060 L_Index
: Node_Id
:= Empty
; -- init to ...
22061 R_Index
: Node_Id
:= Empty
; -- ...avoid warnings
22070 if L_Ndims
/= R_Ndims
then
22074 -- Unconstrained types do not have static bounds
22076 if not Is_Constrained
(L_Typ
) or else not Is_Constrained
(R_Typ
) then
22080 -- First treat specially the first dimension, as the lower bound and
22081 -- length of string literals are not stored like those of arrays.
22083 if Ekind
(L_Typ
) = E_String_Literal_Subtype
then
22084 L_Low
:= String_Literal_Low_Bound
(L_Typ
);
22085 L_Len
:= String_Literal_Length
(L_Typ
);
22087 L_Index
:= First_Index
(L_Typ
);
22088 Get_Index_Bounds
(L_Index
, L_Low
, L_High
);
22090 if Is_OK_Static_Expression
(L_Low
)
22092 Is_OK_Static_Expression
(L_High
)
22094 if Expr_Value
(L_High
) < Expr_Value
(L_Low
) then
22097 L_Len
:= (Expr_Value
(L_High
) - Expr_Value
(L_Low
)) + 1;
22104 if Ekind
(R_Typ
) = E_String_Literal_Subtype
then
22105 R_Low
:= String_Literal_Low_Bound
(R_Typ
);
22106 R_Len
:= String_Literal_Length
(R_Typ
);
22108 R_Index
:= First_Index
(R_Typ
);
22109 Get_Index_Bounds
(R_Index
, R_Low
, R_High
);
22111 if Is_OK_Static_Expression
(R_Low
)
22113 Is_OK_Static_Expression
(R_High
)
22115 if Expr_Value
(R_High
) < Expr_Value
(R_Low
) then
22118 R_Len
:= (Expr_Value
(R_High
) - Expr_Value
(R_Low
)) + 1;
22125 if (Is_OK_Static_Expression
(L_Low
)
22127 Is_OK_Static_Expression
(R_Low
))
22128 and then Expr_Value
(L_Low
) = Expr_Value
(R_Low
)
22129 and then L_Len
= R_Len
22136 -- Then treat all other dimensions
22138 for Indx
in 2 .. L_Ndims
loop
22142 Get_Index_Bounds
(L_Index
, L_Low
, L_High
);
22143 Get_Index_Bounds
(R_Index
, R_Low
, R_High
);
22145 if (Is_OK_Static_Expression
(L_Low
) and then
22146 Is_OK_Static_Expression
(L_High
) and then
22147 Is_OK_Static_Expression
(R_Low
) and then
22148 Is_OK_Static_Expression
(R_High
))
22149 and then (Expr_Value
(L_Low
) = Expr_Value
(R_Low
)
22151 Expr_Value
(L_High
) = Expr_Value
(R_High
))
22159 -- If we fall through the loop, all indexes matched
22162 end Matching_Static_Array_Bounds
;
22168 function Might_Raise
(N
: Node_Id
) return Boolean is
22169 Result
: Boolean := False;
22171 function Process
(N
: Node_Id
) return Traverse_Result
;
22172 -- Set Result to True if we find something that could raise an exception
22178 function Process
(N
: Node_Id
) return Traverse_Result
is
22180 if Nkind
(N
) in N_Procedure_Call_Statement
22182 | N_Raise_Statement
22183 | N_Raise_xxx_Error
22184 | N_Raise_Expression
22193 procedure Set_Result
is new Traverse_Proc
(Process
);
22195 -- Start of processing for Might_Raise
22198 -- False if exceptions can't be propagated
22200 if No_Exception_Handlers_Set
then
22204 -- If the checks handled by the back end are not disabled, we cannot
22205 -- ensure that no exception will be raised.
22207 if not Access_Checks_Suppressed
(Empty
)
22208 or else not Discriminant_Checks_Suppressed
(Empty
)
22209 or else not Range_Checks_Suppressed
(Empty
)
22210 or else not Index_Checks_Suppressed
(Empty
)
22211 or else Opt
.Stack_Checking_Enabled
22220 ----------------------------------------
22221 -- Nearest_Class_Condition_Subprogram --
22222 ----------------------------------------
22224 function Nearest_Class_Condition_Subprogram
22225 (Kind
: Condition_Kind
;
22226 Spec_Id
: Entity_Id
) return Entity_Id
22228 Subp_Id
: constant Entity_Id
:= Ultimate_Alias
(Spec_Id
);
22231 -- Prevent cascaded errors
22233 if not Is_Dispatching_Operation
(Subp_Id
) then
22236 -- No need to search if this subprogram has class-wide postconditions
22238 elsif Present
(Class_Condition
(Kind
, Subp_Id
)) then
22242 -- Process the contracts of inherited subprograms, looking for
22243 -- class-wide pre/postconditions.
22246 Subps
: constant Subprogram_List
:= Inherited_Subprograms
(Subp_Id
);
22247 Subp_Id
: Entity_Id
;
22250 for Index
in Subps
'Range loop
22251 Subp_Id
:= Subps
(Index
);
22253 if Present
(Alias
(Subp_Id
)) then
22254 Subp_Id
:= Ultimate_Alias
(Subp_Id
);
22257 -- Wrappers of class-wide pre/postconditions reference the
22258 -- parent primitive that has the inherited contract.
22260 if Is_Wrapper
(Subp_Id
)
22261 and then Present
(LSP_Subprogram
(Subp_Id
))
22263 Subp_Id
:= LSP_Subprogram
(Subp_Id
);
22266 if Present
(Class_Condition
(Kind
, Subp_Id
)) then
22273 end Nearest_Class_Condition_Subprogram
;
22275 --------------------------------
22276 -- Nearest_Enclosing_Instance --
22277 --------------------------------
22279 function Nearest_Enclosing_Instance
(E
: Entity_Id
) return Entity_Id
is
22284 while Present
(Inst
) and then Inst
/= Standard_Standard
loop
22285 if Is_Generic_Instance
(Inst
) then
22289 Inst
:= Scope
(Inst
);
22293 end Nearest_Enclosing_Instance
;
22295 ------------------------
22296 -- Needs_Finalization --
22297 ------------------------
22299 function Needs_Finalization
(Typ
: Entity_Id
) return Boolean is
22300 function Has_Some_Controlled_Component
22301 (Input_Typ
: Entity_Id
) return Boolean;
22302 -- Determine whether type Input_Typ has at least one controlled
22305 -----------------------------------
22306 -- Has_Some_Controlled_Component --
22307 -----------------------------------
22309 function Has_Some_Controlled_Component
22310 (Input_Typ
: Entity_Id
) return Boolean
22315 -- When a type is already frozen and has at least one controlled
22316 -- component, or is manually decorated, it is sufficient to inspect
22317 -- flag Has_Controlled_Component.
22319 if Has_Controlled_Component
(Input_Typ
) then
22322 -- Otherwise inspect the internals of the type
22324 elsif not Is_Frozen
(Input_Typ
) then
22325 if Is_Array_Type
(Input_Typ
) then
22326 return Needs_Finalization
(Component_Type
(Input_Typ
));
22328 elsif Is_Record_Type
(Input_Typ
) then
22329 Comp
:= First_Component
(Input_Typ
);
22330 while Present
(Comp
) loop
22331 if Needs_Finalization
(Etype
(Comp
)) then
22335 Next_Component
(Comp
);
22341 end Has_Some_Controlled_Component
;
22343 -- Start of processing for Needs_Finalization
22346 -- Certain run-time configurations and targets do not provide support
22347 -- for controlled types.
22349 if Restriction_Active
(No_Finalization
) then
22352 -- C++ types are not considered controlled. It is assumed that the non-
22353 -- Ada side will handle their clean up.
22355 elsif Convention
(Typ
) = Convention_CPP
then
22358 -- Class-wide types are treated as controlled because derivations from
22359 -- the root type may introduce controlled components.
22361 elsif Is_Class_Wide_Type
(Typ
) then
22364 -- Concurrent types are controlled as long as their corresponding record
22367 elsif Is_Concurrent_Type
(Typ
)
22368 and then Present
(Corresponding_Record_Type
(Typ
))
22369 and then Needs_Finalization
(Corresponding_Record_Type
(Typ
))
22373 -- Otherwise the type is controlled when it is either derived from type
22374 -- [Limited_]Controlled and not subject to aspect Disable_Controlled, or
22375 -- contains at least one controlled component.
22379 Is_Controlled
(Typ
) or else Has_Some_Controlled_Component
(Typ
);
22381 end Needs_Finalization
;
22383 ----------------------
22384 -- Needs_One_Actual --
22385 ----------------------
22387 function Needs_One_Actual
(E
: Entity_Id
) return Boolean is
22388 Formal
: Entity_Id
;
22391 -- Ada 2005 or later, and formals present. The first formal must be
22392 -- of a type that supports prefix notation: a controlling argument,
22393 -- a class-wide type, or an access to such.
22395 if Ada_Version
>= Ada_2005
22396 and then Present
(First_Formal
(E
))
22397 and then No
(Default_Value
(First_Formal
(E
)))
22399 (Is_Controlling_Formal
(First_Formal
(E
))
22400 or else Is_Class_Wide_Type
(Etype
(First_Formal
(E
)))
22401 or else Is_Anonymous_Access_Type
(Etype
(First_Formal
(E
))))
22403 Formal
:= Next_Formal
(First_Formal
(E
));
22404 while Present
(Formal
) loop
22405 if No
(Default_Value
(Formal
)) then
22409 Next_Formal
(Formal
);
22414 -- Ada 83/95 or no formals
22419 end Needs_One_Actual
;
22421 ----------------------------
22422 -- Needs_Secondary_Stack --
22423 ----------------------------
22425 function Needs_Secondary_Stack
(Id
: Entity_Id
) return Boolean is
22426 pragma Assert
(if Present
(Id
) then Ekind
(Id
) in E_Void | Type_Kind
);
22428 function Caller_Known_Size_Record
(Typ
: Entity_Id
) return Boolean;
22429 -- Called for untagged record and protected types. Return True if the
22430 -- size of function results is known in the caller for Typ.
22432 function Large_Max_Size_Mutable
(Typ
: Entity_Id
) return Boolean;
22433 -- Returns True if Typ is a nonlimited record with defaulted
22434 -- discriminants whose max size makes it unsuitable for allocating on
22435 -- the primary stack.
22437 ------------------------------
22438 -- Caller_Known_Size_Record --
22439 ------------------------------
22441 function Caller_Known_Size_Record
(Typ
: Entity_Id
) return Boolean is
22442 pragma Assert
(if Present
(Typ
) then Typ
= Underlying_Type
(Typ
));
22444 function Depends_On_Discriminant
(Typ
: Entity_Id
) return Boolean;
22445 -- Called for untagged record and protected types. Return True if Typ
22446 -- depends on discriminants, either directly when it is unconstrained
22447 -- or indirectly when it is constrained by uplevel discriminants.
22449 -----------------------------
22450 -- Depends_On_Discriminant --
22451 -----------------------------
22453 function Depends_On_Discriminant
(Typ
: Entity_Id
) return Boolean is
22457 if Has_Discriminants
(Typ
) then
22458 if not Is_Constrained
(Typ
) then
22462 Cons
:= First_Elmt
(Discriminant_Constraint
(Typ
));
22463 while Present
(Cons
) loop
22464 if Nkind
(Node
(Cons
)) = N_Identifier
22465 and then Ekind
(Entity
(Node
(Cons
))) = E_Discriminant
22476 end Depends_On_Discriminant
;
22479 -- This is a protected type without Corresponding_Record_Type set,
22480 -- typically because expansion is disabled. The safe thing to do is
22481 -- to return True, so Needs_Secondary_Stack returns False.
22487 -- First see if we have a variant part and return False if it depends
22488 -- on discriminants.
22490 if Has_Variant_Part
(Typ
) and then Depends_On_Discriminant
(Typ
) then
22494 -- Then loop over components and return False if their subtype has a
22495 -- caller-unknown size, possibly recursively.
22497 -- ??? This is overly conservative, an array could be nested inside
22498 -- some other record that is constrained by nondiscriminants. That
22499 -- is, the recursive calls are too conservative.
22505 Comp
:= First_Component
(Typ
);
22506 while Present
(Comp
) loop
22508 Comp_Type
: constant Entity_Id
:=
22509 Underlying_Type
(Etype
(Comp
));
22512 if Is_Record_Type
(Comp_Type
) then
22513 if not Caller_Known_Size_Record
(Comp_Type
) then
22517 elsif Is_Protected_Type
(Comp_Type
) then
22518 if not Caller_Known_Size_Record
22519 (Corresponding_Record_Type
(Comp_Type
))
22524 elsif Is_Array_Type
(Comp_Type
) then
22525 if Size_Depends_On_Discriminant
(Comp_Type
) then
22531 Next_Component
(Comp
);
22536 end Caller_Known_Size_Record
;
22538 ------------------------------
22539 -- Large_Max_Size_Mutable --
22540 ------------------------------
22542 function Large_Max_Size_Mutable
(Typ
: Entity_Id
) return Boolean is
22543 pragma Assert
(Typ
= Underlying_Type
(Typ
));
22545 function Is_Large_Discrete_Type
(T
: Entity_Id
) return Boolean;
22546 -- Returns true if the discrete type T has a large range
22548 ----------------------------
22549 -- Is_Large_Discrete_Type --
22550 ----------------------------
22552 function Is_Large_Discrete_Type
(T
: Entity_Id
) return Boolean is
22553 Threshold
: constant Int
:= 16;
22554 -- Arbitrary threshold above which we consider it "large". We want
22555 -- a fairly large threshold, because these large types really
22556 -- shouldn't have default discriminants in the first place, in
22560 return UI_To_Int
(RM_Size
(T
)) > Threshold
;
22561 end Is_Large_Discrete_Type
;
22563 -- Start of processing for Large_Max_Size_Mutable
22566 if Is_Record_Type
(Typ
)
22567 and then not Is_Limited_View
(Typ
)
22568 and then Has_Defaulted_Discriminants
(Typ
)
22570 -- Loop through the components, looking for an array whose upper
22571 -- bound(s) depends on discriminants, where both the subtype of
22572 -- the discriminant and the index subtype are too large.
22578 Comp
:= First_Component
(Typ
);
22579 while Present
(Comp
) loop
22581 Comp_Type
: constant Entity_Id
:=
22582 Underlying_Type
(Etype
(Comp
));
22589 if Present
(Comp_Type
)
22590 and then Is_Array_Type
(Comp_Type
)
22592 Indx
:= First_Index
(Comp_Type
);
22594 while Present
(Indx
) loop
22595 Ityp
:= Etype
(Indx
);
22596 Hi
:= Type_High_Bound
(Ityp
);
22598 if Nkind
(Hi
) = N_Identifier
22599 and then Ekind
(Entity
(Hi
)) = E_Discriminant
22600 and then Is_Large_Discrete_Type
(Ityp
)
22601 and then Is_Large_Discrete_Type
22602 (Etype
(Entity
(Hi
)))
22612 Next_Component
(Comp
);
22618 end Large_Max_Size_Mutable
;
22620 -- Local declarations
22622 Typ
: constant Entity_Id
:= Underlying_Type
(Id
);
22624 -- Start of processing for Needs_Secondary_Stack
22627 -- This is a private type which is not completed yet. This can only
22628 -- happen in a default expression (of a formal parameter or of a
22629 -- record component). The safe thing to do is to return False.
22635 -- Do not expand transient scope for non-existent procedure return or
22636 -- string literal types.
22638 if Typ
= Standard_Void_Type
22639 or else Ekind
(Typ
) = E_String_Literal_Subtype
22643 -- If Typ is a generic formal incomplete type, then we want to look at
22644 -- the actual type.
22646 elsif Ekind
(Typ
) = E_Record_Subtype
22647 and then Present
(Cloned_Subtype
(Typ
))
22649 return Needs_Secondary_Stack
(Cloned_Subtype
(Typ
));
22651 -- Class-wide types obviously have an unknown size. For specific tagged
22652 -- types, if a call returning one of them is dispatching on result, and
22653 -- this type is not returned on the secondary stack, then the call goes
22654 -- through a thunk that only moves the result from the primary onto the
22655 -- secondary stack, because the computation of the size of the result is
22656 -- possible but complex from the outside.
22658 elsif Is_Class_Wide_Type
(Typ
) then
22661 -- If the return slot of the back end cannot be accessed, then there
22662 -- is no way to call Adjust at the right time for the return object if
22663 -- the type needs finalization, so the return object must be allocated
22664 -- on the secondary stack.
22666 elsif not Back_End_Return_Slot
and then Needs_Finalization
(Typ
) then
22669 -- Definite subtypes have a known size. This includes all elementary
22670 -- types. Tasks have a known size even if they have discriminants, so
22671 -- we return False here, with one exception:
22672 -- For a type like:
22673 -- type T (Last : Natural := 0) is
22674 -- X : String (1 .. Last);
22676 -- we return True. That's because for "P(F(...));", where F returns T,
22677 -- we don't know the size of the result at the call site, so if we
22678 -- allocated it on the primary stack, we would have to allocate the
22679 -- maximum size, which is way too big.
22681 elsif Is_Definite_Subtype
(Typ
) or else Is_Task_Type
(Typ
) then
22682 return Large_Max_Size_Mutable
(Typ
);
22684 -- Indefinite (discriminated) record type
22686 elsif Is_Record_Type
(Typ
) then
22687 return not Caller_Known_Size_Record
(Typ
);
22689 -- Indefinite (discriminated) protected type
22691 elsif Is_Protected_Type
(Typ
) then
22692 return not Caller_Known_Size_Record
(Corresponding_Record_Type
(Typ
));
22694 -- Unconstrained array type
22697 pragma Assert
(Is_Array_Type
(Typ
) and then not Is_Constrained
(Typ
));
22700 end Needs_Secondary_Stack
;
22702 ---------------------------------
22703 -- Needs_Simple_Initialization --
22704 ---------------------------------
22706 function Needs_Simple_Initialization
22708 Consider_IS
: Boolean := True) return Boolean
22710 Consider_IS_NS
: constant Boolean :=
22711 Normalize_Scalars
or (Initialize_Scalars
and Consider_IS
);
22714 -- Never need initialization if it is suppressed
22716 if Initialization_Suppressed
(Typ
) then
22720 -- Check for private type, in which case test applies to the underlying
22721 -- type of the private type.
22723 if Is_Private_Type
(Typ
) then
22725 RT
: constant Entity_Id
:= Underlying_Type
(Typ
);
22727 if Present
(RT
) then
22728 return Needs_Simple_Initialization
(RT
);
22734 -- Scalar type with Default_Value aspect requires initialization
22736 elsif Is_Scalar_Type
(Typ
) and then Has_Default_Aspect
(Typ
) then
22739 -- Cases needing simple initialization are access types, and, if pragma
22740 -- Normalize_Scalars or Initialize_Scalars is in effect, then all scalar
22743 elsif Is_Access_Type
(Typ
)
22744 or else (Consider_IS_NS
and then Is_Scalar_Type
(Typ
))
22748 -- If Initialize/Normalize_Scalars is in effect, string objects also
22749 -- need initialization, unless they are created in the course of
22750 -- expanding an aggregate (since in the latter case they will be
22751 -- filled with appropriate initializing values before they are used).
22753 elsif Consider_IS_NS
22754 and then Is_Standard_String_Type
(Typ
)
22756 (not Is_Itype
(Typ
)
22757 or else Nkind
(Associated_Node_For_Itype
(Typ
)) /= N_Aggregate
)
22764 end Needs_Simple_Initialization
;
22766 -------------------------------------
22767 -- Needs_Variable_Reference_Marker --
22768 -------------------------------------
22770 function Needs_Variable_Reference_Marker
22772 Calls_OK
: Boolean) return Boolean
22774 function Within_Suitable_Context
(Ref
: Node_Id
) return Boolean;
22775 -- Deteremine whether variable reference Ref appears within a suitable
22776 -- context that allows the creation of a marker.
22778 -----------------------------
22779 -- Within_Suitable_Context --
22780 -----------------------------
22782 function Within_Suitable_Context
(Ref
: Node_Id
) return Boolean is
22787 while Present
(Par
) loop
22789 -- The context is not suitable when the reference appears within
22790 -- the formal part of an instantiation which acts as compilation
22791 -- unit because there is no proper list for the insertion of the
22794 if Nkind
(Par
) = N_Generic_Association
22795 and then Nkind
(Parent
(Par
)) in N_Generic_Instantiation
22796 and then Nkind
(Parent
(Parent
(Par
))) = N_Compilation_Unit
22800 -- The context is not suitable when the reference appears within
22801 -- a pragma. If the pragma has run-time semantics, the reference
22802 -- will be reconsidered once the pragma is expanded.
22804 elsif Nkind
(Par
) = N_Pragma
then
22807 -- The context is not suitable when the reference appears within a
22808 -- subprogram call, and the caller requests this behavior.
22811 and then Nkind
(Par
) in N_Entry_Call_Statement
22813 | N_Procedure_Call_Statement
22817 -- Prevent the search from going too far
22819 elsif Is_Body_Or_Package_Declaration
(Par
) then
22823 Par
:= Parent
(Par
);
22827 end Within_Suitable_Context
;
22832 Var_Id
: Entity_Id
;
22834 -- Start of processing for Needs_Variable_Reference_Marker
22837 -- No marker needs to be created when switch -gnatH (legacy elaboration
22838 -- checking mode enabled) is in effect because the legacy ABE mechanism
22839 -- does not use markers.
22841 if Legacy_Elaboration_Checks
then
22844 -- No marker needs to be created when the reference is preanalyzed
22845 -- because the marker will be inserted in the wrong place.
22847 elsif Preanalysis_Active
then
22850 -- Only references warrant a marker
22852 elsif Nkind
(N
) not in N_Expanded_Name | N_Identifier
then
22855 -- Only source references warrant a marker
22857 elsif not Comes_From_Source
(N
) then
22860 -- No marker needs to be created when the reference is erroneous, left
22861 -- in a bad state, or does not denote a variable.
22863 elsif not (Present
(Entity
(N
))
22864 and then Ekind
(Entity
(N
)) = E_Variable
22865 and then Entity
(N
) /= Any_Id
)
22870 Var_Id
:= Entity
(N
);
22871 Prag
:= SPARK_Pragma
(Var_Id
);
22873 -- Both the variable and reference must appear in SPARK_Mode On regions
22874 -- because this elaboration scenario falls under the SPARK rules.
22876 if not (Comes_From_Source
(Var_Id
)
22877 and then Present
(Prag
)
22878 and then Get_SPARK_Mode_From_Annotation
(Prag
) = On
22879 and then Is_SPARK_Mode_On_Node
(N
))
22883 -- No marker needs to be created when the reference does not appear
22884 -- within a suitable context (see body for details).
22886 -- Performance note: parent traversal
22888 elsif not Within_Suitable_Context
(N
) then
22892 -- At this point it is known that the variable reference will play a
22893 -- role in ABE diagnostics and requires a marker.
22896 end Needs_Variable_Reference_Marker
;
22898 ------------------------
22899 -- New_Copy_List_Tree --
22900 ------------------------
22902 function New_Copy_List_Tree
(List
: List_Id
) return List_Id
is
22907 if List
= No_List
then
22914 while Present
(E
) loop
22915 Append
(New_Copy_Tree
(E
), NL
);
22921 end New_Copy_List_Tree
;
22923 -------------------
22924 -- New_Copy_Tree --
22925 -------------------
22927 -- The following tables play a key role in replicating entities and Itypes.
22928 -- They are intentionally declared at the library level rather than within
22929 -- New_Copy_Tree to avoid elaborating them on each call. This performance
22930 -- optimization saves up to 2% of the entire compilation time spent in the
22931 -- front end. Care should be taken to reset the tables on each new call to
22934 NCT_Table_Max
: constant := 511;
22936 subtype NCT_Table_Index
is Nat
range 0 .. NCT_Table_Max
- 1;
22938 function NCT_Table_Hash
(Key
: Node_Or_Entity_Id
) return NCT_Table_Index
;
22939 -- Obtain the hash value of node or entity Key
22941 --------------------
22942 -- NCT_Table_Hash --
22943 --------------------
22945 function NCT_Table_Hash
(Key
: Node_Or_Entity_Id
) return NCT_Table_Index
is
22947 return NCT_Table_Index
(Key
mod NCT_Table_Max
);
22948 end NCT_Table_Hash
;
22950 ----------------------
22951 -- NCT_New_Entities --
22952 ----------------------
22954 -- The following table maps old entities and Itypes to their corresponding
22955 -- new entities and Itypes.
22959 package NCT_New_Entities
is new Simple_HTable
(
22960 Header_Num
=> NCT_Table_Index
,
22961 Element
=> Entity_Id
,
22962 No_Element
=> Empty
,
22964 Hash
=> NCT_Table_Hash
,
22967 ------------------------
22968 -- NCT_Pending_Itypes --
22969 ------------------------
22971 -- The following table maps old Associated_Node_For_Itype nodes to a set of
22972 -- new itypes. Given a set of old Itypes Aaa, Bbb, and Ccc, where all three
22973 -- have the same Associated_Node_For_Itype Ppp, and their corresponding new
22974 -- Itypes Xxx, Yyy, Zzz, the table contains the following mapping:
22976 -- Ppp -> (Xxx, Yyy, Zzz)
22978 -- The set is expressed as an Elist
22980 package NCT_Pending_Itypes
is new Simple_HTable
(
22981 Header_Num
=> NCT_Table_Index
,
22982 Element
=> Elist_Id
,
22983 No_Element
=> No_Elist
,
22985 Hash
=> NCT_Table_Hash
,
22988 NCT_Tables_In_Use
: Boolean := False;
22989 -- This flag keeps track of whether the two tables NCT_New_Entities and
22990 -- NCT_Pending_Itypes are in use. The flag is part of an optimization
22991 -- where certain operations are not performed if the tables are not in
22992 -- use. This saves up to 8% of the entire compilation time spent in the
22995 -------------------
22996 -- New_Copy_Tree --
22997 -------------------
22999 function New_Copy_Tree
23001 Map
: Elist_Id
:= No_Elist
;
23002 New_Sloc
: Source_Ptr
:= No_Location
;
23003 New_Scope
: Entity_Id
:= Empty
) return Node_Id
23005 -- This routine performs low-level tree manipulations and needs access
23006 -- to the internals of the tree.
23008 EWA_Level
: Nat
:= 0;
23009 -- This counter keeps track of how many N_Expression_With_Actions nodes
23010 -- are encountered during a depth-first traversal of the subtree. These
23011 -- nodes may define new entities in their Actions lists and thus require
23012 -- special processing.
23014 EWA_Inner_Scope_Level
: Nat
:= 0;
23015 -- This counter keeps track of how many scoping constructs appear within
23016 -- an N_Expression_With_Actions node.
23018 procedure Add_New_Entity
(Old_Id
: Entity_Id
; New_Id
: Entity_Id
);
23019 pragma Inline
(Add_New_Entity
);
23020 -- Add an entry in the NCT_New_Entities table which maps key Old_Id to
23021 -- value New_Id. Old_Id is an entity which appears within the Actions
23022 -- list of an N_Expression_With_Actions node, or within an entity map.
23023 -- New_Id is the corresponding new entity generated during Phase 1.
23025 procedure Add_Pending_Itype
(Assoc_Nod
: Node_Id
; Itype
: Entity_Id
);
23026 pragma Inline
(Add_Pending_Itype
);
23027 -- Add an entry in the NCT_Pending_Itypes which maps key Assoc_Nod to
23028 -- value Itype. Assoc_Nod is the associated node of an itype. Itype is
23031 procedure Build_NCT_Tables
(Entity_Map
: Elist_Id
);
23032 pragma Inline
(Build_NCT_Tables
);
23033 -- Populate tables NCT_New_Entities and NCT_Pending_Itypes with the
23034 -- information supplied in entity map Entity_Map. The format of the
23035 -- entity map must be as follows:
23037 -- Old_Id1, New_Id1, Old_Id2, New_Id2, .., Old_IdN, New_IdN
23039 function Copy_Any_Node_With_Replacement
23040 (N
: Node_Or_Entity_Id
) return Node_Or_Entity_Id
;
23041 pragma Inline
(Copy_Any_Node_With_Replacement
);
23042 -- Replicate entity or node N by invoking one of the following routines:
23044 -- Copy_Node_With_Replacement
23045 -- Corresponding_Entity
23047 function Copy_Elist_With_Replacement
(List
: Elist_Id
) return Elist_Id
;
23048 -- Replicate the elements of entity list List
23050 function Copy_Field_With_Replacement
23052 Old_Par
: Node_Id
:= Empty
;
23053 New_Par
: Node_Id
:= Empty
;
23054 Semantic
: Boolean := False) return Union_Id
;
23055 -- Replicate field Field by invoking one of the following routines:
23057 -- Copy_Elist_With_Replacement
23058 -- Copy_List_With_Replacement
23059 -- Copy_Node_With_Replacement
23060 -- Corresponding_Entity
23062 -- If the field is not an entity list, entity, itype, syntactic list,
23063 -- or node, then the field is returned unchanged. The routine always
23064 -- replicates entities, itypes, and valid syntactic fields. Old_Par is
23065 -- the expected parent of a syntactic field. New_Par is the new parent
23066 -- associated with a replicated syntactic field. Flag Semantic should
23067 -- be set when the input is a semantic field.
23069 function Copy_List_With_Replacement
(List
: List_Id
) return List_Id
;
23070 -- Replicate the elements of syntactic list List
23072 function Copy_Node_With_Replacement
(N
: Node_Id
) return Node_Id
;
23073 -- Replicate node N
23075 function Corresponding_Entity
(Id
: Entity_Id
) return Entity_Id
;
23076 pragma Inline
(Corresponding_Entity
);
23077 -- Return the corresponding new entity of Id generated during Phase 1.
23078 -- If there is no such entity, return Id.
23080 function In_Entity_Map
23082 Entity_Map
: Elist_Id
) return Boolean;
23083 pragma Inline
(In_Entity_Map
);
23084 -- Determine whether entity Id is one of the old ids specified in entity
23085 -- map Entity_Map. The format of the entity map must be as follows:
23087 -- Old_Id1, New_Id1, Old_Id2, New_Id2, .., Old_IdN, New_IdN
23089 procedure Update_CFS_Sloc
(N
: Node_Or_Entity_Id
);
23090 pragma Inline
(Update_CFS_Sloc
);
23091 -- Update the Comes_From_Source and Sloc attributes of node or entity N
23093 procedure Update_Controlling_Argument
23094 (Old_Call
: Node_Id
;
23095 New_Call
: Node_Id
);
23096 pragma Inline
(Update_Controlling_Argument
);
23097 -- Update Controlling_Argument of New_Call base on Old_Call to make it
23098 -- points to the corresponding newly copied actual parameter.
23100 procedure Update_Named_Associations
23101 (Old_Call
: Node_Id
;
23102 New_Call
: Node_Id
);
23103 pragma Inline
(Update_Named_Associations
);
23104 -- Update semantic chain First/Next_Named_Association of call New_call
23105 -- based on call Old_Call.
23107 procedure Update_New_Entities
(Entity_Map
: Elist_Id
);
23108 pragma Inline
(Update_New_Entities
);
23109 -- Update the semantic attributes of all new entities generated during
23110 -- Phase 1 that do not appear in entity map Entity_Map. The format of
23111 -- the entity map must be as follows:
23113 -- Old_Id1, New_Id1, Old_Id2, New_Id2, .., Old_IdN, New_IdN
23115 procedure Update_Pending_Itypes
23116 (Old_Assoc
: Node_Id
;
23117 New_Assoc
: Node_Id
);
23118 pragma Inline
(Update_Pending_Itypes
);
23119 -- Update semantic attribute Associated_Node_For_Itype to refer to node
23120 -- New_Assoc for all itypes whose associated node is Old_Assoc.
23122 procedure Update_Semantic_Fields
(Id
: Entity_Id
);
23123 pragma Inline
(Update_Semantic_Fields
);
23124 -- Subsidiary to Update_New_Entities. Update semantic fields of entity
23127 procedure Visit_Any_Node
(N
: Node_Or_Entity_Id
);
23128 pragma Inline
(Visit_Any_Node
);
23129 -- Visit entity of node N by invoking one of the following routines:
23135 procedure Visit_Elist
(List
: Elist_Id
);
23136 -- Visit the elements of entity list List
23138 procedure Visit_Entity
(Id
: Entity_Id
);
23139 -- Visit entity Id. This action may create a new entity of Id and save
23140 -- it in table NCT_New_Entities.
23142 procedure Visit_Field
23144 Par_Nod
: Node_Id
:= Empty
;
23145 Semantic
: Boolean := False);
23146 -- Visit field Field by invoking one of the following routines:
23154 -- If the field is not an entity list, entity, itype, syntactic list,
23155 -- or node, then the field is not visited. The routine always visits
23156 -- valid syntactic fields. Par_Nod is the expected parent of the
23157 -- syntactic field. Flag Semantic should be set when the input is a
23160 procedure Visit_Itype
(Itype
: Entity_Id
);
23161 -- Visit itype Itype. This action may create a new entity for Itype and
23162 -- save it in table NCT_New_Entities. In addition, the routine may map
23163 -- the associated node of Itype to the new itype in NCT_Pending_Itypes.
23165 procedure Visit_List
(List
: List_Id
);
23166 -- Visit the elements of syntactic list List
23168 procedure Visit_Node
(N
: Node_Id
);
23171 procedure Visit_Semantic_Fields
(Id
: Entity_Id
);
23172 pragma Inline
(Visit_Semantic_Fields
);
23173 -- Subsidiary to Visit_Entity and Visit_Itype. Visit common semantic
23174 -- fields of entity or itype Id.
23176 --------------------
23177 -- Add_New_Entity --
23178 --------------------
23180 procedure Add_New_Entity
(Old_Id
: Entity_Id
; New_Id
: Entity_Id
) is
23182 pragma Assert
(Present
(Old_Id
));
23183 pragma Assert
(Present
(New_Id
));
23184 pragma Assert
(Nkind
(Old_Id
) in N_Entity
);
23185 pragma Assert
(Nkind
(New_Id
) in N_Entity
);
23187 NCT_Tables_In_Use
:= True;
23189 -- Sanity check the NCT_New_Entities table. No previous mapping with
23190 -- key Old_Id should exist.
23192 pragma Assert
(No
(NCT_New_Entities
.Get
(Old_Id
)));
23194 -- Establish the mapping
23196 -- Old_Id -> New_Id
23198 NCT_New_Entities
.Set
(Old_Id
, New_Id
);
23199 end Add_New_Entity
;
23201 -----------------------
23202 -- Add_Pending_Itype --
23203 -----------------------
23205 procedure Add_Pending_Itype
(Assoc_Nod
: Node_Id
; Itype
: Entity_Id
) is
23209 pragma Assert
(Present
(Assoc_Nod
));
23210 pragma Assert
(Present
(Itype
));
23211 pragma Assert
(Nkind
(Itype
) in N_Entity
);
23212 pragma Assert
(Is_Itype
(Itype
));
23214 NCT_Tables_In_Use
:= True;
23216 -- It is not possible to sanity check the NCT_Pendint_Itypes table
23217 -- directly because a single node may act as the associated node for
23218 -- multiple itypes.
23220 Itypes
:= NCT_Pending_Itypes
.Get
(Assoc_Nod
);
23222 if No
(Itypes
) then
23223 Itypes
:= New_Elmt_List
;
23224 NCT_Pending_Itypes
.Set
(Assoc_Nod
, Itypes
);
23227 -- Establish the mapping
23229 -- Assoc_Nod -> (Itype, ...)
23231 -- Avoid inserting the same itype multiple times. This involves a
23232 -- linear search, however the set of itypes with the same associated
23233 -- node is very small.
23235 Append_Unique_Elmt
(Itype
, Itypes
);
23236 end Add_Pending_Itype
;
23238 ----------------------
23239 -- Build_NCT_Tables --
23240 ----------------------
23242 procedure Build_NCT_Tables
(Entity_Map
: Elist_Id
) is
23244 Old_Id
: Entity_Id
;
23245 New_Id
: Entity_Id
;
23248 -- Nothing to do when there is no entity map
23250 if No
(Entity_Map
) then
23254 Elmt
:= First_Elmt
(Entity_Map
);
23255 while Present
(Elmt
) loop
23257 -- Extract the (Old_Id, New_Id) pair from the entity map
23259 Old_Id
:= Node
(Elmt
);
23262 New_Id
:= Node
(Elmt
);
23265 -- Establish the following mapping within table NCT_New_Entities
23267 -- Old_Id -> New_Id
23269 Add_New_Entity
(Old_Id
, New_Id
);
23271 -- Establish the following mapping within table NCT_Pending_Itypes
23272 -- when the new entity is an itype.
23274 -- Assoc_Nod -> (New_Id, ...)
23276 -- IMPORTANT: the associated node is that of the old itype because
23277 -- the node will be replicated in Phase 2.
23279 if Is_Itype
(Old_Id
) then
23281 (Assoc_Nod
=> Associated_Node_For_Itype
(Old_Id
),
23285 end Build_NCT_Tables
;
23287 ------------------------------------
23288 -- Copy_Any_Node_With_Replacement --
23289 ------------------------------------
23291 function Copy_Any_Node_With_Replacement
23292 (N
: Node_Or_Entity_Id
) return Node_Or_Entity_Id
23295 if Nkind
(N
) in N_Entity
then
23296 return Corresponding_Entity
(N
);
23298 return Copy_Node_With_Replacement
(N
);
23300 end Copy_Any_Node_With_Replacement
;
23302 ---------------------------------
23303 -- Copy_Elist_With_Replacement --
23304 ---------------------------------
23306 function Copy_Elist_With_Replacement
(List
: Elist_Id
) return Elist_Id
is
23311 -- Copy the contents of the old list. Note that the list itself may
23312 -- be empty, in which case the routine returns a new empty list. This
23313 -- avoids sharing lists between subtrees. The element of an entity
23314 -- list could be an entity or a node, hence the invocation of routine
23315 -- Copy_Any_Node_With_Replacement.
23317 if Present
(List
) then
23318 Result
:= New_Elmt_List
;
23320 Elmt
:= First_Elmt
(List
);
23321 while Present
(Elmt
) loop
23323 (Copy_Any_Node_With_Replacement
(Node
(Elmt
)), Result
);
23328 -- Otherwise the list does not exist
23331 Result
:= No_Elist
;
23335 end Copy_Elist_With_Replacement
;
23337 ---------------------------------
23338 -- Copy_Field_With_Replacement --
23339 ---------------------------------
23341 function Copy_Field_With_Replacement
23343 Old_Par
: Node_Id
:= Empty
;
23344 New_Par
: Node_Id
:= Empty
;
23345 Semantic
: Boolean := False) return Union_Id
23348 -- The field is empty
23350 if Field
= Union_Id
(Empty
) then
23353 -- The field is an entity/itype/node
23355 elsif Field
in Node_Range
then
23357 Old_N
: constant Node_Id
:= Node_Id
(Field
);
23358 Syntactic
: constant Boolean :=
23359 Is_Syntactic_Node
(Source
=> Old_Par
, Field
=> Old_N
);
23364 -- The field is an entity/itype
23366 if Nkind
(Old_N
) in N_Entity
then
23368 -- An entity/itype is always replicated
23370 New_N
:= Corresponding_Entity
(Old_N
);
23372 -- Update the parent pointer when the entity is a syntactic
23373 -- field. Note that itypes do not have parent pointers.
23375 if Syntactic
and then New_N
/= Old_N
then
23376 Set_Parent
(New_N
, New_Par
);
23379 -- The field is a node
23382 -- A node is replicated when it is either a syntactic field
23383 -- or when the caller treats it as a semantic attribute.
23385 if Syntactic
or else Semantic
then
23386 New_N
:= Copy_Node_With_Replacement
(Old_N
);
23388 -- Update the parent pointer when the node is a syntactic
23391 if Syntactic
and then New_N
/= Old_N
then
23392 Set_Parent
(New_N
, New_Par
);
23395 -- Otherwise the node is returned unchanged
23402 return Union_Id
(New_N
);
23405 -- The field is an entity list
23407 elsif Field
in Elist_Range
then
23408 return Union_Id
(Copy_Elist_With_Replacement
(Elist_Id
(Field
)));
23410 -- The field is a syntactic list
23412 elsif Field
in List_Range
then
23414 Old_List
: constant List_Id
:= List_Id
(Field
);
23415 Syntactic
: constant Boolean := Parent
(Old_List
) = Old_Par
;
23417 New_List
: List_Id
;
23420 -- A list is replicated when it is either a syntactic field or
23421 -- when the caller treats it as a semantic attribute.
23423 if Syntactic
or else Semantic
then
23424 New_List
:= Copy_List_With_Replacement
(Old_List
);
23426 -- Update the parent pointer when the list is a syntactic
23429 if Syntactic
and then New_List
/= Old_List
then
23430 Set_Parent
(New_List
, New_Par
);
23433 -- Otherwise the list is returned unchanged
23436 New_List
:= Old_List
;
23439 return Union_Id
(New_List
);
23442 -- Otherwise the field denotes an attribute that does not need to be
23443 -- replicated (Chars, literals, etc).
23448 end Copy_Field_With_Replacement
;
23450 --------------------------------
23451 -- Copy_List_With_Replacement --
23452 --------------------------------
23454 function Copy_List_With_Replacement
(List
: List_Id
) return List_Id
is
23459 -- Copy the contents of the old list. Note that the list itself may
23460 -- be empty, in which case the routine returns a new empty list. This
23461 -- avoids sharing lists between subtrees. The element of a syntactic
23462 -- list is always a node, never an entity or itype, hence the call to
23463 -- routine Copy_Node_With_Replacement.
23465 if Present
(List
) then
23466 Result
:= New_List
;
23468 Elmt
:= First
(List
);
23469 while Present
(Elmt
) loop
23470 Append
(Copy_Node_With_Replacement
(Elmt
), Result
);
23475 -- Otherwise the list does not exist
23482 end Copy_List_With_Replacement
;
23484 --------------------------------
23485 -- Copy_Node_With_Replacement --
23486 --------------------------------
23488 function Copy_Node_With_Replacement
(N
: Node_Id
) return Node_Id
is
23491 function Transform
(U
: Union_Id
) return Union_Id
;
23492 -- Copies one field, replacing N with Result
23498 function Transform
(U
: Union_Id
) return Union_Id
is
23500 return Copy_Field_With_Replacement
23503 New_Par
=> Result
);
23506 procedure Walk
is new Walk_Sinfo_Fields_Pairwise
(Transform
);
23508 -- Start of processing for Copy_Node_With_Replacement
23511 -- Assume that the node must be returned unchanged
23515 if N
> Empty_Or_Error
then
23516 pragma Assert
(Nkind
(N
) not in N_Entity
);
23518 Result
:= New_Copy
(N
);
23520 Walk
(Result
, Result
);
23522 -- Update the Comes_From_Source and Sloc attributes of the node
23523 -- in case the caller has supplied new values.
23525 Update_CFS_Sloc
(Result
);
23527 -- Update the Associated_Node_For_Itype attribute of all itypes
23528 -- created during Phase 1 whose associated node is N. As a result
23529 -- the Associated_Node_For_Itype refers to the replicated node.
23530 -- No action needs to be taken when the Associated_Node_For_Itype
23531 -- refers to an entity because this was already handled during
23532 -- Phase 1, in Visit_Itype.
23534 Update_Pending_Itypes
23536 New_Assoc
=> Result
);
23538 -- Update the First/Next_Named_Association chain and the
23539 -- Controlling_Argument for a replicated call.
23541 if Nkind
(N
) in N_Entry_Call_Statement
23542 | N_Subprogram_Call
23544 Update_Named_Associations
23546 New_Call
=> Result
);
23548 if Nkind
(N
) in N_Subprogram_Call
then
23549 Update_Controlling_Argument
23551 New_Call
=> Result
);
23554 -- Update the Renamed_Object attribute of a replicated object
23557 elsif Nkind
(N
) = N_Object_Renaming_Declaration
then
23558 Set_Renamed_Object_Of_Possibly_Void
23559 (Defining_Entity
(Result
), Name
(Result
));
23561 -- Update the Chars attribute of identifiers
23563 elsif Nkind
(N
) = N_Identifier
then
23565 -- The Entity field of identifiers that denote aspects is used
23566 -- to store arbitrary expressions (and hence we must check that
23567 -- they reference an actual entity before copying their Chars
23570 if Present
(Entity
(Result
))
23571 and then Nkind
(Entity
(Result
)) in N_Entity
23573 Set_Chars
(Result
, Chars
(Entity
(Result
)));
23577 if Has_Aspects
(N
) then
23578 Set_Aspect_Specifications
(Result
,
23579 Copy_List_With_Replacement
(Aspect_Specifications
(N
)));
23584 end Copy_Node_With_Replacement
;
23586 --------------------------
23587 -- Corresponding_Entity --
23588 --------------------------
23590 function Corresponding_Entity
(Id
: Entity_Id
) return Entity_Id
is
23591 New_Id
: Entity_Id
;
23592 Result
: Entity_Id
;
23595 -- Assume that the entity must be returned unchanged
23599 if Id
> Empty_Or_Error
then
23600 pragma Assert
(Nkind
(Id
) in N_Entity
);
23602 -- Determine whether the entity has a corresponding new entity
23603 -- generated during Phase 1 and if it does, use it.
23605 if NCT_Tables_In_Use
then
23606 New_Id
:= NCT_New_Entities
.Get
(Id
);
23608 if Present
(New_Id
) then
23615 end Corresponding_Entity
;
23617 -------------------
23618 -- In_Entity_Map --
23619 -------------------
23621 function In_Entity_Map
23623 Entity_Map
: Elist_Id
) return Boolean
23626 Old_Id
: Entity_Id
;
23629 -- The entity map contains pairs (Old_Id, New_Id). The advancement
23630 -- step always skips the New_Id portion of the pair.
23632 if Present
(Entity_Map
) then
23633 Elmt
:= First_Elmt
(Entity_Map
);
23634 while Present
(Elmt
) loop
23635 Old_Id
:= Node
(Elmt
);
23637 if Old_Id
= Id
then
23649 ---------------------
23650 -- Update_CFS_Sloc --
23651 ---------------------
23653 procedure Update_CFS_Sloc
(N
: Node_Or_Entity_Id
) is
23655 -- A new source location defaults the Comes_From_Source attribute
23657 if New_Sloc
/= No_Location
then
23658 Set_Comes_From_Source
(N
, Get_Comes_From_Source_Default
);
23659 Set_Sloc
(N
, New_Sloc
);
23661 end Update_CFS_Sloc
;
23663 ---------------------------------
23664 -- Update_Controlling_Argument --
23665 ---------------------------------
23667 procedure Update_Controlling_Argument
23668 (Old_Call
: Node_Id
;
23669 New_Call
: Node_Id
)
23674 Old_Ctrl_Arg
: constant Node_Id
:= Controlling_Argument
(Old_Call
);
23675 -- Controlling argument of the old call node
23677 Replaced
: Boolean := False;
23678 -- Flag to make sure that replacement works as expected
23681 if No
(Old_Ctrl_Arg
) then
23685 -- Recreate the Controlling_Argument of a call by traversing both the
23686 -- old and new actual parameters in parallel.
23688 New_Act
:= First
(Parameter_Associations
(New_Call
));
23689 Old_Act
:= First
(Parameter_Associations
(Old_Call
));
23690 while Present
(Old_Act
) loop
23692 -- Actual parameter appears either in a named parameter
23693 -- association or directly.
23695 if Nkind
(Old_Act
) = N_Parameter_Association
then
23696 if Explicit_Actual_Parameter
(Old_Act
) = Old_Ctrl_Arg
then
23697 Set_Controlling_Argument
23698 (New_Call
, Explicit_Actual_Parameter
(New_Act
));
23703 elsif Old_Act
= Old_Ctrl_Arg
then
23704 Set_Controlling_Argument
(New_Call
, New_Act
);
23713 pragma Assert
(Replaced
);
23714 end Update_Controlling_Argument
;
23716 -------------------------------
23717 -- Update_Named_Associations --
23718 -------------------------------
23720 procedure Update_Named_Associations
23721 (Old_Call
: Node_Id
;
23722 New_Call
: Node_Id
)
23725 New_Next
: Node_Id
;
23727 Old_Next
: Node_Id
;
23730 if No
(First_Named_Actual
(Old_Call
)) then
23734 -- Recreate the First/Next_Named_Actual chain of a call by traversing
23735 -- the chains of both the old and new calls in parallel.
23737 New_Act
:= First
(Parameter_Associations
(New_Call
));
23738 Old_Act
:= First
(Parameter_Associations
(Old_Call
));
23739 while Present
(Old_Act
) loop
23740 if Nkind
(Old_Act
) = N_Parameter_Association
23741 and then Explicit_Actual_Parameter
(Old_Act
)
23742 = First_Named_Actual
(Old_Call
)
23744 Set_First_Named_Actual
(New_Call
,
23745 Explicit_Actual_Parameter
(New_Act
));
23748 if Nkind
(Old_Act
) = N_Parameter_Association
23749 and then Present
(Next_Named_Actual
(Old_Act
))
23751 -- Scan the actual parameter list to find the next suitable
23752 -- named actual. Note that the list may be out of order.
23754 New_Next
:= First
(Parameter_Associations
(New_Call
));
23755 Old_Next
:= First
(Parameter_Associations
(Old_Call
));
23756 while Nkind
(Old_Next
) /= N_Parameter_Association
23757 or else Explicit_Actual_Parameter
(Old_Next
) /=
23758 Next_Named_Actual
(Old_Act
)
23764 Set_Next_Named_Actual
(New_Act
,
23765 Explicit_Actual_Parameter
(New_Next
));
23771 end Update_Named_Associations
;
23773 -------------------------
23774 -- Update_New_Entities --
23775 -------------------------
23777 procedure Update_New_Entities
(Entity_Map
: Elist_Id
) is
23778 New_Id
: Entity_Id
:= Empty
;
23779 Old_Id
: Entity_Id
:= Empty
;
23782 if NCT_Tables_In_Use
then
23783 NCT_New_Entities
.Get_First
(Old_Id
, New_Id
);
23785 -- Update the semantic fields of all new entities created during
23786 -- Phase 1 which were not supplied via an entity map.
23787 -- ??? Is there a better way of distinguishing those?
23789 while Present
(Old_Id
) and then Present
(New_Id
) loop
23790 if not In_Entity_Map
(Old_Id
, Entity_Map
) then
23791 Update_Semantic_Fields
(New_Id
);
23794 NCT_New_Entities
.Get_Next
(Old_Id
, New_Id
);
23797 end Update_New_Entities
;
23799 ---------------------------
23800 -- Update_Pending_Itypes --
23801 ---------------------------
23803 procedure Update_Pending_Itypes
23804 (Old_Assoc
: Node_Id
;
23805 New_Assoc
: Node_Id
)
23811 if NCT_Tables_In_Use
then
23812 Itypes
:= NCT_Pending_Itypes
.Get
(Old_Assoc
);
23814 -- Update the Associated_Node_For_Itype attribute for all itypes
23815 -- which originally refer to Old_Assoc to designate New_Assoc.
23817 if Present
(Itypes
) then
23818 Item
:= First_Elmt
(Itypes
);
23819 while Present
(Item
) loop
23820 Set_Associated_Node_For_Itype
(Node
(Item
), New_Assoc
);
23826 end Update_Pending_Itypes
;
23828 ----------------------------
23829 -- Update_Semantic_Fields --
23830 ----------------------------
23832 procedure Update_Semantic_Fields
(Id
: Entity_Id
) is
23834 -- Discriminant_Constraint
23836 if Is_Type
(Id
) and then Has_Discriminants
(Base_Type
(Id
)) then
23837 Set_Discriminant_Constraint
(Id
, Elist_Id
(
23838 Copy_Field_With_Replacement
23839 (Field
=> Union_Id
(Discriminant_Constraint
(Id
)),
23840 Semantic
=> True)));
23845 Set_Etype
(Id
, Node_Id
(
23846 Copy_Field_With_Replacement
23847 (Field
=> Union_Id
(Etype
(Id
)),
23848 Semantic
=> True)));
23851 -- Packed_Array_Impl_Type
23853 if Is_Array_Type
(Id
) then
23854 if Present
(First_Index
(Id
)) then
23855 Set_First_Index
(Id
, First
(List_Id
(
23856 Copy_Field_With_Replacement
23857 (Field
=> Union_Id
(List_Containing
(First_Index
(Id
))),
23858 Semantic
=> True))));
23861 if Is_Packed
(Id
) then
23862 Set_Packed_Array_Impl_Type
(Id
, Node_Id
(
23863 Copy_Field_With_Replacement
23864 (Field
=> Union_Id
(Packed_Array_Impl_Type
(Id
)),
23865 Semantic
=> True)));
23871 Set_Prev_Entity
(Id
, Node_Id
(
23872 Copy_Field_With_Replacement
23873 (Field
=> Union_Id
(Prev_Entity
(Id
)),
23874 Semantic
=> True)));
23878 Set_Next_Entity
(Id
, Node_Id
(
23879 Copy_Field_With_Replacement
23880 (Field
=> Union_Id
(Next_Entity
(Id
)),
23881 Semantic
=> True)));
23885 if Is_Discrete_Type
(Id
) then
23886 Set_Scalar_Range
(Id
, Node_Id
(
23887 Copy_Field_With_Replacement
23888 (Field
=> Union_Id
(Scalar_Range
(Id
)),
23889 Semantic
=> True)));
23894 -- Update the scope when the caller specified an explicit one
23896 if Present
(New_Scope
) then
23897 Set_Scope
(Id
, New_Scope
);
23899 Set_Scope
(Id
, Node_Id
(
23900 Copy_Field_With_Replacement
23901 (Field
=> Union_Id
(Scope
(Id
)),
23902 Semantic
=> True)));
23904 end Update_Semantic_Fields
;
23906 --------------------
23907 -- Visit_Any_Node --
23908 --------------------
23910 procedure Visit_Any_Node
(N
: Node_Or_Entity_Id
) is
23912 if Nkind
(N
) in N_Entity
then
23913 if Is_Itype
(N
) then
23921 end Visit_Any_Node
;
23927 procedure Visit_Elist
(List
: Elist_Id
) is
23931 -- The element of an entity list could be an entity, itype, or a
23932 -- node, hence the call to Visit_Any_Node.
23934 if Present
(List
) then
23935 Elmt
:= First_Elmt
(List
);
23936 while Present
(Elmt
) loop
23937 Visit_Any_Node
(Node
(Elmt
));
23948 procedure Visit_Entity
(Id
: Entity_Id
) is
23949 New_Id
: Entity_Id
;
23952 pragma Assert
(Nkind
(Id
) in N_Entity
);
23953 pragma Assert
(not Is_Itype
(Id
));
23955 -- Nothing to do when the entity is not defined in the Actions list
23956 -- of an N_Expression_With_Actions node.
23958 if EWA_Level
= 0 then
23961 -- Nothing to do when the entity is defined in a scoping construct
23962 -- within an N_Expression_With_Actions node.
23964 elsif EWA_Inner_Scope_Level
> 0 then
23967 -- Nothing to do when the entity does not denote a construct that
23968 -- may appear within an N_Expression_With_Actions node. Relaxing
23969 -- this restriction leads to a performance penalty.
23971 -- ??? this list is flaky, and may hide dormant bugs
23972 -- Should functions be included???
23974 -- Quantified expressions contain an entity declaration that must
23975 -- always be replaced when the expander is active, even if it has
23976 -- not been analyzed yet like e.g. in predicates.
23978 elsif Ekind
(Id
) not in E_Block
23983 and then not Is_Entity_Of_Quantified_Expression
(Id
)
23984 and then not Is_Type
(Id
)
23988 -- Nothing to do when the entity was already visited
23990 elsif NCT_Tables_In_Use
23991 and then Present
(NCT_New_Entities
.Get
(Id
))
23995 -- Nothing to do when the declaration node of the entity is not in
23996 -- the subtree being replicated.
23998 elsif not In_Subtree
23999 (N
=> Declaration_Node
(Id
),
24005 -- Create a new entity by directly copying the old entity. This
24006 -- action causes all attributes of the old entity to be inherited.
24008 New_Id
:= New_Copy
(Id
);
24010 -- Create a new name for the new entity because the back end needs
24011 -- distinct names for debugging purposes, provided that the entity
24012 -- has already been analyzed.
24014 if Ekind
(Id
) /= E_Void
then
24015 Set_Chars
(New_Id
, New_Internal_Name
('T'));
24018 -- Update the Comes_From_Source and Sloc attributes of the entity in
24019 -- case the caller has supplied new values.
24021 Update_CFS_Sloc
(New_Id
);
24023 -- Establish the following mapping within table NCT_New_Entities:
24027 Add_New_Entity
(Id
, New_Id
);
24029 -- Deal with the semantic fields of entities. The fields are visited
24030 -- because they may mention entities which reside within the subtree
24033 Visit_Semantic_Fields
(Id
);
24040 procedure Visit_Field
24042 Par_Nod
: Node_Id
:= Empty
;
24043 Semantic
: Boolean := False)
24046 -- The field is empty
24048 if Field
= Union_Id
(Empty
) then
24051 -- The field is an entity/itype/node
24053 elsif Field
in Node_Range
then
24055 N
: constant Node_Id
:= Node_Id
(Field
);
24058 -- The field is an entity/itype
24060 if Nkind
(N
) in N_Entity
then
24062 -- Itypes are always visited
24064 if Is_Itype
(N
) then
24067 -- An entity is visited when it is either a syntactic field
24068 -- or when the caller treats it as a semantic attribute.
24070 elsif Parent
(N
) = Par_Nod
or else Semantic
then
24074 -- The field is a node
24077 -- A node is visited when it is either a syntactic field or
24078 -- when the caller treats it as a semantic attribute.
24080 if Parent
(N
) = Par_Nod
or else Semantic
then
24086 -- The field is an entity list
24088 elsif Field
in Elist_Range
then
24089 Visit_Elist
(Elist_Id
(Field
));
24091 -- The field is a syntax list
24093 elsif Field
in List_Range
then
24095 List
: constant List_Id
:= List_Id
(Field
);
24098 -- A syntax list is visited when it is either a syntactic field
24099 -- or when the caller treats it as a semantic attribute.
24101 if Parent
(List
) = Par_Nod
or else Semantic
then
24106 -- Otherwise the field denotes information which does not need to be
24107 -- visited (chars, literals, etc.).
24118 procedure Visit_Itype
(Itype
: Entity_Id
) is
24119 New_Assoc
: Node_Id
;
24120 New_Itype
: Entity_Id
;
24121 Old_Assoc
: Node_Id
;
24124 pragma Assert
(Nkind
(Itype
) in N_Entity
);
24125 pragma Assert
(Is_Itype
(Itype
));
24127 -- Itypes that describe the designated type of access to subprograms
24128 -- have the structure of subprogram declarations, with signatures,
24129 -- etc. Either we duplicate the signatures completely, or choose to
24130 -- share such itypes, which is fine because their elaboration will
24131 -- have no side effects.
24133 if Ekind
(Itype
) = E_Subprogram_Type
then
24136 -- Nothing to do if the itype was already visited
24138 elsif NCT_Tables_In_Use
24139 and then Present
(NCT_New_Entities
.Get
(Itype
))
24143 -- Nothing to do if the associated node of the itype is not within
24144 -- the subtree being replicated.
24146 elsif not In_Subtree
24147 (N
=> Associated_Node_For_Itype
(Itype
),
24153 -- Create a new itype by directly copying the old itype. This action
24154 -- causes all attributes of the old itype to be inherited.
24156 New_Itype
:= New_Copy
(Itype
);
24158 -- Create a new name for the new itype because the back end requires
24159 -- distinct names for debugging purposes.
24161 Set_Chars
(New_Itype
, New_Internal_Name
('T'));
24163 -- Update the Comes_From_Source and Sloc attributes of the itype in
24164 -- case the caller has supplied new values.
24166 Update_CFS_Sloc
(New_Itype
);
24168 -- Establish the following mapping within table NCT_New_Entities:
24170 -- Itype -> New_Itype
24172 Add_New_Entity
(Itype
, New_Itype
);
24174 -- The new itype must be unfrozen because the resulting subtree may
24175 -- be inserted anywhere and cause an earlier or later freezing.
24177 if Present
(Freeze_Node
(New_Itype
)) then
24178 Set_Freeze_Node
(New_Itype
, Empty
);
24179 Set_Is_Frozen
(New_Itype
, False);
24182 -- If a record subtype is simply copied, the entity list will be
24183 -- shared, so Cloned_Subtype must be set to indicate this.
24185 if Ekind
(Itype
) in E_Class_Wide_Subtype | E_Record_Subtype
then
24186 Set_Cloned_Subtype
(New_Itype
, Itype
);
24189 -- The associated node may denote an entity, in which case it may
24190 -- already have a new corresponding entity created during a prior
24191 -- call to Visit_Entity or Visit_Itype for the same subtree.
24194 -- Old_Assoc ---------> New_Assoc
24196 -- Created by Visit_Itype
24197 -- Itype -------------> New_Itype
24198 -- ANFI = Old_Assoc ANFI = Old_Assoc < must be updated
24200 -- In the example above, Old_Assoc is an arbitrary entity that was
24201 -- already visited for the same subtree and has a corresponding new
24202 -- entity New_Assoc. Old_Assoc was inherited by New_Itype by virtue
24203 -- of copying entities, however it must be updated to New_Assoc.
24205 Old_Assoc
:= Associated_Node_For_Itype
(Itype
);
24207 if Nkind
(Old_Assoc
) in N_Entity
then
24208 if NCT_Tables_In_Use
then
24209 New_Assoc
:= NCT_New_Entities
.Get
(Old_Assoc
);
24211 if Present
(New_Assoc
) then
24212 Set_Associated_Node_For_Itype
(New_Itype
, New_Assoc
);
24216 -- Otherwise the associated node denotes a node. Postpone the update
24217 -- until Phase 2 when the node is replicated. Establish the following
24218 -- mapping within table NCT_Pending_Itypes:
24220 -- Old_Assoc -> (New_Type, ...)
24223 Add_Pending_Itype
(Old_Assoc
, New_Itype
);
24226 -- Deal with the semantic fields of itypes. The fields are visited
24227 -- because they may mention entities that reside within the subtree
24230 Visit_Semantic_Fields
(Itype
);
24237 procedure Visit_List
(List
: List_Id
) is
24241 -- Note that the element of a syntactic list is always a node, never
24242 -- an entity or itype, hence the call to Visit_Node.
24244 Elmt
:= First
(List
);
24245 while Present
(Elmt
) loop
24256 procedure Visit_Node
(N
: Node_Id
) is
24258 pragma Assert
(Nkind
(N
) not in N_Entity
);
24260 -- If the node is a quantified expression and expander is active,
24261 -- it contains an implicit declaration that may require a new entity
24262 -- when the condition has already been (pre)analyzed.
24264 if Nkind
(N
) = N_Expression_With_Actions
24266 (Nkind
(N
) = N_Quantified_Expression
and then Expander_Active
)
24268 EWA_Level
:= EWA_Level
+ 1;
24270 elsif EWA_Level
> 0
24271 and then Nkind
(N
) in N_Block_Statement
24272 | N_Subprogram_Body
24273 | N_Subprogram_Declaration
24275 EWA_Inner_Scope_Level
:= EWA_Inner_Scope_Level
+ 1;
24278 -- If the node is a block, we need to process all declarations
24279 -- in the block and make new entities for each.
24281 if Nkind
(N
) = N_Block_Statement
then
24283 Decl
: Node_Id
:= First
(Declarations
(N
));
24286 while Present
(Decl
) loop
24287 if Nkind
(Decl
) = N_Object_Declaration
then
24288 Add_New_Entity
(Defining_Identifier
(Decl
),
24289 New_Copy
(Defining_Identifier
(Decl
)));
24298 procedure Action
(U
: Union_Id
);
24299 procedure Action
(U
: Union_Id
) is
24301 Visit_Field
(Field
=> U
, Par_Nod
=> N
);
24304 procedure Walk
is new Walk_Sinfo_Fields
(Action
);
24310 and then Nkind
(N
) in N_Block_Statement
24311 | N_Subprogram_Body
24312 | N_Subprogram_Declaration
24314 EWA_Inner_Scope_Level
:= EWA_Inner_Scope_Level
- 1;
24316 elsif Nkind
(N
) = N_Expression_With_Actions
24318 (Nkind
(N
) = N_Quantified_Expression
and then Expander_Active
)
24320 EWA_Level
:= EWA_Level
- 1;
24324 ---------------------------
24325 -- Visit_Semantic_Fields --
24326 ---------------------------
24328 procedure Visit_Semantic_Fields
(Id
: Entity_Id
) is
24330 pragma Assert
(Nkind
(Id
) in N_Entity
);
24332 -- Discriminant_Constraint
24334 if Is_Type
(Id
) and then Has_Discriminants
(Base_Type
(Id
)) then
24336 (Field
=> Union_Id
(Discriminant_Constraint
(Id
)),
24343 (Field
=> Union_Id
(Etype
(Id
)),
24347 -- Packed_Array_Impl_Type
24349 if Is_Array_Type
(Id
) then
24350 if Present
(First_Index
(Id
)) then
24352 (Field
=> Union_Id
(List_Containing
(First_Index
(Id
))),
24356 if Is_Packed
(Id
) then
24358 (Field
=> Union_Id
(Packed_Array_Impl_Type
(Id
)),
24365 if Is_Discrete_Type
(Id
) then
24367 (Field
=> Union_Id
(Scalar_Range
(Id
)),
24370 end Visit_Semantic_Fields
;
24372 -- Start of processing for New_Copy_Tree
24375 -- Routine New_Copy_Tree performs a deep copy of a subtree by creating
24376 -- shallow copies for each node within, and then updating the child and
24377 -- parent pointers accordingly. This process is straightforward, however
24378 -- the routine must deal with the following complications:
24380 -- * Entities defined within N_Expression_With_Actions nodes must be
24381 -- replicated rather than shared to avoid introducing two identical
24382 -- symbols within the same scope. Note that no other expression can
24383 -- currently define entities.
24386 -- Source_Low : ...;
24387 -- Source_High : ...;
24389 -- <reference to Source_Low>
24390 -- <reference to Source_High>
24393 -- New_Copy_Tree handles this case by first creating new entities
24394 -- and then updating all existing references to point to these new
24401 -- <reference to New_Low>
24402 -- <reference to New_High>
24405 -- * Itypes defined within the subtree must be replicated to avoid any
24406 -- dependencies on invalid or inaccessible data.
24408 -- subtype Source_Itype is ... range Source_Low .. Source_High;
24410 -- New_Copy_Tree handles this case by first creating a new itype in
24411 -- the same fashion as entities, and then updating various relevant
24414 -- subtype New_Itype is ... range New_Low .. New_High;
24416 -- * The Associated_Node_For_Itype field of itypes must be updated to
24417 -- reference the proper replicated entity or node.
24419 -- * Semantic fields of entities such as Etype and Scope must be
24420 -- updated to reference the proper replicated entities.
24422 -- * Some semantic fields of nodes must be updated to reference
24423 -- the proper replicated nodes.
24425 -- Finally, quantified expressions contain an implicit declaration for
24426 -- the bound variable. Given that quantified expressions appearing
24427 -- in contracts are copied to create pragmas and eventually checking
24428 -- procedures, a new bound variable must be created for each copy, to
24429 -- prevent multiple declarations of the same symbol.
24431 -- To meet all these demands, routine New_Copy_Tree is split into two
24434 -- Phase 1 traverses the tree in order to locate entities and itypes
24435 -- defined within the subtree. New entities are generated and saved in
24436 -- table NCT_New_Entities. The semantic fields of all new entities and
24437 -- itypes are then updated accordingly.
24439 -- Phase 2 traverses the tree in order to replicate each node. Various
24440 -- semantic fields of nodes and entities are updated accordingly.
24442 -- Preparatory phase. Clear the contents of tables NCT_New_Entities and
24443 -- NCT_Pending_Itypes in case a previous call to New_Copy_Tree left some
24446 if NCT_Tables_In_Use
then
24447 NCT_Tables_In_Use
:= False;
24449 NCT_New_Entities
.Reset
;
24450 NCT_Pending_Itypes
.Reset
;
24453 -- Populate tables NCT_New_Entities and NCT_Pending_Itypes with data
24454 -- supplied by a linear entity map. The tables offer faster access to
24457 Build_NCT_Tables
(Map
);
24459 -- Execute Phase 1. Traverse the subtree and generate new entities for
24460 -- the following cases:
24462 -- * An entity defined within an N_Expression_With_Actions node
24464 -- * An itype referenced within the subtree where the associated node
24465 -- is also in the subtree.
24467 -- All new entities are accessible via table NCT_New_Entities, which
24468 -- contains mappings of the form:
24470 -- Old_Entity -> New_Entity
24471 -- Old_Itype -> New_Itype
24473 -- In addition, the associated nodes of all new itypes are mapped in
24474 -- table NCT_Pending_Itypes:
24476 -- Assoc_Nod -> (New_Itype1, New_Itype2, .., New_ItypeN)
24478 Visit_Any_Node
(Source
);
24480 -- Update the semantic attributes of all new entities generated during
24481 -- Phase 1 before starting Phase 2. The updates could be performed in
24482 -- routine Corresponding_Entity, however this may cause the same entity
24483 -- to be updated multiple times, effectively generating useless nodes.
24484 -- Keeping the updates separates from Phase 2 ensures that only one set
24485 -- of attributes is generated for an entity at any one time.
24487 Update_New_Entities
(Map
);
24489 -- Execute Phase 2. Replicate the source subtree one node at a time.
24490 -- The following transformations take place:
24492 -- * References to entities and itypes are updated to refer to the
24493 -- new entities and itypes generated during Phase 1.
24495 -- * All Associated_Node_For_Itype attributes of itypes are updated
24496 -- to refer to the new replicated Associated_Node_For_Itype.
24498 return Copy_Node_With_Replacement
(Source
);
24501 -------------------------
24502 -- New_External_Entity --
24503 -------------------------
24505 function New_External_Entity
24506 (Kind
: Entity_Kind
;
24507 Scope_Id
: Entity_Id
;
24508 Sloc_Value
: Source_Ptr
;
24509 Related_Id
: Entity_Id
;
24510 Suffix
: Character;
24511 Suffix_Index
: Int
:= 0;
24512 Prefix
: Character := ' ') return Entity_Id
24514 N
: constant Entity_Id
:=
24515 Make_Defining_Identifier
(Sloc_Value
,
24517 (Chars
(Related_Id
), Suffix
, Suffix_Index
, Prefix
));
24520 Mutate_Ekind
(N
, Kind
);
24521 Set_Is_Internal
(N
, True);
24522 Append_Entity
(N
, Scope_Id
);
24523 Set_Public_Status
(N
);
24525 if Kind
in Type_Kind
then
24526 Reinit_Size_Align
(N
);
24530 end New_External_Entity
;
24532 -------------------------
24533 -- New_Internal_Entity --
24534 -------------------------
24536 function New_Internal_Entity
24537 (Kind
: Entity_Kind
;
24538 Scope_Id
: Entity_Id
;
24539 Sloc_Value
: Source_Ptr
;
24540 Id_Char
: Character) return Entity_Id
24542 N
: constant Entity_Id
:= Make_Temporary
(Sloc_Value
, Id_Char
);
24545 Mutate_Ekind
(N
, Kind
);
24546 Set_Is_Internal
(N
, True);
24547 Append_Entity
(N
, Scope_Id
);
24549 if Kind
in Type_Kind
then
24550 Reinit_Size_Align
(N
);
24554 end New_Internal_Entity
;
24560 function Next_Actual
(Actual_Id
: Node_Id
) return Node_Id
is
24561 Par
: constant Node_Id
:= Parent
(Actual_Id
);
24565 -- If we are pointing at a positional parameter, it is a member of a
24566 -- node list (the list of parameters), and the next parameter is the
24567 -- next node on the list, unless we hit a parameter association, then
24568 -- we shift to using the chain whose head is the First_Named_Actual in
24569 -- the parent, and then is threaded using the Next_Named_Actual of the
24570 -- Parameter_Association. All this fiddling is because the original node
24571 -- list is in the textual call order, and what we need is the
24572 -- declaration order.
24574 if Is_List_Member
(Actual_Id
) then
24575 N
:= Next
(Actual_Id
);
24577 if Nkind
(N
) = N_Parameter_Association
then
24579 -- In case of a build-in-place call, the call will no longer be a
24580 -- call; it will have been rewritten.
24582 if Nkind
(Par
) in N_Entry_Call_Statement
24584 | N_Procedure_Call_Statement
24586 return First_Named_Actual
(Par
);
24588 -- In case of a call rewritten in GNATprove mode while "inlining
24589 -- for proof" go to the original call.
24591 elsif Nkind
(Par
) = N_Null_Statement
then
24595 Nkind
(Original_Node
(Par
)) in N_Subprogram_Call
);
24597 return First_Named_Actual
(Original_Node
(Par
));
24606 return Next_Named_Actual
(Parent
(Actual_Id
));
24610 procedure Next_Actual
(Actual_Id
: in out Node_Id
) is
24612 Actual_Id
:= Next_Actual
(Actual_Id
);
24619 function Next_Global
(Node
: Node_Id
) return Node_Id
is
24621 -- The global item may either be in a list, or by itself, in which case
24622 -- there is no next global item with the same mode.
24624 if Is_List_Member
(Node
) then
24625 return Next
(Node
);
24631 procedure Next_Global
(Node
: in out Node_Id
) is
24633 Node
:= Next_Global
(Node
);
24636 ------------------------
24637 -- No_Caching_Enabled --
24638 ------------------------
24640 function No_Caching_Enabled
(Id
: Entity_Id
) return Boolean is
24641 Prag
: constant Node_Id
:= Get_Pragma
(Id
, Pragma_No_Caching
);
24645 if Present
(Prag
) then
24646 Arg1
:= First
(Pragma_Argument_Associations
(Prag
));
24648 -- The pragma has an optional Boolean expression, the related
24649 -- property is enabled only when the expression evaluates to True.
24651 if Present
(Arg1
) then
24652 return Is_True
(Expr_Value
(Get_Pragma_Arg
(Arg1
)));
24654 -- Otherwise the lack of expression enables the property by
24661 -- The property was never set in the first place
24666 end No_Caching_Enabled
;
24668 --------------------------
24669 -- No_Heap_Finalization --
24670 --------------------------
24672 function No_Heap_Finalization
(Typ
: Entity_Id
) return Boolean is
24674 if Ekind
(Typ
) in E_Access_Type | E_General_Access_Type
24675 and then Is_Library_Level_Entity
(Typ
)
24677 -- A global No_Heap_Finalization pragma applies to all library-level
24678 -- named access-to-object types.
24680 if Present
(No_Heap_Finalization_Pragma
) then
24683 -- The library-level named access-to-object type itself is subject to
24684 -- pragma No_Heap_Finalization.
24686 elsif Present
(Get_Pragma
(Typ
, Pragma_No_Heap_Finalization
)) then
24692 end No_Heap_Finalization
;
24694 -----------------------
24695 -- Normalize_Actuals --
24696 -----------------------
24698 -- Chain actuals according to formals of subprogram. If there are no named
24699 -- associations, the chain is simply the list of Parameter Associations,
24700 -- since the order is the same as the declaration order. If there are named
24701 -- associations, then the First_Named_Actual field in the N_Function_Call
24702 -- or N_Procedure_Call_Statement node points to the Parameter_Association
24703 -- node for the parameter that comes first in declaration order. The
24704 -- remaining named parameters are then chained in declaration order using
24705 -- Next_Named_Actual.
24707 -- This routine also verifies that the number of actuals is compatible with
24708 -- the number and default values of formals, but performs no type checking
24709 -- (type checking is done by the caller).
24711 -- If the matching succeeds, Success is set to True and the caller proceeds
24712 -- with type-checking. If the match is unsuccessful, then Success is set to
24713 -- False, and the caller attempts a different interpretation, if there is
24716 -- If the flag Report is on, the call is not overloaded, and a failure to
24717 -- match can be reported here, rather than in the caller.
24719 procedure Normalize_Actuals
24723 Success
: out Boolean)
24725 Actuals
: constant List_Id
:= Parameter_Associations
(N
);
24726 Actual
: Node_Id
:= Empty
;
24727 Formal
: Entity_Id
;
24728 Last
: Node_Id
:= Empty
;
24729 First_Named
: Node_Id
:= Empty
;
24732 Formals_To_Match
: Integer := 0;
24733 Actuals_To_Match
: Integer := 0;
24735 procedure Chain
(A
: Node_Id
);
24736 -- Add named actual at the proper place in the list, using the
24737 -- Next_Named_Actual link.
24739 function Reporting
return Boolean;
24740 -- Determines if an error is to be reported. To report an error, we
24741 -- need Report to be True, and also we do not report errors caused
24742 -- by calls to init procs that occur within other init procs. Such
24743 -- errors must always be cascaded errors, since if all the types are
24744 -- declared correctly, the compiler will certainly build decent calls.
24750 procedure Chain
(A
: Node_Id
) is
24754 -- Call node points to first actual in list
24756 Set_First_Named_Actual
(N
, Explicit_Actual_Parameter
(A
));
24759 Set_Next_Named_Actual
(Last
, Explicit_Actual_Parameter
(A
));
24763 Set_Next_Named_Actual
(Last
, Empty
);
24770 function Reporting
return Boolean is
24775 elsif not Within_Init_Proc
then
24778 elsif Is_Init_Proc
(Entity
(Name
(N
))) then
24786 -- Start of processing for Normalize_Actuals
24789 if Is_Access_Type
(S
) then
24791 -- The name in the call is a function call that returns an access
24792 -- to subprogram. The designated type has the list of formals.
24794 Formal
:= First_Formal
(Designated_Type
(S
));
24796 Formal
:= First_Formal
(S
);
24799 while Present
(Formal
) loop
24800 Formals_To_Match
:= Formals_To_Match
+ 1;
24801 Next_Formal
(Formal
);
24804 -- Find if there is a named association, and verify that no positional
24805 -- associations appear after named ones.
24807 if Present
(Actuals
) then
24808 Actual
:= First
(Actuals
);
24811 while Present
(Actual
)
24812 and then Nkind
(Actual
) /= N_Parameter_Association
24814 Actuals_To_Match
:= Actuals_To_Match
+ 1;
24818 if No
(Actual
) and Actuals_To_Match
= Formals_To_Match
then
24820 -- Most common case: positional notation, no defaults
24825 elsif Actuals_To_Match
> Formals_To_Match
then
24827 -- Too many actuals: will not work
24830 if Is_Entity_Name
(Name
(N
)) then
24831 Error_Msg_N
("too many arguments in call to&", Name
(N
));
24833 Error_Msg_N
("too many arguments in call", N
);
24841 First_Named
:= Actual
;
24843 while Present
(Actual
) loop
24844 if Nkind
(Actual
) /= N_Parameter_Association
then
24846 ("positional parameters not allowed after named ones", Actual
);
24851 Actuals_To_Match
:= Actuals_To_Match
+ 1;
24857 if Present
(Actuals
) then
24858 Actual
:= First
(Actuals
);
24861 Formal
:= First_Formal
(S
);
24862 while Present
(Formal
) loop
24864 -- Match the formals in order. If the corresponding actual is
24865 -- positional, nothing to do. Else scan the list of named actuals
24866 -- to find the one with the right name.
24868 if Present
(Actual
)
24869 and then Nkind
(Actual
) /= N_Parameter_Association
24872 Actuals_To_Match
:= Actuals_To_Match
- 1;
24873 Formals_To_Match
:= Formals_To_Match
- 1;
24876 -- For named parameters, search the list of actuals to find
24877 -- one that matches the next formal name.
24879 Actual
:= First_Named
;
24881 while Present
(Actual
) loop
24882 if Chars
(Selector_Name
(Actual
)) = Chars
(Formal
) then
24885 Actuals_To_Match
:= Actuals_To_Match
- 1;
24886 Formals_To_Match
:= Formals_To_Match
- 1;
24894 if Ekind
(Formal
) /= E_In_Parameter
24895 or else No
(Default_Value
(Formal
))
24898 if (Comes_From_Source
(S
)
24899 or else Sloc
(S
) = Standard_Location
)
24900 and then Is_Overloadable
(S
)
24904 Nkind
(Parent
(N
)) in N_Procedure_Call_Statement
24906 | N_Parameter_Association
24907 and then Ekind
(S
) /= E_Function
24909 Set_Etype
(N
, Etype
(S
));
24912 Error_Msg_Name_1
:= Chars
(S
);
24913 Error_Msg_Sloc
:= Sloc
(S
);
24915 ("missing argument for parameter & "
24916 & "in call to % declared #", N
, Formal
);
24919 elsif Is_Overloadable
(S
) then
24920 Error_Msg_Name_1
:= Chars
(S
);
24922 -- Point to type derivation that generated the
24925 Error_Msg_Sloc
:= Sloc
(Parent
(S
));
24928 ("missing argument for parameter & "
24929 & "in call to % (inherited) #", N
, Formal
);
24933 ("missing argument for parameter &", N
, Formal
);
24941 Formals_To_Match
:= Formals_To_Match
- 1;
24946 Next_Formal
(Formal
);
24949 if Formals_To_Match
= 0 and then Actuals_To_Match
= 0 then
24956 -- Find some superfluous named actual that did not get
24957 -- attached to the list of associations.
24959 Actual
:= First
(Actuals
);
24960 while Present
(Actual
) loop
24961 if Nkind
(Actual
) = N_Parameter_Association
24962 and then Actual
/= Last
24963 and then No
(Next_Named_Actual
(Actual
))
24965 -- A validity check may introduce a copy of a call that
24966 -- includes an extra actual (for example for an unrelated
24967 -- accessibility check). Check that the extra actual matches
24968 -- some extra formal, which must exist already because
24969 -- subprogram must be frozen at this point.
24971 if Present
(Extra_Formals
(S
))
24972 and then not Comes_From_Source
(Actual
)
24973 and then Nkind
(Actual
) = N_Parameter_Association
24974 and then Chars
(Extra_Formals
(S
)) =
24975 Chars
(Selector_Name
(Actual
))
24980 ("unmatched actual & in call", Selector_Name
(Actual
));
24992 end Normalize_Actuals
;
24994 --------------------------------
24995 -- Note_Possible_Modification --
24996 --------------------------------
24998 procedure Note_Possible_Modification
(N
: Node_Id
; Sure
: Boolean) is
24999 Modification_Comes_From_Source
: constant Boolean :=
25000 Comes_From_Source
(Parent
(N
));
25006 -- Loop to find referenced entity, if there is one
25012 if Is_Entity_Name
(Exp
) then
25013 Ent
:= Entity
(Exp
);
25015 -- If the entity is missing, it is an undeclared identifier,
25016 -- and there is nothing to annotate.
25022 elsif Nkind
(Exp
) = N_Explicit_Dereference
then
25024 P
: constant Node_Id
:= Prefix
(Exp
);
25027 -- In formal verification mode, keep track of all reads and
25028 -- writes through explicit dereferences.
25030 if GNATprove_Mode
then
25031 SPARK_Specific
.Generate_Dereference
(N
, 'm');
25034 if Nkind
(P
) = N_Selected_Component
25035 and then Present
(Entry_Formal
(Entity
(Selector_Name
(P
))))
25037 -- Case of a reference to an entry formal
25039 Ent
:= Entry_Formal
(Entity
(Selector_Name
(P
)));
25041 elsif Nkind
(P
) = N_Identifier
25042 and then Nkind
(Parent
(Entity
(P
))) = N_Object_Declaration
25043 and then Present
(Expression
(Parent
(Entity
(P
))))
25044 and then Nkind
(Expression
(Parent
(Entity
(P
)))) =
25047 -- Case of a reference to a value on which side effects have
25050 Exp
:= Prefix
(Expression
(Parent
(Entity
(P
))));
25058 elsif Nkind
(Exp
) in N_Type_Conversion | N_Unchecked_Type_Conversion
25060 Exp
:= Expression
(Exp
);
25063 elsif Nkind
(Exp
) in
25064 N_Slice | N_Indexed_Component | N_Selected_Component
25066 -- Special check, if the prefix is an access type, then return
25067 -- since we are modifying the thing pointed to, not the prefix.
25068 -- When we are expanding, most usually the prefix is replaced
25069 -- by an explicit dereference, and this test is not needed, but
25070 -- in some cases (notably -gnatc mode and generics) when we do
25071 -- not do full expansion, we need this special test.
25073 if Is_Access_Type
(Etype
(Prefix
(Exp
))) then
25076 -- Otherwise go to prefix and keep going
25079 Exp
:= Prefix
(Exp
);
25083 -- All other cases, not a modification
25089 -- Now look for entity being referenced
25091 if Present
(Ent
) then
25092 if Is_Object
(Ent
) then
25093 if Comes_From_Source
(Exp
)
25094 or else Modification_Comes_From_Source
25096 -- Give warning if pragma unmodified is given and we are
25097 -- sure this is a modification.
25099 if Has_Pragma_Unmodified
(Ent
) and then Sure
then
25101 -- Note that the entity may be present only as a result
25102 -- of pragma Unused.
25104 if Has_Pragma_Unused
(Ent
) then
25106 ("??aspect Unused specified for &!", N
, Ent
);
25109 ("??aspect Unmodified specified for &!", N
, Ent
);
25113 Set_Never_Set_In_Source
(Ent
, False);
25116 Set_Is_True_Constant
(Ent
, False);
25117 Set_Current_Value
(Ent
, Empty
);
25118 Set_Is_Known_Null
(Ent
, False);
25120 if not Can_Never_Be_Null
(Ent
) then
25121 Set_Is_Known_Non_Null
(Ent
, False);
25124 -- Follow renaming chain
25126 if Ekind
(Ent
) in E_Variable | E_Constant
25127 and then Present
(Renamed_Object
(Ent
))
25129 Exp
:= Renamed_Object
(Ent
);
25131 -- If the entity is the loop variable in an iteration over
25132 -- a container, retrieve container expression to indicate
25133 -- possible modification.
25135 if Present
(Related_Expression
(Ent
))
25136 and then Nkind
(Parent
(Related_Expression
(Ent
))) =
25137 N_Iterator_Specification
25139 Exp
:= Original_Node
(Related_Expression
(Ent
));
25144 -- The expression may be the renaming of a subcomponent of an
25145 -- array or container. The assignment to the subcomponent is
25146 -- a modification of the container.
25148 elsif Comes_From_Source
(Original_Node
(Exp
))
25149 and then Nkind
(Original_Node
(Exp
)) in
25150 N_Selected_Component | N_Indexed_Component
25152 Exp
:= Prefix
(Original_Node
(Exp
));
25156 -- Generate a reference only if the assignment comes from
25157 -- source. This excludes, for example, calls to a dispatching
25158 -- assignment operation when the left-hand side is tagged. In
25159 -- GNATprove mode, we need those references also on generated
25160 -- code, as these are used to compute the local effects of
25163 if Modification_Comes_From_Source
or GNATprove_Mode
then
25164 Generate_Reference
(Ent
, Exp
, 'm');
25166 -- If the target of the assignment is the bound variable
25167 -- in an iterator, indicate that the corresponding array
25168 -- or container is also modified.
25170 if Ada_Version
>= Ada_2012
25171 and then Nkind
(Parent
(Ent
)) = N_Iterator_Specification
25174 Domain
: constant Node_Id
:= Name
(Parent
(Ent
));
25177 -- ??? In the full version of the construct, the
25178 -- domain of iteration can be given by an expression.
25180 if Is_Entity_Name
(Domain
) then
25181 Generate_Reference
(Entity
(Domain
), Exp
, 'm');
25182 Set_Is_True_Constant
(Entity
(Domain
), False);
25183 Set_Never_Set_In_Source
(Entity
(Domain
), False);
25192 -- If we are sure this is a modification from source, and we know
25193 -- this modifies a constant, then give an appropriate warning.
25196 and then Modification_Comes_From_Source
25197 and then Overlays_Constant
(Ent
)
25198 and then Address_Clause_Overlay_Warnings
25201 Addr
: constant Node_Id
:= Address_Clause
(Ent
);
25206 Find_Overlaid_Entity
(Addr
, O_Ent
, Off
);
25208 Error_Msg_Sloc
:= Sloc
(Addr
);
25210 ("?o?constant& may be modified via address clause#",
25221 end Note_Possible_Modification
;
25227 function Null_Status
(N
: Node_Id
) return Null_Status_Kind
is
25228 function Is_Null_Excluding_Def
(Def
: Node_Id
) return Boolean;
25229 -- Determine whether definition Def carries a null exclusion
25231 function Null_Status_Of_Entity
(Id
: Entity_Id
) return Null_Status_Kind
;
25232 -- Determine the null status of arbitrary entity Id
25234 function Null_Status_Of_Type
(Typ
: Entity_Id
) return Null_Status_Kind
;
25235 -- Determine the null status of type Typ
25237 ---------------------------
25238 -- Is_Null_Excluding_Def --
25239 ---------------------------
25241 function Is_Null_Excluding_Def
(Def
: Node_Id
) return Boolean is
25243 return Nkind
(Def
) in N_Access_Definition
25244 | N_Access_Function_Definition
25245 | N_Access_Procedure_Definition
25246 | N_Access_To_Object_Definition
25247 | N_Component_Definition
25248 | N_Derived_Type_Definition
25249 and then Null_Exclusion_Present
(Def
);
25250 end Is_Null_Excluding_Def
;
25252 ---------------------------
25253 -- Null_Status_Of_Entity --
25254 ---------------------------
25256 function Null_Status_Of_Entity
25257 (Id
: Entity_Id
) return Null_Status_Kind
25259 Decl
: constant Node_Id
:= Declaration_Node
(Id
);
25263 -- The value of an imported or exported entity may be set externally
25264 -- regardless of a null exclusion. As a result, the value cannot be
25265 -- determined statically.
25267 if Is_Imported
(Id
) or else Is_Exported
(Id
) then
25270 elsif Nkind
(Decl
) in N_Component_Declaration
25271 | N_Discriminant_Specification
25272 | N_Formal_Object_Declaration
25273 | N_Object_Declaration
25274 | N_Object_Renaming_Declaration
25275 | N_Parameter_Specification
25277 -- A component declaration yields a non-null value when either
25278 -- its component definition or access definition carries a null
25281 if Nkind
(Decl
) = N_Component_Declaration
then
25282 Def
:= Component_Definition
(Decl
);
25284 if Is_Null_Excluding_Def
(Def
) then
25285 return Is_Non_Null
;
25288 Def
:= Access_Definition
(Def
);
25290 if Present
(Def
) and then Is_Null_Excluding_Def
(Def
) then
25291 return Is_Non_Null
;
25294 -- A formal object declaration yields a non-null value if its
25295 -- access definition carries a null exclusion. If the object is
25296 -- default initialized, then the value depends on the expression.
25298 elsif Nkind
(Decl
) = N_Formal_Object_Declaration
then
25299 Def
:= Access_Definition
(Decl
);
25301 if Present
(Def
) and then Is_Null_Excluding_Def
(Def
) then
25302 return Is_Non_Null
;
25305 -- A constant may yield a null or non-null value depending on its
25306 -- initialization expression.
25308 elsif Ekind
(Id
) = E_Constant
then
25309 return Null_Status
(Constant_Value
(Id
));
25311 -- The construct yields a non-null value when it has a null
25314 elsif Null_Exclusion_Present
(Decl
) then
25315 return Is_Non_Null
;
25317 -- An object renaming declaration yields a non-null value if its
25318 -- access definition carries a null exclusion. Otherwise the value
25319 -- depends on the renamed name.
25321 elsif Nkind
(Decl
) = N_Object_Renaming_Declaration
then
25322 Def
:= Access_Definition
(Decl
);
25324 if Present
(Def
) and then Is_Null_Excluding_Def
(Def
) then
25325 return Is_Non_Null
;
25328 return Null_Status
(Name
(Decl
));
25333 -- At this point the declaration of the entity does not carry a null
25334 -- exclusion and lacks an initialization expression. Check the status
25337 return Null_Status_Of_Type
(Etype
(Id
));
25338 end Null_Status_Of_Entity
;
25340 -------------------------
25341 -- Null_Status_Of_Type --
25342 -------------------------
25344 function Null_Status_Of_Type
(Typ
: Entity_Id
) return Null_Status_Kind
is
25349 -- Traverse the type chain looking for types with null exclusion
25352 while Present
(Curr
) and then Etype
(Curr
) /= Curr
loop
25353 Decl
:= Parent
(Curr
);
25355 -- Guard against itypes which do not always have declarations. A
25356 -- type yields a non-null value if it carries a null exclusion.
25358 if Present
(Decl
) then
25359 if Nkind
(Decl
) = N_Full_Type_Declaration
25360 and then Is_Null_Excluding_Def
(Type_Definition
(Decl
))
25362 return Is_Non_Null
;
25364 elsif Nkind
(Decl
) = N_Subtype_Declaration
25365 and then Null_Exclusion_Present
(Decl
)
25367 return Is_Non_Null
;
25371 Curr
:= Etype
(Curr
);
25374 -- The type chain does not contain any null excluding types
25377 end Null_Status_Of_Type
;
25379 -- Start of processing for Null_Status
25382 -- Prevent cascaded errors or infinite loops when trying to determine
25383 -- the null status of an erroneous construct.
25385 if Error_Posted
(N
) then
25388 -- An allocator always creates a non-null value
25390 elsif Nkind
(N
) = N_Allocator
then
25391 return Is_Non_Null
;
25393 -- Taking the 'Access of something yields a non-null value
25395 elsif Nkind
(N
) = N_Attribute_Reference
25396 and then Attribute_Name
(N
) in Name_Access
25397 | Name_Unchecked_Access
25398 | Name_Unrestricted_Access
25400 return Is_Non_Null
;
25402 -- "null" yields null
25404 elsif Nkind
(N
) = N_Null
then
25407 -- Check the status of the operand of a type conversion
25409 elsif Nkind
(N
) = N_Type_Conversion
then
25410 return Null_Status
(Expression
(N
));
25412 -- The input denotes a reference to an entity. Determine whether the
25413 -- entity or its type yields a null or non-null value.
25415 elsif Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
25416 return Null_Status_Of_Entity
(Entity
(N
));
25419 -- Otherwise it is not possible to determine the null status of the
25420 -- subexpression at compile time without resorting to simple flow
25426 --------------------------------------
25427 -- Null_To_Null_Address_Convert_OK --
25428 --------------------------------------
25430 function Null_To_Null_Address_Convert_OK
25432 Typ
: Entity_Id
:= Empty
) return Boolean
25435 if not Relaxed_RM_Semantics
then
25439 if Nkind
(N
) = N_Null
then
25440 return Present
(Typ
) and then Is_Descendant_Of_Address
(Typ
);
25442 elsif Nkind
(N
) in N_Op_Compare
then
25444 L
: constant Node_Id
:= Left_Opnd
(N
);
25445 R
: constant Node_Id
:= Right_Opnd
(N
);
25448 -- We check the Etype of the complementary operand since the
25449 -- N_Null node is not decorated at this stage.
25452 ((Nkind
(L
) = N_Null
25453 and then Is_Descendant_Of_Address
(Etype
(R
)))
25455 (Nkind
(R
) = N_Null
25456 and then Is_Descendant_Of_Address
(Etype
(L
))));
25461 end Null_To_Null_Address_Convert_OK
;
25463 ---------------------------------
25464 -- Number_Of_Elements_In_Array --
25465 ---------------------------------
25467 function Number_Of_Elements_In_Array
(T
: Entity_Id
) return Int
is
25475 pragma Assert
(Is_Array_Type
(T
));
25477 Indx
:= First_Index
(T
);
25478 while Present
(Indx
) loop
25479 Typ
:= Underlying_Type
(Etype
(Indx
));
25481 -- Never look at junk bounds of a generic type
25483 if Is_Generic_Type
(Typ
) then
25487 -- Check the array bounds are known at compile time and return zero
25488 -- if they are not.
25490 Low
:= Type_Low_Bound
(Typ
);
25491 High
:= Type_High_Bound
(Typ
);
25493 if not Compile_Time_Known_Value
(Low
) then
25495 elsif not Compile_Time_Known_Value
(High
) then
25499 Num
* UI_To_Int
((Expr_Value
(High
) - Expr_Value
(Low
) + 1));
25506 end Number_Of_Elements_In_Array
;
25508 ---------------------------------
25509 -- Original_Aspect_Pragma_Name --
25510 ---------------------------------
25512 function Original_Aspect_Pragma_Name
(N
: Node_Id
) return Name_Id
is
25514 Item_Nam
: Name_Id
;
25517 pragma Assert
(Nkind
(N
) in N_Aspect_Specification | N_Pragma
);
25521 -- The pragma was generated to emulate an aspect, use the original
25522 -- aspect specification.
25524 if Nkind
(Item
) = N_Pragma
and then From_Aspect_Specification
(Item
) then
25525 Item
:= Corresponding_Aspect
(Item
);
25528 -- Retrieve the name of the aspect/pragma. As assertion pragmas from
25529 -- a generic instantiation might have been rewritten into pragma Check,
25530 -- we look at the original node for Item. Note also that Pre, Pre_Class,
25531 -- Post and Post_Class rewrite their pragma identifier to preserve the
25532 -- original name, so we look at the original node for the identifier.
25533 -- ??? this is kludgey
25535 if Nkind
(Item
) = N_Pragma
then
25537 Chars
(Original_Node
(Pragma_Identifier
(Original_Node
(Item
))));
25539 if Item_Nam
= Name_Check
then
25540 -- Pragma "Check" preserves the original pragma name as its first
25543 Chars
(Expression
(First
(Pragma_Argument_Associations
25544 (Original_Node
(Item
)))));
25548 pragma Assert
(Nkind
(Item
) = N_Aspect_Specification
);
25549 Item_Nam
:= Chars
(Identifier
(Item
));
25552 -- Deal with 'Class by converting the name to its _XXX form
25554 if Class_Present
(Item
) then
25555 if Item_Nam
= Name_Invariant
then
25556 Item_Nam
:= Name_uInvariant
;
25558 elsif Item_Nam
= Name_Post
then
25559 Item_Nam
:= Name_uPost
;
25561 elsif Item_Nam
= Name_Pre
then
25562 Item_Nam
:= Name_uPre
;
25564 elsif Item_Nam
in Name_Type_Invariant | Name_Type_Invariant_Class
25566 Item_Nam
:= Name_uType_Invariant
;
25568 -- Nothing to do for other cases (e.g. a Check that derived from
25569 -- Pre_Class and has the flag set). Also we do nothing if the name
25570 -- is already in special _xxx form.
25576 end Original_Aspect_Pragma_Name
;
25578 --------------------------------------
25579 -- Original_Corresponding_Operation --
25580 --------------------------------------
25582 function Original_Corresponding_Operation
(S
: Entity_Id
) return Entity_Id
25584 Typ
: constant Entity_Id
:= Find_Dispatching_Type
(S
);
25587 -- If S is an inherited primitive S2 the original corresponding
25588 -- operation of S is the original corresponding operation of S2
25590 if Present
(Alias
(S
))
25591 and then Find_Dispatching_Type
(Alias
(S
)) /= Typ
25593 return Original_Corresponding_Operation
(Alias
(S
));
25595 -- If S overrides an inherited subprogram S2 the original corresponding
25596 -- operation of S is the original corresponding operation of S2
25598 elsif Present
(Overridden_Operation
(S
)) then
25599 return Original_Corresponding_Operation
(Overridden_Operation
(S
));
25601 -- otherwise it is S itself
25606 end Original_Corresponding_Operation
;
25608 -----------------------------------
25609 -- Original_View_In_Visible_Part --
25610 -----------------------------------
25612 function Original_View_In_Visible_Part
25613 (Typ
: Entity_Id
) return Boolean
25615 Scop
: constant Entity_Id
:= Scope
(Typ
);
25618 -- The scope must be a package
25620 if not Is_Package_Or_Generic_Package
(Scop
) then
25624 -- A type with a private declaration has a private view declared in
25625 -- the visible part.
25627 if Has_Private_Declaration
(Typ
) then
25631 return List_Containing
(Parent
(Typ
)) =
25632 Visible_Declarations
(Package_Specification
(Scop
));
25633 end Original_View_In_Visible_Part
;
25635 -------------------
25636 -- Output_Entity --
25637 -------------------
25639 procedure Output_Entity
(Id
: Entity_Id
) is
25643 Scop
:= Scope
(Id
);
25645 -- The entity may lack a scope when it is in the process of being
25646 -- analyzed. Use the current scope as an approximation.
25649 Scop
:= Current_Scope
;
25652 Output_Name
(Chars
(Id
), Scop
);
25659 procedure Output_Name
(Nam
: Name_Id
; Scop
: Entity_Id
:= Current_Scope
) is
25663 (Get_Qualified_Name
25674 -- This would be trivial, simply a test for an identifier that was a
25675 -- reference to a formal, if it were not for the fact that a previous call
25676 -- to Expand_Entry_Parameter will have modified the reference to the
25677 -- identifier. A formal of a protected entity is rewritten as
25679 -- typ!(recobj).rec.all'Constrained
25681 -- where rec is a selector whose Entry_Formal link points to the formal
25683 -- If the type of the entry parameter has a representation clause, then an
25684 -- extra temp is involved (see below).
25686 -- For a formal of a task entity, the formal is rewritten as a local
25689 -- In addition, a formal that is marked volatile because it is aliased
25690 -- through an address clause is rewritten as dereference as well.
25692 function Param_Entity
(N
: Node_Id
) return Entity_Id
is
25693 Renamed_Obj
: Node_Id
;
25696 -- Simple reference case
25698 if Nkind
(N
) in N_Identifier | N_Expanded_Name
then
25699 if Is_Formal
(Entity
(N
)) then
25702 -- Handle renamings of formal parameters and formals of tasks that
25703 -- are rewritten as renamings.
25705 elsif Nkind
(Parent
(Entity
(N
))) = N_Object_Renaming_Declaration
then
25706 Renamed_Obj
:= Get_Referenced_Object
(Renamed_Object
(Entity
(N
)));
25708 if Is_Entity_Name
(Renamed_Obj
)
25709 and then Is_Formal
(Entity
(Renamed_Obj
))
25711 return Entity
(Renamed_Obj
);
25714 Nkind
(Parent
(Parent
(Entity
(N
)))) = N_Accept_Statement
25721 if Nkind
(N
) = N_Explicit_Dereference
then
25723 P
: Node_Id
:= Prefix
(N
);
25729 -- If the type of an entry parameter has a representation
25730 -- clause, then the prefix is not a selected component, but
25731 -- instead a reference to a temp pointing at the selected
25732 -- component. In this case, set P to be the initial value of
25735 if Nkind
(P
) = N_Identifier
then
25738 if Ekind
(E
) = E_Constant
then
25739 Decl
:= Parent
(E
);
25741 if Nkind
(Decl
) = N_Object_Declaration
then
25742 P
:= Expression
(Decl
);
25747 if Nkind
(P
) = N_Selected_Component
then
25748 S
:= Selector_Name
(P
);
25750 if Present
(Entry_Formal
(Entity
(S
))) then
25751 return Entry_Formal
(Entity
(S
));
25754 elsif Nkind
(Original_Node
(N
)) = N_Identifier
then
25755 return Param_Entity
(Original_Node
(N
));
25764 ----------------------
25765 -- Policy_In_Effect --
25766 ----------------------
25768 function Policy_In_Effect
(Policy
: Name_Id
) return Name_Id
is
25769 function Policy_In_List
(List
: Node_Id
) return Name_Id
;
25770 -- Determine the mode of a policy in a N_Pragma list
25772 --------------------
25773 -- Policy_In_List --
25774 --------------------
25776 function Policy_In_List
(List
: Node_Id
) return Name_Id
is
25783 while Present
(Prag
) loop
25784 Arg1
:= First
(Pragma_Argument_Associations
(Prag
));
25785 Arg2
:= Next
(Arg1
);
25787 Arg1
:= Get_Pragma_Arg
(Arg1
);
25788 Arg2
:= Get_Pragma_Arg
(Arg2
);
25790 -- The current Check_Policy pragma matches the requested policy or
25791 -- appears in the single argument form (Assertion, policy_id).
25793 if Chars
(Arg1
) in Name_Assertion | Policy
then
25794 return Chars
(Arg2
);
25797 Prag
:= Next_Pragma
(Prag
);
25801 end Policy_In_List
;
25807 -- Start of processing for Policy_In_Effect
25810 if not Is_Valid_Assertion_Kind
(Policy
) then
25811 raise Program_Error
;
25814 -- Inspect all policy pragmas that appear within scopes (if any)
25816 Kind
:= Policy_In_List
(Check_Policy_List
);
25818 -- Inspect all configuration policy pragmas (if any)
25820 if Kind
= No_Name
then
25821 Kind
:= Policy_In_List
(Check_Policy_List_Config
);
25824 -- The context lacks policy pragmas, determine the mode based on whether
25825 -- assertions are enabled at the configuration level. This ensures that
25826 -- the policy is preserved when analyzing generics.
25828 if Kind
= No_Name
then
25829 if Assertions_Enabled_Config
then
25830 Kind
:= Name_Check
;
25832 Kind
:= Name_Ignore
;
25836 -- In CodePeer mode and GNATprove mode, we need to consider all
25837 -- assertions, unless they are disabled. Force Name_Check on
25838 -- ignored assertions.
25840 if Kind
in Name_Ignore | Name_Off
25841 and then (CodePeer_Mode
or GNATprove_Mode
)
25843 Kind
:= Name_Check
;
25847 end Policy_In_Effect
;
25849 -------------------------------
25850 -- Preanalyze_Without_Errors --
25851 -------------------------------
25853 procedure Preanalyze_Without_Errors
(N
: Node_Id
) is
25854 Status
: constant Boolean := Get_Ignore_Errors
;
25856 Set_Ignore_Errors
(True);
25858 Set_Ignore_Errors
(Status
);
25859 end Preanalyze_Without_Errors
;
25861 -----------------------
25862 -- Predicate_Enabled --
25863 -----------------------
25865 function Predicate_Enabled
(Typ
: Entity_Id
) return Boolean is
25867 return Present
(Predicate_Function
(Typ
))
25868 and then not Predicates_Ignored
(Typ
)
25869 and then not Predicate_Checks_Suppressed
(Empty
);
25870 end Predicate_Enabled
;
25872 ----------------------------------
25873 -- Predicate_Failure_Expression --
25874 ----------------------------------
25876 function Predicate_Failure_Expression
25877 (Typ
: Entity_Id
; Inherited_OK
: Boolean) return Node_Id
25879 PF_Aspect
: constant Node_Id
:=
25880 Find_Aspect
(Typ
, Aspect_Predicate_Failure
);
25882 -- Check for Predicate_Failure aspect specification via an
25883 -- aspect_specification (as opposed to via a pragma).
25885 if Present
(PF_Aspect
) then
25886 if Inherited_OK
or else Entity
(PF_Aspect
) = Typ
then
25887 return Expression
(PF_Aspect
);
25893 -- Check for Predicate_Failure aspect specification via a pragma.
25896 Rep_Item
: Node_Id
:= First_Rep_Item
(Typ
);
25898 while Present
(Rep_Item
) loop
25899 if Nkind
(Rep_Item
) = N_Pragma
25900 and then Get_Pragma_Id
(Rep_Item
) = Pragma_Predicate_Failure
25903 Arg1
: constant Node_Id
:=
25905 (First
(Pragma_Argument_Associations
(Rep_Item
)));
25906 Arg2
: constant Node_Id
:=
25908 (Next
(First
(Pragma_Argument_Associations
(Rep_Item
))));
25910 if Inherited_OK
or else
25911 (Nkind
(Arg1
) in N_Has_Entity
25912 and then Entity
(Arg1
) = Typ
)
25919 Next_Rep_Item
(Rep_Item
);
25923 -- If we are interested in an inherited Predicate_Failure aspect
25924 -- and we have an ancestor to inherit from, then recursively check
25927 if Inherited_OK
and then Present
(Nearest_Ancestor
(Typ
)) then
25928 return Predicate_Failure_Expression
(Nearest_Ancestor
(Typ
),
25929 Inherited_OK
=> True);
25933 end Predicate_Failure_Expression
;
25935 ----------------------------------
25936 -- Predicate_Tests_On_Arguments --
25937 ----------------------------------
25939 function Predicate_Tests_On_Arguments
(Subp
: Entity_Id
) return Boolean is
25941 -- Always test predicates on indirect call
25943 if Ekind
(Subp
) = E_Subprogram_Type
then
25946 -- Do not test predicates on call to generated default Finalize, since
25947 -- we are not interested in whether something we are finalizing (and
25948 -- typically destroying) satisfies its predicates.
25950 elsif Chars
(Subp
) = Name_Finalize
25951 and then not Comes_From_Source
(Subp
)
25955 -- Do not test predicates on any internally generated routines
25957 elsif Is_Internal_Name
(Chars
(Subp
)) then
25960 -- Do not test predicates on call to Init_Proc, since if needed the
25961 -- predicate test will occur at some other point.
25963 elsif Is_Init_Proc
(Subp
) then
25966 -- Do not test predicates on call to predicate function, since this
25967 -- would cause infinite recursion.
25969 elsif Ekind
(Subp
) = E_Function
25970 and then Is_Predicate_Function
(Subp
)
25974 -- For now, no other exceptions
25979 end Predicate_Tests_On_Arguments
;
25981 -----------------------
25982 -- Private_Component --
25983 -----------------------
25985 function Private_Component
(Type_Id
: Entity_Id
) return Entity_Id
is
25986 Ancestor
: constant Entity_Id
:= Base_Type
(Type_Id
);
25988 function Trace_Components
25990 Check
: Boolean) return Entity_Id
;
25991 -- Recursive function that does the work, and checks against circular
25992 -- definition for each subcomponent type.
25994 ----------------------
25995 -- Trace_Components --
25996 ----------------------
25998 function Trace_Components
26000 Check
: Boolean) return Entity_Id
26002 Btype
: constant Entity_Id
:= Base_Type
(T
);
26003 Component
: Entity_Id
;
26005 Candidate
: Entity_Id
:= Empty
;
26008 if Check
and then Btype
= Ancestor
then
26009 Error_Msg_N
("circular type definition", Type_Id
);
26013 if Is_Private_Type
(Btype
) and then not Is_Generic_Type
(Btype
) then
26014 if Present
(Full_View
(Btype
))
26015 and then Is_Record_Type
(Full_View
(Btype
))
26016 and then not Is_Frozen
(Btype
)
26018 -- To indicate that the ancestor depends on a private type, the
26019 -- current Btype is sufficient. However, to check for circular
26020 -- definition we must recurse on the full view.
26022 Candidate
:= Trace_Components
(Full_View
(Btype
), True);
26024 if Candidate
= Any_Type
then
26034 elsif Is_Array_Type
(Btype
) then
26035 return Trace_Components
(Component_Type
(Btype
), True);
26037 elsif Is_Record_Type
(Btype
) then
26038 Component
:= First_Entity
(Btype
);
26039 while Present
(Component
)
26040 and then Comes_From_Source
(Component
)
26042 -- Skip anonymous types generated by constrained components
26044 if not Is_Type
(Component
) then
26045 P
:= Trace_Components
(Etype
(Component
), True);
26047 if Present
(P
) then
26048 if P
= Any_Type
then
26056 Next_Entity
(Component
);
26064 end Trace_Components
;
26066 -- Start of processing for Private_Component
26069 return Trace_Components
(Type_Id
, False);
26070 end Private_Component
;
26072 ---------------------------
26073 -- Primitive_Names_Match --
26074 ---------------------------
26076 function Primitive_Names_Match
(E1
, E2
: Entity_Id
) return Boolean is
26077 function Non_Internal_Name
(E
: Entity_Id
) return Name_Id
;
26078 -- Given an internal name, returns the corresponding non-internal name
26080 ------------------------
26081 -- Non_Internal_Name --
26082 ------------------------
26084 function Non_Internal_Name
(E
: Entity_Id
) return Name_Id
is
26086 Get_Name_String
(Chars
(E
));
26087 Name_Len
:= Name_Len
- 1;
26089 end Non_Internal_Name
;
26091 -- Start of processing for Primitive_Names_Match
26094 pragma Assert
(Present
(E1
) and then Present
(E2
));
26096 return Chars
(E1
) = Chars
(E2
)
26098 (not Is_Internal_Name
(Chars
(E1
))
26099 and then Is_Internal_Name
(Chars
(E2
))
26100 and then Non_Internal_Name
(E2
) = Chars
(E1
))
26102 (not Is_Internal_Name
(Chars
(E2
))
26103 and then Is_Internal_Name
(Chars
(E1
))
26104 and then Non_Internal_Name
(E1
) = Chars
(E2
))
26106 (Is_Predefined_Dispatching_Operation
(E1
)
26107 and then Is_Predefined_Dispatching_Operation
(E2
)
26108 and then Same_TSS
(E1
, E2
))
26110 (Is_Init_Proc
(E1
) and then Is_Init_Proc
(E2
));
26111 end Primitive_Names_Match
;
26113 -----------------------
26114 -- Process_End_Label --
26115 -----------------------
26117 procedure Process_End_Label
26126 Label_Ref
: Boolean;
26127 -- Set True if reference to end label itself is required
26130 -- Gets set to the operator symbol or identifier that references the
26131 -- entity Ent. For the child unit case, this is the identifier from the
26132 -- designator. For other cases, this is simply Endl.
26134 procedure Generate_Parent_Ref
(N
: Node_Id
; E
: Entity_Id
);
26135 -- N is an identifier node that appears as a parent unit reference in
26136 -- the case where Ent is a child unit. This procedure generates an
26137 -- appropriate cross-reference entry. E is the corresponding entity.
26139 -------------------------
26140 -- Generate_Parent_Ref --
26141 -------------------------
26143 procedure Generate_Parent_Ref
(N
: Node_Id
; E
: Entity_Id
) is
26145 -- If names do not match, something weird, skip reference
26147 if Chars
(E
) = Chars
(N
) then
26149 -- Generate the reference. We do NOT consider this as a reference
26150 -- for unreferenced symbol purposes.
26152 Generate_Reference
(E
, N
, 'r', Set_Ref
=> False, Force
=> True);
26154 if Style_Check
then
26155 Style
.Check_Identifier
(N
, E
);
26158 end Generate_Parent_Ref
;
26160 -- Start of processing for Process_End_Label
26163 -- If no node, ignore. This happens in some error situations, and
26164 -- also for some internally generated structures where no end label
26165 -- references are required in any case.
26171 -- Nothing to do if no End_Label, happens for internally generated
26172 -- constructs where we don't want an end label reference anyway. Also
26173 -- nothing to do if Endl is a string literal, which means there was
26174 -- some prior error (bad operator symbol)
26176 Endl
:= End_Label
(N
);
26178 if No
(Endl
) or else Nkind
(Endl
) = N_String_Literal
then
26182 -- Reference node is not in extended main source unit
26184 if not In_Extended_Main_Source_Unit
(N
) then
26186 -- Generally we do not collect references except for the extended
26187 -- main source unit. The one exception is the 'e' entry for a
26188 -- package spec, where it is useful for a client to have the
26189 -- ending information to define scopes.
26195 Label_Ref
:= False;
26197 -- For this case, we can ignore any parent references, but we
26198 -- need the package name itself for the 'e' entry.
26200 if Nkind
(Endl
) = N_Designator
then
26201 Endl
:= Identifier
(Endl
);
26205 -- Reference is in extended main source unit
26210 -- For designator, generate references for the parent entries
26212 if Nkind
(Endl
) = N_Designator
then
26214 -- Generate references for the prefix if the END line comes from
26215 -- source (otherwise we do not need these references) We climb the
26216 -- scope stack to find the expected entities.
26218 if Comes_From_Source
(Endl
) then
26219 Nam
:= Name
(Endl
);
26220 Scop
:= Current_Scope
;
26221 while Nkind
(Nam
) = N_Selected_Component
loop
26222 Scop
:= Scope
(Scop
);
26223 exit when No
(Scop
);
26224 Generate_Parent_Ref
(Selector_Name
(Nam
), Scop
);
26225 Nam
:= Prefix
(Nam
);
26228 if Present
(Scop
) then
26229 Generate_Parent_Ref
(Nam
, Scope
(Scop
));
26233 Endl
:= Identifier
(Endl
);
26237 -- If the end label is not for the given entity, then either we have
26238 -- some previous error, or this is a generic instantiation for which
26239 -- we do not need to make a cross-reference in this case anyway. In
26240 -- either case we simply ignore the call.
26242 if Chars
(Ent
) /= Chars
(Endl
) then
26246 -- If label was really there, then generate a normal reference and then
26247 -- adjust the location in the end label to point past the name (which
26248 -- should almost always be the semicolon).
26250 Loc
:= Sloc
(Endl
);
26252 if Comes_From_Source
(Endl
) then
26254 -- If a label reference is required, then do the style check and
26255 -- generate an l-type cross-reference entry for the label
26258 if Style_Check
then
26259 Style
.Check_Identifier
(Endl
, Ent
);
26262 Generate_Reference
(Ent
, Endl
, 'l', Set_Ref
=> False);
26265 -- Set the location to point past the label (normally this will
26266 -- mean the semicolon immediately following the label). This is
26267 -- done for the sake of the 'e' or 't' entry generated below.
26269 Get_Decoded_Name_String
(Chars
(Endl
));
26270 Set_Sloc
(Endl
, Sloc
(Endl
) + Source_Ptr
(Name_Len
));
26273 -- Now generate the e/t reference
26275 Generate_Reference
(Ent
, Endl
, Typ
, Set_Ref
=> False, Force
=> True);
26277 -- Restore Sloc, in case modified above, since we have an identifier
26278 -- and the normal Sloc should be left set in the tree.
26280 Set_Sloc
(Endl
, Loc
);
26281 end Process_End_Label
;
26283 --------------------------------
26284 -- Propagate_Concurrent_Flags --
26285 --------------------------------
26287 procedure Propagate_Concurrent_Flags
26289 Comp_Typ
: Entity_Id
)
26292 if Has_Task
(Comp_Typ
) then
26293 Set_Has_Task
(Typ
);
26296 if Has_Protected
(Comp_Typ
) then
26297 Set_Has_Protected
(Typ
);
26300 if Has_Timing_Event
(Comp_Typ
) then
26301 Set_Has_Timing_Event
(Typ
);
26303 end Propagate_Concurrent_Flags
;
26305 ------------------------------
26306 -- Propagate_DIC_Attributes --
26307 ------------------------------
26309 procedure Propagate_DIC_Attributes
26311 From_Typ
: Entity_Id
)
26313 DIC_Proc
: Entity_Id
;
26314 Partial_DIC_Proc
: Entity_Id
;
26317 if Present
(Typ
) and then Present
(From_Typ
) then
26318 pragma Assert
(Is_Type
(Typ
) and then Is_Type
(From_Typ
));
26320 -- Nothing to do if both the source and the destination denote the
26323 if From_Typ
= Typ
then
26326 -- Nothing to do when the destination denotes an incomplete type
26327 -- because the DIC is associated with the current instance of a
26328 -- private type, thus it can never apply to an incomplete type.
26330 elsif Is_Incomplete_Type
(Typ
) then
26334 DIC_Proc
:= DIC_Procedure
(From_Typ
);
26335 Partial_DIC_Proc
:= Partial_DIC_Procedure
(From_Typ
);
26337 -- The setting of the attributes is intentionally conservative. This
26338 -- prevents accidental clobbering of enabled attributes. We need to
26339 -- call Base_Type twice, because it is sometimes not set to an actual
26342 if Has_Inherited_DIC
(From_Typ
) then
26343 Set_Has_Inherited_DIC
(Base_Type
(Base_Type
(Typ
)));
26346 if Has_Own_DIC
(From_Typ
) then
26347 Set_Has_Own_DIC
(Base_Type
(Base_Type
(Typ
)));
26350 if Present
(DIC_Proc
) and then No
(DIC_Procedure
(Typ
)) then
26351 Set_DIC_Procedure
(Typ
, DIC_Proc
);
26354 if Present
(Partial_DIC_Proc
)
26355 and then No
(Partial_DIC_Procedure
(Typ
))
26357 Set_Partial_DIC_Procedure
(Typ
, Partial_DIC_Proc
);
26360 end Propagate_DIC_Attributes
;
26362 ------------------------------------
26363 -- Propagate_Invariant_Attributes --
26364 ------------------------------------
26366 procedure Propagate_Invariant_Attributes
26368 From_Typ
: Entity_Id
)
26370 Full_IP
: Entity_Id
;
26371 Part_IP
: Entity_Id
;
26374 if Present
(Typ
) and then Present
(From_Typ
) then
26375 pragma Assert
(Is_Type
(Typ
) and then Is_Type
(From_Typ
));
26377 -- Nothing to do if both the source and the destination denote the
26380 if From_Typ
= Typ
then
26384 Full_IP
:= Invariant_Procedure
(From_Typ
);
26385 Part_IP
:= Partial_Invariant_Procedure
(From_Typ
);
26387 -- The setting of the attributes is intentionally conservative. This
26388 -- prevents accidental clobbering of enabled attributes. We need to
26389 -- call Base_Type twice, because it is sometimes not set to an actual
26392 if Has_Inheritable_Invariants
(From_Typ
) then
26393 Set_Has_Inheritable_Invariants
(Base_Type
(Base_Type
(Typ
)));
26396 if Has_Inherited_Invariants
(From_Typ
) then
26397 Set_Has_Inherited_Invariants
(Base_Type
(Base_Type
(Typ
)));
26400 if Has_Own_Invariants
(From_Typ
) then
26401 Set_Has_Own_Invariants
(Base_Type
(Base_Type
(Typ
)));
26404 if Present
(Full_IP
) and then No
(Invariant_Procedure
(Typ
)) then
26405 Set_Invariant_Procedure
(Typ
, Full_IP
);
26408 if Present
(Part_IP
) and then No
(Partial_Invariant_Procedure
(Typ
))
26410 Set_Partial_Invariant_Procedure
(Typ
, Part_IP
);
26413 end Propagate_Invariant_Attributes
;
26415 ------------------------------------
26416 -- Propagate_Predicate_Attributes --
26417 ------------------------------------
26419 procedure Propagate_Predicate_Attributes
26421 From_Typ
: Entity_Id
)
26423 Pred_Func
: Entity_Id
;
26425 if Present
(Typ
) and then Present
(From_Typ
) then
26426 pragma Assert
(Is_Type
(Typ
) and then Is_Type
(From_Typ
));
26428 -- Nothing to do if both the source and the destination denote the
26431 if From_Typ
= Typ
then
26435 Pred_Func
:= Predicate_Function
(From_Typ
);
26437 -- The setting of the attributes is intentionally conservative. This
26438 -- prevents accidental clobbering of enabled attributes.
26440 if Has_Predicates
(From_Typ
) then
26441 Set_Has_Predicates
(Typ
);
26444 if Present
(Pred_Func
) and then No
(Predicate_Function
(Typ
)) then
26445 Set_Predicate_Function
(Typ
, Pred_Func
);
26448 end Propagate_Predicate_Attributes
;
26450 ---------------------------------------
26451 -- Record_Possible_Part_Of_Reference --
26452 ---------------------------------------
26454 procedure Record_Possible_Part_Of_Reference
26455 (Var_Id
: Entity_Id
;
26458 Encap
: constant Entity_Id
:= Encapsulating_State
(Var_Id
);
26462 -- The variable is a constituent of a single protected/task type. Such
26463 -- a variable acts as a component of the type and must appear within a
26464 -- specific region (SPARK RM 9(3)). Instead of recording the reference,
26465 -- verify its legality now.
26467 if Present
(Encap
) and then Is_Single_Concurrent_Object
(Encap
) then
26468 Check_Part_Of_Reference
(Var_Id
, Ref
);
26470 -- The variable is subject to pragma Part_Of and may eventually become a
26471 -- constituent of a single protected/task type. Record the reference to
26472 -- verify its placement when the contract of the variable is analyzed.
26474 elsif Present
(Get_Pragma
(Var_Id
, Pragma_Part_Of
)) then
26475 Refs
:= Part_Of_References
(Var_Id
);
26478 Refs
:= New_Elmt_List
;
26479 Set_Part_Of_References
(Var_Id
, Refs
);
26482 Append_Elmt
(Ref
, Refs
);
26484 end Record_Possible_Part_Of_Reference
;
26490 function Referenced
(Id
: Entity_Id
; Expr
: Node_Id
) return Boolean is
26491 Seen
: Boolean := False;
26493 function Is_Reference
(N
: Node_Id
) return Traverse_Result
;
26494 -- Determine whether node N denotes a reference to Id. If this is the
26495 -- case, set global flag Seen to True and stop the traversal.
26501 function Is_Reference
(N
: Node_Id
) return Traverse_Result
is
26503 if Is_Entity_Name
(N
)
26504 and then Present
(Entity
(N
))
26505 and then Entity
(N
) = Id
26514 procedure Inspect_Expression
is new Traverse_Proc
(Is_Reference
);
26516 -- Start of processing for Referenced
26519 Inspect_Expression
(Expr
);
26523 ------------------------------------
26524 -- References_Generic_Formal_Type --
26525 ------------------------------------
26527 function References_Generic_Formal_Type
(N
: Node_Id
) return Boolean is
26529 function Process
(N
: Node_Id
) return Traverse_Result
;
26530 -- Process one node in search for generic formal type
26536 function Process
(N
: Node_Id
) return Traverse_Result
is
26538 if Nkind
(N
) in N_Has_Entity
then
26540 E
: constant Entity_Id
:= Entity
(N
);
26542 if Present
(E
) then
26543 if Is_Generic_Type
(E
) then
26545 elsif Present
(Etype
(E
))
26546 and then Is_Generic_Type
(Etype
(E
))
26557 function Traverse
is new Traverse_Func
(Process
);
26558 -- Traverse tree to look for generic type
26561 if Inside_A_Generic
then
26562 return Traverse
(N
) = Abandon
;
26566 end References_Generic_Formal_Type
;
26568 -------------------------------
26569 -- Remove_Entity_And_Homonym --
26570 -------------------------------
26572 procedure Remove_Entity_And_Homonym
(Id
: Entity_Id
) is
26574 Remove_Entity
(Id
);
26575 Remove_Homonym
(Id
);
26576 end Remove_Entity_And_Homonym
;
26578 --------------------
26579 -- Remove_Homonym --
26580 --------------------
26582 procedure Remove_Homonym
(Id
: Entity_Id
) is
26584 Prev
: Entity_Id
:= Empty
;
26587 if Id
= Current_Entity
(Id
) then
26588 if Present
(Homonym
(Id
)) then
26589 Set_Current_Entity
(Homonym
(Id
));
26591 Set_Name_Entity_Id
(Chars
(Id
), Empty
);
26595 Hom
:= Current_Entity
(Id
);
26596 while Present
(Hom
) and then Hom
/= Id
loop
26598 Hom
:= Homonym
(Hom
);
26601 -- If Id is not on the homonym chain, nothing to do
26603 if Present
(Hom
) then
26604 Set_Homonym
(Prev
, Homonym
(Id
));
26607 end Remove_Homonym
;
26609 ------------------------------
26610 -- Remove_Overloaded_Entity --
26611 ------------------------------
26613 procedure Remove_Overloaded_Entity
(Id
: Entity_Id
) is
26614 procedure Remove_Primitive_Of
(Typ
: Entity_Id
);
26615 -- Remove primitive subprogram Id from the list of primitives that
26616 -- belong to type Typ.
26618 -------------------------
26619 -- Remove_Primitive_Of --
26620 -------------------------
26622 procedure Remove_Primitive_Of
(Typ
: Entity_Id
) is
26626 if Is_Tagged_Type
(Typ
) then
26627 Prims
:= Direct_Primitive_Operations
(Typ
);
26629 if Present
(Prims
) then
26630 Remove
(Prims
, Id
);
26633 end Remove_Primitive_Of
;
26637 Formal
: Entity_Id
;
26639 -- Start of processing for Remove_Overloaded_Entity
26642 Remove_Entity_And_Homonym
(Id
);
26644 -- The entity denotes a primitive subprogram. Remove it from the list of
26645 -- primitives of the associated controlling type.
26647 if Ekind
(Id
) in E_Function | E_Procedure
and then Is_Primitive
(Id
) then
26648 Formal
:= First_Formal
(Id
);
26649 while Present
(Formal
) loop
26650 if Is_Controlling_Formal
(Formal
) then
26651 Remove_Primitive_Of
(Etype
(Formal
));
26655 Next_Formal
(Formal
);
26658 if Ekind
(Id
) = E_Function
and then Has_Controlling_Result
(Id
) then
26659 Remove_Primitive_Of
(Etype
(Id
));
26662 end Remove_Overloaded_Entity
;
26664 ---------------------
26665 -- Rep_To_Pos_Flag --
26666 ---------------------
26668 function Rep_To_Pos_Flag
(E
: Entity_Id
; Loc
: Source_Ptr
) return Node_Id
is
26670 return New_Occurrence_Of
26671 (Boolean_Literals
(not Range_Checks_Suppressed
(E
)), Loc
);
26672 end Rep_To_Pos_Flag
;
26674 --------------------
26675 -- Require_Entity --
26676 --------------------
26678 procedure Require_Entity
(N
: Node_Id
) is
26680 if Is_Entity_Name
(N
) and then No
(Entity
(N
)) then
26681 if Total_Errors_Detected
/= 0 then
26682 Set_Entity
(N
, Any_Id
);
26684 raise Program_Error
;
26687 end Require_Entity
;
26689 ------------------------------
26690 -- Requires_Transient_Scope --
26691 ------------------------------
26693 function Requires_Transient_Scope
(Typ
: Entity_Id
) return Boolean is
26695 return Needs_Secondary_Stack
(Typ
) or else Needs_Finalization
(Typ
);
26696 end Requires_Transient_Scope
;
26698 --------------------------
26699 -- Reset_Analyzed_Flags --
26700 --------------------------
26702 procedure Reset_Analyzed_Flags
(N
: Node_Id
) is
26703 function Clear_Analyzed
(N
: Node_Id
) return Traverse_Result
;
26704 -- Function used to reset Analyzed flags in tree. Note that we do
26705 -- not reset Analyzed flags in entities, since there is no need to
26706 -- reanalyze entities, and indeed, it is wrong to do so, since it
26707 -- can result in generating auxiliary stuff more than once.
26709 --------------------
26710 -- Clear_Analyzed --
26711 --------------------
26713 function Clear_Analyzed
(N
: Node_Id
) return Traverse_Result
is
26715 if Nkind
(N
) not in N_Entity
then
26716 Set_Analyzed
(N
, False);
26720 end Clear_Analyzed
;
26722 procedure Reset_Analyzed
is new Traverse_Proc
(Clear_Analyzed
);
26724 -- Start of processing for Reset_Analyzed_Flags
26727 Reset_Analyzed
(N
);
26728 end Reset_Analyzed_Flags
;
26730 ------------------------
26731 -- Restore_SPARK_Mode --
26732 ------------------------
26734 procedure Restore_SPARK_Mode
26735 (Mode
: SPARK_Mode_Type
;
26739 SPARK_Mode
:= Mode
;
26740 SPARK_Mode_Pragma
:= Prag
;
26741 end Restore_SPARK_Mode
;
26743 --------------------------------
26744 -- Returns_Unconstrained_Type --
26745 --------------------------------
26747 function Returns_Unconstrained_Type
(Subp
: Entity_Id
) return Boolean is
26749 return Ekind
(Subp
) = E_Function
26750 and then not Is_Scalar_Type
(Etype
(Subp
))
26751 and then not Is_Access_Type
(Etype
(Subp
))
26752 and then not Is_Constrained
(Etype
(Subp
));
26753 end Returns_Unconstrained_Type
;
26755 ----------------------------
26756 -- Root_Type_Of_Full_View --
26757 ----------------------------
26759 function Root_Type_Of_Full_View
(T
: Entity_Id
) return Entity_Id
is
26760 Rtyp
: constant Entity_Id
:= Root_Type
(T
);
26763 -- The root type of the full view may itself be a private type. Keep
26764 -- looking for the ultimate derivation parent.
26766 if Is_Private_Type
(Rtyp
) and then Present
(Full_View
(Rtyp
)) then
26767 return Root_Type_Of_Full_View
(Full_View
(Rtyp
));
26771 end Root_Type_Of_Full_View
;
26773 ---------------------------
26774 -- Safe_To_Capture_Value --
26775 ---------------------------
26777 function Safe_To_Capture_Value
26780 Cond
: Boolean := False) return Boolean
26783 -- The only entities for which we track constant values are variables
26784 -- that are not renamings, constants and formal parameters, so check
26785 -- if we have this case.
26787 -- Note: it may seem odd to track constant values for constants, but in
26788 -- fact this routine is used for other purposes than simply capturing
26789 -- the value. In particular, the setting of Known[_Non]_Null and
26792 if (Ekind
(Ent
) = E_Variable
and then No
(Renamed_Object
(Ent
)))
26794 Ekind
(Ent
) = E_Constant
26800 -- For conditionals, we also allow loop parameters
26802 elsif Cond
and then Ekind
(Ent
) = E_Loop_Parameter
then
26805 -- For all other cases, not just unsafe, but impossible to capture
26806 -- Current_Value, since the above are the only entities which have
26807 -- Current_Value fields.
26813 -- Skip if volatile or aliased, since funny things might be going on in
26814 -- these cases which we cannot necessarily track. Also skip any variable
26815 -- for which an address clause is given, or whose address is taken. Also
26816 -- never capture value of library level variables (an attempt to do so
26817 -- can occur in the case of package elaboration code).
26819 if Treat_As_Volatile
(Ent
)
26820 or else Is_Aliased
(Ent
)
26821 or else Present
(Address_Clause
(Ent
))
26822 or else Address_Taken
(Ent
)
26823 or else (Is_Library_Level_Entity
(Ent
)
26824 and then Ekind
(Ent
) = E_Variable
)
26829 -- OK, all above conditions are met. We also require that the scope of
26830 -- the reference be the same as the scope of the entity, not counting
26831 -- packages and blocks and loops.
26834 E_Scope
: constant Entity_Id
:= Scope
(Ent
);
26835 R_Scope
: Entity_Id
;
26838 R_Scope
:= Current_Scope
;
26839 while R_Scope
/= Standard_Standard
loop
26840 exit when R_Scope
= E_Scope
;
26842 if Ekind
(R_Scope
) not in E_Package | E_Block | E_Loop
then
26845 R_Scope
:= Scope
(R_Scope
);
26850 -- We also require that the reference does not appear in a context
26851 -- where it is not sure to be executed (i.e. a conditional context
26852 -- or an exception handler). We skip this if Cond is True, since the
26853 -- capturing of values from conditional tests handles this ok.
26855 if Cond
or else No
(N
) then
26866 -- Seems dubious that case expressions are not handled here ???
26869 while Present
(P
) loop
26870 if Is_Body
(P
) then
26873 elsif Nkind
(P
) = N_If_Statement
26874 or else Nkind
(P
) = N_Case_Statement
26875 or else (Nkind
(P
) in N_Short_Circuit
26876 and then Desc
= Right_Opnd
(P
))
26877 or else (Nkind
(P
) = N_If_Expression
26878 and then Desc
/= First
(Expressions
(P
)))
26879 or else Nkind
(P
) = N_Exception_Handler
26880 or else Nkind
(P
) = N_Selective_Accept
26881 or else Nkind
(P
) = N_Conditional_Entry_Call
26882 or else Nkind
(P
) = N_Timed_Entry_Call
26883 or else Nkind
(P
) = N_Asynchronous_Select
26891 -- A special Ada 2012 case: the original node may be part
26892 -- of the else_actions of a conditional expression, in which
26893 -- case it might not have been expanded yet, and appears in
26894 -- a non-syntactic list of actions. In that case it is clearly
26895 -- not safe to save a value.
26898 and then Is_List_Member
(Desc
)
26899 and then No
(Parent
(List_Containing
(Desc
)))
26907 -- OK, looks safe to set value
26910 end Safe_To_Capture_Value
;
26916 function Same_Name
(N1
, N2
: Node_Id
) return Boolean is
26917 K1
: constant Node_Kind
:= Nkind
(N1
);
26918 K2
: constant Node_Kind
:= Nkind
(N2
);
26921 if (K1
= N_Identifier
or else K1
= N_Defining_Identifier
)
26922 and then (K2
= N_Identifier
or else K2
= N_Defining_Identifier
)
26924 return Chars
(N1
) = Chars
(N2
);
26926 elsif (K1
= N_Selected_Component
or else K1
= N_Expanded_Name
)
26927 and then (K2
= N_Selected_Component
or else K2
= N_Expanded_Name
)
26929 return Same_Name
(Selector_Name
(N1
), Selector_Name
(N2
))
26930 and then Same_Name
(Prefix
(N1
), Prefix
(N2
));
26941 function Same_Object
(Node1
, Node2
: Node_Id
) return Boolean is
26942 N1
: constant Node_Id
:= Original_Node
(Node1
);
26943 N2
: constant Node_Id
:= Original_Node
(Node2
);
26944 -- We do the tests on original nodes, since we are most interested
26945 -- in the original source, not any expansion that got in the way.
26947 K1
: constant Node_Kind
:= Nkind
(N1
);
26948 K2
: constant Node_Kind
:= Nkind
(N2
);
26951 -- First case, both are entities with same entity
26953 if K1
in N_Has_Entity
and then K2
in N_Has_Entity
then
26955 EN1
: constant Entity_Id
:= Entity
(N1
);
26956 EN2
: constant Entity_Id
:= Entity
(N2
);
26958 if Present
(EN1
) and then Present
(EN2
)
26959 and then (Ekind
(EN1
) in E_Variable | E_Constant
26960 or else Is_Formal
(EN1
))
26968 -- Second case, selected component with same selector, same record
26970 if K1
= N_Selected_Component
26971 and then K2
= N_Selected_Component
26972 and then Chars
(Selector_Name
(N1
)) = Chars
(Selector_Name
(N2
))
26974 return Same_Object
(Prefix
(N1
), Prefix
(N2
));
26976 -- Third case, indexed component with same subscripts, same array
26978 elsif K1
= N_Indexed_Component
26979 and then K2
= N_Indexed_Component
26980 and then Same_Object
(Prefix
(N1
), Prefix
(N2
))
26985 E1
:= First
(Expressions
(N1
));
26986 E2
:= First
(Expressions
(N2
));
26987 while Present
(E1
) loop
26988 if not Same_Value
(E1
, E2
) then
26999 -- Fourth case, slice of same array with same bounds
27002 and then K2
= N_Slice
27003 and then Nkind
(Discrete_Range
(N1
)) = N_Range
27004 and then Nkind
(Discrete_Range
(N2
)) = N_Range
27005 and then Same_Value
(Low_Bound
(Discrete_Range
(N1
)),
27006 Low_Bound
(Discrete_Range
(N2
)))
27007 and then Same_Value
(High_Bound
(Discrete_Range
(N1
)),
27008 High_Bound
(Discrete_Range
(N2
)))
27010 return Same_Name
(Prefix
(N1
), Prefix
(N2
));
27012 -- All other cases, not clearly the same object
27019 ---------------------------------
27020 -- Same_Or_Aliased_Subprograms --
27021 ---------------------------------
27023 function Same_Or_Aliased_Subprograms
27025 E
: Entity_Id
) return Boolean
27027 Subp_Alias
: constant Entity_Id
:= Alias
(S
);
27028 Subp
: Entity_Id
:= E
;
27030 -- During expansion of subprograms with postconditions the original
27031 -- subprogram's declarations and statements get wrapped into a local
27032 -- _Wrapped_Statements subprogram.
27034 if Chars
(Subp
) = Name_uWrapped_Statements
then
27035 Subp
:= Enclosing_Subprogram
(Subp
);
27039 or else (Present
(Subp_Alias
) and then Subp_Alias
= Subp
);
27040 end Same_Or_Aliased_Subprograms
;
27046 function Same_Type
(T1
, T2
: Entity_Id
) return Boolean is
27051 elsif not Is_Constrained
(T1
)
27052 and then not Is_Constrained
(T2
)
27053 and then Base_Type
(T1
) = Base_Type
(T2
)
27057 -- For now don't bother with case of identical constraints, to be
27058 -- fiddled with later on perhaps (this is only used for optimization
27059 -- purposes, so it is not critical to do a best possible job)
27070 function Same_Value
(Node1
, Node2
: Node_Id
) return Boolean is
27072 if Compile_Time_Known_Value
(Node1
)
27073 and then Compile_Time_Known_Value
(Node2
)
27075 -- Handle properly compile-time expressions that are not
27078 if Is_String_Type
(Etype
(Node1
)) then
27079 return Expr_Value_S
(Node1
) = Expr_Value_S
(Node2
);
27082 return Expr_Value
(Node1
) = Expr_Value
(Node2
);
27085 elsif Same_Object
(Node1
, Node2
) then
27092 --------------------
27093 -- Set_SPARK_Mode --
27094 --------------------
27096 procedure Set_SPARK_Mode
(Context
: Entity_Id
) is
27098 -- Do not consider illegal or partially decorated constructs
27100 if Ekind
(Context
) = E_Void
or else Error_Posted
(Context
) then
27103 elsif Present
(SPARK_Pragma
(Context
)) then
27105 (Mode
=> Get_SPARK_Mode_From_Annotation
(SPARK_Pragma
(Context
)),
27106 Prag
=> SPARK_Pragma
(Context
));
27108 end Set_SPARK_Mode
;
27110 -------------------------
27111 -- Scalar_Part_Present --
27112 -------------------------
27114 function Scalar_Part_Present
(Typ
: Entity_Id
) return Boolean is
27115 Val_Typ
: constant Entity_Id
:= Validated_View
(Typ
);
27119 if Is_Scalar_Type
(Val_Typ
) then
27122 elsif Is_Array_Type
(Val_Typ
) then
27123 return Scalar_Part_Present
(Component_Type
(Val_Typ
));
27125 elsif Is_Record_Type
(Val_Typ
) then
27126 Field
:= First_Component_Or_Discriminant
(Val_Typ
);
27127 while Present
(Field
) loop
27128 if Scalar_Part_Present
(Etype
(Field
)) then
27132 Next_Component_Or_Discriminant
(Field
);
27137 end Scalar_Part_Present
;
27139 ------------------------
27140 -- Scope_Is_Transient --
27141 ------------------------
27143 function Scope_Is_Transient
return Boolean is
27145 return Scope_Stack
.Table
(Scope_Stack
.Last
).Is_Transient
;
27146 end Scope_Is_Transient
;
27152 function Scope_Within
27153 (Inner
: Entity_Id
;
27154 Outer
: Entity_Id
) return Boolean
27160 while Present
(Curr
) and then Curr
/= Standard_Standard
loop
27161 Curr
:= Scope
(Curr
);
27163 if Curr
= Outer
then
27166 -- A selective accept body appears within a task type, but the
27167 -- enclosing subprogram is the procedure of the task body.
27169 elsif Ekind
(Implementation_Base_Type
(Curr
)) = E_Task_Type
27171 Outer
= Task_Body_Procedure
(Implementation_Base_Type
(Curr
))
27175 -- Ditto for the body of a protected operation
27177 elsif Is_Subprogram
(Curr
)
27178 and then Outer
= Protected_Body_Subprogram
(Curr
)
27182 -- The body of a protected operation is within the protected type
27184 elsif Is_Subprogram
(Curr
)
27185 and then Present
(Protected_Subprogram
(Curr
))
27186 and then Is_Protected_Type
(Outer
)
27187 and then Scope
(Protected_Subprogram
(Curr
)) = Outer
27191 -- Outside of its scope, a synchronized type may just be private
27193 elsif Is_Private_Type
(Curr
)
27194 and then Present
(Full_View
(Curr
))
27195 and then Is_Concurrent_Type
(Full_View
(Curr
))
27197 return Scope_Within
(Full_View
(Curr
), Outer
);
27204 --------------------------
27205 -- Scope_Within_Or_Same --
27206 --------------------------
27208 function Scope_Within_Or_Same
27209 (Inner
: Entity_Id
;
27210 Outer
: Entity_Id
) return Boolean
27212 Curr
: Entity_Id
:= Inner
;
27215 -- Similar to the above, but check for scope identity first
27217 while Present
(Curr
) and then Curr
/= Standard_Standard
loop
27218 if Curr
= Outer
then
27221 elsif Ekind
(Implementation_Base_Type
(Curr
)) = E_Task_Type
27223 Outer
= Task_Body_Procedure
(Implementation_Base_Type
(Curr
))
27227 elsif Is_Subprogram
(Curr
)
27228 and then Outer
= Protected_Body_Subprogram
(Curr
)
27232 elsif Is_Subprogram
(Curr
)
27233 and then Present
(Protected_Subprogram
(Curr
))
27234 and then Is_Protected_Type
(Outer
)
27235 and then Scope
(Protected_Subprogram
(Curr
)) = Outer
27239 elsif Is_Private_Type
(Curr
)
27240 and then Present
(Full_View
(Curr
))
27242 if Full_View
(Curr
) = Outer
then
27245 return Scope_Within
(Full_View
(Curr
), Outer
);
27249 Curr
:= Scope
(Curr
);
27253 end Scope_Within_Or_Same
;
27255 ------------------------
27256 -- Set_Current_Entity --
27257 ------------------------
27259 -- The given entity is to be set as the currently visible definition of its
27260 -- associated name (i.e. the Node_Id associated with its name). All we have
27261 -- to do is to get the name from the identifier, and then set the
27262 -- associated Node_Id to point to the given entity.
27264 procedure Set_Current_Entity
(E
: Entity_Id
) is
27266 Set_Name_Entity_Id
(Chars
(E
), E
);
27267 end Set_Current_Entity
;
27269 ---------------------------
27270 -- Set_Debug_Info_Needed --
27271 ---------------------------
27273 procedure Set_Debug_Info_Needed
(T
: Entity_Id
) is
27275 procedure Set_Debug_Info_Needed_If_Not_Set
(E
: Entity_Id
);
27276 pragma Inline
(Set_Debug_Info_Needed_If_Not_Set
);
27277 -- Used to set debug info in a related node if not set already
27279 --------------------------------------
27280 -- Set_Debug_Info_Needed_If_Not_Set --
27281 --------------------------------------
27283 procedure Set_Debug_Info_Needed_If_Not_Set
(E
: Entity_Id
) is
27285 if Present
(E
) and then not Needs_Debug_Info
(E
) then
27286 Set_Debug_Info_Needed
(E
);
27288 -- For a private type, indicate that the full view also needs
27289 -- debug information.
27292 and then Is_Private_Type
(E
)
27293 and then Present
(Full_View
(E
))
27295 Set_Debug_Info_Needed
(Full_View
(E
));
27298 end Set_Debug_Info_Needed_If_Not_Set
;
27300 -- Start of processing for Set_Debug_Info_Needed
27303 -- Nothing to do if there is no available entity
27308 -- Nothing to do for an entity with suppressed debug information
27310 elsif Debug_Info_Off
(T
) then
27313 -- Nothing to do for an ignored Ghost entity because the entity will be
27314 -- eliminated from the tree.
27316 elsif Is_Ignored_Ghost_Entity
(T
) then
27319 -- Nothing to do if entity comes from a predefined file. Library files
27320 -- are compiled without debug information, but inlined bodies of these
27321 -- routines may appear in user code, and debug information on them ends
27322 -- up complicating debugging the user code.
27324 elsif In_Inlined_Body
and then In_Predefined_Unit
(T
) then
27325 Set_Needs_Debug_Info
(T
, False);
27328 -- Set flag in entity itself. Note that we will go through the following
27329 -- circuitry even if the flag is already set on T. That's intentional,
27330 -- it makes sure that the flag will be set in subsidiary entities.
27332 Set_Needs_Debug_Info
(T
);
27334 -- Set flag on subsidiary entities if not set already
27336 if Is_Object
(T
) then
27337 Set_Debug_Info_Needed_If_Not_Set
(Etype
(T
));
27339 elsif Is_Type
(T
) then
27340 Set_Debug_Info_Needed_If_Not_Set
(Etype
(T
));
27342 if Is_Record_Type
(T
) then
27344 Ent
: Entity_Id
:= First_Entity
(T
);
27346 while Present
(Ent
) loop
27347 Set_Debug_Info_Needed_If_Not_Set
(Ent
);
27352 -- For a class wide subtype, we also need debug information
27353 -- for the equivalent type.
27355 if Ekind
(T
) = E_Class_Wide_Subtype
then
27356 Set_Debug_Info_Needed_If_Not_Set
(Equivalent_Type
(T
));
27359 elsif Is_Array_Type
(T
) then
27360 Set_Debug_Info_Needed_If_Not_Set
(Component_Type
(T
));
27363 Indx
: Node_Id
:= First_Index
(T
);
27365 while Present
(Indx
) loop
27366 Set_Debug_Info_Needed_If_Not_Set
(Etype
(Indx
));
27371 -- For a packed array type, we also need debug information for
27372 -- the type used to represent the packed array. Conversely, we
27373 -- also need it for the former if we need it for the latter.
27375 if Is_Packed
(T
) then
27376 Set_Debug_Info_Needed_If_Not_Set
(Packed_Array_Impl_Type
(T
));
27379 if Is_Packed_Array_Impl_Type
(T
) then
27380 Set_Debug_Info_Needed_If_Not_Set
(Original_Array_Type
(T
));
27383 elsif Is_Access_Type
(T
) then
27384 Set_Debug_Info_Needed_If_Not_Set
(Directly_Designated_Type
(T
));
27386 elsif Is_Private_Type
(T
) then
27388 FV
: constant Entity_Id
:= Full_View
(T
);
27391 Set_Debug_Info_Needed_If_Not_Set
(FV
);
27393 -- If the full view is itself a derived private type, we need
27394 -- debug information on its underlying type.
27397 and then Is_Private_Type
(FV
)
27398 and then Present
(Underlying_Full_View
(FV
))
27400 Set_Needs_Debug_Info
(Underlying_Full_View
(FV
));
27404 elsif Is_Protected_Type
(T
) then
27405 Set_Debug_Info_Needed_If_Not_Set
(Corresponding_Record_Type
(T
));
27407 elsif Is_Scalar_Type
(T
) then
27409 -- If the subrange bounds are materialized by dedicated constant
27410 -- objects, also include them in the debug info to make sure the
27411 -- debugger can properly use them.
27413 if Present
(Scalar_Range
(T
))
27414 and then Nkind
(Scalar_Range
(T
)) = N_Range
27417 Low_Bnd
: constant Node_Id
:= Type_Low_Bound
(T
);
27418 High_Bnd
: constant Node_Id
:= Type_High_Bound
(T
);
27421 if Is_Entity_Name
(Low_Bnd
) then
27422 Set_Debug_Info_Needed_If_Not_Set
(Entity
(Low_Bnd
));
27425 if Is_Entity_Name
(High_Bnd
) then
27426 Set_Debug_Info_Needed_If_Not_Set
(Entity
(High_Bnd
));
27432 end Set_Debug_Info_Needed
;
27434 --------------------------------
27435 -- Set_Debug_Info_Defining_Id --
27436 --------------------------------
27438 procedure Set_Debug_Info_Defining_Id
(N
: Node_Id
) is
27440 if Comes_From_Source
(Defining_Identifier
(N
))
27441 or else Debug_Generated_Code
27443 Set_Debug_Info_Needed
(Defining_Identifier
(N
));
27445 end Set_Debug_Info_Defining_Id
;
27447 ----------------------------
27448 -- Set_Entity_With_Checks --
27449 ----------------------------
27451 procedure Set_Entity_With_Checks
(N
: Node_Id
; Val
: Entity_Id
) is
27452 Val_Actual
: Entity_Id
;
27454 Post_Node
: Node_Id
;
27457 -- Unconditionally set the entity
27459 Set_Entity
(N
, Val
);
27461 -- The node to post on is the selector in the case of an expanded name,
27462 -- and otherwise the node itself.
27464 if Nkind
(N
) = N_Expanded_Name
then
27465 Post_Node
:= Selector_Name
(N
);
27470 -- Check for violation of No_Fixed_IO
27472 if Restriction_Check_Required
(No_Fixed_IO
)
27474 ((RTU_Loaded
(Ada_Text_IO
)
27475 and then (Is_RTE
(Val
, RE_Decimal_IO
)
27477 Is_RTE
(Val
, RE_Fixed_IO
)))
27480 (RTU_Loaded
(Ada_Wide_Text_IO
)
27481 and then (Is_RTE
(Val
, RO_WT_Decimal_IO
)
27483 Is_RTE
(Val
, RO_WT_Fixed_IO
)))
27486 (RTU_Loaded
(Ada_Wide_Wide_Text_IO
)
27487 and then (Is_RTE
(Val
, RO_WW_Decimal_IO
)
27489 Is_RTE
(Val
, RO_WW_Fixed_IO
))))
27491 -- A special extra check, don't complain about a reference from within
27492 -- the Ada.Interrupts package itself!
27494 and then not In_Same_Extended_Unit
(N
, Val
)
27496 Check_Restriction
(No_Fixed_IO
, Post_Node
);
27499 -- Remaining checks are only done on source nodes. Note that we test
27500 -- for violation of No_Fixed_IO even on non-source nodes, because the
27501 -- cases for checking violations of this restriction are instantiations
27502 -- where the reference in the instance has Comes_From_Source False.
27504 if not Comes_From_Source
(N
) then
27508 -- Check for violation of No_Abort_Statements, which is triggered by
27509 -- call to Ada.Task_Identification.Abort_Task.
27511 if Restriction_Check_Required
(No_Abort_Statements
)
27512 and then Is_RTE
(Val
, RE_Abort_Task
)
27514 -- A special extra check, don't complain about a reference from within
27515 -- the Ada.Task_Identification package itself!
27517 and then not In_Same_Extended_Unit
(N
, Val
)
27519 Check_Restriction
(No_Abort_Statements
, Post_Node
);
27522 if Val
= Standard_Long_Long_Integer
then
27523 Check_Restriction
(No_Long_Long_Integers
, Post_Node
);
27526 -- Check for violation of No_Dynamic_Attachment
27528 if Restriction_Check_Required
(No_Dynamic_Attachment
)
27529 and then RTU_Loaded
(Ada_Interrupts
)
27530 and then (Is_RTE
(Val
, RE_Is_Reserved
) or else
27531 Is_RTE
(Val
, RE_Is_Attached
) or else
27532 Is_RTE
(Val
, RE_Current_Handler
) or else
27533 Is_RTE
(Val
, RE_Attach_Handler
) or else
27534 Is_RTE
(Val
, RE_Exchange_Handler
) or else
27535 Is_RTE
(Val
, RE_Detach_Handler
) or else
27536 Is_RTE
(Val
, RE_Reference
))
27538 -- A special extra check, don't complain about a reference from within
27539 -- the Ada.Interrupts package itself!
27541 and then not In_Same_Extended_Unit
(N
, Val
)
27543 Check_Restriction
(No_Dynamic_Attachment
, Post_Node
);
27546 -- Check for No_Implementation_Identifiers
27548 if Restriction_Check_Required
(No_Implementation_Identifiers
) then
27550 -- We have an implementation defined entity if it is marked as
27551 -- implementation defined, or is defined in a package marked as
27552 -- implementation defined. However, library packages themselves
27553 -- are excluded (we don't want to flag Interfaces itself, just
27554 -- the entities within it).
27556 if (Is_Implementation_Defined
(Val
)
27558 (Present
(Scope
(Val
))
27559 and then Is_Implementation_Defined
(Scope
(Val
))))
27560 and then not (Is_Package_Or_Generic_Package
(Val
)
27561 and then Is_Library_Level_Entity
(Val
))
27563 Check_Restriction
(No_Implementation_Identifiers
, Post_Node
);
27567 -- Do the style check
27570 and then not Suppress_Style_Checks
(Val
)
27571 and then not In_Instance
27573 if Nkind
(N
) = N_Identifier
then
27575 elsif Nkind
(N
) = N_Expanded_Name
then
27576 Nod
:= Selector_Name
(N
);
27581 -- A special situation arises for derived operations, where we want
27582 -- to do the check against the parent (since the Sloc of the derived
27583 -- operation points to the derived type declaration itself).
27586 while not Comes_From_Source
(Val_Actual
)
27587 and then Nkind
(Val_Actual
) in N_Entity
27588 and then (Ekind
(Val_Actual
) = E_Enumeration_Literal
27589 or else Is_Subprogram_Or_Generic_Subprogram
(Val_Actual
))
27590 and then Present
(Alias
(Val_Actual
))
27592 Val_Actual
:= Alias
(Val_Actual
);
27595 -- Renaming declarations for generic actuals do not come from source,
27596 -- and have a different name from that of the entity they rename, so
27597 -- there is no style check to perform here.
27599 if Chars
(Nod
) = Chars
(Val_Actual
) then
27600 Style
.Check_Identifier
(Nod
, Val_Actual
);
27603 end Set_Entity_With_Checks
;
27605 ------------------------------
27606 -- Set_Invalid_Scalar_Value --
27607 ------------------------------
27609 procedure Set_Invalid_Scalar_Value
27610 (Scal_Typ
: Float_Scalar_Id
;
27613 Slot
: Ureal
renames Invalid_Floats
(Scal_Typ
);
27616 -- Detect an attempt to set a different value for the same scalar type
27618 pragma Assert
(Slot
= No_Ureal
);
27620 end Set_Invalid_Scalar_Value
;
27622 ------------------------------
27623 -- Set_Invalid_Scalar_Value --
27624 ------------------------------
27626 procedure Set_Invalid_Scalar_Value
27627 (Scal_Typ
: Integer_Scalar_Id
;
27630 Slot
: Uint
renames Invalid_Integers
(Scal_Typ
);
27633 -- Detect an attempt to set a different value for the same scalar type
27635 pragma Assert
(No
(Slot
));
27637 end Set_Invalid_Scalar_Value
;
27639 ------------------------
27640 -- Set_Name_Entity_Id --
27641 ------------------------
27643 procedure Set_Name_Entity_Id
(Id
: Name_Id
; Val
: Entity_Id
) is
27645 Set_Name_Table_Int
(Id
, Int
(Val
));
27646 end Set_Name_Entity_Id
;
27648 ---------------------
27649 -- Set_Next_Actual --
27650 ---------------------
27652 procedure Set_Next_Actual
(Ass1_Id
: Node_Id
; Ass2_Id
: Node_Id
) is
27654 if Nkind
(Parent
(Ass1_Id
)) = N_Parameter_Association
then
27655 Set_First_Named_Actual
(Parent
(Ass1_Id
), Ass2_Id
);
27657 end Set_Next_Actual
;
27659 ----------------------------------
27660 -- Set_Optimize_Alignment_Flags --
27661 ----------------------------------
27663 procedure Set_Optimize_Alignment_Flags
(E
: Entity_Id
) is
27665 if Optimize_Alignment
= 'S' then
27666 Set_Optimize_Alignment_Space
(E
);
27667 elsif Optimize_Alignment
= 'T' then
27668 Set_Optimize_Alignment_Time
(E
);
27670 end Set_Optimize_Alignment_Flags
;
27672 -----------------------
27673 -- Set_Public_Status --
27674 -----------------------
27676 procedure Set_Public_Status
(Id
: Entity_Id
) is
27677 S
: constant Entity_Id
:= Current_Scope
;
27679 function Within_HSS_Or_If
(E
: Entity_Id
) return Boolean;
27680 -- Determines if E is defined within handled statement sequence or
27681 -- an if statement, returns True if so, False otherwise.
27683 ----------------------
27684 -- Within_HSS_Or_If --
27685 ----------------------
27687 function Within_HSS_Or_If
(E
: Entity_Id
) return Boolean is
27690 N
:= Declaration_Node
(E
);
27698 N_Handled_Sequence_Of_Statements | N_If_Statement
27703 end Within_HSS_Or_If
;
27705 -- Start of processing for Set_Public_Status
27708 -- Everything in the scope of Standard is public
27710 if S
= Standard_Standard
then
27711 Set_Is_Public
(Id
);
27713 -- Entity is definitely not public if enclosing scope is not public
27715 elsif not Is_Public
(S
) then
27718 -- An object or function declaration that occurs in a handled sequence
27719 -- of statements or within an if statement is the declaration for a
27720 -- temporary object or local subprogram generated by the expander. It
27721 -- never needs to be made public and furthermore, making it public can
27722 -- cause back end problems.
27724 elsif Nkind
(Parent
(Id
)) in
27725 N_Object_Declaration | N_Function_Specification
27726 and then Within_HSS_Or_If
(Id
)
27730 -- Entities in public packages or records are public
27732 elsif Ekind
(S
) = E_Package
or Is_Record_Type
(S
) then
27733 Set_Is_Public
(Id
);
27735 -- The bounds of an entry family declaration can generate object
27736 -- declarations that are visible to the back-end, e.g. in the
27737 -- the declaration of a composite type that contains tasks.
27739 elsif Is_Concurrent_Type
(S
)
27740 and then not Has_Completion
(S
)
27741 and then Nkind
(Parent
(Id
)) = N_Object_Declaration
27743 Set_Is_Public
(Id
);
27745 end Set_Public_Status
;
27747 -----------------------------
27748 -- Set_Referenced_Modified --
27749 -----------------------------
27751 procedure Set_Referenced_Modified
(N
: Node_Id
; Out_Param
: Boolean) is
27755 -- Deal with indexed or selected component where prefix is modified
27757 if Nkind
(N
) in N_Indexed_Component | N_Selected_Component
then
27758 Pref
:= Prefix
(N
);
27760 -- If prefix is access type, then it is the designated object that is
27761 -- being modified, which means we have no entity to set the flag on.
27763 if No
(Etype
(Pref
)) or else Is_Access_Type
(Etype
(Pref
)) then
27766 -- Otherwise chase the prefix
27769 Set_Referenced_Modified
(Pref
, Out_Param
);
27772 -- Otherwise see if we have an entity name (only other case to process)
27774 elsif Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
27775 Set_Referenced_As_LHS
(Entity
(N
), not Out_Param
);
27776 Set_Referenced_As_Out_Parameter
(Entity
(N
), Out_Param
);
27778 end Set_Referenced_Modified
;
27784 procedure Set_Rep_Info
(T1
: Entity_Id
; T2
: Entity_Id
) is
27786 Set_Is_Atomic
(T1
, Is_Atomic
(T2
));
27787 Set_Is_Independent
(T1
, Is_Independent
(T2
));
27788 Set_Is_Volatile_Full_Access
(T1
, Is_Volatile_Full_Access
(T2
));
27790 if Is_Base_Type
(T1
) then
27791 Set_Is_Volatile
(T1
, Is_Volatile
(T2
));
27795 -------------------
27796 -- Set_Size_Info --
27797 -------------------
27799 procedure Set_Size_Info
(T1
, T2
: Entity_Id
) is
27801 -- We copy Esize, but not RM_Size, since in general RM_Size is
27802 -- subtype specific and does not get inherited by all subtypes.
27804 Copy_Esize
(To
=> T1
, From
=> T2
);
27805 Set_Has_Biased_Representation
(T1
, Has_Biased_Representation
(T2
));
27807 if Is_Discrete_Or_Fixed_Point_Type
(T1
)
27809 Is_Discrete_Or_Fixed_Point_Type
(T2
)
27811 Set_Is_Unsigned_Type
(T1
, Is_Unsigned_Type
(T2
));
27814 Copy_Alignment
(To
=> T1
, From
=> T2
);
27817 ------------------------------
27818 -- Should_Ignore_Pragma_Par --
27819 ------------------------------
27821 function Should_Ignore_Pragma_Par
(Prag_Name
: Name_Id
) return Boolean is
27822 pragma Assert
(Compiler_State
= Parsing
);
27823 -- This one can't work during semantic analysis, because we don't have a
27824 -- correct Current_Source_File.
27826 Result
: constant Boolean :=
27827 Get_Name_Table_Boolean3
(Prag_Name
)
27828 and then not Is_Internal_File_Name
27829 (File_Name
(Current_Source_File
));
27832 end Should_Ignore_Pragma_Par
;
27834 ------------------------------
27835 -- Should_Ignore_Pragma_Sem --
27836 ------------------------------
27838 function Should_Ignore_Pragma_Sem
(N
: Node_Id
) return Boolean is
27839 pragma Assert
(Compiler_State
= Analyzing
);
27840 Prag_Name
: constant Name_Id
:= Pragma_Name
(N
);
27841 Result
: constant Boolean :=
27842 Get_Name_Table_Boolean3
(Prag_Name
)
27843 and then not In_Internal_Unit
(N
);
27847 end Should_Ignore_Pragma_Sem
;
27849 --------------------
27850 -- Static_Boolean --
27851 --------------------
27853 function Static_Boolean
(N
: Node_Id
) return Opt_Ubool
is
27855 Analyze_And_Resolve
(N
, Standard_Boolean
);
27858 or else Error_Posted
(N
)
27859 or else Etype
(N
) = Any_Type
27864 if Is_OK_Static_Expression
(N
) then
27865 if not Raises_Constraint_Error
(N
) then
27866 return Expr_Value
(N
);
27871 elsif Etype
(N
) = Any_Type
then
27875 Flag_Non_Static_Expr
27876 ("static boolean expression required here", N
);
27879 end Static_Boolean
;
27881 --------------------
27882 -- Static_Integer --
27883 --------------------
27885 function Static_Integer
(N
: Node_Id
) return Uint
is
27887 Analyze_And_Resolve
(N
, Any_Integer
);
27890 or else Error_Posted
(N
)
27891 or else Etype
(N
) = Any_Type
27896 if Is_OK_Static_Expression
(N
) then
27897 if not Raises_Constraint_Error
(N
) then
27898 return Expr_Value
(N
);
27903 elsif Etype
(N
) = Any_Type
then
27907 Flag_Non_Static_Expr
27908 ("static integer expression required here", N
);
27911 end Static_Integer
;
27913 -------------------------------
27914 -- Statically_Denotes_Entity --
27915 -------------------------------
27917 function Statically_Denotes_Entity
(N
: Node_Id
) return Boolean is
27920 if not Is_Entity_Name
(N
) then
27927 Nkind
(Parent
(E
)) /= N_Object_Renaming_Declaration
27928 or else Is_Prival
(E
)
27929 or else Statically_Denotes_Entity
(Renamed_Object
(E
));
27930 end Statically_Denotes_Entity
;
27932 -------------------------------
27933 -- Statically_Denotes_Object --
27934 -------------------------------
27936 function Statically_Denotes_Object
(N
: Node_Id
) return Boolean is
27938 return Statically_Denotes_Entity
(N
)
27939 and then Is_Object_Reference
(N
);
27940 end Statically_Denotes_Object
;
27942 --------------------------
27943 -- Statically_Different --
27944 --------------------------
27946 function Statically_Different
(E1
, E2
: Node_Id
) return Boolean is
27947 R1
: constant Node_Id
:= Get_Referenced_Object
(E1
);
27948 R2
: constant Node_Id
:= Get_Referenced_Object
(E2
);
27950 return Is_Entity_Name
(R1
)
27951 and then Is_Entity_Name
(R2
)
27952 and then Entity
(R1
) /= Entity
(R2
)
27953 and then not Is_Formal
(Entity
(R1
))
27954 and then not Is_Formal
(Entity
(R2
));
27955 end Statically_Different
;
27957 -----------------------------
27958 -- Statically_Names_Object --
27959 -----------------------------
27961 function Statically_Names_Object
(N
: Node_Id
) return Boolean is
27963 if Statically_Denotes_Object
(N
) then
27965 elsif Is_Entity_Name
(N
) then
27967 E
: constant Entity_Id
:= Entity
(N
);
27969 return Nkind
(Parent
(E
)) = N_Object_Renaming_Declaration
27970 and then Statically_Names_Object
(Renamed_Object
(E
));
27975 when N_Indexed_Component
=>
27976 if Is_Access_Type
(Etype
(Prefix
(N
))) then
27977 -- treat implicit dereference same as explicit
27981 if not Is_Constrained
(Etype
(Prefix
(N
))) then
27986 Indx
: Node_Id
:= First_Index
(Etype
(Prefix
(N
)));
27987 Expr
: Node_Id
:= First
(Expressions
(N
));
27988 Index_Subtype
: Node_Id
;
27991 Index_Subtype
:= Etype
(Indx
);
27993 if not Is_Static_Subtype
(Index_Subtype
) then
27996 if not Is_OK_Static_Expression
(Expr
) then
28001 Index_Value
: constant Uint
:= Expr_Value
(Expr
);
28002 Low_Value
: constant Uint
:=
28003 Expr_Value
(Type_Low_Bound
(Index_Subtype
));
28004 High_Value
: constant Uint
:=
28005 Expr_Value
(Type_High_Bound
(Index_Subtype
));
28007 if Index_Value
< Low_Value
28008 or Index_Value
> High_Value
28015 Expr
:= Next
(Expr
);
28016 pragma Assert
(Present
(Indx
) = Present
(Expr
)
28017 or else Serious_Errors_Detected
> 0);
28018 exit when not (Present
(Indx
) and Present
(Expr
));
28022 when N_Selected_Component
=>
28023 if Is_Access_Type
(Etype
(Prefix
(N
))) then
28024 -- treat implicit dereference same as explicit
28028 if Ekind
(Entity
(Selector_Name
(N
))) not in
28029 E_Component | E_Discriminant
28035 Comp
: constant Entity_Id
:=
28036 Original_Record_Component
(Entity
(Selector_Name
(N
)));
28038 -- AI12-0373 confirms that we should not call
28039 -- Has_Discriminant_Dependent_Constraint here which would be
28042 if Is_Declared_Within_Variant
(Comp
) then
28047 when others => -- includes N_Slice, N_Explicit_Dereference
28051 pragma Assert
(Present
(Prefix
(N
)));
28053 return Statically_Names_Object
(Prefix
(N
));
28054 end Statically_Names_Object
;
28056 ---------------------------------
28057 -- String_From_Numeric_Literal --
28058 ---------------------------------
28060 function String_From_Numeric_Literal
(N
: Node_Id
) return String_Id
is
28061 Loc
: constant Source_Ptr
:= Sloc
(N
);
28062 Sbuffer
: constant Source_Buffer_Ptr
:=
28063 Source_Text
(Get_Source_File_Index
(Loc
));
28064 Src_Ptr
: Source_Ptr
:= Loc
;
28066 C
: Character := Sbuffer
(Src_Ptr
);
28067 -- Current source program character
28069 function Belongs_To_Numeric_Literal
(C
: Character) return Boolean;
28070 -- Return True if C belongs to the numeric literal
28072 --------------------------------
28073 -- Belongs_To_Numeric_Literal --
28074 --------------------------------
28076 function Belongs_To_Numeric_Literal
(C
: Character) return Boolean is
28079 when '0' .. '9' |
'_' |
'.' |
'e' |
'#' |
'A' .. 'F' =>
28082 -- Make sure '+' or '-' is part of an exponent
28086 Prev_C
: constant Character := Sbuffer
(Src_Ptr
- 1);
28088 return Prev_C
in 'e' |
'E';
28091 -- Other characters cannot belong to a numeric literal
28096 end Belongs_To_Numeric_Literal
;
28098 -- Start of processing for String_From_Numeric_Literal
28102 while Belongs_To_Numeric_Literal
(C
) loop
28103 Store_String_Char
(C
);
28104 Src_Ptr
:= Src_Ptr
+ 1;
28105 C
:= Sbuffer
(Src_Ptr
);
28109 end String_From_Numeric_Literal
;
28111 --------------------------------------
28112 -- Subject_To_Loop_Entry_Attributes --
28113 --------------------------------------
28115 function Subject_To_Loop_Entry_Attributes
(N
: Node_Id
) return Boolean is
28121 -- The expansion mechanism transform a loop subject to at least one
28122 -- 'Loop_Entry attribute into a conditional block. Infinite loops lack
28123 -- the conditional part.
28125 if Nkind
(Stmt
) in N_Block_Statement | N_If_Statement
28126 and then Nkind
(Original_Node
(N
)) = N_Loop_Statement
28128 Stmt
:= Original_Node
(N
);
28132 Nkind
(Stmt
) = N_Loop_Statement
28133 and then Present
(Identifier
(Stmt
))
28134 and then Present
(Entity
(Identifier
(Stmt
)))
28135 and then Has_Loop_Entry_Attributes
(Entity
(Identifier
(Stmt
)));
28136 end Subject_To_Loop_Entry_Attributes
;
28138 ---------------------
28139 -- Subprogram_Name --
28140 ---------------------
28142 function Subprogram_Name
(N
: Node_Id
) return String is
28143 Buf
: Bounded_String
;
28144 Ent
: Node_Id
:= N
;
28148 while Present
(Ent
) loop
28149 case Nkind
(Ent
) is
28150 when N_Subprogram_Body
=>
28151 Ent
:= Defining_Unit_Name
(Specification
(Ent
));
28154 when N_Subprogram_Declaration
=>
28155 Nod
:= Corresponding_Body
(Ent
);
28157 if Present
(Nod
) then
28160 Ent
:= Defining_Unit_Name
(Specification
(Ent
));
28165 when N_Subprogram_Instantiation
28167 | N_Package_Specification
28169 Ent
:= Defining_Unit_Name
(Ent
);
28172 when N_Protected_Type_Declaration
=>
28173 Ent
:= Corresponding_Body
(Ent
);
28176 when N_Protected_Body
28179 Ent
:= Defining_Identifier
(Ent
);
28189 Ent
:= Parent
(Ent
);
28193 return "unknown subprogram:unknown file:0:0";
28196 -- If the subprogram is a child unit, use its simple name to start the
28197 -- construction of the fully qualified name.
28199 if Nkind
(Ent
) = N_Defining_Program_Unit_Name
then
28200 Ent
:= Defining_Identifier
(Ent
);
28203 Append_Entity_Name
(Buf
, Ent
);
28205 -- Append homonym number if needed
28207 if Nkind
(N
) in N_Entity
and then Has_Homonym
(N
) then
28209 H
: Entity_Id
:= Homonym
(N
);
28213 while Present
(H
) loop
28214 if Scope
(H
) = Scope
(N
) then
28228 -- Append source location of Ent to Buf so that the string will
28229 -- look like "subp:file:line:col".
28232 Loc
: constant Source_Ptr
:= Sloc
(Ent
);
28235 Append
(Buf
, Reference_Name
(Get_Source_File_Index
(Loc
)));
28237 Append
(Buf
, Nat
(Get_Logical_Line_Number
(Loc
)));
28239 Append
(Buf
, Nat
(Get_Column_Number
(Loc
)));
28243 end Subprogram_Name
;
28245 -------------------------------
28246 -- Support_Atomic_Primitives --
28247 -------------------------------
28249 function Support_Atomic_Primitives
(Typ
: Entity_Id
) return Boolean is
28253 -- Verify the alignment of Typ is known
28255 if not Known_Alignment
(Typ
) then
28259 if Known_Static_Esize
(Typ
) then
28260 Size
:= UI_To_Int
(Esize
(Typ
));
28262 -- If the Esize (Object_Size) is unknown at compile time, look at the
28263 -- RM_Size (Value_Size) which may have been set by an explicit rep item.
28265 elsif Known_Static_RM_Size
(Typ
) then
28266 Size
:= UI_To_Int
(RM_Size
(Typ
));
28268 -- Otherwise, the size is considered to be unknown.
28274 -- Check that the size of the component is 8, 16, 32, or 64 bits and
28275 -- that Typ is properly aligned.
28278 when 8 |
16 |
32 |
64 =>
28279 return Size
= UI_To_Int
(Alignment
(Typ
)) * 8;
28284 end Support_Atomic_Primitives
;
28290 procedure Trace_Scope
(N
: Node_Id
; E
: Entity_Id
; Msg
: String) is
28292 if Debug_Flag_W
then
28293 for J
in 0 .. Scope_Stack
.Last
loop
28298 Write_Name
(Chars
(E
));
28299 Write_Str
(" from ");
28300 Write_Location
(Sloc
(N
));
28305 -----------------------
28306 -- Transfer_Entities --
28307 -----------------------
28309 procedure Transfer_Entities
(From
: Entity_Id
; To
: Entity_Id
) is
28310 procedure Set_Public_Status_Of
(Id
: Entity_Id
);
28311 -- Set the Is_Public attribute of arbitrary entity Id by calling routine
28312 -- Set_Public_Status. If successful and Id denotes a record type, set
28313 -- the Is_Public attribute of its fields.
28315 --------------------------
28316 -- Set_Public_Status_Of --
28317 --------------------------
28319 procedure Set_Public_Status_Of
(Id
: Entity_Id
) is
28323 if not Is_Public
(Id
) then
28324 Set_Public_Status
(Id
);
28326 -- When the input entity is a public record type, ensure that all
28327 -- its internal fields are also exposed to the linker. The fields
28328 -- of a class-wide type are never made public.
28331 and then Is_Record_Type
(Id
)
28332 and then not Is_Class_Wide_Type
(Id
)
28334 Field
:= First_Entity
(Id
);
28335 while Present
(Field
) loop
28336 Set_Is_Public
(Field
);
28337 Next_Entity
(Field
);
28341 end Set_Public_Status_Of
;
28345 Full_Id
: Entity_Id
;
28348 -- Start of processing for Transfer_Entities
28351 Id
:= First_Entity
(From
);
28353 if Present
(Id
) then
28355 -- Merge the entity chain of the source scope with that of the
28356 -- destination scope.
28358 if Present
(Last_Entity
(To
)) then
28359 Link_Entities
(Last_Entity
(To
), Id
);
28361 Set_First_Entity
(To
, Id
);
28364 Set_Last_Entity
(To
, Last_Entity
(From
));
28366 -- Inspect the entities of the source scope and update their Scope
28369 while Present
(Id
) loop
28370 Set_Scope
(Id
, To
);
28371 Set_Public_Status_Of
(Id
);
28373 -- Handle an internally generated full view for a private type
28375 if Is_Private_Type
(Id
)
28376 and then Present
(Full_View
(Id
))
28377 and then Is_Itype
(Full_View
(Id
))
28379 Full_Id
:= Full_View
(Id
);
28381 Set_Scope
(Full_Id
, To
);
28382 Set_Public_Status_Of
(Full_Id
);
28388 Set_First_Entity
(From
, Empty
);
28389 Set_Last_Entity
(From
, Empty
);
28391 end Transfer_Entities
;
28393 ------------------------
28394 -- Traverse_More_Func --
28395 ------------------------
28397 function Traverse_More_Func
(Node
: Node_Id
) return Traverse_Final_Result
is
28399 Processing_Itype
: Boolean := False;
28400 -- Set to True while traversing the nodes under an Itype, to prevent
28401 -- looping on Itype handling during that traversal.
28403 function Process_More
(N
: Node_Id
) return Traverse_Result
;
28404 -- Wrapper over the Process callback to handle parts of the AST that
28405 -- are not normally traversed as syntactic children.
28407 function Traverse_Rec
(N
: Node_Id
) return Traverse_Final_Result
;
28408 -- Main recursive traversal implemented as an instantiation of
28409 -- Traverse_Func over a modified Process callback.
28415 function Process_More
(N
: Node_Id
) return Traverse_Result
is
28417 procedure Traverse_More
(N
: Node_Id
;
28418 Res
: in out Traverse_Result
);
28419 procedure Traverse_More
(L
: List_Id
;
28420 Res
: in out Traverse_Result
);
28421 -- Traverse a node or list and update the traversal result to value
28422 -- Abandon when needed.
28424 -------------------
28425 -- Traverse_More --
28426 -------------------
28428 procedure Traverse_More
(N
: Node_Id
;
28429 Res
: in out Traverse_Result
)
28432 -- Do not process any more nodes if Abandon was reached
28434 if Res
= Abandon
then
28438 if Traverse_Rec
(N
) = Abandon
then
28443 procedure Traverse_More
(L
: List_Id
;
28444 Res
: in out Traverse_Result
)
28446 N
: Node_Id
:= First
(L
);
28449 -- Do not process any more nodes if Abandon was reached
28451 if Res
= Abandon
then
28455 while Present
(N
) loop
28456 Traverse_More
(N
, Res
);
28464 Result
: Traverse_Result
;
28466 -- Start of processing for Process_More
28469 -- Initial callback to Process. Return immediately on Skip/Abandon.
28470 -- Otherwise update the value of Node for further processing of
28471 -- non-syntactic children.
28473 Result
:= Process
(N
);
28476 when OK
=> Node
:= N
;
28477 when OK_Orig
=> Node
:= Original_Node
(N
);
28478 when Skip
=> return Skip
;
28479 when Abandon
=> return Abandon
;
28482 -- Process the relevant semantic children which are a logical part of
28483 -- the AST under this node before returning for the processing of
28484 -- syntactic children.
28486 -- Start with all non-syntactic lists of action nodes
28488 case Nkind
(Node
) is
28489 when N_Component_Association
=>
28490 Traverse_More
(Loop_Actions
(Node
), Result
);
28492 when N_Elsif_Part
=>
28493 Traverse_More
(Condition_Actions
(Node
), Result
);
28495 when N_Short_Circuit
=>
28496 Traverse_More
(Actions
(Node
), Result
);
28498 when N_Case_Expression_Alternative
=>
28499 Traverse_More
(Actions
(Node
), Result
);
28501 when N_Iterated_Component_Association
=>
28502 Traverse_More
(Loop_Actions
(Node
), Result
);
28504 when N_Iterated_Element_Association
=>
28505 Traverse_More
(Loop_Actions
(Node
), Result
);
28507 when N_Iteration_Scheme
=>
28508 Traverse_More
(Condition_Actions
(Node
), Result
);
28510 when N_If_Expression
=>
28511 Traverse_More
(Then_Actions
(Node
), Result
);
28512 Traverse_More
(Else_Actions
(Node
), Result
);
28514 -- Various nodes have a field Actions as a syntactic node,
28515 -- so it will be traversed in the regular syntactic traversal.
28517 when N_Compilation_Unit_Aux
28518 | N_Compound_Statement
28519 | N_Expression_With_Actions
28528 -- If Process_Itypes is True, process unattached nodes which come
28529 -- from Itypes. This only concerns currently ranges of scalar
28530 -- (possibly as index) types. This traversal is protected against
28531 -- looping with Processing_Itype.
28534 and then not Processing_Itype
28535 and then Nkind
(Node
) in N_Has_Etype
28536 and then Present
(Etype
(Node
))
28537 and then Is_Itype
(Etype
(Node
))
28540 Typ
: constant Entity_Id
:= Etype
(Node
);
28542 Processing_Itype
:= True;
28544 case Ekind
(Typ
) is
28545 when Scalar_Kind
=>
28546 Traverse_More
(Scalar_Range
(Typ
), Result
);
28550 Index
: Node_Id
:= First_Index
(Typ
);
28553 while Present
(Index
) loop
28554 if Nkind
(Index
) in N_Has_Entity
then
28555 Rng
:= Scalar_Range
(Entity
(Index
));
28560 Traverse_More
(Rng
, Result
);
28561 Next_Index
(Index
);
28568 Processing_Itype
:= False;
28575 -- Define Traverse_Rec as a renaming of the instantiation, as an
28576 -- instantiation cannot complete a previous spec.
28578 function Traverse_Recursive
is new Traverse_Func
(Process_More
);
28579 function Traverse_Rec
(N
: Node_Id
) return Traverse_Final_Result
28580 renames Traverse_Recursive
;
28582 -- Start of processing for Traverse_More_Func
28585 return Traverse_Rec
(Node
);
28586 end Traverse_More_Func
;
28588 ------------------------
28589 -- Traverse_More_Proc --
28590 ------------------------
28592 procedure Traverse_More_Proc
(Node
: Node_Id
) is
28593 function Traverse
is new Traverse_More_Func
(Process
, Process_Itypes
);
28594 Discard
: Traverse_Final_Result
;
28595 pragma Warnings
(Off
, Discard
);
28597 Discard
:= Traverse
(Node
);
28598 end Traverse_More_Proc
;
28600 ------------------------------------
28601 -- Type_Without_Stream_Operation --
28602 ------------------------------------
28604 function Type_Without_Stream_Operation
28606 Op
: TSS_Name_Type
:= TSS_Null
) return Entity_Id
28608 BT
: constant Entity_Id
:= Base_Type
(T
);
28609 Op_Missing
: Boolean;
28612 if not Restriction_Active
(No_Default_Stream_Attributes
) then
28616 if Is_Elementary_Type
(T
) then
28617 if Op
= TSS_Null
then
28619 No
(TSS
(BT
, TSS_Stream_Read
))
28620 or else No
(TSS
(BT
, TSS_Stream_Write
));
28623 Op_Missing
:= No
(TSS
(BT
, Op
));
28632 elsif Is_Array_Type
(T
) then
28633 return Type_Without_Stream_Operation
(Component_Type
(T
), Op
);
28635 elsif Is_Record_Type
(T
) then
28641 Comp
:= First_Component
(T
);
28642 while Present
(Comp
) loop
28643 C_Typ
:= Type_Without_Stream_Operation
(Etype
(Comp
), Op
);
28645 if Present
(C_Typ
) then
28649 Next_Component
(Comp
);
28655 elsif Is_Private_Type
(T
) and then Present
(Full_View
(T
)) then
28656 return Type_Without_Stream_Operation
(Full_View
(T
), Op
);
28660 end Type_Without_Stream_Operation
;
28662 ------------------------------
28663 -- Ultimate_Overlaid_Entity --
28664 ------------------------------
28666 function Ultimate_Overlaid_Entity
(E
: Entity_Id
) return Entity_Id
is
28668 Alias
: Entity_Id
:= E
;
28672 -- Currently this routine is only called for stand-alone objects that
28673 -- have been analysed, since the analysis of the Address aspect is often
28676 pragma Assert
(Ekind
(E
) in E_Constant | E_Variable
);
28679 Address
:= Address_Clause
(Alias
);
28680 if Present
(Address
) then
28681 Find_Overlaid_Entity
(Address
, Alias
, Offset
);
28682 if Present
(Alias
) then
28687 elsif Alias
= E
then
28693 end Ultimate_Overlaid_Entity
;
28695 ---------------------
28696 -- Ultimate_Prefix --
28697 ---------------------
28699 function Ultimate_Prefix
(N
: Node_Id
) return Node_Id
is
28704 while Nkind
(Pref
) in N_Explicit_Dereference
28705 | N_Indexed_Component
28706 | N_Selected_Component
28709 Pref
:= Prefix
(Pref
);
28713 end Ultimate_Prefix
;
28715 ----------------------------
28716 -- Unique_Defining_Entity --
28717 ----------------------------
28719 function Unique_Defining_Entity
(N
: Node_Id
) return Entity_Id
is
28721 return Unique_Entity
(Defining_Entity
(N
));
28722 end Unique_Defining_Entity
;
28724 -------------------
28725 -- Unique_Entity --
28726 -------------------
28728 function Unique_Entity
(E
: Entity_Id
) return Entity_Id
is
28729 U
: Entity_Id
:= E
;
28735 if Present
(Full_View
(E
)) then
28736 U
:= Full_View
(E
);
28740 if Nkind
(Parent
(E
)) = N_Entry_Body
then
28742 Prot_Item
: Entity_Id
;
28743 Prot_Type
: Entity_Id
;
28746 if Ekind
(E
) = E_Entry
then
28747 Prot_Type
:= Scope
(E
);
28749 -- Bodies of entry families are nested within an extra scope
28750 -- that contains an entry index declaration.
28753 Prot_Type
:= Scope
(Scope
(E
));
28756 -- A protected type may be declared as a private type, in
28757 -- which case we need to get its full view.
28759 if Is_Private_Type
(Prot_Type
) then
28760 Prot_Type
:= Full_View
(Prot_Type
);
28763 -- Full view may not be present on error, in which case
28764 -- return E by default.
28766 if Present
(Prot_Type
) then
28767 pragma Assert
(Ekind
(Prot_Type
) = E_Protected_Type
);
28769 -- Traverse the entity list of the protected type and
28770 -- locate an entry declaration which matches the entry
28773 Prot_Item
:= First_Entity
(Prot_Type
);
28774 while Present
(Prot_Item
) loop
28775 if Ekind
(Prot_Item
) in Entry_Kind
28776 and then Corresponding_Body
(Parent
(Prot_Item
)) = E
28782 Next_Entity
(Prot_Item
);
28788 when Formal_Kind
=>
28789 if Present
(Spec_Entity
(E
)) then
28790 U
:= Spec_Entity
(E
);
28793 when E_Package_Body
=>
28796 if Nkind
(P
) = N_Defining_Program_Unit_Name
then
28800 if Nkind
(P
) = N_Package_Body
28801 and then Present
(Corresponding_Spec
(P
))
28803 U
:= Corresponding_Spec
(P
);
28805 elsif Nkind
(P
) = N_Package_Body_Stub
28806 and then Present
(Corresponding_Spec_Of_Stub
(P
))
28808 U
:= Corresponding_Spec_Of_Stub
(P
);
28811 when E_Protected_Body
=>
28814 if Nkind
(P
) = N_Protected_Body
28815 and then Present
(Corresponding_Spec
(P
))
28817 U
:= Corresponding_Spec
(P
);
28819 elsif Nkind
(P
) = N_Protected_Body_Stub
28820 and then Present
(Corresponding_Spec_Of_Stub
(P
))
28822 U
:= Corresponding_Spec_Of_Stub
(P
);
28824 if Is_Single_Protected_Object
(U
) then
28829 if Is_Private_Type
(U
) then
28830 U
:= Full_View
(U
);
28833 when E_Subprogram_Body
=>
28836 if Nkind
(P
) = N_Defining_Program_Unit_Name
then
28842 if Nkind
(P
) = N_Subprogram_Body
28843 and then Present
(Corresponding_Spec
(P
))
28845 U
:= Corresponding_Spec
(P
);
28847 elsif Nkind
(P
) = N_Subprogram_Body_Stub
28848 and then Present
(Corresponding_Spec_Of_Stub
(P
))
28850 U
:= Corresponding_Spec_Of_Stub
(P
);
28852 elsif Nkind
(P
) = N_Subprogram_Renaming_Declaration
then
28853 U
:= Corresponding_Spec
(P
);
28856 when E_Task_Body
=>
28859 if Nkind
(P
) = N_Task_Body
28860 and then Present
(Corresponding_Spec
(P
))
28862 U
:= Corresponding_Spec
(P
);
28864 elsif Nkind
(P
) = N_Task_Body_Stub
28865 and then Present
(Corresponding_Spec_Of_Stub
(P
))
28867 U
:= Corresponding_Spec_Of_Stub
(P
);
28869 if Is_Single_Task_Object
(U
) then
28874 if Is_Private_Type
(U
) then
28875 U
:= Full_View
(U
);
28879 if Present
(Full_View
(E
)) then
28880 U
:= Full_View
(E
);
28894 function Unique_Name
(E
: Entity_Id
) return String is
28896 -- Local subprograms
28898 function Add_Homonym_Suffix
(E
: Entity_Id
) return String;
28900 function This_Name
return String;
28902 ------------------------
28903 -- Add_Homonym_Suffix --
28904 ------------------------
28906 function Add_Homonym_Suffix
(E
: Entity_Id
) return String is
28908 -- Names in E_Subprogram_Body or E_Package_Body entities are not
28909 -- reliable, as they may not include the overloading suffix.
28910 -- Instead, when looking for the name of E or one of its enclosing
28911 -- scope, we get the name of the corresponding Unique_Entity.
28913 U
: constant Entity_Id
:= Unique_Entity
(E
);
28914 Nam
: constant String := Get_Name_String
(Chars
(U
));
28917 -- If E has homonyms but is not fully qualified, as done in
28918 -- GNATprove mode, append the homonym number on the fly. Strip the
28919 -- leading space character in the image of natural numbers. Also do
28920 -- not print the homonym value of 1.
28922 if Has_Homonym
(U
) then
28924 N
: constant Pos
:= Homonym_Number
(U
);
28925 S
: constant String := N
'Img;
28928 return Nam
& "__" & S
(2 .. S
'Last);
28934 end Add_Homonym_Suffix
;
28940 function This_Name
return String is
28942 return Add_Homonym_Suffix
(E
);
28947 U
: constant Entity_Id
:= Unique_Entity
(E
);
28949 -- Start of processing for Unique_Name
28952 if E
= Standard_Standard
28953 or else Has_Fully_Qualified_Name
(E
)
28957 elsif Ekind
(E
) = E_Enumeration_Literal
then
28958 return Unique_Name
(Etype
(E
)) & "__" & This_Name
;
28962 S
: constant Entity_Id
:= Scope
(U
);
28963 pragma Assert
(Present
(S
));
28966 -- Prefix names of predefined types with standard__, but leave
28967 -- names of user-defined packages and subprograms without prefix
28968 -- (even if technically they are nested in the Standard package).
28970 if S
= Standard_Standard
then
28971 if Ekind
(U
) = E_Package
or else Is_Subprogram
(U
) then
28974 return Unique_Name
(S
) & "__" & This_Name
;
28977 -- For intances of generic subprograms use the name of the related
28978 -- instance and skip the scope of its wrapper package.
28980 elsif Is_Wrapper_Package
(S
) then
28981 pragma Assert
(Scope
(S
) = Scope
(Related_Instance
(S
)));
28982 -- Wrapper package and the instantiation are in the same scope
28985 Related_Name
: constant String :=
28986 Add_Homonym_Suffix
(Related_Instance
(S
));
28987 Enclosing_Name
: constant String :=
28988 Unique_Name
(Scope
(S
)) & "__" & Related_Name
;
28991 if Is_Subprogram
(U
)
28992 and then not Is_Generic_Actual_Subprogram
(U
)
28994 return Enclosing_Name
;
28996 return Enclosing_Name
& "__" & This_Name
;
29000 elsif Is_Child_Unit
(U
) then
29001 return Child_Prefix
& Unique_Name
(S
) & "__" & This_Name
;
29003 return Unique_Name
(S
) & "__" & This_Name
;
29009 ---------------------
29010 -- Unit_Is_Visible --
29011 ---------------------
29013 function Unit_Is_Visible
(U
: Entity_Id
) return Boolean is
29014 Curr
: constant Node_Id
:= Cunit
(Current_Sem_Unit
);
29015 Curr_Entity
: constant Entity_Id
:= Cunit_Entity
(Current_Sem_Unit
);
29017 function Unit_In_Parent_Context
(Par_Unit
: Node_Id
) return Boolean;
29018 -- For a child unit, check whether unit appears in a with_clause
29021 function Unit_In_Context
(Comp_Unit
: Node_Id
) return Boolean;
29022 -- Scan the context clause of one compilation unit looking for a
29023 -- with_clause for the unit in question.
29025 ----------------------------
29026 -- Unit_In_Parent_Context --
29027 ----------------------------
29029 function Unit_In_Parent_Context
(Par_Unit
: Node_Id
) return Boolean is
29031 if Unit_In_Context
(Par_Unit
) then
29034 elsif Is_Child_Unit
(Defining_Entity
(Unit
(Par_Unit
))) then
29035 return Unit_In_Parent_Context
(Parent_Spec
(Unit
(Par_Unit
)));
29040 end Unit_In_Parent_Context
;
29042 ---------------------
29043 -- Unit_In_Context --
29044 ---------------------
29046 function Unit_In_Context
(Comp_Unit
: Node_Id
) return Boolean is
29050 Clause
:= First
(Context_Items
(Comp_Unit
));
29051 while Present
(Clause
) loop
29052 if Nkind
(Clause
) = N_With_Clause
then
29053 if Library_Unit
(Clause
) = U
then
29056 -- The with_clause may denote a renaming of the unit we are
29057 -- looking for, eg. Text_IO which renames Ada.Text_IO.
29060 Renamed_Entity
(Entity
(Name
(Clause
))) =
29061 Defining_Entity
(Unit
(U
))
29071 end Unit_In_Context
;
29073 -- Start of processing for Unit_Is_Visible
29076 -- The currrent unit is directly visible
29081 elsif Unit_In_Context
(Curr
) then
29084 -- If the current unit is a body, check the context of the spec
29086 elsif Nkind
(Unit
(Curr
)) = N_Package_Body
29088 (Nkind
(Unit
(Curr
)) = N_Subprogram_Body
29089 and then not Acts_As_Spec
(Unit
(Curr
)))
29091 if Unit_In_Context
(Library_Unit
(Curr
)) then
29096 -- If the spec is a child unit, examine the parents
29098 if Is_Child_Unit
(Curr_Entity
) then
29099 if Nkind
(Unit
(Curr
)) in N_Unit_Body
then
29101 Unit_In_Parent_Context
29102 (Parent_Spec
(Unit
(Library_Unit
(Curr
))));
29104 return Unit_In_Parent_Context
(Parent_Spec
(Unit
(Curr
)));
29110 end Unit_Is_Visible
;
29112 ------------------------------
29113 -- Universal_Interpretation --
29114 ------------------------------
29116 function Universal_Interpretation
(Opnd
: Node_Id
) return Entity_Id
is
29117 Index
: Interp_Index
;
29121 -- The argument may be a formal parameter of an operator or subprogram
29122 -- with multiple interpretations, or else an expression for an actual.
29124 if Nkind
(Opnd
) = N_Defining_Identifier
29125 or else not Is_Overloaded
(Opnd
)
29127 if Is_Universal_Numeric_Type
(Etype
(Opnd
)) then
29128 return Etype
(Opnd
);
29134 Get_First_Interp
(Opnd
, Index
, It
);
29135 while Present
(It
.Typ
) loop
29136 if Is_Universal_Numeric_Type
(It
.Typ
) then
29140 Get_Next_Interp
(Index
, It
);
29145 end Universal_Interpretation
;
29151 function Unqualify
(Expr
: Node_Id
) return Node_Id
is
29153 -- Recurse to handle unlikely case of multiple levels of qualification
29155 if Nkind
(Expr
) = N_Qualified_Expression
then
29156 return Unqualify
(Expression
(Expr
));
29158 -- Normal case, not a qualified expression
29169 function Unqual_Conv
(Expr
: Node_Id
) return Node_Id
is
29171 -- Recurse to handle unlikely case of multiple levels of qualification
29172 -- and/or conversion.
29174 if Nkind
(Expr
) in N_Qualified_Expression
29175 | N_Type_Conversion
29176 | N_Unchecked_Type_Conversion
29178 return Unqual_Conv
(Expression
(Expr
));
29180 -- Normal case, not a qualified expression
29187 --------------------
29188 -- Validated_View --
29189 --------------------
29191 function Validated_View
(Typ
: Entity_Id
) return Entity_Id
is
29193 -- Scalar types can be always validated. In fast, switiching to the base
29194 -- type would drop the range constraints and force validation to use a
29195 -- larger type than necessary.
29197 if Is_Scalar_Type
(Typ
) then
29200 -- Array types can be validated even when they are derived, because
29201 -- validation only requires their bounds and component types to be
29202 -- accessible. In fact, switching to the parent type would pollute
29203 -- expansion of attribute Valid_Scalars with unnecessary conversion
29204 -- that might not be eliminated by the frontend.
29206 elsif Is_Array_Type
(Typ
) then
29209 -- For other types, in particular for record subtypes, we switch to the
29212 elsif not Is_Base_Type
(Typ
) then
29213 return Validated_View
(Base_Type
(Typ
));
29215 -- Obtain the full view of the input type by stripping away concurrency,
29216 -- derivations, and privacy.
29218 elsif Is_Concurrent_Type
(Typ
) then
29219 if Present
(Corresponding_Record_Type
(Typ
)) then
29220 return Corresponding_Record_Type
(Typ
);
29225 elsif Is_Derived_Type
(Typ
) then
29226 return Validated_View
(Etype
(Typ
));
29228 elsif Is_Private_Type
(Typ
) then
29229 if Present
(Underlying_Full_View
(Typ
)) then
29230 return Validated_View
(Underlying_Full_View
(Typ
));
29232 elsif Present
(Full_View
(Typ
)) then
29233 return Validated_View
(Full_View
(Typ
));
29238 elsif From_Limited_With
(Typ
) then
29239 if Has_Non_Limited_View
(Typ
) then
29240 return Validated_View
(Non_Limited_View
(Typ
));
29248 end Validated_View
;
29250 -----------------------
29251 -- Visible_Ancestors --
29252 -----------------------
29254 function Visible_Ancestors
(Typ
: Entity_Id
) return Elist_Id
is
29260 pragma Assert
(Is_Record_Type
(Typ
) and then Is_Tagged_Type
(Typ
));
29262 -- Collect all the parents and progenitors of Typ. If the full-view of
29263 -- private parents and progenitors is available then it is used to
29264 -- generate the list of visible ancestors; otherwise their partial
29265 -- view is added to the resulting list.
29270 Use_Full_View
=> True);
29274 Ifaces_List
=> List_2
,
29275 Exclude_Parents
=> True,
29276 Use_Full_View
=> True);
29278 -- Join the two lists. Avoid duplications because an interface may
29279 -- simultaneously be parent and progenitor of a type.
29281 Elmt
:= First_Elmt
(List_2
);
29282 while Present
(Elmt
) loop
29283 Append_Unique_Elmt
(Node
(Elmt
), List_1
);
29288 end Visible_Ancestors
;
29290 ---------------------------
29291 -- Warn_On_Hiding_Entity --
29292 ---------------------------
29294 procedure Warn_On_Hiding_Entity
29296 Hidden
, Visible
: Entity_Id
;
29297 On_Use_Clause
: Boolean)
29300 -- Don't warn for record components since they always have a well
29301 -- defined scope which does not confuse other uses. Note that in
29302 -- some cases, Ekind has not been set yet.
29304 if Ekind
(Hidden
) /= E_Component
29305 and then Ekind
(Hidden
) /= E_Discriminant
29306 and then Nkind
(Parent
(Hidden
)) /= N_Component_Declaration
29307 and then Ekind
(Visible
) /= E_Component
29308 and then Ekind
(Visible
) /= E_Discriminant
29309 and then Nkind
(Parent
(Visible
)) /= N_Component_Declaration
29311 -- Don't warn for one character variables. It is too common to use
29312 -- such variables as locals and will just cause too many false hits.
29314 and then Length_Of_Name
(Chars
(Hidden
)) /= 1
29316 -- Don't warn for non-source entities
29318 and then Comes_From_Source
(Hidden
)
29319 and then Comes_From_Source
(Visible
)
29321 -- Don't warn within a generic instantiation
29323 and then not In_Instance
29325 -- Don't warn unless entity in question is in extended main source
29327 and then In_Extended_Main_Source_Unit
(Visible
)
29329 -- Finally, in the case of a declaration, the hidden entity must
29330 -- be either immediately visible or use visible (i.e. from a used
29331 -- package). In the case of a use clause, the visible entity must
29332 -- be immediately visible.
29335 (if On_Use_Clause
then
29336 Is_Immediately_Visible
(Visible
)
29338 (Is_Immediately_Visible
(Hidden
)
29340 Is_Potentially_Use_Visible
(Hidden
)))
29342 if On_Use_Clause
then
29343 Error_Msg_Sloc
:= Sloc
(Visible
);
29344 Error_Msg_NE
("visible declaration of&# hides homonym "
29345 & "from use clause?h?", N
, Hidden
);
29347 Error_Msg_Sloc
:= Sloc
(Hidden
);
29348 Error_Msg_NE
("declaration hides &#?h?", N
, Visible
);
29351 end Warn_On_Hiding_Entity
;
29353 ----------------------
29354 -- Within_Init_Proc --
29355 ----------------------
29357 function Within_Init_Proc
return Boolean is
29361 S
:= Current_Scope
;
29362 while not Is_Overloadable
(S
) loop
29363 if S
= Standard_Standard
then
29370 return Is_Init_Proc
(S
);
29371 end Within_Init_Proc
;
29373 ---------------------------
29374 -- Within_Protected_Type --
29375 ---------------------------
29377 function Within_Protected_Type
(E
: Entity_Id
) return Boolean is
29378 Scop
: Entity_Id
:= Scope
(E
);
29381 while Present
(Scop
) loop
29382 if Ekind
(Scop
) = E_Protected_Type
then
29386 Scop
:= Scope
(Scop
);
29390 end Within_Protected_Type
;
29396 function Within_Scope
(E
: Entity_Id
; S
: Entity_Id
) return Boolean is
29398 return Scope_Within_Or_Same
(Scope
(E
), S
);
29405 procedure Wrong_Type
29407 Expected_Type
: Entity_Id
;
29408 Multiple
: Boolean := False)
29410 Found_Type
: constant Entity_Id
:= First_Subtype
(Etype
(Expr
));
29411 Expec_Type
: constant Entity_Id
:= First_Subtype
(Expected_Type
);
29413 Err_Msg_Exp_Typ
: Entity_Id
:= Expected_Type
;
29414 -- Type entity used when printing errors concerning the expected type
29416 Matching_Field
: Entity_Id
;
29417 -- Entity to give a more precise suggestion on how to write a one-
29418 -- element positional aggregate.
29420 function Has_One_Matching_Field
return Boolean;
29421 -- Determines if Expec_Type is a record type with a single component or
29422 -- discriminant whose type matches the found type or is one dimensional
29423 -- array whose component type matches the found type. In the case of
29424 -- one discriminant, we ignore the variant parts. That's not accurate,
29425 -- but good enough for the warning.
29427 ----------------------------
29428 -- Has_One_Matching_Field --
29429 ----------------------------
29431 function Has_One_Matching_Field
return Boolean is
29435 Matching_Field
:= Empty
;
29437 if Is_Array_Type
(Expec_Type
)
29438 and then Number_Dimensions
(Expec_Type
) = 1
29439 and then Covers
(Etype
(Component_Type
(Expec_Type
)), Found_Type
)
29441 -- Use type name if available. This excludes multidimensional
29442 -- arrays and anonymous arrays.
29444 if Comes_From_Source
(Expec_Type
) then
29445 Matching_Field
:= Expec_Type
;
29447 -- For an assignment, use name of target
29449 elsif Nkind
(Parent
(Expr
)) = N_Assignment_Statement
29450 and then Is_Entity_Name
(Name
(Parent
(Expr
)))
29452 Matching_Field
:= Entity
(Name
(Parent
(Expr
)));
29457 elsif not Is_Record_Type
(Expec_Type
) then
29461 E
:= First_Entity
(Expec_Type
);
29466 elsif Ekind
(E
) not in E_Discriminant | E_Component
29467 or else Chars
(E
) in Name_uTag | Name_uParent
29476 if not Covers
(Etype
(E
), Found_Type
) then
29479 elsif Present
(Next_Entity
(E
))
29480 and then (Ekind
(E
) = E_Component
29481 or else Ekind
(Next_Entity
(E
)) = E_Discriminant
)
29486 Matching_Field
:= E
;
29490 end Has_One_Matching_Field
;
29492 -- Start of processing for Wrong_Type
29495 -- Don't output message if either type is Any_Type, or if a message
29496 -- has already been posted for this node and we do not want multiple
29497 -- error messages. We need to do the latter check explicitly (it is
29498 -- ordinarily done in Errout) because we are using '!' to force the
29499 -- output of the error messages.
29501 if Expec_Type
= Any_Type
29502 or else Found_Type
= Any_Type
29503 or else (Error_Posted
(Expr
) and then not Multiple
)
29507 -- If one of the types is a Taft-Amendment type and the other it its
29508 -- completion, it must be an illegal use of a TAT in the spec, for
29509 -- which an error was already emitted. Avoid cascaded errors.
29511 elsif Is_Incomplete_Type
(Expec_Type
)
29512 and then Has_Completion_In_Body
(Expec_Type
)
29513 and then Full_View
(Expec_Type
) = Etype
(Expr
)
29517 elsif Is_Incomplete_Type
(Etype
(Expr
))
29518 and then Has_Completion_In_Body
(Etype
(Expr
))
29519 and then Full_View
(Etype
(Expr
)) = Expec_Type
29524 -- Avoid printing internally generated subtypes in error messages and
29525 -- instead use the corresponding first subtype in such cases.
29527 if not Comes_From_Source
(Err_Msg_Exp_Typ
)
29528 or else not Comes_From_Source
(Declaration_Node
(Err_Msg_Exp_Typ
))
29530 Err_Msg_Exp_Typ
:= First_Subtype
(Err_Msg_Exp_Typ
);
29533 -- An interesting special check. If the expression is parenthesized
29534 -- and its type corresponds to the type of the sole component of the
29535 -- expected record type, or to the component type of the expected one
29536 -- dimensional array type, then assume we have a bad aggregate attempt.
29538 if Nkind
(Expr
) in N_Subexpr
29539 and then Paren_Count
(Expr
) /= 0
29540 and then Has_One_Matching_Field
29542 Error_Msg_N
("positional aggregate cannot have one component", Expr
);
29544 if Present
(Matching_Field
) then
29545 if Is_Array_Type
(Expec_Type
) then
29547 ("\write instead `&''First ='> ...`", Expr
, Matching_Field
);
29550 ("\write instead `& ='> ...`", Expr
, Matching_Field
);
29554 -- Another special check, if we are looking for a pool-specific access
29555 -- type and we found an E_Access_Attribute_Type, then we have the case
29556 -- of an Access attribute being used in a context which needs a pool-
29557 -- specific type, which is never allowed. The one extra check we make
29558 -- is that the expected designated type covers the Found_Type.
29560 elsif Is_Access_Type
(Expec_Type
)
29561 and then Ekind
(Found_Type
) = E_Access_Attribute_Type
29562 and then Ekind
(Base_Type
(Expec_Type
)) /= E_General_Access_Type
29563 and then Ekind
(Base_Type
(Expec_Type
)) /= E_Anonymous_Access_Type
29565 (Designated_Type
(Expec_Type
), Designated_Type
(Found_Type
))
29568 ("result must be general access type!", Expr
);
29569 Error_Msg_NE
-- CODEFIX
29570 ("\add ALL to }!", Expr
, Err_Msg_Exp_Typ
);
29572 -- Another special check, if the expected type is an integer type,
29573 -- but the expression is of type System.Address, and the parent is
29574 -- an addition or subtraction operation whose left operand is the
29575 -- expression in question and whose right operand is of an integral
29576 -- type, then this is an attempt at address arithmetic, so give
29577 -- appropriate message.
29579 elsif Is_Integer_Type
(Expec_Type
)
29580 and then Is_RTE
(Found_Type
, RE_Address
)
29581 and then Nkind
(Parent
(Expr
)) in N_Op_Add | N_Op_Subtract
29582 and then Expr
= Left_Opnd
(Parent
(Expr
))
29583 and then Is_Integer_Type
(Etype
(Right_Opnd
(Parent
(Expr
))))
29586 ("address arithmetic not predefined in package System",
29589 ("\possible missing with/use of System.Storage_Elements",
29593 -- If the expected type is an anonymous access type, as for access
29594 -- parameters and discriminants, the error is on the designated types.
29596 elsif Ekind
(Expec_Type
) = E_Anonymous_Access_Type
then
29597 if Comes_From_Source
(Expec_Type
) then
29598 Error_Msg_NE
("expected}!", Expr
, Expec_Type
);
29601 ("expected an access type with designated}",
29602 Expr
, Designated_Type
(Expec_Type
));
29605 if Is_Access_Type
(Found_Type
)
29606 and then not Comes_From_Source
(Found_Type
)
29609 ("\\found an access type with designated}!",
29610 Expr
, Designated_Type
(Found_Type
));
29612 if From_Limited_With
(Found_Type
) then
29613 Error_Msg_NE
("\\found incomplete}!", Expr
, Found_Type
);
29614 Error_Msg_Qual_Level
:= 99;
29615 Error_Msg_NE
-- CODEFIX
29616 ("\\missing `WITH &;", Expr
, Scope
(Found_Type
));
29617 Error_Msg_Qual_Level
:= 0;
29619 Error_Msg_NE
("found}!", Expr
, Found_Type
);
29623 -- Normal case of one type found, some other type expected
29626 -- If the names of the two types are the same, see if some number
29627 -- of levels of qualification will help. Don't try more than three
29628 -- levels, and if we get to standard, it's no use (and probably
29629 -- represents an error in the compiler) Also do not bother with
29630 -- internal scope names.
29633 Expec_Scope
: Entity_Id
;
29634 Found_Scope
: Entity_Id
;
29637 Expec_Scope
:= Expec_Type
;
29638 Found_Scope
:= Found_Type
;
29640 for Levels
in Nat
range 0 .. 3 loop
29641 if Chars
(Expec_Scope
) /= Chars
(Found_Scope
) then
29642 Error_Msg_Qual_Level
:= Levels
;
29646 Expec_Scope
:= Scope
(Expec_Scope
);
29647 Found_Scope
:= Scope
(Found_Scope
);
29649 exit when Expec_Scope
= Standard_Standard
29650 or else Found_Scope
= Standard_Standard
29651 or else not Comes_From_Source
(Expec_Scope
)
29652 or else not Comes_From_Source
(Found_Scope
);
29656 if Is_Record_Type
(Expec_Type
)
29657 and then Present
(Corresponding_Remote_Type
(Expec_Type
))
29659 Error_Msg_NE
("expected}!", Expr
,
29660 Corresponding_Remote_Type
(Expec_Type
));
29662 Error_Msg_NE
("expected}!", Expr
, Err_Msg_Exp_Typ
);
29665 if Is_Entity_Name
(Expr
)
29666 and then Is_Package_Or_Generic_Package
(Entity
(Expr
))
29668 Error_Msg_N
("\\found package name!", Expr
);
29670 elsif Is_Entity_Name
(Expr
)
29671 and then Ekind
(Entity
(Expr
)) in E_Procedure | E_Generic_Procedure
29673 if Ekind
(Expec_Type
) = E_Access_Subprogram_Type
then
29675 ("found procedure name, possibly missing Access attribute!",
29679 ("\\found procedure name instead of function!", Expr
);
29682 elsif Nkind
(Expr
) = N_Function_Call
29683 and then Ekind
(Expec_Type
) = E_Access_Subprogram_Type
29684 and then Etype
(Designated_Type
(Expec_Type
)) = Etype
(Expr
)
29685 and then No
(Parameter_Associations
(Expr
))
29688 ("found function name, possibly missing Access attribute!",
29691 -- Catch common error: a prefix or infix operator which is not
29692 -- directly visible because the type isn't.
29694 elsif Nkind
(Expr
) in N_Op
29695 and then Is_Overloaded
(Expr
)
29696 and then not Is_Immediately_Visible
(Expec_Type
)
29697 and then not Is_Potentially_Use_Visible
(Expec_Type
)
29698 and then not In_Use
(Expec_Type
)
29699 and then Has_Compatible_Type
(Right_Opnd
(Expr
), Expec_Type
)
29702 ("operator of the type is not directly visible!", Expr
);
29704 elsif Ekind
(Found_Type
) = E_Void
29705 and then Present
(Parent
(Found_Type
))
29706 and then Nkind
(Parent
(Found_Type
)) = N_Full_Type_Declaration
29708 Error_Msg_NE
("\\found premature usage of}!", Expr
, Found_Type
);
29711 Error_Msg_NE
("\\found}!", Expr
, Found_Type
);
29714 -- A special check for cases like M1 and M2 = 0 where M1 and M2 are
29715 -- of the same modular type, and (M1 and M2) = 0 was intended.
29717 if Expec_Type
= Standard_Boolean
29718 and then Is_Modular_Integer_Type
(Found_Type
)
29719 and then Nkind
(Parent
(Expr
)) in N_Op_And | N_Op_Or | N_Op_Xor
29720 and then Nkind
(Right_Opnd
(Parent
(Expr
))) in N_Op_Compare
29723 Op
: constant Node_Id
:= Right_Opnd
(Parent
(Expr
));
29724 L
: constant Node_Id
:= Left_Opnd
(Op
);
29725 R
: constant Node_Id
:= Right_Opnd
(Op
);
29728 -- The case for the message is when the left operand of the
29729 -- comparison is the same modular type, or when it is an
29730 -- integer literal (or other universal integer expression),
29731 -- which would have been typed as the modular type if the
29732 -- parens had been there.
29734 if (Etype
(L
) = Found_Type
29736 Etype
(L
) = Universal_Integer
)
29737 and then Is_Integer_Type
(Etype
(R
))
29740 ("\\possible missing parens for modular operation", Expr
);
29745 -- Reset error message qualification indication
29747 Error_Msg_Qual_Level
:= 0;
29751 --------------------------------
29752 -- Yields_Synchronized_Object --
29753 --------------------------------
29755 function Yields_Synchronized_Object
(Typ
: Entity_Id
) return Boolean is
29756 Has_Sync_Comp
: Boolean := False;
29760 -- An array type yields a synchronized object if its component type
29761 -- yields a synchronized object.
29763 if Is_Array_Type
(Typ
) then
29764 return Yields_Synchronized_Object
(Component_Type
(Typ
));
29766 -- A descendant of type Ada.Synchronous_Task_Control.Suspension_Object
29767 -- yields a synchronized object by default.
29769 elsif Is_Descendant_Of_Suspension_Object
(Typ
) then
29772 -- A protected type yields a synchronized object by default
29774 elsif Is_Protected_Type
(Typ
) then
29777 -- A record type or type extension yields a synchronized object when its
29778 -- discriminants (if any) lack default values and all components are of
29779 -- a type that yields a synchronized object.
29781 elsif Is_Record_Type
(Typ
) then
29783 -- Inspect all entities defined in the scope of the type, looking for
29784 -- components of a type that does not yield a synchronized object or
29785 -- for discriminants with default values.
29787 Id
:= First_Entity
(Typ
);
29788 while Present
(Id
) loop
29789 if Comes_From_Source
(Id
) then
29790 if Ekind
(Id
) = E_Component
then
29791 if Yields_Synchronized_Object
(Etype
(Id
)) then
29792 Has_Sync_Comp
:= True;
29794 -- The component does not yield a synchronized object
29800 elsif Ekind
(Id
) = E_Discriminant
29801 and then Present
(Expression
(Parent
(Id
)))
29810 -- Ensure that the parent type of a type extension yields a
29811 -- synchronized object.
29813 if Etype
(Typ
) /= Typ
29814 and then not Is_Private_Type
(Etype
(Typ
))
29815 and then not Yields_Synchronized_Object
(Etype
(Typ
))
29820 -- If we get here, then all discriminants lack default values and all
29821 -- components are of a type that yields a synchronized object.
29823 return Has_Sync_Comp
;
29825 -- A synchronized interface type yields a synchronized object by default
29827 elsif Is_Synchronized_Interface
(Typ
) then
29830 -- A task type yields a synchronized object by default
29832 elsif Is_Task_Type
(Typ
) then
29835 -- A private type yields a synchronized object if its underlying type
29838 elsif Is_Private_Type
(Typ
)
29839 and then Present
(Underlying_Type
(Typ
))
29841 return Yields_Synchronized_Object
(Underlying_Type
(Typ
));
29843 -- Otherwise the type does not yield a synchronized object
29848 end Yields_Synchronized_Object
;
29850 ---------------------------
29851 -- Yields_Universal_Type --
29852 ---------------------------
29854 function Yields_Universal_Type
(N
: Node_Id
) return Boolean is
29856 -- Integer and real literals are of a universal type
29858 if Nkind
(N
) in N_Integer_Literal | N_Real_Literal
then
29861 -- The values of certain attributes are of a universal type
29863 elsif Nkind
(N
) = N_Attribute_Reference
then
29865 Universal_Type_Attribute
(Get_Attribute_Id
(Attribute_Name
(N
)));
29867 -- ??? There are possibly other cases to consider
29872 end Yields_Universal_Type
;
29874 package body Interval_Lists
is
29876 procedure Check_Consistency
(Intervals
: Discrete_Interval_List
);
29877 -- Check that list is sorted, lacks null intervals, and has gaps
29878 -- between intervals.
29880 function Chosen_Interval
(Choice
: Node_Id
) return Discrete_Interval
;
29881 -- Given an element of a Discrete_Choices list, a
29882 -- Static_Discrete_Predicate list, or an Others_Discrete_Choices
29883 -- list (but not an N_Others_Choice node) return the corresponding
29884 -- interval. If an element that does not represent a single
29885 -- contiguous interval due to a static predicate (or which
29886 -- represents a single contiguous interval whose bounds depend on
29887 -- a static predicate) is encountered, then that is an error on the
29888 -- part of whoever built the list in question.
29890 function In_Interval
29891 (Value
: Uint
; Interval
: Discrete_Interval
) return Boolean;
29892 -- Does the given value lie within the given interval?
29894 procedure Normalize_Interval_List
29895 (List
: in out Discrete_Interval_List
; Last
: out Nat
);
29896 -- Perform sorting and merging as required by Check_Consistency
29898 -------------------------
29899 -- Aggregate_Intervals --
29900 -------------------------
29902 function Aggregate_Intervals
(N
: Node_Id
) return Discrete_Interval_List
29904 pragma Assert
(Nkind
(N
) = N_Aggregate
29905 and then Is_Array_Type
(Etype
(N
)));
29907 function Unmerged_Intervals_Count
return Nat
;
29908 -- Count the number of intervals given in the aggregate N; the others
29909 -- choice (if present) is not taken into account.
29911 ------------------------------
29912 -- Unmerged_Intervals_Count --
29913 ------------------------------
29915 function Unmerged_Intervals_Count
return Nat
is
29920 Comp
:= First
(Component_Associations
(N
));
29921 while Present
(Comp
) loop
29922 Choice
:= First
(Choices
(Comp
));
29924 while Present
(Choice
) loop
29925 if Nkind
(Choice
) /= N_Others_Choice
then
29926 Count
:= Count
+ 1;
29936 end Unmerged_Intervals_Count
;
29941 Max_I
: constant Nat
:= Unmerged_Intervals_Count
;
29942 Intervals
: Discrete_Interval_List
(1 .. Max_I
);
29945 -- Start of processing for Aggregate_Intervals
29948 -- No action needed if there are no intervals
29954 -- Internally store all the unsorted intervals
29956 Comp
:= First
(Component_Associations
(N
));
29957 while Present
(Comp
) loop
29959 Choice_Intervals
: constant Discrete_Interval_List
29960 := Choice_List_Intervals
(Choices
(Comp
));
29962 for J
in Choice_Intervals
'Range loop
29963 Num_I
:= Num_I
+ 1;
29964 Intervals
(Num_I
) := Choice_Intervals
(J
);
29971 -- Normalize the lists sorting and merging the intervals
29974 Aggr_Intervals
: Discrete_Interval_List
(1 .. Num_I
)
29975 := Intervals
(1 .. Num_I
);
29977 Normalize_Interval_List
(Aggr_Intervals
, Num_I
);
29978 Check_Consistency
(Aggr_Intervals
(1 .. Num_I
));
29979 return Aggr_Intervals
(1 .. Num_I
);
29981 end Aggregate_Intervals
;
29983 ------------------------
29984 -- Check_Consistency --
29985 ------------------------
29987 procedure Check_Consistency
(Intervals
: Discrete_Interval_List
) is
29989 if Serious_Errors_Detected
> 0 then
29993 -- low bound is 1 and high bound equals length
29994 pragma Assert
(Intervals
'First = 1 and Intervals
'Last >= 0);
29995 for Idx
in Intervals
'Range loop
29996 -- each interval is non-null
29997 pragma Assert
(Intervals
(Idx
).Low
<= Intervals
(Idx
).High
);
29998 if Idx
/= Intervals
'First then
29999 -- intervals are sorted with non-empty gaps between them
30001 (Intervals
(Idx
- 1).High
< (Intervals
(Idx
).Low
- 1));
30005 end Check_Consistency
;
30007 ---------------------------
30008 -- Choice_List_Intervals --
30009 ---------------------------
30011 function Choice_List_Intervals
30012 (Discrete_Choices
: List_Id
) return Discrete_Interval_List
30014 function Unmerged_Choice_Count
return Nat
;
30015 -- The number of intervals before adjacent intervals are merged
30017 ---------------------------
30018 -- Unmerged_Choice_Count --
30019 ---------------------------
30021 function Unmerged_Choice_Count
return Nat
is
30022 Choice
: Node_Id
:= First
(Discrete_Choices
);
30025 while Present
(Choice
) loop
30026 -- Non-contiguous choices involving static predicates
30027 -- have already been normalized away.
30029 if Nkind
(Choice
) = N_Others_Choice
then
30031 Count
+ List_Length
(Others_Discrete_Choices
(Choice
));
30033 Count
:= Count
+ 1; -- an ordinary expression or range
30039 end Unmerged_Choice_Count
;
30043 Choice
: Node_Id
:= First
(Discrete_Choices
);
30044 Result
: Discrete_Interval_List
(1 .. Unmerged_Choice_Count
);
30047 -- Start of processing for Choice_List_Intervals
30050 while Present
(Choice
) loop
30051 if Nkind
(Choice
) = N_Others_Choice
then
30053 Others_Choice
: Node_Id
30054 := First
(Others_Discrete_Choices
(Choice
));
30056 while Present
(Others_Choice
) loop
30057 Count
:= Count
+ 1;
30058 Result
(Count
) := Chosen_Interval
(Others_Choice
);
30059 Next
(Others_Choice
);
30063 Count
:= Count
+ 1;
30064 Result
(Count
) := Chosen_Interval
(Choice
);
30070 pragma Assert
(Count
= Result
'Last);
30071 Normalize_Interval_List
(Result
, Count
);
30072 Check_Consistency
(Result
(1 .. Count
));
30073 return Result
(1 .. Count
);
30074 end Choice_List_Intervals
;
30076 ---------------------
30077 -- Chosen_Interval --
30078 ---------------------
30080 function Chosen_Interval
(Choice
: Node_Id
) return Discrete_Interval
is
30082 case Nkind
(Choice
) is
30084 return (Low
=> Expr_Value
(Low_Bound
(Choice
)),
30085 High
=> Expr_Value
(High_Bound
(Choice
)));
30087 when N_Subtype_Indication
=>
30089 Range_Exp
: constant Node_Id
30090 := Range_Expression
(Constraint
(Choice
));
30092 return (Low
=> Expr_Value
(Low_Bound
(Range_Exp
)),
30093 High
=> Expr_Value
(High_Bound
(Range_Exp
)));
30096 when N_Others_Choice
=>
30097 raise Program_Error
;
30100 if Is_Entity_Name
(Choice
) and then Is_Type
(Entity
(Choice
))
30103 (Low
=> Expr_Value
(Type_Low_Bound
(Entity
(Choice
))),
30104 High
=> Expr_Value
(Type_High_Bound
(Entity
(Choice
))));
30107 return (Low | High
=> Expr_Value
(Choice
));
30110 end Chosen_Interval
;
30116 function In_Interval
30117 (Value
: Uint
; Interval
: Discrete_Interval
) return Boolean is
30119 return Value
>= Interval
.Low
and then Value
<= Interval
.High
;
30127 (Subset
, Of_Set
: Discrete_Interval_List
) return Boolean
30129 -- Returns True iff for each interval of Subset we can find
30130 -- a single interval of Of_Set which contains the Subset interval.
30132 if Of_Set
'Length = 0 then
30133 return Subset
'Length = 0;
30137 Set_Index
: Pos
range Of_Set
'Range := Of_Set
'First;
30140 for Ss_Idx
in Subset
'Range loop
30141 while not In_Interval
30142 (Value
=> Subset
(Ss_Idx
).Low
,
30143 Interval
=> Of_Set
(Set_Index
))
30145 if Set_Index
= Of_Set
'Last then
30149 Set_Index
:= Set_Index
+ 1;
30153 (Value
=> Subset
(Ss_Idx
).High
,
30154 Interval
=> Of_Set
(Set_Index
))
30164 -----------------------------
30165 -- Normalize_Interval_List --
30166 -----------------------------
30168 procedure Normalize_Interval_List
30169 (List
: in out Discrete_Interval_List
; Last
: out Nat
)
30171 Temp_0
: Discrete_Interval
:= (others => Uint_0
);
30172 -- Cope with Heap_Sort_G idiosyncrasies.
30174 function Is_Null
(Idx
: Pos
) return Boolean;
30175 -- True iff List (Idx) defines a null range
30177 function Lt_Interval
(Idx1
, Idx2
: Natural) return Boolean;
30178 -- Compare two list elements
30180 procedure Merge_Intervals
(Null_Interval_Count
: out Nat
);
30181 -- Merge contiguous ranges by replacing one with merged range and
30182 -- the other with a null value. Return a count of the null intervals,
30183 -- both preexisting and those introduced by merging.
30185 procedure Move_Interval
(From
, To
: Natural);
30186 -- Copy interval from one location to another
30188 function Read_Interval
(From
: Natural) return Discrete_Interval
;
30189 -- Normal array indexing unless From = 0
30191 ----------------------
30192 -- Interval_Sorting --
30193 ----------------------
30195 package Interval_Sorting
is
30196 new Gnat
.Heap_Sort_G
(Move_Interval
, Lt_Interval
);
30202 function Is_Null
(Idx
: Pos
) return Boolean is
30204 return List
(Idx
).Low
> List
(Idx
).High
;
30211 function Lt_Interval
(Idx1
, Idx2
: Natural) return Boolean is
30212 Elem1
: constant Discrete_Interval
:= Read_Interval
(Idx1
);
30213 Elem2
: constant Discrete_Interval
:= Read_Interval
(Idx2
);
30214 Null_1
: constant Boolean := Elem1
.Low
> Elem1
.High
;
30215 Null_2
: constant Boolean := Elem2
.Low
> Elem2
.High
;
30217 if Null_1
/= Null_2
then
30218 -- So that sorting moves null intervals to high end
30221 elsif Elem1
.Low
/= Elem2
.Low
then
30222 return Elem1
.Low
< Elem2
.Low
;
30225 return Elem1
.High
< Elem2
.High
;
30229 ---------------------
30230 -- Merge_Intervals --
30231 ---------------------
30233 procedure Merge_Intervals
(Null_Interval_Count
: out Nat
) is
30234 Not_Null
: Pos
range List
'Range;
30235 -- Index of the most recently examined non-null interval
30237 Null_Interval
: constant Discrete_Interval
30238 := (Low
=> Uint_1
, High
=> Uint_0
); -- any null range ok here
30240 if List
'Length = 0 or else Is_Null
(List
'First) then
30241 Null_Interval_Count
:= List
'Length;
30242 -- no non-null elements, so no merge candidates
30246 Null_Interval_Count
:= 0;
30247 Not_Null
:= List
'First;
30249 for Idx
in List
'First + 1 .. List
'Last loop
30250 if Is_Null
(Idx
) then
30252 -- all remaining elements are null
30254 Null_Interval_Count
:=
30255 Null_Interval_Count
+ List
(Idx
.. List
'Last)'Length;
30258 elsif List
(Idx
).Low
= List
(Not_Null
).High
+ 1 then
30260 -- Merge the two intervals into one; discard the other
30262 List
(Not_Null
).High
:= List
(Idx
).High
;
30263 List
(Idx
) := Null_Interval
;
30264 Null_Interval_Count
:= Null_Interval_Count
+ 1;
30267 if List
(Idx
).Low
<= List
(Not_Null
).High
then
30268 raise Intervals_Error
;
30271 pragma Assert
(List
(Idx
).Low
> List
(Not_Null
).High
);
30275 end Merge_Intervals
;
30277 -------------------
30278 -- Move_Interval --
30279 -------------------
30281 procedure Move_Interval
(From
, To
: Natural) is
30282 Rhs
: constant Discrete_Interval
:= Read_Interval
(From
);
30287 List
(Pos
(To
)) := Rhs
;
30291 -------------------
30292 -- Read_Interval --
30293 -------------------
30295 function Read_Interval
(From
: Natural) return Discrete_Interval
is
30300 return List
(Pos
(From
));
30304 -- Start of processing for Normalize_Interval_Lists
30307 Interval_Sorting
.Sort
(Natural (List
'Last));
30310 Null_Interval_Count
: Nat
;
30313 Merge_Intervals
(Null_Interval_Count
);
30314 Last
:= List
'Last - Null_Interval_Count
;
30316 if Null_Interval_Count
/= 0 then
30317 -- Move null intervals introduced during merging to high end
30318 Interval_Sorting
.Sort
(Natural (List
'Last));
30321 end Normalize_Interval_List
;
30323 --------------------
30324 -- Type_Intervals --
30325 --------------------
30327 function Type_Intervals
(Typ
: Entity_Id
) return Discrete_Interval_List
30330 if Has_Static_Predicate
(Typ
) then
30332 -- No sorting or merging needed
30333 SDP_List
: constant List_Id
:= Static_Discrete_Predicate
(Typ
);
30334 Range_Or_Expr
: Node_Id
:= First
(SDP_List
);
30335 Result
: Discrete_Interval_List
(1 .. List_Length
(SDP_List
));
30338 for Idx
in Result
'Range loop
30339 Result
(Idx
) := Chosen_Interval
(Range_Or_Expr
);
30340 Next
(Range_Or_Expr
);
30343 pragma Assert
(No
(Range_Or_Expr
));
30344 Check_Consistency
(Result
);
30349 Low
: constant Uint
:= Expr_Value
(Type_Low_Bound
(Typ
));
30350 High
: constant Uint
:= Expr_Value
(Type_High_Bound
(Typ
));
30354 Null_Array
: Discrete_Interval_List
(1 .. 0);
30359 return (1 => (Low
=> Low
, High
=> High
));
30363 end Type_Intervals
;
30365 end Interval_Lists
;
30367 package body Old_Attr_Util
is
30368 package body Conditional_Evaluation
is
30369 type Determining_Expr_Context
is
30370 (No_Context
, If_Expr
, Case_Expr
, Short_Circuit_Op
, Membership_Test
);
30372 -- Determining_Expr_Context enumeration elements (except for
30373 -- No_Context) correspond to the list items in RM 6.1.1 definition
30374 -- of "determining expression".
30376 type Determining_Expr
30377 (Context
: Determining_Expr_Context
:= No_Context
)
30379 Expr
: Node_Id
:= Empty
;
30381 when Short_Circuit_Op
=>
30382 Is_And_Then
: Boolean;
30384 Is_Then_Part
: Boolean;
30386 Alternatives
: Node_Id
;
30387 when Membership_Test
=>
30388 -- Given a subexpression of <exp4> in a membership test
30389 -- <exp1> in <exp2> | <exp3> | <exp4> | <exp5>
30390 -- the corresponding determining expression value would
30391 -- have First_Non_Preceding = <exp4> (See RM 6.1.1).
30392 First_Non_Preceding
: Node_Id
;
30398 type Determining_Expression_List
is
30399 array (Positive range <>) of Determining_Expr
;
30401 function Determining_Condition
(Det
: Determining_Expr
)
30403 -- Given a determining expression, build a Boolean-valued
30404 -- condition that incorporates that expression into condition
30405 -- suitable for deciding whether to initialize a 'Old constant.
30406 -- Polarity is "True => initialize the constant".
30408 function Determining_Expressions
30409 (Expr
: Node_Id
; Expr_Trailer
: Node_Id
:= Empty
)
30410 return Determining_Expression_List
;
30411 -- Given a conditionally evaluated expression, return its
30412 -- determining expressions.
30413 -- See RM 6.1.1 for definition of term "determining expressions".
30414 -- Tests should be performed in the order they occur in the
30415 -- array, with short circuiting.
30416 -- A determining expression need not be of a boolean type (e.g.,
30417 -- it might be the determining expression of a case expression).
30418 -- The Expr_Trailer parameter should be defaulted for nonrecursive
30421 function Is_Conditionally_Evaluated
(Expr
: Node_Id
) return Boolean;
30422 -- See RM 6.1.1 for definition of term "conditionally evaluated".
30424 function Is_Known_On_Entry
(Expr
: Node_Id
) return Boolean;
30425 -- See RM 6.1.1 for definition of term "known on entry".
30427 --------------------------------------
30428 -- Conditional_Evaluation_Condition --
30429 --------------------------------------
30431 function Conditional_Evaluation_Condition
30432 (Expr
: Node_Id
) return Node_Id
30434 Determiners
: constant Determining_Expression_List
:=
30435 Determining_Expressions
(Expr
);
30436 Loc
: constant Source_Ptr
:= Sloc
(Expr
);
30437 Result
: Node_Id
:=
30438 New_Occurrence_Of
(Standard_True
, Loc
);
30440 pragma Assert
(Determiners
'Length > 0 or else
30441 Is_Anonymous_Access_Type
(Etype
(Expr
)));
30443 for I
in Determiners
'Range loop
30444 Result
:= Make_And_Then
30446 Left_Opnd
=> Result
,
30448 Determining_Condition
(Determiners
(I
)));
30451 end Conditional_Evaluation_Condition
;
30453 ---------------------------
30454 -- Determining_Condition --
30455 ---------------------------
30457 function Determining_Condition
(Det
: Determining_Expr
) return Node_Id
30459 Loc
: constant Source_Ptr
:= Sloc
(Det
.Expr
);
30461 case Det
.Context
is
30462 when Short_Circuit_Op
=>
30463 if Det
.Is_And_Then
then
30464 return New_Copy_Tree
(Det
.Expr
);
30466 return Make_Op_Not
(Loc
, New_Copy_Tree
(Det
.Expr
));
30470 if Det
.Is_Then_Part
then
30471 return New_Copy_Tree
(Det
.Expr
);
30473 return Make_Op_Not
(Loc
, New_Copy_Tree
(Det
.Expr
));
30478 Alts
: List_Id
:= Discrete_Choices
(Det
.Alternatives
);
30480 if Nkind
(First
(Alts
)) = N_Others_Choice
then
30481 Alts
:= Others_Discrete_Choices
(First
(Alts
));
30484 return Make_In
(Loc
,
30485 Left_Opnd
=> New_Copy_Tree
(Det
.Expr
),
30486 Right_Opnd
=> Empty
,
30487 Alternatives
=> New_Copy_List
(Alts
));
30490 when Membership_Test
=>
30492 function Copy_Prefix
30493 (List
: List_Id
; Suffix_Start
: Node_Id
)
30495 -- Given a list and a member of that list, returns
30496 -- a copy (similar to Nlists.New_Copy_List) of the
30497 -- prefix of the list up to but not including
30504 function Copy_Prefix
30505 (List
: List_Id
; Suffix_Start
: Node_Id
)
30508 Result
: constant List_Id
:= New_List
;
30509 Elem
: Node_Id
:= First
(List
);
30511 while Elem
/= Suffix_Start
loop
30512 Append
(New_Copy
(Elem
), Result
);
30514 pragma Assert
(Present
(Elem
));
30520 return Make_In
(Loc
,
30521 Left_Opnd
=> New_Copy_Tree
(Left_Opnd
(Det
.Expr
)),
30522 Right_Opnd
=> Empty
,
30523 Alternatives
=> Copy_Prefix
30524 (Alternatives
(Det
.Expr
),
30525 Det
.First_Non_Preceding
));
30529 raise Program_Error
;
30531 end Determining_Condition
;
30533 -----------------------------
30534 -- Determining_Expressions --
30535 -----------------------------
30537 function Determining_Expressions
30538 (Expr
: Node_Id
; Expr_Trailer
: Node_Id
:= Empty
)
30539 return Determining_Expression_List
30541 Par
: Node_Id
:= Expr
;
30542 Trailer
: Node_Id
:= Expr_Trailer
;
30543 Next_Element
: Determining_Expr
;
30545 -- We want to stop climbing up the tree when we reach the
30546 -- postcondition expression. An aspect_specification is
30547 -- transformed into a pragma, so reaching a pragma is our
30548 -- termination condition. This relies on the fact that
30549 -- pragmas are not allowed in declare expressions (or any
30550 -- other kind of expression).
30553 Next_Element
.Expr
:= Empty
;
30555 case Nkind
(Par
) is
30556 when N_Short_Circuit
=>
30557 if Trailer
= Right_Opnd
(Par
) then
30559 (Expr
=> Left_Opnd
(Par
),
30560 Context
=> Short_Circuit_Op
,
30561 Is_And_Then
=> Nkind
(Par
) = N_And_Then
);
30564 when N_If_Expression
=>
30565 -- For an expression like
30566 -- (if C1 then ... elsif C2 then ... else Foo'Old)
30567 -- the RM says are two determining expressions,
30568 -- C1 and C2. Our treatment here (where we only add
30569 -- one determining expression to the list) is ok because
30570 -- we will see two if-expressions, one within the other.
30572 if Trailer
/= First
(Expressions
(Par
)) then
30574 (Expr
=> First
(Expressions
(Par
)),
30575 Context
=> If_Expr
,
30577 Trailer
= Next
(First
(Expressions
(Par
))));
30580 when N_Case_Expression_Alternative
=>
30581 pragma Assert
(Nkind
(Parent
(Par
)) = N_Case_Expression
);
30584 (Expr
=> Expression
(Parent
(Par
)),
30585 Context
=> Case_Expr
,
30586 Alternatives
=> Par
);
30588 when N_Membership_Test
=>
30589 if Trailer
/= Left_Opnd
(Par
)
30590 and then Is_Non_Empty_List
(Alternatives
(Par
))
30591 and then Trailer
/= First
(Alternatives
(Par
))
30593 pragma Assert
(No
(Right_Opnd
(Par
)));
30595 (Is_List_Member
(Trailer
)
30596 and then List_Containing
(Trailer
)
30597 = Alternatives
(Par
));
30599 -- This one is different than the others
30600 -- because one element in the array result
30601 -- may represent multiple determining
30602 -- expressions (i.e. every member of the list
30603 -- Alternatives (Par)
30604 -- up to but not including Trailer).
30608 Context
=> Membership_Test
,
30609 First_Non_Preceding
=> Trailer
);
30614 Previous
: constant Node_Id
:= Prev
(Par
);
30615 Prev_Expr
: Node_Id
;
30617 if Nkind
(Previous
) = N_Pragma
and then
30618 Split_PPC
(Previous
)
30620 -- A source-level postcondition of
30621 -- A and then B and then C
30623 -- pragma Postcondition (A);
30624 -- pragma Postcondition (B);
30625 -- pragma Postcondition (C);
30626 -- with Split_PPC set to True on all but the
30627 -- last pragma. We account for that here.
30631 (Pragma_Argument_Associations
(Previous
)));
30633 -- This Analyze call is needed in the case when
30634 -- Sem_Attr.Analyze_Attribute calls
30635 -- Eligible_For_Conditional_Evaluation. Without
30636 -- it, we end up passing an unanalyzed expression
30637 -- to Is_Known_On_Entry and that doesn't work.
30639 Analyze
(Prev_Expr
);
30642 (Expr
=> Prev_Expr
,
30643 Context
=> Short_Circuit_Op
,
30644 Is_And_Then
=> True);
30646 return Determining_Expressions
(Prev_Expr
)
30650 (Get_Pragma_Id
(Pragma_Name
(Par
)) in
30652 | Pragma_Contract_Cases
30653 | Pragma_Exceptional_Cases
30655 | Pragma_Postcondition
30656 | Pragma_Post_Class
30657 | Pragma_Refined_Post
);
30659 return (1 .. 0 => <>); -- recursion terminates here
30664 -- This case should be impossible, but if it does
30665 -- happen somehow then we don't want an infinite loop.
30666 raise Program_Error
;
30673 Par
:= Parent
(Par
);
30675 if Present
(Next_Element
.Expr
) then
30676 return Determining_Expressions
30677 (Expr
=> Par
, Expr_Trailer
=> Trailer
)
30681 end Determining_Expressions
;
30683 -----------------------------------------
30684 -- Eligible_For_Conditional_Evaluation --
30685 -----------------------------------------
30687 function Eligible_For_Conditional_Evaluation
30688 (Expr
: Node_Id
) return Boolean
30691 if Is_Anonymous_Access_Type
(Etype
(Expr
)) then
30692 -- The code in exp_attr.adb that also builds declarations
30693 -- for 'Old constants doesn't handle the anonymous access
30694 -- type case correctly, so we avoid that problem by
30695 -- returning True here.
30698 elsif Ada_Version
< Ada_2022
then
30701 elsif Inside_Class_Condition_Preanalysis
then
30702 -- No need to evaluate it during preanalysis of a class-wide
30703 -- pre/postcondition since the expression is not installed yet
30704 -- on its definite context.
30707 elsif not Is_Conditionally_Evaluated
(Expr
) then
30711 Determiners
: constant Determining_Expression_List
:=
30712 Determining_Expressions
(Expr
);
30714 pragma Assert
(Determiners
'Length > 0);
30716 for Idx
in Determiners
'Range loop
30717 if not Is_Known_On_Entry
(Determiners
(Idx
).Expr
) then
30724 end Eligible_For_Conditional_Evaluation
;
30726 --------------------------------
30727 -- Is_Conditionally_Evaluated --
30728 --------------------------------
30730 function Is_Conditionally_Evaluated
(Expr
: Node_Id
) return Boolean
30732 -- There are three possibilities - the expression is
30733 -- unconditionally evaluated, repeatedly evaluated, or
30734 -- conditionally evaluated (see RM 6.1.1). So we implement
30735 -- this test by testing for the other two.
30737 function Is_Repeatedly_Evaluated
(Expr
: Node_Id
) return Boolean;
30738 -- See RM 6.1.1 for definition of "repeatedly evaluated".
30740 -----------------------------
30741 -- Is_Repeatedly_Evaluated --
30742 -----------------------------
30744 function Is_Repeatedly_Evaluated
(Expr
: Node_Id
) return Boolean is
30745 Par
: Node_Id
:= Expr
;
30746 Trailer
: Node_Id
:= Empty
;
30748 -- There are three ways that an expression can be repeatedly
30751 -- An aspect_specification is transformed into a pragma, so
30752 -- reaching a pragma is our termination condition. We want to
30753 -- stop when we reach the postcondition expression.
30755 while Nkind
(Par
) /= N_Pragma
loop
30756 pragma Assert
(Present
(Par
));
30758 -- test for case 1:
30759 -- A subexpression of a predicate of a
30760 -- quantified_expression.
30762 if Nkind
(Par
) = N_Quantified_Expression
30763 and then Trailer
= Condition
(Par
)
30766 elsif Nkind
(Par
) = N_Expression_With_Actions
30768 Nkind
(Original_Node
(Par
)) = N_Quantified_Expression
30773 -- test for cases 2 and 3:
30774 -- A subexpression of the expression of an
30775 -- array_component_association or of
30776 -- a container_element_associatiation.
30778 if Nkind
(Par
) in N_Component_Association
30779 | N_Iterated_Component_Association
30780 and then Trailer
= Expression
(Par
)
30782 -- determine whether Par is part of an array aggregate
30783 -- or a container aggregate
30785 Rover
: Node_Id
:= Par
;
30787 while Nkind
(Rover
) not in N_Has_Etype
loop
30788 pragma Assert
(Present
(Rover
));
30789 Rover
:= Parent
(Rover
);
30791 if Present
(Etype
(Rover
)) then
30792 if Is_Array_Type
(Etype
(Rover
))
30793 or else Is_Container_Aggregate
(Rover
)
30802 Par
:= Parent
(Par
);
30806 end Is_Repeatedly_Evaluated
;
30809 if not Is_Potentially_Unevaluated
(Expr
) then
30810 -- the expression is unconditionally evaluated
30812 elsif Is_Repeatedly_Evaluated
(Expr
) then
30817 end Is_Conditionally_Evaluated
;
30819 -----------------------
30820 -- Is_Known_On_Entry --
30821 -----------------------
30823 function Is_Known_On_Entry
(Expr
: Node_Id
) return Boolean is
30824 -- ??? This implementation is incomplete. See RM 6.1.1
30825 -- for details. In particular, this function *should* return
30826 -- True for a function call (or a user-defined literal, which
30827 -- is equivalent to a function call) if all actual parameters
30828 -- (including defaulted params) are known on entry and the
30829 -- function has "Globals => null" specified; the current
30830 -- implementation will incorrectly return False in this case.
30832 function All_Exps_Known_On_Entry
30833 (Expr_List
: List_Id
) return Boolean;
30834 -- Given a list of expressions, returns False iff
30835 -- Is_Known_On_Entry is False for at least one list element.
30837 -----------------------------
30838 -- All_Exps_Known_On_Entry --
30839 -----------------------------
30841 function All_Exps_Known_On_Entry
30842 (Expr_List
: List_Id
) return Boolean
30844 Expr
: Node_Id
:= First
(Expr_List
);
30846 while Present
(Expr
) loop
30847 if not Is_Known_On_Entry
(Expr
) then
30853 end All_Exps_Known_On_Entry
;
30856 if Is_Static_Expression
(Expr
) then
30860 if Is_Attribute_Old
(Expr
) then
30865 Pref
: Node_Id
:= Expr
;
30868 case Nkind
(Pref
) is
30869 when N_Selected_Component
=>
30872 when N_Indexed_Component
=>
30873 if not All_Exps_Known_On_Entry
(Expressions
(Pref
))
30879 return False; -- just to be clear about this case
30885 Pref
:= Prefix
(Pref
);
30888 if Is_Entity_Name
(Pref
)
30889 and then Is_Constant_Object
(Entity
(Pref
))
30892 Obj
: constant Entity_Id
:= Entity
(Pref
);
30893 Obj_Typ
: constant Entity_Id
:= Etype
(Obj
);
30895 case Ekind
(Obj
) is
30896 when E_In_Parameter
=>
30897 if not Is_Elementary_Type
(Obj_Typ
) then
30899 elsif Is_Aliased
(Obj
) then
30904 -- return False for a deferred constant
30905 if Present
(Full_View
(Obj
)) then
30909 -- return False if not "all views are constant".
30910 if Is_Immutably_Limited_Type
(Obj_Typ
)
30911 or Needs_Finalization
(Obj_Typ
)
30924 -- ??? Cope with a malformed tree. Code to cope with a
30925 -- nonstatic use of an enumeration literal should not be
30927 if Is_Entity_Name
(Pref
)
30928 and then Ekind
(Entity
(Pref
)) = E_Enumeration_Literal
30934 case Nkind
(Expr
) is
30936 return Is_Known_On_Entry
(Right_Opnd
(Expr
));
30938 when N_Binary_Op
=>
30939 return Is_Known_On_Entry
(Left_Opnd
(Expr
))
30940 and then Is_Known_On_Entry
(Right_Opnd
(Expr
));
30942 when N_Type_Conversion | N_Qualified_Expression
=>
30943 return Is_Known_On_Entry
(Expression
(Expr
));
30945 when N_If_Expression
=>
30946 if not All_Exps_Known_On_Entry
(Expressions
(Expr
)) then
30950 when N_Case_Expression
=>
30951 if not Is_Known_On_Entry
(Expression
(Expr
)) then
30956 Alt
: Node_Id
:= First
(Alternatives
(Expr
));
30958 while Present
(Alt
) loop
30959 if not Is_Known_On_Entry
(Expression
(Alt
)) then
30973 end Is_Known_On_Entry
;
30975 end Conditional_Evaluation
;
30977 package body Indirect_Temps
is
30979 Indirect_Temp_Access_Type_Char
: constant Character := 'K';
30980 -- The character passed to Make_Temporary when declaring
30981 -- the access type that is used in the implementation of an
30982 -- indirect temporary.
30984 --------------------------
30985 -- Indirect_Temp_Needed --
30986 --------------------------
30988 function Indirect_Temp_Needed
(Typ
: Entity_Id
) return Boolean is
30990 -- There should be no correctness issues if the only cases where
30991 -- this function returns False are cases where Typ is an
30992 -- anonymous access type and we need to generate a saooaaat (a
30993 -- stand-alone object of an anonymous access type) in order get
30994 -- accessibility right. In other cases where this function
30995 -- returns False, there would be no correctness problems with
30996 -- returning True instead; however, returning False when we can
30997 -- generally results in simpler code.
31001 -- If Typ is not definite, then we cannot generate
31004 or else not Is_Definite_Subtype
(Typ
)
31006 -- If Typ is tagged, then generating
31008 -- might generate an object with the wrong tag. If we had
31009 -- a predicate that indicated whether the nominal tag is
31010 -- trustworthy, we could use that predicate here.
31012 or else Is_Tagged_Type
(Typ
)
31014 -- If Typ needs finalization, then generating an implicit
31016 -- declaration could have user-visible side effects.
31018 or else Needs_Finalization
(Typ
)
31020 -- In the anonymous access type case, we need to
31021 -- generate a saooaaat. We don't want the code in
31022 -- in exp_attr.adb that deals with the case where this
31023 -- function returns False to have to deal with that case
31024 -- (just to avoid code duplication). So we cheat a little
31025 -- bit and return True here for an anonymous access type.
31027 or else Is_Anonymous_Access_Type
(Typ
);
31029 -- ??? Unimplemented - spec description says:
31030 -- For an unconstrained-but-definite discriminated subtype,
31031 -- returns True if the potential difference in size between an
31032 -- unconstrained object and a constrained object is large.
31035 -- type Typ (Len : Natural := 0) is
31036 -- record F : String (1 .. Len); end record;
31038 -- See Large_Max_Size_Mutable function elsewhere in this file,
31039 -- currently declared inside of Needs_Secondary_Stack, so it
31040 -- would have to be moved if we want it to be callable from here.
31042 end Indirect_Temp_Needed
;
31044 ---------------------------
31045 -- Declare_Indirect_Temp --
31046 ---------------------------
31048 procedure Declare_Indirect_Temp
31049 (Attr_Prefix
: Node_Id
; Indirect_Temp
: out Entity_Id
)
31051 Loc
: constant Source_Ptr
:= Sloc
(Attr_Prefix
);
31052 Prefix_Type
: constant Entity_Id
:= Etype
(Attr_Prefix
);
31053 Temp_Id
: constant Entity_Id
:=
31054 Make_Temporary
(Loc
, 'P', Attr_Prefix
);
31056 procedure Declare_Indirect_Temp_Via_Allocation
;
31057 -- Handle the usual case.
31059 -------------------------------------------
31060 -- Declare_Indirect_Temp_Via_Allocation --
31061 -------------------------------------------
31063 procedure Declare_Indirect_Temp_Via_Allocation
is
31064 Access_Type_Id
: constant Entity_Id
31066 (Loc
, Indirect_Temp_Access_Type_Char
, Attr_Prefix
);
31068 Temp_Decl
: constant Node_Id
:=
31069 Make_Object_Declaration
(Loc
,
31070 Defining_Identifier
=> Temp_Id
,
31071 Object_Definition
=>
31072 New_Occurrence_Of
(Access_Type_Id
, Loc
));
31074 Allocate_Class_Wide
: constant Boolean :=
31075 Is_Specific_Tagged_Type
(Prefix_Type
);
31076 -- If True then access type designates the class-wide type in
31077 -- order to preserve (at run time) the value of the underlying
31079 -- ??? We could do better here (in the case where Prefix_Type
31080 -- is tagged and specific) if we had a predicate which takes an
31081 -- expression and returns True iff the expression is of
31082 -- a specific tagged type and the underlying tag (at run time)
31083 -- is statically known to match that of the specific type.
31084 -- In that case, Allocate_Class_Wide could safely be False.
31086 function Designated_Subtype_Mark
return Node_Id
;
31087 -- Usually, a subtype mark indicating the subtype of the
31088 -- attribute prefix. If that subtype is a specific tagged
31089 -- type, then returns the corresponding class-wide type.
31090 -- If the prefix is of an anonymous access type, then returns
31091 -- the designated type of that type.
31093 -----------------------------
31094 -- Designated_Subtype_Mark --
31095 -----------------------------
31097 function Designated_Subtype_Mark
return Node_Id
is
31098 Typ
: Entity_Id
:= Prefix_Type
;
31100 if Allocate_Class_Wide
then
31101 if Is_Private_Type
(Typ
)
31102 and then Present
(Full_View
(Typ
))
31104 Typ
:= Full_View
(Typ
);
31106 Typ
:= Class_Wide_Type
(Typ
);
31109 return New_Occurrence_Of
(Typ
, Loc
);
31110 end Designated_Subtype_Mark
;
31112 Access_Type_Def
: constant Node_Id
31113 := Make_Access_To_Object_Definition
31114 (Loc
, Subtype_Indication
=> Designated_Subtype_Mark
);
31116 Access_Type_Decl
: constant Node_Id
31117 := Make_Full_Type_Declaration
31118 (Loc
, Access_Type_Id
,
31119 Type_Definition
=> Access_Type_Def
);
31121 Mutate_Ekind
(Temp_Id
, E_Variable
);
31122 Set_Etype
(Temp_Id
, Access_Type_Id
);
31123 Mutate_Ekind
(Access_Type_Id
, E_Access_Type
);
31125 if Append_Decls_In_Reverse_Order
then
31126 Append_Item
(Temp_Decl
, Is_Eval_Stmt
=> False);
31127 Append_Item
(Access_Type_Decl
, Is_Eval_Stmt
=> False);
31129 Append_Item
(Access_Type_Decl
, Is_Eval_Stmt
=> False);
31130 Append_Item
(Temp_Decl
, Is_Eval_Stmt
=> False);
31133 -- When a type associated with an indirect temporary gets
31134 -- created for a 'Old attribute reference we need to mark
31135 -- the type as such. This allows, for example, finalization
31136 -- masters associated with them to be finalized in the correct
31137 -- order after postcondition checks.
31139 if Attribute_Name
(Parent
(Attr_Prefix
)) = Name_Old
then
31140 Set_Stores_Attribute_Old_Prefix
(Access_Type_Id
);
31143 Analyze
(Access_Type_Decl
);
31144 Analyze
(Temp_Decl
);
31147 (Is_Access_Type_For_Indirect_Temp
(Access_Type_Id
));
31150 Expression
: Node_Id
:= Attr_Prefix
;
31151 Allocator
: Node_Id
;
31153 if Allocate_Class_Wide
then
31154 -- generate T'Class'(T'Class (<prefix>))
31156 Make_Type_Conversion
(Loc
,
31157 Subtype_Mark
=> Designated_Subtype_Mark
,
31158 Expression
=> Expression
);
31162 Make_Allocator
(Loc
,
31163 Make_Qualified_Expression
31165 Subtype_Mark
=> Designated_Subtype_Mark
,
31166 Expression
=> Expression
));
31168 -- Allocate saved prefix value on the secondary stack
31169 -- in order to avoid introducing a storage leak. This
31170 -- allocated object is never explicitly reclaimed.
31172 -- ??? Emit storage leak warning if RE_SS_Pool
31175 if RTE_Available
(RE_SS_Pool
) then
31176 Set_Storage_Pool
(Allocator
, RTE
(RE_SS_Pool
));
31177 Set_Procedure_To_Call
31178 (Allocator
, RTE
(RE_SS_Allocate
));
31179 Set_Uses_Sec_Stack
(Current_Scope
);
31183 (Make_Assignment_Statement
(Loc
,
31184 Name
=> New_Occurrence_Of
(Temp_Id
, Loc
),
31185 Expression
=> Allocator
),
31186 Is_Eval_Stmt
=> True);
31188 end Declare_Indirect_Temp_Via_Allocation
;
31191 Indirect_Temp
:= Temp_Id
;
31193 if Is_Anonymous_Access_Type
(Prefix_Type
) then
31194 -- In the anonymous access type case, we do not want a level
31195 -- indirection (which would result in declaring an
31196 -- access-to-access type); that would result in correctness
31197 -- problems - the accessibility level of the type of the
31198 -- 'Old constant would be wrong (See 6.1.1.). So in that case,
31199 -- we do not generate an allocator. Instead we generate
31200 -- Temp : access Designated := null;
31201 -- which is unconditionally elaborated and then
31202 -- Temp := <attribute prefix>;
31203 -- which is conditionally executed.
31206 Temp_Decl
: constant Node_Id
:=
31207 Make_Object_Declaration
(Loc
,
31208 Defining_Identifier
=> Temp_Id
,
31209 Object_Definition
=>
31210 Make_Access_Definition
31212 Constant_Present
=>
31213 Is_Access_Constant
(Prefix_Type
),
31216 (Designated_Type
(Prefix_Type
), Loc
)));
31218 Append_Item
(Temp_Decl
, Is_Eval_Stmt
=> False);
31219 Analyze
(Temp_Decl
);
31221 (Make_Assignment_Statement
(Loc
,
31222 Name
=> New_Occurrence_Of
(Temp_Id
, Loc
),
31223 Expression
=> Attr_Prefix
),
31224 Is_Eval_Stmt
=> True);
31228 Declare_Indirect_Temp_Via_Allocation
;
31230 end Declare_Indirect_Temp
;
31232 -------------------------
31233 -- Indirect_Temp_Value --
31234 -------------------------
31236 function Indirect_Temp_Value
31239 Loc
: Source_Ptr
) return Node_Id
31243 if Is_Anonymous_Access_Type
(Typ
) then
31244 -- No indirection in this case; just evaluate the temp.
31245 Result
:= New_Occurrence_Of
(Temp
, Loc
);
31246 Set_Etype
(Result
, Etype
(Temp
));
31249 Result
:= Make_Explicit_Dereference
(Loc
,
31250 New_Occurrence_Of
(Temp
, Loc
));
31252 Set_Etype
(Result
, Designated_Type
(Etype
(Temp
)));
31254 if Is_Specific_Tagged_Type
(Typ
) then
31255 -- The designated type of the access type is class-wide, so
31256 -- convert to the specific type.
31259 Make_Type_Conversion
(Loc
,
31260 Subtype_Mark
=> New_Occurrence_Of
(Typ
, Loc
),
31261 Expression
=> Result
);
31263 Set_Etype
(Result
, Typ
);
31268 end Indirect_Temp_Value
;
31270 function Is_Access_Type_For_Indirect_Temp
31271 (T
: Entity_Id
) return Boolean is
31273 if Is_Access_Type
(T
)
31274 and then not Comes_From_Source
(T
)
31275 and then Is_Internal_Name
(Chars
(T
))
31276 and then Nkind
(Scope
(T
)) in N_Entity
31277 and then Ekind
(Scope
(T
))
31278 in E_Entry | E_Entry_Family | E_Function | E_Procedure
31280 (Present
(Wrapped_Statements
(Scope
(T
)))
31281 or else Present
(Contract
(Scope
(T
))))
31283 -- ??? Should define a flag for this. We could incorrectly
31284 -- return True if other clients of Make_Temporary happen to
31285 -- pass in the same character.
31287 Name
: constant String := Get_Name_String
(Chars
(T
));
31289 if Name
(Name
'First) = Indirect_Temp_Access_Type_Char
then
31296 end Is_Access_Type_For_Indirect_Temp
;
31298 end Indirect_Temps
;
31301 package body Storage_Model_Support
is
31303 -----------------------------------------
31304 -- Has_Designated_Storage_Model_Aspect --
31305 -----------------------------------------
31307 function Has_Designated_Storage_Model_Aspect
31308 (Typ
: Entity_Id
) return Boolean
31311 return Has_Aspect
(Typ
, Aspect_Designated_Storage_Model
);
31312 end Has_Designated_Storage_Model_Aspect
;
31314 -----------------------------------
31315 -- Has_Storage_Model_Type_Aspect --
31316 -----------------------------------
31318 function Has_Storage_Model_Type_Aspect
(Typ
: Entity_Id
) return Boolean
31321 return Has_Aspect
(Typ
, Aspect_Storage_Model_Type
);
31322 end Has_Storage_Model_Type_Aspect
;
31324 --------------------------
31325 -- Storage_Model_Object --
31326 --------------------------
31328 function Storage_Model_Object
(Typ
: Entity_Id
) return Entity_Id
is
31330 pragma Assert
(Has_Designated_Storage_Model_Aspect
(Typ
));
31334 (Find_Value_Of_Aspect
(Typ
, Aspect_Designated_Storage_Model
));
31335 end Storage_Model_Object
;
31337 ------------------------
31338 -- Storage_Model_Type --
31339 ------------------------
31341 function Storage_Model_Type
(Obj
: Entity_Id
) return Entity_Id
is
31343 pragma Assert
(Has_Storage_Model_Type_Aspect
(Etype
(Obj
)));
31345 return Etype
(Obj
);
31346 end Storage_Model_Type
;
31348 -----------------------------------
31349 -- Get_Storage_Model_Type_Entity --
31350 -----------------------------------
31352 function Get_Storage_Model_Type_Entity
31353 (SM_Obj_Or_Type
: Entity_Id
;
31354 Nam
: Name_Id
) return Entity_Id
31356 Typ
: constant Entity_Id
:= (if Is_Object
(SM_Obj_Or_Type
) then
31357 Storage_Model_Type
(SM_Obj_Or_Type
)
31363 Nam
in Name_Address_Type
31364 | Name_Null_Address
31369 | Name_Storage_Size
);
31372 SMT_Aspect_Value
: constant Node_Id
:=
31373 Find_Value_Of_Aspect
(Typ
, Aspect_Storage_Model_Type
);
31376 -- When the aspect has an aggregate expression, search through it
31377 -- to locate a match for the name of the given "subaspect" and return
31378 -- the entity of the aggregate association's expression.
31380 if Present
(SMT_Aspect_Value
) then
31381 Assoc
:= First
(Component_Associations
(SMT_Aspect_Value
));
31382 while Present
(Assoc
) loop
31383 if Chars
(First
(Choices
(Assoc
))) = Nam
then
31384 return Entity
(Expression
(Assoc
));
31391 -- The aggregate argument of Storage_Model_Type is optional, and when
31392 -- not present the aspect defaults to the native storage model, where
31393 -- the address type is System.Address. In that case, we return
31394 -- System.Address for Name_Address_Type and System.Null_Address for
31395 -- Name_Null_Address, but return Empty for other cases, and leave it
31396 -- to the back end to map those to the appropriate native operations.
31398 if Nam
= Name_Address_Type
then
31399 return RTE
(RE_Address
);
31401 elsif Nam
= Name_Null_Address
then
31402 return RTE
(RE_Null_Address
);
31407 end Get_Storage_Model_Type_Entity
;
31409 --------------------------------
31410 -- Storage_Model_Address_Type --
31411 --------------------------------
31413 function Storage_Model_Address_Type
31414 (SM_Obj_Or_Type
: Entity_Id
) return Entity_Id
31418 Get_Storage_Model_Type_Entity
(SM_Obj_Or_Type
, Name_Address_Type
);
31419 end Storage_Model_Address_Type
;
31421 --------------------------------
31422 -- Storage_Model_Null_Address --
31423 --------------------------------
31425 function Storage_Model_Null_Address
31426 (SM_Obj_Or_Type
: Entity_Id
) return Entity_Id
31430 Get_Storage_Model_Type_Entity
(SM_Obj_Or_Type
, Name_Null_Address
);
31431 end Storage_Model_Null_Address
;
31433 ----------------------------
31434 -- Storage_Model_Allocate --
31435 ----------------------------
31437 function Storage_Model_Allocate
31438 (SM_Obj_Or_Type
: Entity_Id
) return Entity_Id
31441 return Get_Storage_Model_Type_Entity
(SM_Obj_Or_Type
, Name_Allocate
);
31442 end Storage_Model_Allocate
;
31444 ------------------------------
31445 -- Storage_Model_Deallocate --
31446 ------------------------------
31448 function Storage_Model_Deallocate
31449 (SM_Obj_Or_Type
: Entity_Id
) return Entity_Id
31453 Get_Storage_Model_Type_Entity
(SM_Obj_Or_Type
, Name_Deallocate
);
31454 end Storage_Model_Deallocate
;
31456 -----------------------------
31457 -- Storage_Model_Copy_From --
31458 -----------------------------
31460 function Storage_Model_Copy_From
31461 (SM_Obj_Or_Type
: Entity_Id
) return Entity_Id
31464 return Get_Storage_Model_Type_Entity
(SM_Obj_Or_Type
, Name_Copy_From
);
31465 end Storage_Model_Copy_From
;
31467 ---------------------------
31468 -- Storage_Model_Copy_To --
31469 ---------------------------
31471 function Storage_Model_Copy_To
31472 (SM_Obj_Or_Type
: Entity_Id
) return Entity_Id
31475 return Get_Storage_Model_Type_Entity
(SM_Obj_Or_Type
, Name_Copy_To
);
31476 end Storage_Model_Copy_To
;
31478 --------------------------------
31479 -- Storage_Model_Storage_Size --
31480 --------------------------------
31482 function Storage_Model_Storage_Size
31483 (SM_Obj_Or_Type
: Entity_Id
) return Entity_Id
31487 Get_Storage_Model_Type_Entity
(SM_Obj_Or_Type
, Name_Storage_Size
);
31488 end Storage_Model_Storage_Size
;
31490 end Storage_Model_Support
;
31493 Erroutc
.Subprogram_Name_Ptr
:= Subprogram_Name
'Access;