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
1818 if Is_Constrained
(T
) then
1820 -- We won't build a new subtype if T is constrained
1825 return Is_Definite_Subtype
(T
) and then Is_Inherently_Limited_Type
(T
);
1826 end Build_Default_Subtype_OK
;
1828 --------------------------------------------
1829 -- Build_Discriminal_Subtype_Of_Component --
1830 --------------------------------------------
1832 function Build_Discriminal_Subtype_Of_Component
1833 (T
: Entity_Id
) return Node_Id
1835 Loc
: constant Source_Ptr
:= Sloc
(T
);
1839 function Build_Discriminal_Array_Constraint
return List_Id
;
1840 -- If one or more of the bounds of the component depends on
1841 -- discriminants, build actual constraint using the discriminants
1844 function Build_Discriminal_Record_Constraint
return List_Id
;
1845 -- Similar to previous one, for discriminated components constrained by
1846 -- the discriminant of the enclosing object.
1848 ----------------------------------------
1849 -- Build_Discriminal_Array_Constraint --
1850 ----------------------------------------
1852 function Build_Discriminal_Array_Constraint
return List_Id
is
1853 Constraints
: constant List_Id
:= New_List
;
1861 Indx
:= First_Index
(T
);
1862 while Present
(Indx
) loop
1863 Old_Lo
:= Type_Low_Bound
(Etype
(Indx
));
1864 Old_Hi
:= Type_High_Bound
(Etype
(Indx
));
1866 if Denotes_Discriminant
(Old_Lo
) then
1867 Lo
:= New_Occurrence_Of
(Discriminal
(Entity
(Old_Lo
)), Loc
);
1870 Lo
:= New_Copy_Tree
(Old_Lo
);
1873 if Denotes_Discriminant
(Old_Hi
) then
1874 Hi
:= New_Occurrence_Of
(Discriminal
(Entity
(Old_Hi
)), Loc
);
1877 Hi
:= New_Copy_Tree
(Old_Hi
);
1880 Append
(Make_Range
(Loc
, Lo
, Hi
), Constraints
);
1885 end Build_Discriminal_Array_Constraint
;
1887 -----------------------------------------
1888 -- Build_Discriminal_Record_Constraint --
1889 -----------------------------------------
1891 function Build_Discriminal_Record_Constraint
return List_Id
is
1892 Constraints
: constant List_Id
:= New_List
;
1897 D
:= First_Elmt
(Discriminant_Constraint
(T
));
1898 while Present
(D
) loop
1899 if Denotes_Discriminant
(Node
(D
)) then
1901 New_Occurrence_Of
(Discriminal
(Entity
(Node
(D
))), Loc
);
1903 D_Val
:= New_Copy_Tree
(Node
(D
));
1906 Append
(D_Val
, Constraints
);
1911 end Build_Discriminal_Record_Constraint
;
1913 -- Start of processing for Build_Discriminal_Subtype_Of_Component
1916 if Ekind
(T
) = E_Array_Subtype
then
1917 Id
:= First_Index
(T
);
1918 while Present
(Id
) loop
1919 if Denotes_Discriminant
(Type_Low_Bound
(Etype
(Id
)))
1921 Denotes_Discriminant
(Type_High_Bound
(Etype
(Id
)))
1923 return Build_Component_Subtype
1924 (Build_Discriminal_Array_Constraint
, Loc
, T
);
1930 elsif Ekind
(T
) = E_Record_Subtype
1931 and then Has_Discriminants
(T
)
1932 and then not Has_Unknown_Discriminants
(T
)
1934 D
:= First_Elmt
(Discriminant_Constraint
(T
));
1935 while Present
(D
) loop
1936 if Denotes_Discriminant
(Node
(D
)) then
1937 return Build_Component_Subtype
1938 (Build_Discriminal_Record_Constraint
, Loc
, T
);
1945 -- If none of the above, the actual and nominal subtypes are the same
1948 end Build_Discriminal_Subtype_Of_Component
;
1950 ------------------------------
1951 -- Build_Elaboration_Entity --
1952 ------------------------------
1954 procedure Build_Elaboration_Entity
(N
: Node_Id
; Spec_Id
: Entity_Id
) is
1955 Loc
: constant Source_Ptr
:= Sloc
(N
);
1957 Elab_Ent
: Entity_Id
;
1959 procedure Set_Package_Name
(Ent
: Entity_Id
);
1960 -- Given an entity, sets the fully qualified name of the entity in
1961 -- Name_Buffer, with components separated by double underscores. This
1962 -- is a recursive routine that climbs the scope chain to Standard.
1964 ----------------------
1965 -- Set_Package_Name --
1966 ----------------------
1968 procedure Set_Package_Name
(Ent
: Entity_Id
) is
1970 if Scope
(Ent
) /= Standard_Standard
then
1971 Set_Package_Name
(Scope
(Ent
));
1974 Nam
: constant String := Get_Name_String
(Chars
(Ent
));
1976 Name_Buffer
(Name_Len
+ 1) := '_';
1977 Name_Buffer
(Name_Len
+ 2) := '_';
1978 Name_Buffer
(Name_Len
+ 3 .. Name_Len
+ Nam
'Length + 2) := Nam
;
1979 Name_Len
:= Name_Len
+ Nam
'Length + 2;
1983 Get_Name_String
(Chars
(Ent
));
1985 end Set_Package_Name
;
1987 -- Start of processing for Build_Elaboration_Entity
1990 -- Ignore call if already constructed
1992 if Present
(Elaboration_Entity
(Spec_Id
)) then
1995 -- Do not generate an elaboration entity in GNATprove move because the
1996 -- elaboration counter is a form of expansion.
1998 elsif GNATprove_Mode
then
2001 -- See if we need elaboration entity
2003 -- We always need an elaboration entity when preserving control flow, as
2004 -- we want to remain explicit about the unit's elaboration order.
2006 elsif Opt
.Suppress_Control_Flow_Optimizations
then
2009 -- We always need an elaboration entity for the dynamic elaboration
2010 -- model, since it is needed to properly generate the PE exception for
2011 -- access before elaboration.
2013 elsif Dynamic_Elaboration_Checks
then
2016 -- For the static model, we don't need the elaboration counter if this
2017 -- unit is sure to have no elaboration code, since that means there
2018 -- is no elaboration unit to be called. Note that we can't just decide
2019 -- after the fact by looking to see whether there was elaboration code,
2020 -- because that's too late to make this decision.
2022 elsif Restriction_Active
(No_Elaboration_Code
) then
2025 -- Similarly, for the static model, we can skip the elaboration counter
2026 -- if we have the No_Multiple_Elaboration restriction, since for the
2027 -- static model, that's the only purpose of the counter (to avoid
2028 -- multiple elaboration).
2030 elsif Restriction_Active
(No_Multiple_Elaboration
) then
2034 -- Here we need the elaboration entity
2036 -- Construct name of elaboration entity as xxx_E, where xxx is the unit
2037 -- name with dots replaced by double underscore. We have to manually
2038 -- construct this name, since it will be elaborated in the outer scope,
2039 -- and thus will not have the unit name automatically prepended.
2041 Set_Package_Name
(Spec_Id
);
2042 Add_Str_To_Name_Buffer
("_E");
2044 -- Create elaboration counter
2046 Elab_Ent
:= Make_Defining_Identifier
(Loc
, Chars
=> Name_Find
);
2047 Set_Elaboration_Entity
(Spec_Id
, Elab_Ent
);
2050 Make_Object_Declaration
(Loc
,
2051 Defining_Identifier
=> Elab_Ent
,
2052 Object_Definition
=>
2053 New_Occurrence_Of
(Standard_Short_Integer
, Loc
),
2054 Expression
=> Make_Integer_Literal
(Loc
, Uint_0
));
2056 Push_Scope
(Standard_Standard
);
2057 Add_Global_Declaration
(Decl
);
2060 -- Reset True_Constant indication, since we will indeed assign a value
2061 -- to the variable in the binder main. We also kill the Current_Value
2062 -- and Last_Assignment fields for the same reason.
2064 Set_Is_True_Constant
(Elab_Ent
, False);
2065 Set_Current_Value
(Elab_Ent
, Empty
);
2066 Set_Last_Assignment
(Elab_Ent
, Empty
);
2068 -- We do not want any further qualification of the name (if we did not
2069 -- do this, we would pick up the name of the generic package in the case
2070 -- of a library level generic instantiation).
2072 Set_Has_Qualified_Name
(Elab_Ent
);
2073 Set_Has_Fully_Qualified_Name
(Elab_Ent
);
2074 end Build_Elaboration_Entity
;
2076 --------------------------------
2077 -- Build_Explicit_Dereference --
2078 --------------------------------
2080 procedure Build_Explicit_Dereference
2084 Loc
: constant Source_Ptr
:= Sloc
(Expr
);
2089 -- An entity of a type with a reference aspect is overloaded with
2090 -- both interpretations: with and without the dereference. Now that
2091 -- the dereference is made explicit, set the type of the node properly,
2092 -- to prevent anomalies in the backend. Same if the expression is an
2093 -- overloaded function call whose return type has a reference aspect.
2095 if Is_Entity_Name
(Expr
) then
2096 Set_Etype
(Expr
, Etype
(Entity
(Expr
)));
2098 -- The designated entity will not be examined again when resolving
2099 -- the dereference, so generate a reference to it now.
2101 Generate_Reference
(Entity
(Expr
), Expr
);
2103 elsif Nkind
(Expr
) = N_Function_Call
then
2105 -- If the name of the indexing function is overloaded, locate the one
2106 -- whose return type has an implicit dereference on the desired
2107 -- discriminant, and set entity and type of function call.
2109 if Is_Overloaded
(Name
(Expr
)) then
2110 Get_First_Interp
(Name
(Expr
), I
, It
);
2112 while Present
(It
.Nam
) loop
2113 if Ekind
((It
.Typ
)) = E_Record_Type
2114 and then First_Entity
((It
.Typ
)) = Disc
2116 Set_Entity
(Name
(Expr
), It
.Nam
);
2117 Set_Etype
(Name
(Expr
), Etype
(It
.Nam
));
2121 Get_Next_Interp
(I
, It
);
2125 -- Set type of call from resolved function name.
2127 Set_Etype
(Expr
, Etype
(Name
(Expr
)));
2130 Set_Is_Overloaded
(Expr
, False);
2132 -- The expression will often be a generalized indexing that yields a
2133 -- container element that is then dereferenced, in which case the
2134 -- generalized indexing call is also non-overloaded.
2136 if Nkind
(Expr
) = N_Indexed_Component
2137 and then Present
(Generalized_Indexing
(Expr
))
2139 Set_Is_Overloaded
(Generalized_Indexing
(Expr
), False);
2143 Make_Explicit_Dereference
(Loc
,
2145 Make_Selected_Component
(Loc
,
2146 Prefix
=> Relocate_Node
(Expr
),
2147 Selector_Name
=> New_Occurrence_Of
(Disc
, Loc
))));
2148 Set_Etype
(Prefix
(Expr
), Etype
(Disc
));
2149 Set_Etype
(Expr
, Designated_Type
(Etype
(Disc
)));
2150 end Build_Explicit_Dereference
;
2152 ---------------------------
2153 -- Build_Overriding_Spec --
2154 ---------------------------
2156 function Build_Overriding_Spec
2158 Typ
: Entity_Id
) return Node_Id
2160 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
2161 Par_Typ
: constant Entity_Id
:= Find_Dispatching_Type
(Op
);
2162 Spec
: constant Node_Id
:= Specification
(Unit_Declaration_Node
(Op
));
2164 Formal_Spec
: Node_Id
;
2165 Formal_Type
: Node_Id
;
2169 New_Spec
:= Copy_Subprogram_Spec
(Spec
);
2171 Formal_Spec
:= First
(Parameter_Specifications
(New_Spec
));
2172 while Present
(Formal_Spec
) loop
2173 Formal_Type
:= Parameter_Type
(Formal_Spec
);
2175 if Is_Entity_Name
(Formal_Type
)
2176 and then Entity
(Formal_Type
) = Par_Typ
2178 Rewrite
(Formal_Type
, New_Occurrence_Of
(Typ
, Loc
));
2180 elsif Nkind
(Formal_Type
) = N_Access_Definition
2181 and then Entity
(Subtype_Mark
(Formal_Type
)) = Par_Typ
2183 Rewrite
(Subtype_Mark
(Formal_Type
), New_Occurrence_Of
(Typ
, Loc
));
2190 end Build_Overriding_Spec
;
2196 function Build_Subtype
2197 (Related_Node
: Node_Id
;
2200 Constraints
: List_Id
)
2204 Subtyp_Decl
: Node_Id
;
2206 Btyp
: Entity_Id
:= Base_Type
(Typ
);
2209 -- The Related_Node better be here or else we won't be able to
2210 -- attach new itypes to a node in the tree.
2212 pragma Assert
(Present
(Related_Node
));
2214 -- If the view of the component's type is incomplete or private
2215 -- with unknown discriminants, then the constraint must be applied
2216 -- to the full type.
2218 if Has_Unknown_Discriminants
(Btyp
)
2219 and then Present
(Underlying_Type
(Btyp
))
2221 Btyp
:= Underlying_Type
(Btyp
);
2225 Make_Subtype_Indication
(Loc
,
2226 Subtype_Mark
=> New_Occurrence_Of
(Btyp
, Loc
),
2228 Make_Index_Or_Discriminant_Constraint
(Loc
, Constraints
));
2230 Def_Id
:= Create_Itype
(Ekind
(Typ
), Related_Node
);
2233 Make_Subtype_Declaration
(Loc
,
2234 Defining_Identifier
=> Def_Id
,
2235 Subtype_Indication
=> Indic
);
2237 Set_Parent
(Subtyp_Decl
, Parent
(Related_Node
));
2239 -- Itypes must be analyzed with checks off (see package Itypes)
2241 Analyze
(Subtyp_Decl
, Suppress
=> All_Checks
);
2243 if Is_Itype
(Def_Id
) and then Has_Predicates
(Typ
) then
2244 Inherit_Predicate_Flags
(Def_Id
, Typ
);
2246 -- Indicate where the predicate function may be found
2248 if Is_Itype
(Typ
) then
2249 if Present
(Predicate_Function
(Def_Id
)) then
2252 elsif Present
(Predicate_Function
(Typ
)) then
2253 Set_Predicate_Function
(Def_Id
, Predicate_Function
(Typ
));
2256 Set_Predicated_Parent
(Def_Id
, Predicated_Parent
(Typ
));
2259 elsif No
(Predicate_Function
(Def_Id
)) then
2260 Set_Predicated_Parent
(Def_Id
, Typ
);
2267 -----------------------------------
2268 -- Cannot_Raise_Constraint_Error --
2269 -----------------------------------
2271 function Cannot_Raise_Constraint_Error
(Expr
: Node_Id
) return Boolean is
2273 function List_Cannot_Raise_CE
(L
: List_Id
) return Boolean;
2274 -- Returns True if none of the list members cannot possibly raise
2275 -- Constraint_Error.
2277 --------------------------
2278 -- List_Cannot_Raise_CE --
2279 --------------------------
2281 function List_Cannot_Raise_CE
(L
: List_Id
) return Boolean is
2285 while Present
(N
) loop
2286 if Cannot_Raise_Constraint_Error
(N
) then
2294 end List_Cannot_Raise_CE
;
2296 -- Start of processing for Cannot_Raise_Constraint_Error
2299 if Compile_Time_Known_Value
(Expr
) then
2302 elsif Do_Range_Check
(Expr
) then
2305 elsif Raises_Constraint_Error
(Expr
) then
2309 case Nkind
(Expr
) is
2310 when N_Identifier
=>
2313 when N_Expanded_Name
=>
2316 when N_Indexed_Component
=>
2317 return not Do_Range_Check
(Expr
)
2318 and then Cannot_Raise_Constraint_Error
(Prefix
(Expr
))
2319 and then List_Cannot_Raise_CE
(Expressions
(Expr
));
2321 when N_Selected_Component
=>
2322 return not Do_Discriminant_Check
(Expr
)
2323 and then Cannot_Raise_Constraint_Error
(Prefix
(Expr
));
2325 when N_Attribute_Reference
=>
2326 if Do_Overflow_Check
(Expr
) then
2329 elsif No
(Expressions
(Expr
)) then
2333 return List_Cannot_Raise_CE
(Expressions
(Expr
));
2336 when N_Type_Conversion
=>
2337 if Do_Overflow_Check
(Expr
)
2338 or else Do_Length_Check
(Expr
)
2342 return Cannot_Raise_Constraint_Error
(Expression
(Expr
));
2345 when N_Unchecked_Type_Conversion
=>
2346 return Cannot_Raise_Constraint_Error
(Expression
(Expr
));
2349 if Do_Overflow_Check
(Expr
) then
2352 return Cannot_Raise_Constraint_Error
(Right_Opnd
(Expr
));
2359 if Do_Division_Check
(Expr
)
2361 Do_Overflow_Check
(Expr
)
2366 Cannot_Raise_Constraint_Error
(Left_Opnd
(Expr
))
2368 Cannot_Raise_Constraint_Error
(Right_Opnd
(Expr
));
2387 | N_Op_Shift_Right_Arithmetic
2391 if Do_Overflow_Check
(Expr
) then
2395 Cannot_Raise_Constraint_Error
(Left_Opnd
(Expr
))
2397 Cannot_Raise_Constraint_Error
(Right_Opnd
(Expr
));
2404 end Cannot_Raise_Constraint_Error
;
2406 -------------------------------
2407 -- Check_Ambiguous_Aggregate --
2408 -------------------------------
2410 procedure Check_Ambiguous_Aggregate
(Call
: Node_Id
) is
2414 if All_Extensions_Allowed
then
2415 Actual
:= First_Actual
(Call
);
2416 while Present
(Actual
) loop
2417 if Nkind
(Actual
) = N_Aggregate
then
2419 ("\add type qualification to aggregate actual", Actual
);
2422 Next_Actual
(Actual
);
2425 end Check_Ambiguous_Aggregate
;
2427 -----------------------------------------
2428 -- Check_Dynamically_Tagged_Expression --
2429 -----------------------------------------
2431 procedure Check_Dynamically_Tagged_Expression
2434 Related_Nod
: Node_Id
)
2437 pragma Assert
(Is_Tagged_Type
(Typ
));
2439 -- In order to avoid spurious errors when analyzing the expanded code,
2440 -- this check is done only for nodes that come from source and for
2441 -- actuals of generic instantiations.
2443 if (Comes_From_Source
(Related_Nod
)
2444 or else In_Generic_Actual
(Expr
))
2445 and then (Is_Class_Wide_Type
(Etype
(Expr
))
2446 or else Is_Dynamically_Tagged
(Expr
))
2447 and then not Is_Class_Wide_Type
(Typ
)
2449 Error_Msg_N
("dynamically tagged expression not allowed!", Expr
);
2451 end Check_Dynamically_Tagged_Expression
;
2453 --------------------------
2454 -- Check_Fully_Declared --
2455 --------------------------
2457 procedure Check_Fully_Declared
(T
: Entity_Id
; N
: Node_Id
) is
2459 if Ekind
(T
) = E_Incomplete_Type
then
2461 -- Ada 2005 (AI-50217): If the type is available through a limited
2462 -- with_clause, verify that its full view has been analyzed.
2464 if From_Limited_With
(T
)
2465 and then Present
(Non_Limited_View
(T
))
2466 and then Ekind
(Non_Limited_View
(T
)) /= E_Incomplete_Type
2468 -- The non-limited view is fully declared
2474 ("premature usage of incomplete}", N
, First_Subtype
(T
));
2477 -- Need comments for these tests ???
2479 elsif Has_Private_Component
(T
)
2480 and then not Is_Generic_Type
(Root_Type
(T
))
2481 and then not In_Spec_Expression
2483 -- Special case: if T is the anonymous type created for a single
2484 -- task or protected object, use the name of the source object.
2486 if Is_Concurrent_Type
(T
)
2487 and then not Comes_From_Source
(T
)
2488 and then Nkind
(N
) = N_Object_Declaration
2491 ("type of& has incomplete component",
2492 N
, Defining_Identifier
(N
));
2495 ("premature usage of incomplete}",
2496 N
, First_Subtype
(T
));
2499 end Check_Fully_Declared
;
2501 -------------------------------------------
2502 -- Check_Function_With_Address_Parameter --
2503 -------------------------------------------
2505 procedure Check_Function_With_Address_Parameter
(Subp_Id
: Entity_Id
) is
2510 F
:= First_Formal
(Subp_Id
);
2511 while Present
(F
) loop
2514 if Is_Private_Type
(T
) and then Present
(Full_View
(T
)) then
2518 if Is_Descendant_Of_Address
(T
) or else Is_Limited_Type
(T
) then
2519 Set_Is_Pure
(Subp_Id
, False);
2525 end Check_Function_With_Address_Parameter
;
2527 -------------------------------------
2528 -- Check_Function_Writable_Actuals --
2529 -------------------------------------
2531 procedure Check_Function_Writable_Actuals
(N
: Node_Id
) is
2532 Writable_Actuals_List
: Elist_Id
:= No_Elist
;
2533 Identifiers_List
: Elist_Id
:= No_Elist
;
2534 Aggr_Error_Node
: Node_Id
:= Empty
;
2535 Error_Node
: Node_Id
:= Empty
;
2537 procedure Collect_Identifiers
(N
: Node_Id
);
2538 -- In a single traversal of subtree N collect in Writable_Actuals_List
2539 -- all the actuals of functions with writable actuals, and in the list
2540 -- Identifiers_List collect all the identifiers that are not actuals of
2541 -- functions with writable actuals. If a writable actual is referenced
2542 -- twice as writable actual then Error_Node is set to reference its
2543 -- second occurrence, the error is reported, and the tree traversal
2546 -------------------------
2547 -- Collect_Identifiers --
2548 -------------------------
2550 procedure Collect_Identifiers
(N
: Node_Id
) is
2552 function Check_Node
(N
: Node_Id
) return Traverse_Result
;
2553 -- Process a single node during the tree traversal to collect the
2554 -- writable actuals of functions and all the identifiers which are
2555 -- not writable actuals of functions.
2557 function Contains
(List
: Elist_Id
; N
: Node_Id
) return Boolean;
2558 -- Returns True if List has a node whose Entity is Entity (N)
2564 function Check_Node
(N
: Node_Id
) return Traverse_Result
is
2565 Is_Writable_Actual
: Boolean := False;
2566 Id
: Entity_Id
:= Empty
;
2567 -- Default init of Id for CodePeer
2570 if Nkind
(N
) = N_Identifier
then
2572 -- No analysis possible if the entity is not decorated
2574 if No
(Entity
(N
)) then
2577 -- Don't collect identifiers of packages, called functions, etc
2579 elsif Ekind
(Entity
(N
)) in
2580 E_Package | E_Function | E_Procedure | E_Entry
2584 -- For rewritten nodes, continue the traversal in the original
2585 -- subtree. Needed to handle aggregates in original expressions
2586 -- extracted from the tree by Remove_Side_Effects.
2588 elsif Is_Rewrite_Substitution
(N
) then
2589 Collect_Identifiers
(Original_Node
(N
));
2592 -- For now we skip aggregate discriminants, since they require
2593 -- performing the analysis in two phases to identify conflicts:
2594 -- first one analyzing discriminants and second one analyzing
2595 -- the rest of components (since at run time, discriminants are
2596 -- evaluated prior to components): too much computation cost
2597 -- to identify a corner case???
2599 elsif Nkind
(Parent
(N
)) = N_Component_Association
2600 and then Nkind
(Parent
(Parent
(N
))) in
2601 N_Aggregate | N_Extension_Aggregate
2604 Choice
: constant Node_Id
:= First
(Choices
(Parent
(N
)));
2607 if Ekind
(Entity
(N
)) = E_Discriminant
then
2610 elsif Expression
(Parent
(N
)) = N
2611 and then Nkind
(Choice
) = N_Identifier
2612 and then Ekind
(Entity
(Choice
)) = E_Discriminant
2618 -- Analyze if N is a writable actual of a function
2620 elsif Nkind
(Parent
(N
)) = N_Function_Call
then
2622 Call
: constant Node_Id
:= Parent
(N
);
2627 Id
:= Get_Called_Entity
(Call
);
2629 -- In case of previous error, no check is possible
2635 if Ekind
(Id
) in E_Function | E_Generic_Function
2636 and then Has_Out_Or_In_Out_Parameter
(Id
)
2638 Formal
:= First_Formal
(Id
);
2639 Actual
:= First_Actual
(Call
);
2640 while Present
(Actual
) and then Present
(Formal
) loop
2642 if Ekind
(Formal
) in E_Out_Parameter
2643 | E_In_Out_Parameter
2645 Is_Writable_Actual
:= True;
2651 Next_Formal
(Formal
);
2652 Next_Actual
(Actual
);
2658 if Is_Writable_Actual
then
2660 -- Skip checking the error in non-elementary types since
2661 -- RM 6.4.1(6.15/3) is restricted to elementary types, but
2662 -- store this actual in Writable_Actuals_List since it is
2663 -- needed to perform checks on other constructs that have
2664 -- arbitrary order of evaluation (for example, aggregates).
2666 if not Is_Elementary_Type
(Etype
(N
)) then
2667 if not Contains
(Writable_Actuals_List
, N
) then
2668 Append_New_Elmt
(N
, To
=> Writable_Actuals_List
);
2671 -- Second occurrence of an elementary type writable actual
2673 elsif Contains
(Writable_Actuals_List
, N
) then
2675 -- Report the error on the second occurrence of the
2676 -- identifier. We cannot assume that N is the second
2677 -- occurrence (according to their location in the
2678 -- sources), since Traverse_Func walks through Field2
2679 -- last (see comment in the body of Traverse_Func).
2685 Elmt
:= First_Elmt
(Writable_Actuals_List
);
2686 while Present
(Elmt
)
2687 and then Entity
(Node
(Elmt
)) /= Entity
(N
)
2692 if Sloc
(N
) > Sloc
(Node
(Elmt
)) then
2695 Error_Node
:= Node
(Elmt
);
2699 ("value may be affected by call to & "
2700 & "because order of evaluation is arbitrary",
2705 -- First occurrence of a elementary type writable actual
2708 Append_New_Elmt
(N
, To
=> Writable_Actuals_List
);
2712 if No
(Identifiers_List
) then
2713 Identifiers_List
:= New_Elmt_List
;
2716 Append_Unique_Elmt
(N
, Identifiers_List
);
2729 N
: Node_Id
) return Boolean
2731 pragma Assert
(Nkind
(N
) in N_Has_Entity
);
2740 Elmt
:= First_Elmt
(List
);
2741 while Present
(Elmt
) loop
2742 if Entity
(Node
(Elmt
)) = Entity
(N
) then
2756 procedure Do_Traversal
is new Traverse_Proc
(Check_Node
);
2757 -- The traversal procedure
2759 -- Start of processing for Collect_Identifiers
2762 if Present
(Error_Node
) then
2766 if Nkind
(N
) in N_Subexpr
and then Is_OK_Static_Expression
(N
) then
2771 end Collect_Identifiers
;
2773 -- Start of processing for Check_Function_Writable_Actuals
2776 -- The check only applies to Ada 2012 code on which Check_Actuals has
2777 -- been set, and only to constructs that have multiple constituents
2778 -- whose order of evaluation is not specified by the language.
2780 if Ada_Version
< Ada_2012
2781 or else not Check_Actuals
(N
)
2782 or else Nkind
(N
) not in N_Op
2786 | N_Extension_Aggregate
2787 | N_Full_Type_Declaration
2789 | N_Procedure_Call_Statement
2790 | N_Entry_Call_Statement
2791 or else (Nkind
(N
) = N_Full_Type_Declaration
2792 and then not Is_Record_Type
(Defining_Identifier
(N
)))
2794 -- In addition, this check only applies to source code, not to code
2795 -- generated by constraint checks.
2797 or else not Comes_From_Source
(N
)
2802 -- If a construct C has two or more direct constituents that are names
2803 -- or expressions whose evaluation may occur in an arbitrary order, at
2804 -- least one of which contains a function call with an in out or out
2805 -- parameter, then the construct is legal only if: for each name N that
2806 -- is passed as a parameter of mode in out or out to some inner function
2807 -- call C2 (not including the construct C itself), there is no other
2808 -- name anywhere within a direct constituent of the construct C other
2809 -- than the one containing C2, that is known to refer to the same
2810 -- object (RM 6.4.1(6.17/3)).
2814 Collect_Identifiers
(Low_Bound
(N
));
2815 Collect_Identifiers
(High_Bound
(N
));
2817 when N_Membership_Test
2824 Collect_Identifiers
(Left_Opnd
(N
));
2826 if Present
(Right_Opnd
(N
)) then
2827 Collect_Identifiers
(Right_Opnd
(N
));
2830 if Nkind
(N
) in N_Membership_Test
then
2831 Expr
:= First
(Alternatives
(N
));
2832 while Present
(Expr
) loop
2833 Collect_Identifiers
(Expr
);
2840 when N_Full_Type_Declaration
=>
2842 function Get_Record_Part
(N
: Node_Id
) return Node_Id
;
2843 -- Return the record part of this record type definition
2845 ---------------------
2846 -- Get_Record_Part --
2847 ---------------------
2849 function Get_Record_Part
(N
: Node_Id
) return Node_Id
is
2850 Type_Def
: constant Node_Id
:= Type_Definition
(N
);
2852 if Nkind
(Type_Def
) = N_Derived_Type_Definition
then
2853 return Record_Extension_Part
(Type_Def
);
2857 end Get_Record_Part
;
2860 Def_Id
: Entity_Id
:= Defining_Identifier
(N
);
2861 Rec
: Node_Id
:= Get_Record_Part
(N
);
2864 -- No need to perform any analysis if the record has no
2867 if No
(Rec
) or else No
(Component_List
(Rec
)) then
2871 -- Collect the identifiers starting from the deepest
2872 -- derivation. Done to report the error in the deepest
2876 if Present
(Component_List
(Rec
)) then
2877 Comp
:= First
(Component_Items
(Component_List
(Rec
)));
2878 while Present
(Comp
) loop
2879 if Nkind
(Comp
) = N_Component_Declaration
2880 and then Present
(Expression
(Comp
))
2882 Collect_Identifiers
(Expression
(Comp
));
2889 exit when No
(Underlying_Type
(Etype
(Def_Id
)))
2890 or else Base_Type
(Underlying_Type
(Etype
(Def_Id
)))
2893 Def_Id
:= Base_Type
(Underlying_Type
(Etype
(Def_Id
)));
2894 Rec
:= Get_Record_Part
(Parent
(Def_Id
));
2898 when N_Entry_Call_Statement
2902 Id
: constant Entity_Id
:= Get_Called_Entity
(N
);
2907 Formal
:= First_Formal
(Id
);
2908 Actual
:= First_Actual
(N
);
2909 while Present
(Actual
) and then Present
(Formal
) loop
2910 if Ekind
(Formal
) in E_Out_Parameter | E_In_Out_Parameter
2912 Collect_Identifiers
(Actual
);
2915 Next_Formal
(Formal
);
2916 Next_Actual
(Actual
);
2921 | N_Extension_Aggregate
2926 Comp_Expr
: Node_Id
;
2929 -- Handle the N_Others_Choice of array aggregates with static
2930 -- bounds. There is no need to perform this analysis in
2931 -- aggregates without static bounds since we cannot evaluate
2932 -- if the N_Others_Choice covers several elements. There is
2933 -- no need to handle the N_Others choice of record aggregates
2934 -- since at this stage it has been already expanded by
2935 -- Resolve_Record_Aggregate.
2937 if Is_Array_Type
(Etype
(N
))
2938 and then Nkind
(N
) = N_Aggregate
2939 and then Present
(Aggregate_Bounds
(N
))
2940 and then Compile_Time_Known_Bounds
(Etype
(N
))
2941 and then Expr_Value
(High_Bound
(Aggregate_Bounds
(N
)))
2943 Expr_Value
(Low_Bound
(Aggregate_Bounds
(N
)))
2946 Count_Components
: Uint
:= Uint_0
;
2947 Num_Components
: Uint
;
2948 Others_Assoc
: Node_Id
:= Empty
;
2949 Others_Choice
: Node_Id
:= Empty
;
2950 Others_Box_Present
: Boolean := False;
2953 -- Count positional associations
2955 if Present
(Expressions
(N
)) then
2956 Comp_Expr
:= First
(Expressions
(N
));
2957 while Present
(Comp_Expr
) loop
2958 Count_Components
:= Count_Components
+ 1;
2963 -- Count the rest of elements and locate the N_Others
2966 Assoc
:= First
(Component_Associations
(N
));
2967 while Present
(Assoc
) loop
2968 Choice
:= First
(Choices
(Assoc
));
2969 while Present
(Choice
) loop
2970 if Nkind
(Choice
) = N_Others_Choice
then
2971 Others_Assoc
:= Assoc
;
2972 Others_Choice
:= Choice
;
2973 Others_Box_Present
:= Box_Present
(Assoc
);
2975 -- Count several components
2977 elsif Nkind
(Choice
) in
2978 N_Range | N_Subtype_Indication
2979 or else (Is_Entity_Name
(Choice
)
2980 and then Is_Type
(Entity
(Choice
)))
2985 Get_Index_Bounds
(Choice
, L
, H
);
2987 (Compile_Time_Known_Value
(L
)
2988 and then Compile_Time_Known_Value
(H
));
2991 + Expr_Value
(H
) - Expr_Value
(L
) + 1;
2994 -- Count single component. No other case available
2995 -- since we are handling an aggregate with static
2999 pragma Assert
(Is_OK_Static_Expression
(Choice
)
3000 or else Nkind
(Choice
) = N_Identifier
3001 or else Nkind
(Choice
) = N_Integer_Literal
);
3003 Count_Components
:= Count_Components
+ 1;
3013 Expr_Value
(High_Bound
(Aggregate_Bounds
(N
))) -
3014 Expr_Value
(Low_Bound
(Aggregate_Bounds
(N
))) + 1;
3016 pragma Assert
(Count_Components
<= Num_Components
);
3018 -- Handle the N_Others choice if it covers several
3021 if Present
(Others_Choice
)
3022 and then (Num_Components
- Count_Components
) > 1
3024 if not Others_Box_Present
then
3026 -- At this stage, if expansion is active, the
3027 -- expression of the others choice has not been
3028 -- analyzed. Hence we generate a duplicate and
3029 -- we analyze it silently to have available the
3030 -- minimum decoration required to collect the
3033 pragma Assert
(Present
(Others_Assoc
));
3035 if not Expander_Active
then
3036 Comp_Expr
:= Expression
(Others_Assoc
);
3039 New_Copy_Tree
(Expression
(Others_Assoc
));
3040 Preanalyze_Without_Errors
(Comp_Expr
);
3043 Collect_Identifiers
(Comp_Expr
);
3045 if Present
(Writable_Actuals_List
) then
3047 -- As suggested by Robert, at current stage we
3048 -- report occurrences of this case as warnings.
3051 ("writable function parameter may affect "
3052 & "value in other component because order "
3053 & "of evaluation is unspecified??",
3054 Node
(First_Elmt
(Writable_Actuals_List
)));
3060 -- For an array aggregate, a discrete_choice_list that has
3061 -- a nonstatic range is considered as two or more separate
3062 -- occurrences of the expression (RM 6.4.1(20/3)).
3064 elsif Is_Array_Type
(Etype
(N
))
3065 and then Nkind
(N
) = N_Aggregate
3066 and then Present
(Aggregate_Bounds
(N
))
3067 and then not Compile_Time_Known_Bounds
(Etype
(N
))
3069 -- Collect identifiers found in the dynamic bounds
3072 Count_Components
: Natural := 0;
3073 Low
, High
: Node_Id
;
3076 Assoc
:= First
(Component_Associations
(N
));
3077 while Present
(Assoc
) loop
3078 Choice
:= First
(Choices
(Assoc
));
3079 while Present
(Choice
) loop
3080 if Nkind
(Choice
) in
3081 N_Range | N_Subtype_Indication
3082 or else (Is_Entity_Name
(Choice
)
3083 and then Is_Type
(Entity
(Choice
)))
3085 Get_Index_Bounds
(Choice
, Low
, High
);
3087 if not Compile_Time_Known_Value
(Low
) then
3088 Collect_Identifiers
(Low
);
3090 if No
(Aggr_Error_Node
) then
3091 Aggr_Error_Node
:= Low
;
3095 if not Compile_Time_Known_Value
(High
) then
3096 Collect_Identifiers
(High
);
3098 if No
(Aggr_Error_Node
) then
3099 Aggr_Error_Node
:= High
;
3103 -- The RM rule is violated if there is more than
3104 -- a single choice in a component association.
3107 Count_Components
:= Count_Components
+ 1;
3109 if No
(Aggr_Error_Node
)
3110 and then Count_Components
> 1
3112 Aggr_Error_Node
:= Choice
;
3115 if not Compile_Time_Known_Value
(Choice
) then
3116 Collect_Identifiers
(Choice
);
3128 -- Handle ancestor part of extension aggregates
3130 if Nkind
(N
) = N_Extension_Aggregate
then
3131 Collect_Identifiers
(Ancestor_Part
(N
));
3134 -- Handle positional associations
3136 if Present
(Expressions
(N
)) then
3137 Comp_Expr
:= First
(Expressions
(N
));
3138 while Present
(Comp_Expr
) loop
3139 if not Is_OK_Static_Expression
(Comp_Expr
) then
3140 Collect_Identifiers
(Comp_Expr
);
3147 -- Handle discrete associations
3149 if Present
(Component_Associations
(N
)) then
3150 Assoc
:= First
(Component_Associations
(N
));
3151 while Present
(Assoc
) loop
3153 if not Box_Present
(Assoc
) then
3154 Choice
:= First
(Choices
(Assoc
));
3155 while Present
(Choice
) loop
3157 -- For now we skip discriminants since it requires
3158 -- performing the analysis in two phases: first one
3159 -- analyzing discriminants and second one analyzing
3160 -- the rest of components since discriminants are
3161 -- evaluated prior to components: too much extra
3162 -- work to detect a corner case???
3164 if Nkind
(Choice
) in N_Has_Entity
3165 and then Present
(Entity
(Choice
))
3166 and then Ekind
(Entity
(Choice
)) = E_Discriminant
3170 elsif Box_Present
(Assoc
) then
3174 if not Analyzed
(Expression
(Assoc
)) then
3176 New_Copy_Tree
(Expression
(Assoc
));
3177 Set_Parent
(Comp_Expr
, Parent
(N
));
3178 Preanalyze_Without_Errors
(Comp_Expr
);
3180 Comp_Expr
:= Expression
(Assoc
);
3183 Collect_Identifiers
(Comp_Expr
);
3199 -- No further action needed if we already reported an error
3201 if Present
(Error_Node
) then
3205 -- Check violation of RM 6.20/3 in aggregates
3207 if Present
(Aggr_Error_Node
)
3208 and then Present
(Writable_Actuals_List
)
3211 ("value may be affected by call in other component because they "
3212 & "are evaluated in unspecified order",
3213 Node
(First_Elmt
(Writable_Actuals_List
)));
3217 -- Check if some writable argument of a function is referenced
3219 if Present
(Writable_Actuals_List
)
3220 and then Present
(Identifiers_List
)
3227 Elmt_1
:= First_Elmt
(Writable_Actuals_List
);
3228 while Present
(Elmt_1
) loop
3229 Elmt_2
:= First_Elmt
(Identifiers_List
);
3230 while Present
(Elmt_2
) loop
3231 if Entity
(Node
(Elmt_1
)) = Entity
(Node
(Elmt_2
)) then
3232 case Nkind
(Parent
(Node
(Elmt_2
))) is
3234 | N_Component_Association
3235 | N_Component_Declaration
3238 ("value may be affected by call in other "
3239 & "component because they are evaluated "
3240 & "in unspecified order",
3243 when N_Membership_Test
=>
3245 ("value may be affected by call in other "
3246 & "alternative because they are evaluated "
3247 & "in unspecified order",
3252 ("value of actual may be affected by call in "
3253 & "other actual because they are evaluated "
3254 & "in unspecified order",
3266 end Check_Function_Writable_Actuals
;
3268 --------------------------------
3269 -- Check_Implicit_Dereference --
3270 --------------------------------
3272 procedure Check_Implicit_Dereference
(N
: Node_Id
; Typ
: Entity_Id
) is
3278 if Nkind
(N
) = N_Indexed_Component
3279 and then Present
(Generalized_Indexing
(N
))
3281 Nam
:= Generalized_Indexing
(N
);
3286 if Ada_Version
< Ada_2012
3287 or else not Has_Implicit_Dereference
(Base_Type
(Typ
))
3291 elsif not Comes_From_Source
(N
)
3292 and then Nkind
(N
) /= N_Indexed_Component
3296 elsif Is_Entity_Name
(Nam
) and then Is_Type
(Entity
(Nam
)) then
3300 Disc
:= First_Discriminant
(Typ
);
3301 while Present
(Disc
) loop
3302 if Has_Implicit_Dereference
(Disc
) then
3303 Desig
:= Designated_Type
(Etype
(Disc
));
3304 Add_One_Interp
(Nam
, Disc
, Desig
);
3306 -- If the node is a generalized indexing, add interpretation
3307 -- to that node as well, for subsequent resolution.
3309 if Nkind
(N
) = N_Indexed_Component
then
3310 Add_One_Interp
(N
, Disc
, Desig
);
3313 -- If the operation comes from a generic unit and the context
3314 -- is a selected component, the selector name may be global
3315 -- and set in the instance already. Remove the entity to
3316 -- force resolution of the selected component, and the
3317 -- generation of an explicit dereference if needed.
3320 and then Nkind
(Parent
(Nam
)) = N_Selected_Component
3322 Set_Entity
(Selector_Name
(Parent
(Nam
)), Empty
);
3328 Next_Discriminant
(Disc
);
3331 end Check_Implicit_Dereference
;
3333 ----------------------------------
3334 -- Check_Internal_Protected_Use --
3335 ----------------------------------
3337 procedure Check_Internal_Protected_Use
(N
: Node_Id
; Nam
: Entity_Id
) is
3345 while Present
(S
) loop
3346 if S
= Standard_Standard
then
3349 elsif Ekind
(S
) = E_Function
3350 and then Ekind
(Scope
(S
)) = E_Protected_Type
3360 and then Scope
(Nam
) = Prot
3361 and then Ekind
(Nam
) /= E_Function
3363 -- An indirect function call (e.g. a callback within a protected
3364 -- function body) is not statically illegal. If the access type is
3365 -- anonymous and is the type of an access parameter, the scope of Nam
3366 -- will be the protected type, but it is not a protected operation.
3368 if Ekind
(Nam
) = E_Subprogram_Type
3369 and then Nkind
(Associated_Node_For_Itype
(Nam
)) =
3370 N_Function_Specification
3374 elsif Nkind
(N
) = N_Subprogram_Renaming_Declaration
then
3376 ("within protected function cannot use protected procedure in "
3377 & "renaming or as generic actual", N
);
3379 elsif Nkind
(N
) = N_Attribute_Reference
then
3381 ("within protected function cannot take access of protected "
3386 ("within protected function, protected object is constant", N
);
3388 ("\cannot call operation that may modify it", N
);
3392 -- Verify that an internal call does not appear within a precondition
3393 -- of a protected operation. This implements AI12-0166.
3394 -- The precondition aspect has been rewritten as a pragma Precondition
3395 -- and we check whether the scope of the called subprogram is the same
3396 -- as that of the entity to which the aspect applies.
3398 if Convention
(Nam
) = Convention_Protected
then
3404 while Present
(P
) loop
3405 if Nkind
(P
) = N_Pragma
3406 and then Chars
(Pragma_Identifier
(P
)) = Name_Precondition
3407 and then From_Aspect_Specification
(P
)
3409 Scope
(Entity
(Corresponding_Aspect
(P
))) = Scope
(Nam
)
3412 ("internal call cannot appear in precondition of "
3413 & "protected operation", N
);
3416 elsif Nkind
(P
) = N_Pragma
3417 and then Chars
(Pragma_Identifier
(P
)) = Name_Contract_Cases
3419 -- Check whether call is in a case guard. It is legal in a
3423 while Present
(P
) loop
3424 if Nkind
(Parent
(P
)) = N_Component_Association
3425 and then P
/= Expression
(Parent
(P
))
3428 ("internal call cannot appear in case guard in a "
3429 & "contract case", N
);
3437 elsif Nkind
(P
) = N_Parameter_Specification
3438 and then Scope
(Current_Scope
) = Scope
(Nam
)
3439 and then Nkind
(Parent
(P
)) in
3440 N_Entry_Declaration | N_Subprogram_Declaration
3443 ("internal call cannot appear in default for formal of "
3444 & "protected operation", N
);
3447 -- Prevent the search from going too far
3449 elsif Is_Body_Or_Package_Declaration
(P
) then
3457 end Check_Internal_Protected_Use
;
3459 ---------------------------------------
3460 -- Check_Later_Vs_Basic_Declarations --
3461 ---------------------------------------
3463 procedure Check_Later_Vs_Basic_Declarations
3465 During_Parsing
: Boolean)
3467 Body_Sloc
: Source_Ptr
;
3470 function Is_Later_Declarative_Item
(Decl
: Node_Id
) return Boolean;
3471 -- Return whether Decl is considered as a declarative item.
3472 -- When During_Parsing is True, the semantics of Ada 83 is followed.
3473 -- When During_Parsing is False, the semantics of SPARK is followed.
3475 -------------------------------
3476 -- Is_Later_Declarative_Item --
3477 -------------------------------
3479 function Is_Later_Declarative_Item
(Decl
: Node_Id
) return Boolean is
3481 if Nkind
(Decl
) in N_Later_Decl_Item
then
3484 elsif Nkind
(Decl
) = N_Pragma
then
3487 elsif During_Parsing
then
3490 -- In SPARK, a package declaration is not considered as a later
3491 -- declarative item.
3493 elsif Nkind
(Decl
) = N_Package_Declaration
then
3496 -- In SPARK, a renaming is considered as a later declarative item
3498 elsif Nkind
(Decl
) in N_Renaming_Declaration
then
3504 end Is_Later_Declarative_Item
;
3506 -- Start of processing for Check_Later_Vs_Basic_Declarations
3509 Decl
:= First
(Decls
);
3511 -- Loop through sequence of basic declarative items
3513 Outer
: while Present
(Decl
) loop
3514 if Nkind
(Decl
) not in
3515 N_Subprogram_Body | N_Package_Body | N_Task_Body
3516 and then Nkind
(Decl
) not in N_Body_Stub
3520 -- Once a body is encountered, we only allow later declarative
3521 -- items. The inner loop checks the rest of the list.
3524 Body_Sloc
:= Sloc
(Decl
);
3526 Inner
: while Present
(Decl
) loop
3527 if not Is_Later_Declarative_Item
(Decl
) then
3528 if During_Parsing
then
3529 if Ada_Version
= Ada_83
then
3530 Error_Msg_Sloc
:= Body_Sloc
;
3532 ("(Ada 83) decl cannot appear after body#", Decl
);
3541 end Check_Later_Vs_Basic_Declarations
;
3543 ---------------------------
3544 -- Check_No_Hidden_State --
3545 ---------------------------
3547 procedure Check_No_Hidden_State
(Id
: Entity_Id
) is
3548 Context
: Entity_Id
:= Empty
;
3549 Not_Visible
: Boolean := False;
3553 pragma Assert
(Ekind
(Id
) in E_Abstract_State | E_Variable
);
3555 -- Nothing to do for internally-generated abstract states and variables
3556 -- because they do not represent the hidden state of the source unit.
3558 if not Comes_From_Source
(Id
) then
3562 -- Find the proper context where the object or state appears
3565 while Present
(Scop
) loop
3568 -- Keep track of the context's visibility
3570 Not_Visible
:= Not_Visible
or else In_Private_Part
(Context
);
3572 -- Prevent the search from going too far
3574 if Context
= Standard_Standard
then
3577 -- Objects and states that appear immediately within a subprogram or
3578 -- entry inside a construct nested within a subprogram do not
3579 -- introduce a hidden state. They behave as local variable
3580 -- declarations. The same is true for elaboration code inside a block
3583 elsif Is_Subprogram_Or_Entry
(Context
)
3584 or else Ekind
(Context
) in E_Block | E_Task_Type
3589 -- Stop the traversal when a package subject to a null abstract state
3592 if Is_Package_Or_Generic_Package
(Context
)
3593 and then Has_Null_Abstract_State
(Context
)
3598 Scop
:= Scope
(Scop
);
3601 -- At this point we know that there is at least one package with a null
3602 -- abstract state in visibility. Emit an error message unconditionally
3603 -- if the entity being processed is a state because the placement of the
3604 -- related package is irrelevant. This is not the case for objects as
3605 -- the intermediate context matters.
3607 if Present
(Context
)
3608 and then (Ekind
(Id
) = E_Abstract_State
or else Not_Visible
)
3610 Error_Msg_N
("cannot introduce hidden state &", Id
);
3611 Error_Msg_NE
("\package & has null abstract state", Id
, Context
);
3613 end Check_No_Hidden_State
;
3615 ---------------------------------------------
3616 -- Check_Nonoverridable_Aspect_Consistency --
3617 ---------------------------------------------
3619 procedure Check_Inherited_Nonoverridable_Aspects
3620 (Inheritor
: Entity_Id
;
3621 Interface_List
: List_Id
;
3622 Parent_Type
: Entity_Id
) is
3624 -- array needed for iterating over subtype values
3625 Nonoverridable_Aspects
: constant array (Positive range <>) of
3626 Nonoverridable_Aspect_Id
:=
3627 (Aspect_Default_Iterator
,
3628 Aspect_Iterator_Element
,
3629 Aspect_Implicit_Dereference
,
3630 Aspect_Constant_Indexing
,
3631 Aspect_Variable_Indexing
,
3633 Aspect_Max_Entry_Queue_Length
3634 -- , Aspect_No_Controlled_Parts
3637 -- Note that none of these 8 aspects can be specified (for a type)
3638 -- via a pragma. For 7 of them, the corresponding pragma does not
3639 -- exist. The Pragma_Id enumeration type does include
3640 -- Pragma_Max_Entry_Queue_Length, but that pragma is only use to
3641 -- specify the aspect for a protected entry or entry family, not for
3642 -- a type, and therefore cannot introduce the sorts of inheritance
3643 -- issues that we are concerned with in this procedure.
3645 type Entity_Array
is array (Nat
range <>) of Entity_Id
;
3647 function Ancestor_Entities
return Entity_Array
;
3648 -- Returns all progenitors (including parent type, if present)
3650 procedure Check_Consistency_For_One_Aspect_Of_Two_Ancestors
3651 (Aspect
: Nonoverridable_Aspect_Id
;
3652 Ancestor_1
: Entity_Id
;
3653 Aspect_Spec_1
: Node_Id
;
3654 Ancestor_2
: Entity_Id
;
3655 Aspect_Spec_2
: Node_Id
);
3656 -- A given aspect has been specified for each of two ancestors;
3657 -- check that the two aspect specifications are compatible (see
3658 -- RM 13.1.1(18.5) and AI12-0211).
3660 -----------------------
3661 -- Ancestor_Entities --
3662 -----------------------
3664 function Ancestor_Entities
return Entity_Array
is
3665 Ifc_Count
: constant Nat
:= List_Length
(Interface_List
);
3666 Ifc_Ancestors
: Entity_Array
(1 .. Ifc_Count
);
3667 Ifc
: Node_Id
:= First
(Interface_List
);
3669 for Idx
in Ifc_Ancestors
'Range loop
3670 Ifc_Ancestors
(Idx
) := Entity
(Ifc
);
3671 pragma Assert
(Present
(Ifc_Ancestors
(Idx
)));
3674 pragma Assert
(No
(Ifc
));
3675 if Present
(Parent_Type
) then
3676 return Parent_Type
& Ifc_Ancestors
;
3678 return Ifc_Ancestors
;
3680 end Ancestor_Entities
;
3682 -------------------------------------------------------
3683 -- Check_Consistency_For_One_Aspect_Of_Two_Ancestors --
3684 -------------------------------------------------------
3686 procedure Check_Consistency_For_One_Aspect_Of_Two_Ancestors
3687 (Aspect
: Nonoverridable_Aspect_Id
;
3688 Ancestor_1
: Entity_Id
;
3689 Aspect_Spec_1
: Node_Id
;
3690 Ancestor_2
: Entity_Id
;
3691 Aspect_Spec_2
: Node_Id
) is
3693 if not Is_Confirming
(Aspect
, Aspect_Spec_1
, Aspect_Spec_2
) then
3694 Error_Msg_Name_1
:= Aspect_Names
(Aspect
);
3695 Error_Msg_Name_2
:= Chars
(Ancestor_1
);
3696 Error_Msg_Name_3
:= Chars
(Ancestor_2
);
3699 "incompatible % aspects inherited from ancestors % and %",
3702 end Check_Consistency_For_One_Aspect_Of_Two_Ancestors
;
3704 Ancestors
: constant Entity_Array
:= Ancestor_Entities
;
3706 -- start of processing for Check_Inherited_Nonoverridable_Aspects
3708 -- No Ada_Version check here; AI12-0211 is a binding interpretation.
3710 if Ancestors
'Length < 2 then
3711 return; -- Inconsistency impossible; it takes 2 to disagree.
3712 elsif In_Instance_Body
then
3713 return; -- No legality checking in an instance body.
3716 for Aspect
of Nonoverridable_Aspects
loop
3718 First_Ancestor_With_Aspect
: Entity_Id
:= Empty
;
3719 First_Aspect_Spec
, Current_Aspect_Spec
: Node_Id
:= Empty
;
3721 for Ancestor
of Ancestors
loop
3722 Current_Aspect_Spec
:= Find_Aspect
(Ancestor
, Aspect
);
3723 if Present
(Current_Aspect_Spec
) then
3724 if Present
(First_Ancestor_With_Aspect
) then
3725 Check_Consistency_For_One_Aspect_Of_Two_Ancestors
3727 Ancestor_1
=> First_Ancestor_With_Aspect
,
3728 Aspect_Spec_1
=> First_Aspect_Spec
,
3729 Ancestor_2
=> Ancestor
,
3730 Aspect_Spec_2
=> Current_Aspect_Spec
);
3732 First_Ancestor_With_Aspect
:= Ancestor
;
3733 First_Aspect_Spec
:= Current_Aspect_Spec
;
3739 end Check_Inherited_Nonoverridable_Aspects
;
3745 function Check_Parents
(N
: Node_Id
; List
: Elist_Id
) return Boolean is
3748 (Parent_Node
: Node_Id
;
3749 N
: Node_Id
) return Traverse_Result
;
3750 -- Process a single node.
3757 (Parent_Node
: Node_Id
;
3758 N
: Node_Id
) return Traverse_Result
is
3760 if Nkind
(N
) = N_Identifier
3761 and then Parent
(N
) /= Parent_Node
3762 and then Present
(Entity
(N
))
3763 and then Contains
(List
, Entity
(N
))
3771 function Traverse
is new Traverse_Func_With_Parent
(Check_Node
);
3773 -- Start of processing for Check_Parents
3776 return Traverse
(N
) = OK
;
3779 -----------------------------
3780 -- Check_Part_Of_Reference --
3781 -----------------------------
3783 procedure Check_Part_Of_Reference
(Var_Id
: Entity_Id
; Ref
: Node_Id
) is
3784 function Is_Enclosing_Package_Body
3785 (Body_Decl
: Node_Id
;
3786 Obj_Id
: Entity_Id
) return Boolean;
3787 pragma Inline
(Is_Enclosing_Package_Body
);
3788 -- Determine whether package body Body_Decl or its corresponding spec
3789 -- immediately encloses the declaration of object Obj_Id.
3791 function Is_Internal_Declaration_Or_Body
3792 (Decl
: Node_Id
) return Boolean;
3793 pragma Inline
(Is_Internal_Declaration_Or_Body
);
3794 -- Determine whether declaration or body denoted by Decl is internal
3796 function Is_Single_Declaration_Or_Body
3798 Conc_Typ
: Entity_Id
) return Boolean;
3799 pragma Inline
(Is_Single_Declaration_Or_Body
);
3800 -- Determine whether protected/task declaration or body denoted by Decl
3801 -- belongs to single concurrent type Conc_Typ.
3803 function Is_Single_Task_Pragma
3805 Task_Typ
: Entity_Id
) return Boolean;
3806 pragma Inline
(Is_Single_Task_Pragma
);
3807 -- Determine whether pragma Prag belongs to single task type Task_Typ
3809 -------------------------------
3810 -- Is_Enclosing_Package_Body --
3811 -------------------------------
3813 function Is_Enclosing_Package_Body
3814 (Body_Decl
: Node_Id
;
3815 Obj_Id
: Entity_Id
) return Boolean
3817 Obj_Context
: Node_Id
;
3820 -- Find the context of the object declaration
3822 Obj_Context
:= Parent
(Declaration_Node
(Obj_Id
));
3824 if Nkind
(Obj_Context
) = N_Package_Specification
then
3825 Obj_Context
:= Parent
(Obj_Context
);
3828 -- The object appears immediately within the package body
3830 if Obj_Context
= Body_Decl
then
3833 -- The object appears immediately within the corresponding spec
3835 elsif Nkind
(Obj_Context
) = N_Package_Declaration
3836 and then Unit_Declaration_Node
(Corresponding_Spec
(Body_Decl
)) =
3843 end Is_Enclosing_Package_Body
;
3845 -------------------------------------
3846 -- Is_Internal_Declaration_Or_Body --
3847 -------------------------------------
3849 function Is_Internal_Declaration_Or_Body
3850 (Decl
: Node_Id
) return Boolean
3853 if Comes_From_Source
(Decl
) then
3856 -- A body generated for an expression function which has not been
3857 -- inserted into the tree yet (In_Spec_Expression is True) is not
3858 -- considered internal.
3860 elsif Nkind
(Decl
) = N_Subprogram_Body
3861 and then Was_Expression_Function
(Decl
)
3862 and then not In_Spec_Expression
3868 end Is_Internal_Declaration_Or_Body
;
3870 -----------------------------------
3871 -- Is_Single_Declaration_Or_Body --
3872 -----------------------------------
3874 function Is_Single_Declaration_Or_Body
3876 Conc_Typ
: Entity_Id
) return Boolean
3878 Spec_Id
: constant Entity_Id
:= Unique_Defining_Entity
(Decl
);
3882 Present
(Anonymous_Object
(Spec_Id
))
3883 and then Anonymous_Object
(Spec_Id
) = Conc_Typ
;
3884 end Is_Single_Declaration_Or_Body
;
3886 ---------------------------
3887 -- Is_Single_Task_Pragma --
3888 ---------------------------
3890 function Is_Single_Task_Pragma
3892 Task_Typ
: Entity_Id
) return Boolean
3894 Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(Prag
);
3897 -- To qualify, the pragma must be associated with single task type
3901 Is_Single_Task_Object
(Task_Typ
)
3902 and then Nkind
(Decl
) = N_Object_Declaration
3903 and then Defining_Entity
(Decl
) = Task_Typ
;
3904 end Is_Single_Task_Pragma
;
3908 Conc_Obj
: constant Entity_Id
:= Encapsulating_State
(Var_Id
);
3913 -- Start of processing for Check_Part_Of_Reference
3916 -- Nothing to do when the variable was recorded, but did not become a
3917 -- constituent of a single concurrent type.
3919 if No
(Conc_Obj
) then
3923 -- Traverse the parent chain looking for a suitable context for the
3924 -- reference to the concurrent constituent.
3927 Par
:= Parent
(Prev
);
3928 while Present
(Par
) loop
3929 if Nkind
(Par
) = N_Pragma
then
3930 Prag_Nam
:= Pragma_Name
(Par
);
3932 -- A concurrent constituent is allowed to appear in pragmas
3933 -- Initial_Condition and Initializes as this is part of the
3934 -- elaboration checks for the constituent (SPARK RM 9(3)).
3936 if Prag_Nam
in Name_Initial_Condition | Name_Initializes
then
3939 -- When the reference appears within pragma Depends or Global,
3940 -- check whether the pragma applies to a single task type. Note
3941 -- that the pragma may not encapsulated by the type definition,
3942 -- but this is still a valid context.
3944 elsif Prag_Nam
in Name_Depends | Name_Global
3945 and then Is_Single_Task_Pragma
(Par
, Conc_Obj
)
3950 -- The reference appears somewhere in the definition of a single
3951 -- concurrent type (SPARK RM 9(3)).
3953 elsif Nkind
(Par
) in
3954 N_Single_Protected_Declaration | N_Single_Task_Declaration
3955 and then Defining_Entity
(Par
) = Conc_Obj
3959 -- The reference appears within the declaration or body of a single
3960 -- concurrent type (SPARK RM 9(3)).
3962 elsif Nkind
(Par
) in N_Protected_Body
3963 | N_Protected_Type_Declaration
3965 | N_Task_Type_Declaration
3966 and then Is_Single_Declaration_Or_Body
(Par
, Conc_Obj
)
3970 -- The reference appears within the statement list of the object's
3971 -- immediately enclosing package (SPARK RM 9(3)).
3973 elsif Nkind
(Par
) = N_Package_Body
3974 and then Nkind
(Prev
) = N_Handled_Sequence_Of_Statements
3975 and then Is_Enclosing_Package_Body
(Par
, Var_Id
)
3979 -- The reference has been relocated within an internally generated
3980 -- package or subprogram. Assume that the reference is legal as the
3981 -- real check was already performed in the original context of the
3984 elsif Nkind
(Par
) in N_Package_Body
3985 | N_Package_Declaration
3987 | N_Subprogram_Declaration
3988 and then Is_Internal_Declaration_Or_Body
(Par
)
3992 -- The reference has been relocated to an inlined body for GNATprove.
3993 -- Assume that the reference is legal as the real check was already
3994 -- performed in the original context of the reference.
3996 elsif GNATprove_Mode
3997 and then Nkind
(Par
) = N_Subprogram_Body
3998 and then Chars
(Defining_Entity
(Par
)) = Name_uParent
4004 Par
:= Parent
(Prev
);
4007 -- At this point it is known that the reference does not appear within a
4011 ("reference to variable & cannot appear in this context", Ref
, Var_Id
);
4012 Error_Msg_Name_1
:= Chars
(Var_Id
);
4014 if Is_Single_Protected_Object
(Conc_Obj
) then
4016 ("\% is constituent of single protected type &", Ref
, Conc_Obj
);
4020 ("\% is constituent of single task type &", Ref
, Conc_Obj
);
4022 end Check_Part_Of_Reference
;
4024 ------------------------------------------
4025 -- Check_Potentially_Blocking_Operation --
4026 ------------------------------------------
4028 procedure Check_Potentially_Blocking_Operation
(N
: Node_Id
) is
4032 -- N is one of the potentially blocking operations listed in 9.5.1(8).
4033 -- When pragma Detect_Blocking is active, the run time will raise
4034 -- Program_Error. Here we only issue a warning, since we generally
4035 -- support the use of potentially blocking operations in the absence
4038 -- Indirect blocking through a subprogram call cannot be diagnosed
4039 -- statically without interprocedural analysis, so we do not attempt
4042 S
:= Scope
(Current_Scope
);
4043 while Present
(S
) and then S
/= Standard_Standard
loop
4044 if Is_Protected_Type
(S
) then
4046 ("potentially blocking operation in protected operation??", N
);
4052 end Check_Potentially_Blocking_Operation
;
4054 ------------------------------------
4055 -- Check_Previous_Null_Procedure --
4056 ------------------------------------
4058 procedure Check_Previous_Null_Procedure
4063 if Ekind
(Prev
) = E_Procedure
4064 and then Nkind
(Parent
(Prev
)) = N_Procedure_Specification
4065 and then Null_Present
(Parent
(Prev
))
4067 Error_Msg_Sloc
:= Sloc
(Prev
);
4069 ("declaration cannot complete previous null procedure#", Decl
);
4071 end Check_Previous_Null_Procedure
;
4073 ---------------------------------
4074 -- Check_Result_And_Post_State --
4075 ---------------------------------
4077 procedure Check_Result_And_Post_State
(Subp_Id
: Entity_Id
) is
4078 procedure Check_Result_And_Post_State_In_Pragma
4080 Result_Seen
: in out Boolean);
4081 -- Determine whether pragma Prag mentions attribute 'Result and whether
4082 -- the pragma contains an expression that evaluates differently in pre-
4083 -- and post-state. Prag is a [refined] postcondition or a contract-cases
4084 -- pragma. Result_Seen is set when the pragma mentions attribute 'Result
4086 -------------------------------------------
4087 -- Check_Result_And_Post_State_In_Pragma --
4088 -------------------------------------------
4090 procedure Check_Result_And_Post_State_In_Pragma
4092 Result_Seen
: in out Boolean)
4094 procedure Check_Conjunct
(Expr
: Node_Id
);
4095 -- Check an individual conjunct in a conjunction of Boolean
4096 -- expressions, connected by "and" or "and then" operators.
4098 procedure Check_Conjuncts
(Expr
: Node_Id
);
4099 -- Apply the post-state check to every conjunct in an expression, in
4100 -- case this is a conjunction of Boolean expressions. Otherwise apply
4101 -- it to the expression as a whole.
4103 procedure Check_Expression
(Expr
: Node_Id
);
4104 -- Perform the 'Result and post-state checks on a given expression
4106 function Is_Function_Result
(N
: Node_Id
) return Traverse_Result
;
4107 -- Attempt to find attribute 'Result in a subtree denoted by N
4109 function Mentions_Post_State
(N
: Node_Id
) return Boolean;
4110 -- Determine whether a subtree denoted by N mentions any construct
4111 -- that denotes a post-state.
4113 procedure Check_Function_Result
is
4114 new Traverse_Proc
(Is_Function_Result
);
4116 --------------------
4117 -- Check_Conjunct --
4118 --------------------
4120 procedure Check_Conjunct
(Expr
: Node_Id
) is
4121 function Adjust_Message
(Msg
: String) return String;
4122 -- Prepend a prefix to the input message Msg denoting that the
4123 -- message applies to a conjunct in the expression, when this
4126 function Applied_On_Conjunct
return Boolean;
4127 -- Returns True if the message applies to a conjunct in the
4128 -- expression, instead of the whole expression.
4130 function Has_Global_Output
(Subp
: Entity_Id
) return Boolean;
4131 -- Returns True if Subp has an output in its Global contract
4133 function Has_No_Output
(Subp
: Entity_Id
) return Boolean;
4134 -- Returns True if Subp has no declared output: no function
4135 -- result, no output parameter, and no output in its Global
4138 --------------------
4139 -- Adjust_Message --
4140 --------------------
4142 function Adjust_Message
(Msg
: String) return String is
4144 if Applied_On_Conjunct
then
4145 return "conjunct in " & Msg
;
4151 -------------------------
4152 -- Applied_On_Conjunct --
4153 -------------------------
4155 function Applied_On_Conjunct
return Boolean is
4157 -- Expr is the conjunct of an enclosing "and" expression
4159 return Nkind
(Parent
(Expr
)) in N_Subexpr
4161 -- or Expr is a conjunct of an enclosing "and then"
4162 -- expression in a postcondition aspect that was split into
4163 -- multiple pragmas. The first conjunct has the "and then"
4164 -- expression as Original_Node, and other conjuncts have
4165 -- Split_PCC set to True.
4167 or else Nkind
(Original_Node
(Expr
)) = N_And_Then
4168 or else Split_PPC
(Prag
);
4169 end Applied_On_Conjunct
;
4171 -----------------------
4172 -- Has_Global_Output --
4173 -----------------------
4175 function Has_Global_Output
(Subp
: Entity_Id
) return Boolean is
4176 Global
: constant Node_Id
:= Get_Pragma
(Subp
, Pragma_Global
);
4185 List
:= Expression
(Get_Argument
(Global
, Subp
));
4187 -- Empty list (no global items) or single global item
4188 -- declaration (only input items).
4190 if Nkind
(List
) in N_Null
4193 | N_Selected_Component
4197 -- Simple global list (only input items) or moded global list
4200 elsif Nkind
(List
) = N_Aggregate
then
4201 if Present
(Expressions
(List
)) then
4205 Assoc
:= First
(Component_Associations
(List
));
4206 while Present
(Assoc
) loop
4207 if Chars
(First
(Choices
(Assoc
))) /= Name_Input
then
4217 -- To accommodate partial decoration of disabled SPARK
4218 -- features, this routine may be called with illegal input.
4219 -- If this is the case, do not raise Program_Error.
4224 end Has_Global_Output
;
4230 function Has_No_Output
(Subp
: Entity_Id
) return Boolean is
4234 -- A function has its result as output
4236 if Ekind
(Subp
) = E_Function
then
4240 -- An OUT or IN OUT parameter is an output
4242 Param
:= First_Formal
(Subp
);
4243 while Present
(Param
) loop
4244 if Ekind
(Param
) in E_Out_Parameter | E_In_Out_Parameter
then
4248 Next_Formal
(Param
);
4251 -- An item of mode Output or In_Out in the Global contract is
4254 if Has_Global_Output
(Subp
) then
4264 -- Error node when reporting a warning on a (refined)
4267 -- Start of processing for Check_Conjunct
4270 if Applied_On_Conjunct
then
4276 -- Do not report missing reference to outcome in postcondition if
4277 -- either the postcondition is trivially True or False, or if the
4278 -- subprogram is ghost and has no declared output.
4280 if not Is_Trivial_Boolean
(Expr
)
4281 and then not Mentions_Post_State
(Expr
)
4282 and then not (Is_Ghost_Entity
(Subp_Id
)
4283 and then Has_No_Output
(Subp_Id
))
4284 and then not Is_Wrapper
(Subp_Id
)
4286 case Pragma_Name
(Prag
) is
4287 when Name_Contract_Cases
=>
4288 Error_Msg_NE
(Adjust_Message
4289 ("contract case does not check the outcome of calling "
4290 & "&?.t?"), Expr
, Subp_Id
);
4292 when Name_Refined_Post
=>
4293 Error_Msg_NE
(Adjust_Message
4294 ("refined postcondition does not check the outcome of "
4295 & "calling &?.t?"), Err_Node
, Subp_Id
);
4297 when Name_Postcondition
=>
4298 Error_Msg_NE
(Adjust_Message
4299 ("postcondition does not check the outcome of calling "
4300 & "&?.t?"), Err_Node
, Subp_Id
);
4302 when others => pragma Assert
(False);
4307 ---------------------
4308 -- Check_Conjuncts --
4309 ---------------------
4311 procedure Check_Conjuncts
(Expr
: Node_Id
) is
4313 if Nkind
(Expr
) in N_Op_And | N_And_Then
then
4314 Check_Conjuncts
(Left_Opnd
(Expr
));
4315 Check_Conjuncts
(Right_Opnd
(Expr
));
4317 Check_Conjunct
(Expr
);
4319 end Check_Conjuncts
;
4321 ----------------------
4322 -- Check_Expression --
4323 ----------------------
4325 procedure Check_Expression
(Expr
: Node_Id
) is
4327 if not Is_Trivial_Boolean
(Expr
) then
4328 Check_Function_Result
(Expr
);
4329 Check_Conjuncts
(Expr
);
4331 end Check_Expression
;
4333 ------------------------
4334 -- Is_Function_Result --
4335 ------------------------
4337 function Is_Function_Result
(N
: Node_Id
) return Traverse_Result
is
4339 if Is_Attribute_Result
(N
) then
4340 Result_Seen
:= True;
4343 -- Warn on infinite recursion if call is to current function
4345 elsif Nkind
(N
) = N_Function_Call
4346 and then Is_Entity_Name
(Name
(N
))
4347 and then Entity
(Name
(N
)) = Subp_Id
4348 and then not Is_Potentially_Unevaluated
(N
)
4351 ("call to & within its postcondition will lead to infinite "
4352 & "recursion?", N
, Subp_Id
);
4355 -- Continue the traversal
4360 end Is_Function_Result
;
4362 -------------------------
4363 -- Mentions_Post_State --
4364 -------------------------
4366 function Mentions_Post_State
(N
: Node_Id
) return Boolean is
4367 Post_State_Seen
: Boolean := False;
4369 function Is_Post_State
(N
: Node_Id
) return Traverse_Result
;
4370 -- Attempt to find a construct that denotes a post-state. If this
4371 -- is the case, set flag Post_State_Seen.
4377 function Is_Post_State
(N
: Node_Id
) return Traverse_Result
is
4381 if Nkind
(N
) in N_Explicit_Dereference | N_Function_Call
then
4382 Post_State_Seen
:= True;
4385 elsif Nkind
(N
) in N_Expanded_Name | N_Identifier
then
4388 -- Treat an undecorated reference as OK
4392 -- A reference to an assignable entity is considered a
4393 -- change in the post-state of a subprogram.
4395 or else Ekind
(Ent
) in E_Generic_In_Out_Parameter
4396 | E_In_Out_Parameter
4400 -- The reference may be modified through a dereference
4402 or else (Is_Access_Type
(Etype
(Ent
))
4403 and then Nkind
(Parent
(N
)) =
4404 N_Selected_Component
)
4406 Post_State_Seen
:= True;
4410 elsif Nkind
(N
) = N_Attribute_Reference
then
4411 if Attribute_Name
(N
) = Name_Old
then
4414 elsif Attribute_Name
(N
) = Name_Result
then
4415 Post_State_Seen
:= True;
4423 procedure Find_Post_State
is new Traverse_Proc
(Is_Post_State
);
4425 -- Start of processing for Mentions_Post_State
4428 Find_Post_State
(N
);
4430 return Post_State_Seen
;
4431 end Mentions_Post_State
;
4435 Expr
: constant Node_Id
:=
4437 (First
(Pragma_Argument_Associations
(Prag
)));
4438 Nam
: constant Name_Id
:= Pragma_Name
(Prag
);
4441 -- Start of processing for Check_Result_And_Post_State_In_Pragma
4444 -- Examine all consequences
4446 if Nam
= Name_Contract_Cases
then
4447 CCase
:= First
(Component_Associations
(Expr
));
4448 while Present
(CCase
) loop
4449 Check_Expression
(Expression
(CCase
));
4454 -- Examine the expression of a postcondition
4456 else pragma Assert
(Nam
in Name_Postcondition | Name_Refined_Post
);
4457 Check_Expression
(Expr
);
4459 end Check_Result_And_Post_State_In_Pragma
;
4463 Items
: constant Node_Id
:= Contract
(Subp_Id
);
4464 Case_Prag
: Node_Id
:= Empty
;
4465 Post_Prag
: Node_Id
:= Empty
;
4467 Seen_In_Case
: Boolean := False;
4468 Seen_In_Post
: Boolean := False;
4469 Spec_Id
: constant Entity_Id
:= Unique_Entity
(Subp_Id
);
4471 -- Start of processing for Check_Result_And_Post_State
4474 -- Do not check in instances, because we already checked the generic
4479 -- The lack of attribute 'Result or a post-state is classified as a
4480 -- suspicious contract. Do not perform the check if the corresponding
4481 -- switch is not set.
4483 elsif not Warn_On_Suspicious_Contract
then
4486 -- Nothing to do if there is no contract
4488 elsif No
(Items
) then
4491 -- If the subprogram has a contract Exceptional_Cases, it is often
4492 -- useful to refer only to the pre-state in the postcondition, to
4493 -- indicate when the subprogram might terminate normally.
4495 elsif Present
(Get_Pragma
(Subp_Id
, Pragma_Exceptional_Cases
)) then
4498 -- Same if the subprogram has a contract Always_Terminates => Cond,
4499 -- where Cond is not syntactically True.
4503 Prag
: constant Node_Id
:=
4504 Get_Pragma
(Subp_Id
, Pragma_Always_Terminates
);
4507 and then Present
(Pragma_Argument_Associations
(Prag
))
4510 Cond
: constant Node_Id
:=
4512 (First
(Pragma_Argument_Associations
(Prag
)));
4514 if not Compile_Time_Known_Value
(Cond
)
4515 or else not Is_True
(Expr_Value
(Cond
))
4524 -- Examine all postconditions for attribute 'Result and a post-state
4526 Prag
:= Pre_Post_Conditions
(Items
);
4527 while Present
(Prag
) loop
4528 if Pragma_Name_Unmapped
(Prag
)
4529 in Name_Postcondition | Name_Refined_Post
4530 and then not Error_Posted
(Prag
)
4533 Check_Result_And_Post_State_In_Pragma
(Prag
, Seen_In_Post
);
4536 Prag
:= Next_Pragma
(Prag
);
4539 -- Examine the contract cases of the subprogram for attribute 'Result
4540 -- and a post-state.
4542 Prag
:= Contract_Test_Cases
(Items
);
4543 while Present
(Prag
) loop
4544 if Pragma_Name
(Prag
) = Name_Contract_Cases
4545 and then not Error_Posted
(Prag
)
4548 Check_Result_And_Post_State_In_Pragma
(Prag
, Seen_In_Case
);
4551 Prag
:= Next_Pragma
(Prag
);
4554 -- Do not emit any errors if the subprogram is not a function
4556 if Ekind
(Spec_Id
) not in E_Function | E_Generic_Function
then
4559 -- Regardless of whether the function has postconditions or contract
4560 -- cases, or whether they mention attribute 'Result, an [IN] OUT formal
4561 -- parameter is always treated as a result.
4563 elsif Has_Out_Or_In_Out_Parameter
(Spec_Id
) then
4566 -- The function has both a postcondition and contract cases and they do
4567 -- not mention attribute 'Result.
4569 elsif Present
(Case_Prag
)
4570 and then not Seen_In_Case
4571 and then Present
(Post_Prag
)
4572 and then not Seen_In_Post
4575 ("neither postcondition nor contract cases mention function "
4576 & "result?.t?", Post_Prag
);
4578 -- The function has contract cases only and they do not mention
4579 -- attribute 'Result.
4581 elsif Present
(Case_Prag
) and then not Seen_In_Case
then
4583 ("contract cases do not mention function result?.t?", Case_Prag
);
4585 -- The function has non-trivial postconditions only and they do not
4586 -- mention attribute 'Result.
4588 elsif Present
(Post_Prag
)
4589 and then not Seen_In_Post
4590 and then not Is_Trivial_Boolean
4591 (Get_Pragma_Arg
(First
(Pragma_Argument_Associations
(Post_Prag
))))
4594 ("postcondition does not mention function result?.t?", Post_Prag
);
4596 end Check_Result_And_Post_State
;
4598 -----------------------------
4599 -- Check_State_Refinements --
4600 -----------------------------
4602 procedure Check_State_Refinements
4604 Is_Main_Unit
: Boolean := False)
4606 procedure Check_Package
(Pack
: Node_Id
);
4607 -- Verify that all abstract states of a [generic] package denoted by its
4608 -- declarative node Pack have proper refinement. Recursively verify the
4609 -- visible and private declarations of the [generic] package for other
4612 procedure Check_Packages_In
(Decls
: List_Id
);
4613 -- Seek out [generic] package declarations within declarative list Decls
4614 -- and verify the status of their abstract state refinement.
4616 function SPARK_Mode_Is_Off
(N
: Node_Id
) return Boolean;
4617 -- Determine whether construct N is subject to pragma SPARK_Mode Off
4623 procedure Check_Package
(Pack
: Node_Id
) is
4624 Body_Id
: constant Entity_Id
:= Corresponding_Body
(Pack
);
4625 Spec
: constant Node_Id
:= Specification
(Pack
);
4626 States
: constant Elist_Id
:=
4627 Abstract_States
(Defining_Entity
(Pack
));
4629 State_Elmt
: Elmt_Id
;
4630 State_Id
: Entity_Id
;
4633 -- Do not verify proper state refinement when the package is subject
4634 -- to pragma SPARK_Mode Off because this disables the requirement for
4635 -- state refinement.
4637 if SPARK_Mode_Is_Off
(Pack
) then
4640 -- State refinement can only occur in a completing package body. Do
4641 -- not verify proper state refinement when the body is subject to
4642 -- pragma SPARK_Mode Off because this disables the requirement for
4643 -- state refinement.
4645 elsif Present
(Body_Id
)
4646 and then SPARK_Mode_Is_Off
(Unit_Declaration_Node
(Body_Id
))
4650 -- Do not verify proper state refinement when the package is an
4651 -- instance as this check was already performed in the generic.
4653 elsif Present
(Generic_Parent
(Spec
)) then
4656 -- Otherwise examine the contents of the package
4659 if Present
(States
) then
4660 State_Elmt
:= First_Elmt
(States
);
4661 while Present
(State_Elmt
) loop
4662 State_Id
:= Node
(State_Elmt
);
4664 -- Emit an error when a non-null state lacks refinement,
4665 -- but has Part_Of constituents or there is a package
4666 -- body (SPARK RM 7.1.4(4)). Constituents in private
4667 -- child packages, which are not known at this stage,
4668 -- independently require the existence of a package body.
4670 if not Is_Null_State
(State_Id
)
4671 and then No
(Refinement_Constituents
(State_Id
))
4673 (Present
(Part_Of_Constituents
(State_Id
))
4677 Error_Msg_N
("state & requires refinement", State_Id
);
4678 Error_Msg_N
("\package body should have Refined_State "
4679 & "for state & with constituents", State_Id
);
4682 Next_Elmt
(State_Elmt
);
4686 Check_Packages_In
(Visible_Declarations
(Spec
));
4687 Check_Packages_In
(Private_Declarations
(Spec
));
4691 -----------------------
4692 -- Check_Packages_In --
4693 -----------------------
4695 procedure Check_Packages_In
(Decls
: List_Id
) is
4699 if Present
(Decls
) then
4700 Decl
:= First
(Decls
);
4701 while Present
(Decl
) loop
4702 if Nkind
(Decl
) in N_Generic_Package_Declaration
4703 | N_Package_Declaration
4705 Check_Package
(Decl
);
4711 end Check_Packages_In
;
4713 -----------------------
4714 -- SPARK_Mode_Is_Off --
4715 -----------------------
4717 function SPARK_Mode_Is_Off
(N
: Node_Id
) return Boolean is
4718 Id
: constant Entity_Id
:= Defining_Entity
(N
);
4719 Prag
: constant Node_Id
:= SPARK_Pragma
(Id
);
4722 -- Default the mode to "off" when the context is an instance and all
4723 -- SPARK_Mode pragmas found within are to be ignored.
4725 if Ignore_SPARK_Mode_Pragmas
(Id
) then
4731 and then Get_SPARK_Mode_From_Annotation
(Prag
) = Off
;
4733 end SPARK_Mode_Is_Off
;
4735 -- Start of processing for Check_State_Refinements
4738 -- A block may declare a nested package
4740 if Nkind
(Context
) = N_Block_Statement
then
4741 Check_Packages_In
(Declarations
(Context
));
4743 -- An entry, protected, subprogram, or task body may declare a nested
4746 elsif Nkind
(Context
) in N_Entry_Body
4751 -- Do not verify proper state refinement when the body is subject to
4752 -- pragma SPARK_Mode Off because this disables the requirement for
4753 -- state refinement.
4755 if not SPARK_Mode_Is_Off
(Context
) then
4756 Check_Packages_In
(Declarations
(Context
));
4759 -- A package body may declare a nested package
4761 elsif Nkind
(Context
) = N_Package_Body
then
4762 Check_Package
(Unit_Declaration_Node
(Corresponding_Spec
(Context
)));
4764 -- Do not verify proper state refinement when the body is subject to
4765 -- pragma SPARK_Mode Off because this disables the requirement for
4766 -- state refinement.
4768 if not SPARK_Mode_Is_Off
(Context
) then
4769 Check_Packages_In
(Declarations
(Context
));
4772 -- A library level [generic] package may declare a nested package
4774 elsif Nkind
(Context
) in
4775 N_Generic_Package_Declaration | N_Package_Declaration
4776 and then Is_Main_Unit
4778 Check_Package
(Context
);
4780 end Check_State_Refinements
;
4782 ------------------------------
4783 -- Check_Unprotected_Access --
4784 ------------------------------
4786 procedure Check_Unprotected_Access
4790 Cont_Encl_Typ
: Entity_Id
;
4791 Pref_Encl_Typ
: Entity_Id
;
4793 function Enclosing_Protected_Type
(Obj
: Node_Id
) return Entity_Id
;
4794 -- Check whether Obj is a private component of a protected object.
4795 -- Return the protected type where the component resides, Empty
4798 function Is_Public_Operation
return Boolean;
4799 -- Verify that the enclosing operation is callable from outside the
4800 -- protected object, to minimize false positives.
4802 ------------------------------
4803 -- Enclosing_Protected_Type --
4804 ------------------------------
4806 function Enclosing_Protected_Type
(Obj
: Node_Id
) return Entity_Id
is
4808 if Is_Entity_Name
(Obj
) then
4810 Ent
: Entity_Id
:= Entity
(Obj
);
4813 -- The object can be a renaming of a private component, use
4814 -- the original record component.
4816 if Is_Prival
(Ent
) then
4817 Ent
:= Prival_Link
(Ent
);
4820 if Is_Protected_Type
(Scope
(Ent
)) then
4826 -- For indexed and selected components, recursively check the prefix
4828 if Nkind
(Obj
) in N_Indexed_Component | N_Selected_Component
then
4829 return Enclosing_Protected_Type
(Prefix
(Obj
));
4831 -- The object does not denote a protected component
4836 end Enclosing_Protected_Type
;
4838 -------------------------
4839 -- Is_Public_Operation --
4840 -------------------------
4842 function Is_Public_Operation
return Boolean is
4848 while Present
(S
) and then S
/= Pref_Encl_Typ
loop
4849 if Scope
(S
) = Pref_Encl_Typ
then
4850 E
:= First_Entity
(Pref_Encl_Typ
);
4852 and then E
/= First_Private_Entity
(Pref_Encl_Typ
)
4866 end Is_Public_Operation
;
4868 -- Start of processing for Check_Unprotected_Access
4871 if Nkind
(Expr
) = N_Attribute_Reference
4872 and then Attribute_Name
(Expr
) = Name_Unchecked_Access
4874 Cont_Encl_Typ
:= Enclosing_Protected_Type
(Context
);
4875 Pref_Encl_Typ
:= Enclosing_Protected_Type
(Prefix
(Expr
));
4877 -- Check whether we are trying to export a protected component to a
4878 -- context with an equal or lower access level.
4880 if Present
(Pref_Encl_Typ
)
4881 and then No
(Cont_Encl_Typ
)
4882 and then Is_Public_Operation
4883 and then Scope_Depth
(Pref_Encl_Typ
)
4884 >= Static_Accessibility_Level
4885 (Context
, Object_Decl_Level
)
4888 ("??possible unprotected access to protected data", Expr
);
4891 end Check_Unprotected_Access
;
4893 ------------------------------
4894 -- Check_Unused_Body_States --
4895 ------------------------------
4897 procedure Check_Unused_Body_States
(Body_Id
: Entity_Id
) is
4898 procedure Process_Refinement_Clause
4901 -- Inspect all constituents of refinement clause Clause and remove any
4902 -- matches from body state list States.
4904 procedure Report_Unused_Body_States
(States
: Elist_Id
);
4905 -- Emit errors for each abstract state or object found in list States
4907 -------------------------------
4908 -- Process_Refinement_Clause --
4909 -------------------------------
4911 procedure Process_Refinement_Clause
4915 procedure Process_Constituent
(Constit
: Node_Id
);
4916 -- Remove constituent Constit from body state list States
4918 -------------------------
4919 -- Process_Constituent --
4920 -------------------------
4922 procedure Process_Constituent
(Constit
: Node_Id
) is
4923 Constit_Id
: Entity_Id
;
4926 -- Guard against illegal constituents. Only abstract states and
4927 -- objects can appear on the right hand side of a refinement.
4929 if Is_Entity_Name
(Constit
) then
4930 Constit_Id
:= Entity_Of
(Constit
);
4932 if Present
(Constit_Id
)
4933 and then Ekind
(Constit_Id
) in
4934 E_Abstract_State | E_Constant | E_Variable
4936 Remove
(States
, Constit_Id
);
4939 end Process_Constituent
;
4945 -- Start of processing for Process_Refinement_Clause
4948 if Nkind
(Clause
) = N_Component_Association
then
4949 Constit
:= Expression
(Clause
);
4951 -- Multiple constituents appear as an aggregate
4953 if Nkind
(Constit
) = N_Aggregate
then
4954 Constit
:= First
(Expressions
(Constit
));
4955 while Present
(Constit
) loop
4956 Process_Constituent
(Constit
);
4960 -- Various forms of a single constituent
4963 Process_Constituent
(Constit
);
4966 end Process_Refinement_Clause
;
4968 -------------------------------
4969 -- Report_Unused_Body_States --
4970 -------------------------------
4972 procedure Report_Unused_Body_States
(States
: Elist_Id
) is
4973 Posted
: Boolean := False;
4974 State_Elmt
: Elmt_Id
;
4975 State_Id
: Entity_Id
;
4978 if Present
(States
) then
4979 State_Elmt
:= First_Elmt
(States
);
4980 while Present
(State_Elmt
) loop
4981 State_Id
:= Node
(State_Elmt
);
4983 -- Constants are part of the hidden state of a package, but the
4984 -- compiler cannot determine whether they have variable input
4985 -- (SPARK RM 7.1.1(2)) and cannot classify them properly as a
4986 -- hidden state. Do not emit an error when a constant does not
4987 -- participate in a state refinement, even though it acts as a
4990 if Ekind
(State_Id
) = E_Constant
then
4993 -- Overlays do not contribute to package state
4995 elsif Ekind
(State_Id
) = E_Variable
4996 and then Present
(Ultimate_Overlaid_Entity
(State_Id
))
5000 -- Generate an error message of the form:
5002 -- body of package ... has unused hidden states
5003 -- abstract state ... defined at ...
5004 -- variable ... defined at ...
5010 ("body of package & has unused hidden states", Body_Id
);
5013 Error_Msg_Sloc
:= Sloc
(State_Id
);
5015 if Ekind
(State_Id
) = E_Abstract_State
then
5017 ("\abstract state & defined #", Body_Id
, State_Id
);
5020 SPARK_Msg_NE
("\variable & defined #", Body_Id
, State_Id
);
5024 Next_Elmt
(State_Elmt
);
5027 end Report_Unused_Body_States
;
5031 Prag
: constant Node_Id
:= Get_Pragma
(Body_Id
, Pragma_Refined_State
);
5032 Spec_Id
: constant Entity_Id
:= Spec_Entity
(Body_Id
);
5036 -- Start of processing for Check_Unused_Body_States
5039 -- Inspect the clauses of pragma Refined_State and determine whether all
5040 -- visible states declared within the package body participate in the
5043 if Present
(Prag
) then
5044 Clause
:= Expression
(Get_Argument
(Prag
, Spec_Id
));
5045 States
:= Collect_Body_States
(Body_Id
);
5047 -- Multiple non-null state refinements appear as an aggregate
5049 if Nkind
(Clause
) = N_Aggregate
then
5050 Clause
:= First
(Component_Associations
(Clause
));
5051 while Present
(Clause
) loop
5052 Process_Refinement_Clause
(Clause
, States
);
5056 -- Various forms of a single state refinement
5059 Process_Refinement_Clause
(Clause
, States
);
5062 -- Ensure that all abstract states and objects declared in the
5063 -- package body state space are utilized as constituents.
5065 Report_Unused_Body_States
(States
);
5067 end Check_Unused_Body_States
;
5073 function Choice_List
(N
: Node_Id
) return List_Id
is
5075 if Nkind
(N
) = N_Iterated_Component_Association
then
5076 return Discrete_Choices
(N
);
5082 ---------------------
5083 -- Class_Condition --
5084 ---------------------
5086 function Class_Condition
5087 (Kind
: Condition_Kind
;
5088 Subp
: Entity_Id
) return Node_Id
is
5092 when Class_Postcondition
=>
5093 return Class_Postconditions
(Subp
);
5095 when Class_Precondition
=>
5096 return Class_Preconditions
(Subp
);
5098 when Ignored_Class_Postcondition
=>
5099 return Ignored_Class_Postconditions
(Subp
);
5101 when Ignored_Class_Precondition
=>
5102 return Ignored_Class_Preconditions
(Subp
);
5104 end Class_Condition
;
5106 -------------------------
5107 -- Collect_Body_States --
5108 -------------------------
5110 function Collect_Body_States
(Body_Id
: Entity_Id
) return Elist_Id
is
5111 function Is_Visible_Object
(Obj_Id
: Entity_Id
) return Boolean;
5112 -- Determine whether object Obj_Id is a suitable visible state of a
5115 procedure Collect_Visible_States
5116 (Pack_Id
: Entity_Id
;
5117 States
: in out Elist_Id
);
5118 -- Gather the entities of all abstract states and objects declared in
5119 -- the visible state space of package Pack_Id.
5121 ----------------------------
5122 -- Collect_Visible_States --
5123 ----------------------------
5125 procedure Collect_Visible_States
5126 (Pack_Id
: Entity_Id
;
5127 States
: in out Elist_Id
)
5129 Item_Id
: Entity_Id
;
5132 -- Traverse the entity chain of the package and inspect all visible
5135 Item_Id
:= First_Entity
(Pack_Id
);
5136 while Present
(Item_Id
) and then not In_Private_Part
(Item_Id
) loop
5138 -- Do not consider internally generated items as those cannot be
5139 -- named and participate in refinement.
5141 if not Comes_From_Source
(Item_Id
) then
5144 elsif Ekind
(Item_Id
) = E_Abstract_State
then
5145 Append_New_Elmt
(Item_Id
, States
);
5147 elsif Ekind
(Item_Id
) in E_Constant | E_Variable
5148 and then Is_Visible_Object
(Item_Id
)
5150 Append_New_Elmt
(Item_Id
, States
);
5152 -- Recursively gather the visible states of a nested package
5153 -- except for nested package renamings.
5155 elsif Ekind
(Item_Id
) = E_Package
5156 and then No
(Renamed_Entity
(Item_Id
))
5158 Collect_Visible_States
(Item_Id
, States
);
5161 Next_Entity
(Item_Id
);
5163 end Collect_Visible_States
;
5165 -----------------------
5166 -- Is_Visible_Object --
5167 -----------------------
5169 function Is_Visible_Object
(Obj_Id
: Entity_Id
) return Boolean is
5171 -- Objects that map generic formals to their actuals are not visible
5172 -- from outside the generic instantiation.
5174 if Present
(Corresponding_Generic_Association
5175 (Declaration_Node
(Obj_Id
)))
5179 -- Constituents of a single protected/task type act as components of
5180 -- the type and are not visible from outside the type.
5182 elsif Ekind
(Obj_Id
) = E_Variable
5183 and then Present
(Encapsulating_State
(Obj_Id
))
5184 and then Is_Single_Concurrent_Object
(Encapsulating_State
(Obj_Id
))
5191 end Is_Visible_Object
;
5195 Body_Decl
: constant Node_Id
:= Unit_Declaration_Node
(Body_Id
);
5197 Item_Id
: Entity_Id
;
5198 States
: Elist_Id
:= No_Elist
;
5200 -- Start of processing for Collect_Body_States
5203 -- Inspect the declarations of the body looking for source objects,
5204 -- packages and package instantiations. Note that even though this
5205 -- processing is very similar to Collect_Visible_States, a package
5206 -- body does not have a First/Next_Entity list.
5208 Decl
:= First
(Declarations
(Body_Decl
));
5209 while Present
(Decl
) loop
5211 -- Capture source objects as internally generated temporaries cannot
5212 -- be named and participate in refinement.
5214 if Nkind
(Decl
) = N_Object_Declaration
then
5215 Item_Id
:= Defining_Entity
(Decl
);
5217 if Comes_From_Source
(Item_Id
)
5218 and then Is_Visible_Object
(Item_Id
)
5220 Append_New_Elmt
(Item_Id
, States
);
5223 -- Capture the visible abstract states and objects of a source
5224 -- package [instantiation].
5226 elsif Nkind
(Decl
) = N_Package_Declaration
then
5227 Item_Id
:= Defining_Entity
(Decl
);
5229 if Comes_From_Source
(Item_Id
) then
5230 Collect_Visible_States
(Item_Id
, States
);
5238 end Collect_Body_States
;
5240 ------------------------
5241 -- Collect_Interfaces --
5242 ------------------------
5244 procedure Collect_Interfaces
5246 Ifaces_List
: out Elist_Id
;
5247 Exclude_Parents
: Boolean := False;
5248 Use_Full_View
: Boolean := True)
5250 procedure Collect
(Typ
: Entity_Id
);
5251 -- Subsidiary subprogram used to traverse the whole list
5252 -- of directly and indirectly implemented interfaces
5258 procedure Collect
(Typ
: Entity_Id
) is
5259 Ancestor
: Entity_Id
;
5267 -- Handle private types and subtypes
5270 and then Is_Private_Type
(Typ
)
5271 and then Present
(Full_View
(Typ
))
5273 Full_T
:= Full_View
(Typ
);
5275 if Ekind
(Full_T
) = E_Record_Subtype
then
5276 Full_T
:= Etype
(Typ
);
5278 if Present
(Full_View
(Full_T
)) then
5279 Full_T
:= Full_View
(Full_T
);
5284 -- Include the ancestor if we are generating the whole list of
5285 -- abstract interfaces.
5287 if Etype
(Full_T
) /= Typ
5289 -- Protect the frontend against wrong sources. For example:
5292 -- type A is tagged null record;
5293 -- type B is new A with private;
5294 -- type C is new A with private;
5296 -- type B is new C with null record;
5297 -- type C is new B with null record;
5300 and then Etype
(Full_T
) /= T
5302 Ancestor
:= Etype
(Full_T
);
5305 if Is_Interface
(Ancestor
) and then not Exclude_Parents
then
5306 Append_Unique_Elmt
(Ancestor
, Ifaces_List
);
5310 -- Traverse the graph of ancestor interfaces
5312 Id
:= First
(Abstract_Interface_List
(Full_T
));
5313 while Present
(Id
) loop
5314 Iface
:= Etype
(Id
);
5316 -- Protect against wrong uses. For example:
5317 -- type I is interface;
5318 -- type O is tagged null record;
5319 -- type Wrong is new I and O with null record; -- ERROR
5321 if Is_Interface
(Iface
) then
5323 and then Etype
(T
) /= T
5324 and then Interface_Present_In_Ancestor
(Etype
(T
), Iface
)
5329 Append_Unique_Elmt
(Iface
, Ifaces_List
);
5337 -- Start of processing for Collect_Interfaces
5340 pragma Assert
(Is_Tagged_Type
(T
) or else Is_Concurrent_Type
(T
));
5341 Ifaces_List
:= New_Elmt_List
;
5343 end Collect_Interfaces
;
5345 ----------------------------------
5346 -- Collect_Interface_Components --
5347 ----------------------------------
5349 procedure Collect_Interface_Components
5350 (Tagged_Type
: Entity_Id
;
5351 Components_List
: out Elist_Id
)
5353 procedure Collect
(Typ
: Entity_Id
);
5354 -- Subsidiary subprogram used to climb to the parents
5360 procedure Collect
(Typ
: Entity_Id
) is
5361 Tag_Comp
: Entity_Id
;
5362 Parent_Typ
: Entity_Id
;
5365 -- Handle private types
5367 if Present
(Full_View
(Etype
(Typ
))) then
5368 Parent_Typ
:= Full_View
(Etype
(Typ
));
5370 Parent_Typ
:= Etype
(Typ
);
5373 if Parent_Typ
/= Typ
5375 -- Protect the frontend against wrong sources. For example:
5378 -- type A is tagged null record;
5379 -- type B is new A with private;
5380 -- type C is new A with private;
5382 -- type B is new C with null record;
5383 -- type C is new B with null record;
5386 and then Parent_Typ
/= Tagged_Type
5388 Collect
(Parent_Typ
);
5391 -- Collect the components containing tags of secondary dispatch
5394 Tag_Comp
:= Next_Tag_Component
(First_Tag_Component
(Typ
));
5395 while Present
(Tag_Comp
) loop
5396 pragma Assert
(Present
(Related_Type
(Tag_Comp
)));
5397 Append_Elmt
(Tag_Comp
, Components_List
);
5399 Tag_Comp
:= Next_Tag_Component
(Tag_Comp
);
5403 -- Start of processing for Collect_Interface_Components
5406 pragma Assert
(Ekind
(Tagged_Type
) = E_Record_Type
5407 and then Is_Tagged_Type
(Tagged_Type
));
5409 Components_List
:= New_Elmt_List
;
5410 Collect
(Tagged_Type
);
5411 end Collect_Interface_Components
;
5413 -----------------------------
5414 -- Collect_Interfaces_Info --
5415 -----------------------------
5417 procedure Collect_Interfaces_Info
5419 Ifaces_List
: out Elist_Id
;
5420 Components_List
: out Elist_Id
;
5421 Tags_List
: out Elist_Id
)
5423 Comps_List
: Elist_Id
;
5424 Comp_Elmt
: Elmt_Id
;
5425 Comp_Iface
: Entity_Id
;
5426 Iface_Elmt
: Elmt_Id
;
5429 function Search_Tag
(Iface
: Entity_Id
) return Entity_Id
;
5430 -- Search for the secondary tag associated with the interface type
5431 -- Iface that is implemented by T.
5437 function Search_Tag
(Iface
: Entity_Id
) return Entity_Id
is
5440 if not Is_CPP_Class
(T
) then
5441 ADT
:= Next_Elmt
(Next_Elmt
(First_Elmt
(Access_Disp_Table
(T
))));
5443 ADT
:= Next_Elmt
(First_Elmt
(Access_Disp_Table
(T
)));
5447 and then Is_Tag
(Node
(ADT
))
5448 and then Related_Type
(Node
(ADT
)) /= Iface
5450 -- Skip secondary dispatch table referencing thunks to user
5451 -- defined primitives covered by this interface.
5453 pragma Assert
(Has_Suffix
(Node
(ADT
), 'P'));
5456 -- Skip secondary dispatch tables of Ada types
5458 if not Is_CPP_Class
(T
) then
5460 -- Skip secondary dispatch table referencing thunks to
5461 -- predefined primitives.
5463 pragma Assert
(Has_Suffix
(Node
(ADT
), 'Y'));
5466 -- Skip secondary dispatch table referencing user-defined
5467 -- primitives covered by this interface.
5469 pragma Assert
(Has_Suffix
(Node
(ADT
), 'D'));
5472 -- Skip secondary dispatch table referencing predefined
5475 pragma Assert
(Has_Suffix
(Node
(ADT
), 'Z'));
5480 pragma Assert
(Is_Tag
(Node
(ADT
)));
5484 -- Start of processing for Collect_Interfaces_Info
5487 Collect_Interfaces
(T
, Ifaces_List
);
5488 Collect_Interface_Components
(T
, Comps_List
);
5490 -- Search for the record component and tag associated with each
5491 -- interface type of T.
5493 Components_List
:= New_Elmt_List
;
5494 Tags_List
:= New_Elmt_List
;
5496 Iface_Elmt
:= First_Elmt
(Ifaces_List
);
5497 while Present
(Iface_Elmt
) loop
5498 Iface
:= Node
(Iface_Elmt
);
5500 -- Associate the primary tag component and the primary dispatch table
5501 -- with all the interfaces that are parents of T
5503 if Is_Ancestor
(Iface
, T
, Use_Full_View
=> True) then
5504 Append_Elmt
(First_Tag_Component
(T
), Components_List
);
5505 Append_Elmt
(Node
(First_Elmt
(Access_Disp_Table
(T
))), Tags_List
);
5507 -- Otherwise search for the tag component and secondary dispatch
5511 Comp_Elmt
:= First_Elmt
(Comps_List
);
5512 while Present
(Comp_Elmt
) loop
5513 Comp_Iface
:= Related_Type
(Node
(Comp_Elmt
));
5515 if Comp_Iface
= Iface
5516 or else Is_Ancestor
(Iface
, Comp_Iface
, Use_Full_View
=> True)
5518 Append_Elmt
(Node
(Comp_Elmt
), Components_List
);
5519 Append_Elmt
(Search_Tag
(Comp_Iface
), Tags_List
);
5523 Next_Elmt
(Comp_Elmt
);
5525 pragma Assert
(Present
(Comp_Elmt
));
5528 Next_Elmt
(Iface_Elmt
);
5530 end Collect_Interfaces_Info
;
5532 ---------------------
5533 -- Collect_Parents --
5534 ---------------------
5536 procedure Collect_Parents
5538 List
: out Elist_Id
;
5539 Use_Full_View
: Boolean := True)
5541 Current_Typ
: Entity_Id
:= T
;
5542 Parent_Typ
: Entity_Id
;
5545 List
:= New_Elmt_List
;
5547 -- No action if the if the type has no parents
5549 if T
= Etype
(T
) then
5554 Parent_Typ
:= Etype
(Current_Typ
);
5556 if Is_Private_Type
(Parent_Typ
)
5557 and then Present
(Full_View
(Parent_Typ
))
5558 and then Use_Full_View
5560 Parent_Typ
:= Full_View
(Base_Type
(Parent_Typ
));
5563 Append_Elmt
(Parent_Typ
, List
);
5565 exit when Parent_Typ
= Current_Typ
;
5566 Current_Typ
:= Parent_Typ
;
5568 end Collect_Parents
;
5570 ----------------------------------
5571 -- Collect_Primitive_Operations --
5572 ----------------------------------
5574 function Collect_Primitive_Operations
(T
: Entity_Id
) return Elist_Id
is
5575 B_Type
: constant Entity_Id
:= Base_Type
(T
);
5577 function Match
(E
: Entity_Id
) return Boolean;
5578 -- True if E's base type is B_Type, or E is of an anonymous access type
5579 -- and the base type of its designated type is B_Type.
5585 function Match
(E
: Entity_Id
) return Boolean is
5586 Etyp
: Entity_Id
:= Etype
(E
);
5589 if Ekind
(Etyp
) = E_Anonymous_Access_Type
then
5590 Etyp
:= Designated_Type
(Etyp
);
5593 -- In Ada 2012 a primitive operation may have a formal of an
5594 -- incomplete view of the parent type.
5596 return Base_Type
(Etyp
) = B_Type
5598 (Ada_Version
>= Ada_2012
5599 and then Ekind
(Etyp
) = E_Incomplete_Type
5600 and then Full_View
(Etyp
) = B_Type
);
5605 B_Decl
: constant Node_Id
:= Original_Node
(Parent
(B_Type
));
5606 B_Scope
: Entity_Id
:= Scope
(B_Type
);
5608 Eq_Prims_List
: Elist_Id
:= No_Elist
;
5611 Is_Type_In_Pkg
: Boolean;
5612 Formal_Derived
: Boolean := False;
5615 -- Start of processing for Collect_Primitive_Operations
5618 -- For tagged types, the primitive operations are collected as they
5619 -- are declared, and held in an explicit list which is simply returned.
5621 if Is_Tagged_Type
(B_Type
) then
5622 return Primitive_Operations
(B_Type
);
5624 -- An untagged generic type that is a derived type inherits the
5625 -- primitive operations of its parent type. Other formal types only
5626 -- have predefined operators, which are not explicitly represented.
5628 elsif Is_Generic_Type
(B_Type
) then
5629 if Nkind
(B_Decl
) = N_Formal_Type_Declaration
5630 and then Nkind
(Formal_Type_Definition
(B_Decl
)) =
5631 N_Formal_Derived_Type_Definition
5633 Formal_Derived
:= True;
5635 return New_Elmt_List
;
5639 Op_List
:= New_Elmt_List
;
5641 if B_Scope
= Standard_Standard
then
5642 if B_Type
= Standard_String
then
5643 Append_Elmt
(Standard_Op_Concat
, Op_List
);
5645 elsif B_Type
= Standard_Wide_String
then
5646 Append_Elmt
(Standard_Op_Concatw
, Op_List
);
5652 -- Locate the primitive subprograms of the type
5655 -- The primitive operations appear after the base type, except if the
5656 -- derivation happens within the private part of B_Scope and the type
5657 -- is a private type, in which case both the type and some primitive
5658 -- operations may appear before the base type, and the list of
5659 -- candidates starts after the type.
5661 if In_Open_Scopes
(B_Scope
)
5662 and then Scope
(T
) = B_Scope
5663 and then In_Private_Part
(B_Scope
)
5665 Id
:= Next_Entity
(T
);
5667 -- In Ada 2012, If the type has an incomplete partial view, there may
5668 -- be primitive operations declared before the full view, so we need
5669 -- to start scanning from the incomplete view, which is earlier on
5670 -- the entity chain.
5672 elsif Nkind
(Parent
(B_Type
)) = N_Full_Type_Declaration
5673 and then Present
(Incomplete_View
(Parent
(B_Type
)))
5675 Id
:= Incomplete_View
(Parent
(B_Type
));
5677 -- If T is a derived from a type with an incomplete view declared
5678 -- elsewhere, that incomplete view is irrelevant, we want the
5679 -- operations in the scope of T.
5681 if Scope
(Id
) /= Scope
(B_Type
) then
5682 Id
:= Next_Entity
(B_Type
);
5686 Id
:= Next_Entity
(B_Type
);
5689 -- Set flag if this is a type in a package spec
5692 Is_Package_Or_Generic_Package
(B_Scope
)
5694 Parent_Kind
(Declaration_Node
(First_Subtype
(T
))) /=
5697 while Present
(Id
) loop
5699 -- Test whether the result type or any of the parameter types of
5700 -- each subprogram following the type match that type when the
5701 -- type is declared in a package spec, is a derived type, or the
5702 -- subprogram is marked as primitive. (The Is_Primitive test is
5703 -- needed to find primitives of nonderived types in declarative
5704 -- parts that happen to override the predefined "=" operator.)
5706 -- Note that generic formal subprograms are not considered to be
5707 -- primitive operations and thus are never inherited.
5709 if Is_Overloadable
(Id
)
5710 and then (Is_Type_In_Pkg
5711 or else Is_Derived_Type
(B_Type
)
5712 or else Is_Primitive
(Id
))
5713 and then Parent_Kind
(Parent
(Id
))
5714 not in N_Formal_Subprogram_Declaration
5722 Formal
:= First_Formal
(Id
);
5723 while Present
(Formal
) loop
5724 if Match
(Formal
) then
5729 Next_Formal
(Formal
);
5733 -- For a formal derived type, the only primitives are the ones
5734 -- inherited from the parent type. Operations appearing in the
5735 -- package declaration are not primitive for it.
5738 and then (not Formal_Derived
or else Present
(Alias
(Id
)))
5740 -- In the special case of an equality operator aliased to
5741 -- an overriding dispatching equality belonging to the same
5742 -- type, we don't include it in the list of primitives.
5743 -- This avoids inheriting multiple equality operators when
5744 -- deriving from untagged private types whose full type is
5745 -- tagged, which can otherwise cause ambiguities. Note that
5746 -- this should only happen for this kind of untagged parent
5747 -- type, since normally dispatching operations are inherited
5748 -- using the type's Primitive_Operations list.
5750 if Chars
(Id
) = Name_Op_Eq
5751 and then Is_Dispatching_Operation
(Id
)
5752 and then Present
(Alias
(Id
))
5753 and then Present
(Overridden_Operation
(Alias
(Id
)))
5754 and then Base_Type
(Etype
(First_Entity
(Id
))) =
5755 Base_Type
(Etype
(First_Entity
(Alias
(Id
))))
5759 -- Include the subprogram in the list of primitives
5762 Append_Elmt
(Id
, Op_List
);
5764 -- Save collected equality primitives for later filtering
5765 -- (if we are processing a private type for which we can
5766 -- collect several candidates).
5768 if Inherits_From_Tagged_Full_View
(T
)
5769 and then Chars
(Id
) = Name_Op_Eq
5770 and then Etype
(First_Formal
(Id
)) =
5771 Etype
(Next_Formal
(First_Formal
(Id
)))
5773 Append_New_Elmt
(Id
, Eq_Prims_List
);
5781 -- For a type declared in System, some of its operations may
5782 -- appear in the target-specific extension to System.
5785 and then Is_RTU
(B_Scope
, System
)
5786 and then Present_System_Aux
5788 B_Scope
:= System_Aux_Id
;
5789 Id
:= First_Entity
(System_Aux_Id
);
5793 -- Filter collected equality primitives
5795 if Inherits_From_Tagged_Full_View
(T
)
5796 and then Present
(Eq_Prims_List
)
5799 First
: constant Elmt_Id
:= First_Elmt
(Eq_Prims_List
);
5803 pragma Assert
(No
(Next_Elmt
(First
))
5804 or else No
(Next_Elmt
(Next_Elmt
(First
))));
5806 -- No action needed if we have collected a single equality
5809 if Present
(Next_Elmt
(First
)) then
5810 Second
:= Next_Elmt
(First
);
5812 if Is_Dispatching_Operation
5813 (Ultimate_Alias
(Node
(First
)))
5815 Remove
(Op_List
, Node
(First
));
5817 elsif Is_Dispatching_Operation
5818 (Ultimate_Alias
(Node
(Second
)))
5820 Remove
(Op_List
, Node
(Second
));
5823 raise Program_Error
;
5831 end Collect_Primitive_Operations
;
5833 -----------------------------------
5834 -- Compile_Time_Constraint_Error --
5835 -----------------------------------
5837 function Compile_Time_Constraint_Error
5840 Ent
: Entity_Id
:= Empty
;
5841 Loc
: Source_Ptr
:= No_Location
;
5842 Warn
: Boolean := False;
5843 Extra_Msg
: String := "") return Node_Id
5845 Msgc
: String (1 .. Msg
'Length + 3);
5846 -- Copy of message, with room for possible ?? or << and ! at end
5853 -- If this is a warning, convert it into an error if we are in code
5854 -- subject to SPARK_Mode being set On, unless Warn is True to force a
5855 -- warning. The rationale is that a compile-time constraint error should
5856 -- lead to an error instead of a warning when SPARK_Mode is On, but in
5857 -- a few cases we prefer to issue a warning and generate both a suitable
5858 -- run-time error in GNAT and a suitable check message in GNATprove.
5859 -- Those cases are those that likely correspond to deactivated SPARK
5860 -- code, so that this kind of code can be compiled and analyzed instead
5861 -- of being rejected.
5863 Error_Msg_Warn
:= Warn
or SPARK_Mode
/= On
;
5865 -- A static constraint error in an instance body is not a fatal error.
5866 -- We choose to inhibit the message altogether, because there is no
5867 -- obvious node (for now) on which to post it. On the other hand the
5868 -- offending node must be replaced with a constraint_error in any case.
5870 -- No messages are generated if we already posted an error on this node
5872 if not Error_Posted
(N
) then
5873 if Loc
/= No_Location
then
5879 -- Copy message to Msgc, converting any ? in the message into <
5880 -- instead, so that we have an error in GNATprove mode.
5884 for J
in 1 .. Msgl
loop
5885 if Msg
(J
) = '?' and then (J
= 1 or else Msg
(J
- 1) /= ''') then
5888 Msgc
(J
) := Msg
(J
);
5892 -- Message is a warning, even in Ada 95 case
5894 if Msg
(Msg
'Last) = '?' or else Msg
(Msg
'Last) = '<' then
5897 -- In Ada 83, all messages are warnings. In the private part and the
5898 -- body of an instance, constraint_checks are only warnings. We also
5899 -- make this a warning if the Warn parameter is set.
5902 or else (Ada_Version
= Ada_83
and then Comes_From_Source
(N
))
5903 or else In_Instance_Not_Visible
5911 -- Otherwise we have a real error message (Ada 95 static case) and we
5912 -- make this an unconditional message. Note that in the warning case
5913 -- we do not make the message unconditional, it seems reasonable to
5914 -- delete messages like this (about exceptions that will be raised)
5923 -- One more test, skip the warning if the related expression is
5924 -- statically unevaluated, since we don't want to warn about what
5925 -- will happen when something is evaluated if it never will be
5928 -- Suppress error reporting when checking that the expression of a
5929 -- static expression function is a potentially static expression,
5930 -- because we don't want additional errors being reported during the
5931 -- preanalysis of the expression (see Analyze_Expression_Function).
5933 if not Is_Statically_Unevaluated
(N
)
5934 and then not Checking_Potentially_Static_Expression
5936 if Present
(Ent
) then
5937 Error_Msg_NEL
(Msgc
(1 .. Msgl
), N
, Ent
, Eloc
);
5939 Error_Msg_NEL
(Msgc
(1 .. Msgl
), N
, Etype
(N
), Eloc
);
5942 -- Emit any extra message as a continuation
5944 if Extra_Msg
/= "" then
5945 Error_Msg_N
('\' & Extra_Msg
, N
);
5950 -- Check whether the context is an Init_Proc
5952 if Inside_Init_Proc
then
5954 Init_Proc_Type
: constant Entity_Id
:=
5955 Etype
(First_Formal
(Current_Scope_No_Loops
));
5957 Conc_Typ
: constant Entity_Id
:=
5958 (if Present
(Init_Proc_Type
)
5959 and then Ekind
(Init_Proc_Type
) = E_Record_Type
5960 then Corresponding_Concurrent_Type
(Init_Proc_Type
)
5964 -- Don't complain if the corresponding concurrent type
5965 -- doesn't come from source (i.e. a single task/protected
5968 if Present
(Conc_Typ
)
5969 and then not Comes_From_Source
(Conc_Typ
)
5971 Error_Msg
("\& [<<", Eloc
, N
);
5974 if GNATprove_Mode
then
5976 ("\Constraint_Error would have been raised"
5977 & " for objects of this type", Eloc
, N
);
5980 ("\Constraint_Error will be raised"
5981 & " for objects of this type??", Eloc
, N
);
5987 Error_Msg
("\Constraint_Error [<<", Eloc
, N
);
5991 Error_Msg
("\static expression fails Constraint_Check", Eloc
);
5992 Set_Error_Posted
(N
);
5998 end Compile_Time_Constraint_Error
;
6000 ----------------------------
6001 -- Compute_Returns_By_Ref --
6002 ----------------------------
6004 procedure Compute_Returns_By_Ref
(Func
: Entity_Id
) is
6005 Kind
: constant Entity_Kind
:= Ekind
(Func
);
6006 Typ
: constant Entity_Id
:= Etype
(Func
);
6009 -- Nothing to do for procedures
6011 if Kind
in E_Procedure | E_Generic_Procedure
6012 or else (Kind
= E_Subprogram_Type
and then Typ
= Standard_Void_Type
)
6016 -- The build-in-place protocols return a reference to the result
6018 elsif Is_Build_In_Place_Function
(Func
) then
6019 Set_Returns_By_Ref
(Func
);
6021 -- In Ada 95, limited types are returned by reference, but not if the
6022 -- convention is other than Ada.
6024 elsif Is_Inherently_Limited_Type
(Typ
)
6025 and then not Has_Foreign_Convention
(Func
)
6027 Set_Returns_By_Ref
(Func
);
6029 end Compute_Returns_By_Ref
;
6031 --------------------------------
6032 -- Collect_Types_In_Hierarchy --
6033 --------------------------------
6035 function Collect_Types_In_Hierarchy
6037 Examine_Components
: Boolean := False) return Elist_Id
6041 procedure Process_Type
(Typ
: Entity_Id
);
6042 -- Collect type Typ if it satisfies function Predicate. Do so for its
6043 -- parent type, base type, progenitor types, and any component types.
6049 procedure Process_Type
(Typ
: Entity_Id
) is
6051 Iface_Elmt
: Elmt_Id
;
6054 if not Is_Type
(Typ
) or else Error_Posted
(Typ
) then
6058 -- Collect the current type if it satisfies the predicate
6060 if Predicate
(Typ
) then
6061 Append_Elmt
(Typ
, Results
);
6064 -- Process component types
6066 if Examine_Components
then
6068 -- Examine components and discriminants
6070 if Is_Concurrent_Type
(Typ
)
6071 or else Is_Incomplete_Or_Private_Type
(Typ
)
6072 or else Is_Record_Type
(Typ
)
6073 or else Has_Discriminants
(Typ
)
6075 Comp
:= First_Component_Or_Discriminant
(Typ
);
6077 while Present
(Comp
) loop
6078 Process_Type
(Etype
(Comp
));
6080 Next_Component_Or_Discriminant
(Comp
);
6083 -- Examine array components
6085 elsif Ekind
(Typ
) = E_Array_Type
then
6086 Process_Type
(Component_Type
(Typ
));
6090 -- Examine parent type
6092 if Etype
(Typ
) /= Typ
then
6093 -- Prevent infinite recursion, which can happen in illegal
6094 -- programs. Silently return if illegal. For now, just deal
6095 -- with the 2-type cycle case. Larger cycles will get
6096 -- SIGSEGV at compile time from running out of stack.
6098 if Etype
(Etype
(Typ
)) = Typ
then
6099 if Total_Errors_Detected
= 0 then
6100 raise Program_Error
;
6106 Process_Type
(Etype
(Typ
));
6109 -- Examine base type
6111 if Base_Type
(Typ
) /= Typ
then
6112 Process_Type
(Base_Type
(Typ
));
6115 -- Examine interfaces
6117 if Is_Record_Type
(Typ
)
6118 and then Present
(Interfaces
(Typ
))
6120 Iface_Elmt
:= First_Elmt
(Interfaces
(Typ
));
6121 while Present
(Iface_Elmt
) loop
6122 Process_Type
(Node
(Iface_Elmt
));
6124 Next_Elmt
(Iface_Elmt
);
6129 -- Start of processing for Collect_Types_In_Hierarchy
6132 Results
:= New_Elmt_List
;
6135 end Collect_Types_In_Hierarchy
;
6137 -----------------------
6138 -- Conditional_Delay --
6139 -----------------------
6141 procedure Conditional_Delay
(New_Ent
, Old_Ent
: Entity_Id
) is
6143 if Has_Delayed_Freeze
(Old_Ent
) and then not Is_Frozen
(Old_Ent
) then
6144 Set_Has_Delayed_Freeze
(New_Ent
);
6146 end Conditional_Delay
;
6148 -------------------------
6149 -- Copy_Component_List --
6150 -------------------------
6152 function Copy_Component_List
6154 Loc
: Source_Ptr
) return List_Id
6157 Comps
: constant List_Id
:= New_List
;
6160 Comp
:= First_Component
(Underlying_Type
(R_Typ
));
6161 while Present
(Comp
) loop
6162 if Comes_From_Source
(Comp
) then
6164 Comp_Decl
: constant Node_Id
:= Declaration_Node
(Comp
);
6167 Make_Component_Declaration
(Loc
,
6168 Defining_Identifier
=>
6169 Make_Defining_Identifier
(Loc
, Chars
(Comp
)),
6170 Component_Definition
=>
6172 (Component_Definition
(Comp_Decl
), New_Sloc
=> Loc
)));
6176 Next_Component
(Comp
);
6180 end Copy_Component_List
;
6182 -----------------------
6183 -- Copy_Ghost_Aspect --
6184 -----------------------
6186 procedure Copy_Ghost_Aspect
(From
: Node_Id
; To
: Node_Id
) is
6187 pragma Assert
(not Has_Aspects
(To
));
6191 if Has_Aspects
(From
) then
6192 Asp
:= Find_Aspect
(Defining_Entity
(From
), Aspect_Ghost
);
6194 if Present
(Asp
) then
6195 Set_Aspect_Specifications
(To
, New_List
(New_Copy_Tree
(Asp
)));
6198 end Copy_Ghost_Aspect
;
6200 -------------------------
6201 -- Copy_Parameter_List --
6202 -------------------------
6204 function Copy_Parameter_List
(Subp_Id
: Entity_Id
) return List_Id
is
6205 Loc
: constant Source_Ptr
:= Sloc
(Subp_Id
);
6207 Formal
: Entity_Id
:= First_Formal
(Subp_Id
);
6210 if Present
(Formal
) then
6212 while Present
(Formal
) loop
6214 Make_Parameter_Specification
(Loc
,
6215 Defining_Identifier
=>
6216 Make_Defining_Identifier
(Sloc
(Formal
), Chars
(Formal
)),
6217 In_Present
=> In_Present
(Parent
(Formal
)),
6218 Out_Present
=> Out_Present
(Parent
(Formal
)),
6220 New_Occurrence_Of
(Etype
(Formal
), Loc
),
6222 New_Copy_Tree
(Expression
(Parent
(Formal
)))));
6224 Next_Formal
(Formal
);
6231 end Copy_Parameter_List
;
6233 ----------------------------
6234 -- Copy_SPARK_Mode_Aspect --
6235 ----------------------------
6237 procedure Copy_SPARK_Mode_Aspect
(From
: Node_Id
; To
: Node_Id
) is
6238 pragma Assert
(not Has_Aspects
(To
));
6242 if Has_Aspects
(From
) then
6243 Asp
:= Find_Aspect
(Defining_Entity
(From
), Aspect_SPARK_Mode
);
6245 if Present
(Asp
) then
6246 Set_Aspect_Specifications
(To
, New_List
(New_Copy_Tree
(Asp
)));
6249 end Copy_SPARK_Mode_Aspect
;
6251 --------------------------
6252 -- Copy_Subprogram_Spec --
6253 --------------------------
6255 function Copy_Subprogram_Spec
6257 New_Sloc
: Source_Ptr
:= No_Location
) return Node_Id
6260 Formal_Spec
: Node_Id
;
6264 -- The structure of the original tree must be replicated without any
6265 -- alterations. Use New_Copy_Tree for this purpose.
6267 Result
:= New_Copy_Tree
(Spec
, New_Sloc
=> New_Sloc
);
6269 -- However, the spec of a null procedure carries the corresponding null
6270 -- statement of the body (created by the parser), and this cannot be
6271 -- shared with the new subprogram spec.
6273 if Nkind
(Result
) = N_Procedure_Specification
then
6274 Set_Null_Statement
(Result
, Empty
);
6277 -- Create a new entity for the defining unit name
6279 Def_Id
:= Defining_Unit_Name
(Result
);
6280 Set_Defining_Unit_Name
(Result
,
6281 Make_Defining_Identifier
(Sloc
(Def_Id
), Chars
(Def_Id
)));
6283 -- Create new entities for the formal parameters
6285 Formal_Spec
:= First
(Parameter_Specifications
(Result
));
6286 while Present
(Formal_Spec
) loop
6287 Def_Id
:= Defining_Identifier
(Formal_Spec
);
6288 Set_Defining_Identifier
(Formal_Spec
,
6289 Make_Defining_Identifier
(Sloc
(Def_Id
), Chars
(Def_Id
)));
6295 end Copy_Subprogram_Spec
;
6297 --------------------------------
6298 -- Corresponding_Generic_Type --
6299 --------------------------------
6301 function Corresponding_Generic_Type
(T
: Entity_Id
) return Entity_Id
is
6307 if not Is_Generic_Actual_Type
(T
) then
6310 -- If the actual is the actual of an enclosing instance, resolution
6311 -- was correct in the generic.
6313 elsif Nkind
(Parent
(T
)) = N_Subtype_Declaration
6314 and then Is_Entity_Name
(Subtype_Indication
(Parent
(T
)))
6316 Is_Generic_Actual_Type
(Entity
(Subtype_Indication
(Parent
(T
))))
6323 if Is_Wrapper_Package
(Inst
) then
6324 Inst
:= Related_Instance
(Inst
);
6329 (Specification
(Unit_Declaration_Node
(Inst
)));
6331 -- Generic actual has the same name as the corresponding formal
6333 Typ
:= First_Entity
(Gen
);
6334 while Present
(Typ
) loop
6335 if Chars
(Typ
) = Chars
(T
) then
6344 end Corresponding_Generic_Type
;
6346 --------------------------------
6347 -- Corresponding_Primitive_Op --
6348 --------------------------------
6350 function Corresponding_Primitive_Op
6351 (Ancestor_Op
: Entity_Id
;
6352 Descendant_Type
: Entity_Id
) return Entity_Id
6354 function Find_Untagged_Type_Of
(Prim
: Entity_Id
) return Entity_Id
;
6355 -- Search for the untagged type of the primitive operation Prim.
6357 function Profile_Matches_Ancestor
(S
: Entity_Id
) return Boolean;
6358 -- Returns True if subprogram S has the proper profile for an
6359 -- overriding of Ancestor_Op (that is, corresponding formals either
6360 -- have the same type, or are corresponding controlling formals,
6361 -- and similarly for result types).
6363 ---------------------------
6364 -- Find_Untagged_Type_Of --
6365 ---------------------------
6367 function Find_Untagged_Type_Of
(Prim
: Entity_Id
) return Entity_Id
is
6368 E
: Entity_Id
:= First_Entity
(Scope
(Prim
));
6371 while Present
(E
) and then E
/= Prim
loop
6372 if not Is_Tagged_Type
(E
)
6373 and then Contains
(Direct_Primitive_Operations
(E
), Prim
)
6381 pragma Assert
(False);
6383 end Find_Untagged_Type_Of
;
6385 Typ
: constant Entity_Id
:=
6386 (if Is_Dispatching_Operation
(Ancestor_Op
)
6387 then Find_Dispatching_Type
(Ancestor_Op
)
6388 else Find_Untagged_Type_Of
(Ancestor_Op
));
6390 ------------------------------
6391 -- Profile_Matches_Ancestor --
6392 ------------------------------
6394 function Profile_Matches_Ancestor
(S
: Entity_Id
) return Boolean is
6395 F1
: Entity_Id
:= First_Formal
(Ancestor_Op
);
6396 F2
: Entity_Id
:= First_Formal
(S
);
6399 if Ekind
(Ancestor_Op
) /= Ekind
(S
) then
6403 -- ??? This should probably account for anonymous access formals,
6404 -- but the parent function (Corresponding_Primitive_Op) is currently
6405 -- only called for user-defined literal functions, which can't have
6406 -- such formals. But if this is ever used in a more general context
6407 -- it should be extended to handle such formals (and result types).
6409 while Present
(F1
) and then Present
(F2
) loop
6410 if Etype
(F1
) = Etype
(F2
)
6411 or else Is_Ancestor
(Typ
, Etype
(F2
))
6422 and then (Etype
(Ancestor_Op
) = Etype
(S
)
6423 or else Is_Ancestor
(Typ
, Etype
(S
)));
6424 end Profile_Matches_Ancestor
;
6431 -- Start of processing for Corresponding_Primitive_Op
6434 pragma Assert
(Is_Ancestor
(Typ
, Descendant_Type
)
6435 or else Is_Progenitor
(Typ
, Descendant_Type
));
6437 Elmt
:= First_Elmt
(Primitive_Operations
(Descendant_Type
));
6439 while Present
(Elmt
) loop
6440 Subp
:= Node
(Elmt
);
6442 -- For regular primitives we need to check the profile against
6443 -- the ancestor when the name matches the name of Ancestor_Op,
6444 -- but for predefined dispatching operations we cannot rely on
6445 -- the name of the primitive to identify a candidate since their
6446 -- name is internally built by adding a suffix to the name of the
6449 if Chars
(Subp
) = Chars
(Ancestor_Op
)
6450 or else Is_Predefined_Dispatching_Operation
(Subp
)
6452 -- Handle case where Ancestor_Op is a primitive of a progenitor.
6453 -- We rely on internal entities that map interface primitives:
6454 -- their attribute Interface_Alias references the interface
6455 -- primitive, and their Alias attribute references the primitive
6456 -- of Descendant_Type implementing that interface primitive.
6458 if Present
(Interface_Alias
(Subp
)) then
6459 if Interface_Alias
(Subp
) = Ancestor_Op
then
6460 return Alias
(Subp
);
6463 -- Otherwise, return subprogram when profile matches its ancestor
6465 elsif Profile_Matches_Ancestor
(Subp
) then
6473 pragma Assert
(False);
6475 end Corresponding_Primitive_Op
;
6477 --------------------
6478 -- Current_Entity --
6479 --------------------
6481 -- The currently visible definition for a given identifier is the
6482 -- one most chained at the start of the visibility chain, i.e. the
6483 -- one that is referenced by the Node_Id value of the name of the
6484 -- given identifier.
6486 function Current_Entity
(N
: Node_Id
) return Entity_Id
is
6488 return Get_Name_Entity_Id
(Chars
(N
));
6491 -----------------------------
6492 -- Current_Entity_In_Scope --
6493 -----------------------------
6495 function Current_Entity_In_Scope
(N
: Name_Id
) return Entity_Id
is
6496 CS
: constant Entity_Id
:= Current_Scope
;
6501 E
:= Get_Name_Entity_Id
(N
);
6506 elsif Scope_Is_Transient
then
6507 while Present
(E
) loop
6508 exit when Scope
(E
) = CS
or else Scope
(E
) = Scope
(CS
);
6514 while Present
(E
) loop
6515 exit when Scope
(E
) = CS
;
6522 end Current_Entity_In_Scope
;
6524 -----------------------------
6525 -- Current_Entity_In_Scope --
6526 -----------------------------
6528 function Current_Entity_In_Scope
(N
: Node_Id
) return Entity_Id
is
6530 return Current_Entity_In_Scope
(Chars
(N
));
6531 end Current_Entity_In_Scope
;
6537 function Current_Scope
return Entity_Id
is
6539 if Scope_Stack
.Last
= -1 then
6540 return Standard_Standard
;
6543 C
: constant Entity_Id
:=
6544 Scope_Stack
.Table
(Scope_Stack
.Last
).Entity
;
6549 return Standard_Standard
;
6555 ----------------------------
6556 -- Current_Scope_No_Loops --
6557 ----------------------------
6559 function Current_Scope_No_Loops
return Entity_Id
is
6563 -- Examine the scope stack starting from the current scope and skip any
6564 -- internally generated loops.
6567 while Present
(S
) and then S
/= Standard_Standard
loop
6568 if Ekind
(S
) = E_Loop
and then not Comes_From_Source
(S
) then
6576 end Current_Scope_No_Loops
;
6578 ------------------------
6579 -- Current_Subprogram --
6580 ------------------------
6582 function Current_Subprogram
return Entity_Id
is
6583 Scop
: constant Entity_Id
:= Current_Scope
;
6585 if Is_Subprogram_Or_Generic_Subprogram
(Scop
) then
6588 return Enclosing_Subprogram
(Scop
);
6590 end Current_Subprogram
;
6592 ------------------------------
6593 -- CW_Or_Needs_Finalization --
6594 ------------------------------
6596 function CW_Or_Needs_Finalization
(Typ
: Entity_Id
) return Boolean is
6598 return Is_Class_Wide_Type
(Typ
) or else Needs_Finalization
(Typ
);
6599 end CW_Or_Needs_Finalization
;
6601 ---------------------
6602 -- Defining_Entity --
6603 ---------------------
6605 function Defining_Entity
(N
: Node_Id
) return Entity_Id
is
6606 Ent
: constant Entity_Id
:= Defining_Entity_Or_Empty
(N
);
6609 if Present
(Ent
) then
6613 raise Program_Error
;
6615 end Defining_Entity
;
6617 ------------------------------
6618 -- Defining_Entity_Or_Empty --
6619 ------------------------------
6621 function Defining_Entity_Or_Empty
(N
: Node_Id
) return Entity_Id
is
6624 when N_Abstract_Subprogram_Declaration
6625 | N_Expression_Function
6626 | N_Formal_Subprogram_Declaration
6627 | N_Generic_Package_Declaration
6628 | N_Generic_Subprogram_Declaration
6629 | N_Package_Declaration
6631 | N_Subprogram_Body_Stub
6632 | N_Subprogram_Declaration
6633 | N_Subprogram_Renaming_Declaration
6635 return Defining_Entity
(Specification
(N
));
6637 when N_Component_Declaration
6638 | N_Defining_Program_Unit_Name
6639 | N_Discriminant_Specification
6641 | N_Entry_Declaration
6642 | N_Entry_Index_Specification
6643 | N_Exception_Declaration
6644 | N_Exception_Renaming_Declaration
6645 | N_Formal_Object_Declaration
6646 | N_Formal_Package_Declaration
6647 | N_Formal_Type_Declaration
6648 | N_Full_Type_Declaration
6649 | N_Implicit_Label_Declaration
6650 | N_Incomplete_Type_Declaration
6651 | N_Iterator_Specification
6652 | N_Loop_Parameter_Specification
6653 | N_Number_Declaration
6654 | N_Object_Declaration
6655 | N_Object_Renaming_Declaration
6656 | N_Package_Body_Stub
6657 | N_Parameter_Specification
6658 | N_Private_Extension_Declaration
6659 | N_Private_Type_Declaration
6661 | N_Protected_Body_Stub
6662 | N_Protected_Type_Declaration
6663 | N_Single_Protected_Declaration
6664 | N_Single_Task_Declaration
6665 | N_Subtype_Declaration
6668 | N_Task_Type_Declaration
6670 return Defining_Identifier
(N
);
6672 when N_Compilation_Unit
=>
6673 return Defining_Entity
(Unit
(N
));
6676 return Defining_Entity
(Proper_Body
(N
));
6678 when N_Function_Instantiation
6679 | N_Function_Specification
6680 | N_Generic_Function_Renaming_Declaration
6681 | N_Generic_Package_Renaming_Declaration
6682 | N_Generic_Procedure_Renaming_Declaration
6684 | N_Package_Instantiation
6685 | N_Package_Renaming_Declaration
6686 | N_Package_Specification
6687 | N_Procedure_Instantiation
6688 | N_Procedure_Specification
6691 Nam
: constant Node_Id
:= Defining_Unit_Name
(N
);
6692 Err
: Entity_Id
:= Empty
;
6695 if Nkind
(Nam
) in N_Entity
then
6698 -- For Error, make up a name and attach to declaration so we
6699 -- can continue semantic analysis.
6701 elsif Nam
= Error
then
6702 Err
:= Make_Temporary
(Sloc
(N
), 'T');
6703 Set_Defining_Unit_Name
(N
, Err
);
6707 -- If not an entity, get defining identifier
6710 return Defining_Identifier
(Nam
);
6714 when N_Block_Statement
6717 return Entity
(Identifier
(N
));
6722 end Defining_Entity_Or_Empty
;
6724 --------------------------
6725 -- Denotes_Discriminant --
6726 --------------------------
6728 function Denotes_Discriminant
6730 Check_Concurrent
: Boolean := False) return Boolean
6735 if not Is_Entity_Name
(N
) or else No
(Entity
(N
)) then
6741 -- If we are checking for a protected type, the discriminant may have
6742 -- been rewritten as the corresponding discriminal of the original type
6743 -- or of the corresponding concurrent record, depending on whether we
6744 -- are in the spec or body of the protected type.
6746 return Ekind
(E
) = E_Discriminant
6749 and then Ekind
(E
) = E_In_Parameter
6750 and then Present
(Discriminal_Link
(E
))
6752 (Is_Concurrent_Type
(Scope
(Discriminal_Link
(E
)))
6754 Is_Concurrent_Record_Type
(Scope
(Discriminal_Link
(E
)))));
6755 end Denotes_Discriminant
;
6757 -------------------------
6758 -- Denotes_Same_Object --
6759 -------------------------
6761 function Denotes_Same_Object
(A1
, A2
: Node_Id
) return Boolean is
6762 function Is_Object_Renaming
(N
: Node_Id
) return Boolean;
6763 -- Return true if N names an object renaming entity
6765 function Is_Valid_Renaming
(N
: Node_Id
) return Boolean;
6766 -- For renamings, return False if the prefix of any dereference within
6767 -- the renamed object_name is a variable, or any expression within the
6768 -- renamed object_name contains references to variables or calls on
6769 -- nonstatic functions; otherwise return True (RM 6.4.1(6.10/3))
6771 ------------------------
6772 -- Is_Object_Renaming --
6773 ------------------------
6775 function Is_Object_Renaming
(N
: Node_Id
) return Boolean is
6777 return Is_Entity_Name
(N
)
6778 and then Ekind
(Entity
(N
)) in E_Variable | E_Constant
6779 and then Present
(Renamed_Object
(Entity
(N
)));
6780 end Is_Object_Renaming
;
6782 -----------------------
6783 -- Is_Valid_Renaming --
6784 -----------------------
6786 function Is_Valid_Renaming
(N
: Node_Id
) return Boolean is
6788 if Is_Object_Renaming
(N
)
6789 and then not Is_Valid_Renaming
(Renamed_Object
(Entity
(N
)))
6794 -- Check if any expression within the renamed object_name contains no
6795 -- references to variables nor calls on nonstatic functions.
6797 if Nkind
(N
) = N_Indexed_Component
then
6802 Indx
:= First
(Expressions
(N
));
6803 while Present
(Indx
) loop
6804 if not Is_OK_Static_Expression
(Indx
) then
6812 elsif Nkind
(N
) = N_Slice
then
6814 Rng
: constant Node_Id
:= Discrete_Range
(N
);
6816 -- Bounds specified as a range
6818 if Nkind
(Rng
) = N_Range
then
6819 if not Is_OK_Static_Range
(Rng
) then
6823 -- Bounds specified as a constrained subtype indication
6825 elsif Nkind
(Rng
) = N_Subtype_Indication
then
6826 if not Is_OK_Static_Range
6827 (Range_Expression
(Constraint
(Rng
)))
6832 -- Bounds specified as a subtype name
6834 elsif not Is_OK_Static_Expression
(Rng
) then
6840 if Has_Prefix
(N
) then
6842 P
: constant Node_Id
:= Prefix
(N
);
6845 if Nkind
(N
) = N_Explicit_Dereference
6846 and then Is_Variable
(P
)
6850 elsif Is_Entity_Name
(P
)
6851 and then Ekind
(Entity
(P
)) = E_Function
6855 elsif Nkind
(P
) = N_Function_Call
then
6859 -- Recursion to continue traversing the prefix of the
6860 -- renaming expression
6862 return Is_Valid_Renaming
(P
);
6867 end Is_Valid_Renaming
;
6869 -- Start of processing for Denotes_Same_Object
6872 -- Both names statically denote the same stand-alone object or
6873 -- parameter (RM 6.4.1(6.6/3)).
6875 if Is_Entity_Name
(A1
)
6876 and then Is_Entity_Name
(A2
)
6877 and then Entity
(A1
) = Entity
(A2
)
6881 -- Both names are selected_components, their prefixes are known to
6882 -- denote the same object, and their selector_names denote the same
6883 -- component (RM 6.4.1(6.7/3)).
6885 elsif Nkind
(A1
) = N_Selected_Component
6886 and then Nkind
(A2
) = N_Selected_Component
6888 return Denotes_Same_Object
(Prefix
(A1
), Prefix
(A2
))
6890 Entity
(Selector_Name
(A1
)) = Entity
(Selector_Name
(A2
));
6892 -- Both names are dereferences and the dereferenced names are known to
6893 -- denote the same object (RM 6.4.1(6.8/3)).
6895 elsif Nkind
(A1
) = N_Explicit_Dereference
6896 and then Nkind
(A2
) = N_Explicit_Dereference
6898 return Denotes_Same_Object
(Prefix
(A1
), Prefix
(A2
));
6900 -- Both names are indexed_components, their prefixes are known to denote
6901 -- the same object, and each of the pairs of corresponding index values
6902 -- are either both static expressions with the same static value or both
6903 -- names that are known to denote the same object (RM 6.4.1(6.9/3)).
6905 elsif Nkind
(A1
) = N_Indexed_Component
6906 and then Nkind
(A2
) = N_Indexed_Component
6908 if not Denotes_Same_Object
(Prefix
(A1
), Prefix
(A2
)) then
6916 Indx1
:= First
(Expressions
(A1
));
6917 Indx2
:= First
(Expressions
(A2
));
6918 while Present
(Indx1
) loop
6920 -- Indexes must denote the same static value or same object
6922 if Is_OK_Static_Expression
(Indx1
) then
6923 if not Is_OK_Static_Expression
(Indx2
) then
6926 elsif Expr_Value
(Indx1
) /= Expr_Value
(Indx2
) then
6930 elsif not Denotes_Same_Object
(Indx1
, Indx2
) then
6942 -- Both names are slices, their prefixes are known to denote the same
6943 -- object, and the two slices have statically matching index constraints
6944 -- (RM 6.4.1(6.10/3)).
6946 elsif Nkind
(A1
) = N_Slice
6947 and then Nkind
(A2
) = N_Slice
6949 if not Denotes_Same_Object
(Prefix
(A1
), Prefix
(A2
)) then
6953 Lo1
, Lo2
, Hi1
, Hi2
: Node_Id
;
6956 Get_Index_Bounds
(Discrete_Range
(A1
), Lo1
, Hi1
);
6957 Get_Index_Bounds
(Discrete_Range
(A2
), Lo2
, Hi2
);
6959 -- Check whether bounds are statically identical. There is no
6960 -- attempt to detect partial overlap of slices.
6962 return Is_OK_Static_Expression
(Lo1
)
6963 and then Is_OK_Static_Expression
(Lo2
)
6964 and then Is_OK_Static_Expression
(Hi1
)
6965 and then Is_OK_Static_Expression
(Hi2
)
6966 and then Expr_Value
(Lo1
) = Expr_Value
(Lo2
)
6967 and then Expr_Value
(Hi1
) = Expr_Value
(Hi2
);
6971 -- One of the two names statically denotes a renaming declaration whose
6972 -- renamed object_name is known to denote the same object as the other;
6973 -- the prefix of any dereference within the renamed object_name is not a
6974 -- variable, and any expression within the renamed object_name contains
6975 -- no references to variables nor calls on nonstatic functions (RM
6978 elsif Is_Object_Renaming
(A1
)
6979 and then Is_Valid_Renaming
(A1
)
6981 return Denotes_Same_Object
(Renamed_Object
(Entity
(A1
)), A2
);
6983 elsif Is_Object_Renaming
(A2
)
6984 and then Is_Valid_Renaming
(A2
)
6986 return Denotes_Same_Object
(A1
, Renamed_Object
(Entity
(A2
)));
6991 end Denotes_Same_Object
;
6993 -------------------------
6994 -- Denotes_Same_Prefix --
6995 -------------------------
6997 function Denotes_Same_Prefix
(A1
, A2
: Node_Id
) return Boolean is
6999 if Is_Entity_Name
(A1
) then
7000 if Nkind
(A2
) in N_Selected_Component | N_Indexed_Component
7001 and then not Is_Access_Type
(Etype
(A1
))
7003 return Denotes_Same_Object
(A1
, Prefix
(A2
))
7004 or else Denotes_Same_Prefix
(A1
, Prefix
(A2
));
7009 elsif Is_Entity_Name
(A2
) then
7010 return Denotes_Same_Prefix
(A1
=> A2
, A2
=> A1
);
7012 elsif Nkind
(A1
) in N_Selected_Component | N_Indexed_Component | N_Slice
7014 Nkind
(A2
) in N_Selected_Component | N_Indexed_Component | N_Slice
7017 Root1
, Root2
: Node_Id
;
7018 Depth1
, Depth2
: Nat
:= 0;
7021 Root1
:= Prefix
(A1
);
7022 while not Is_Entity_Name
(Root1
) loop
7023 if Nkind
(Root1
) not in
7024 N_Selected_Component | N_Indexed_Component
7028 Root1
:= Prefix
(Root1
);
7031 Depth1
:= Depth1
+ 1;
7034 Root2
:= Prefix
(A2
);
7035 while not Is_Entity_Name
(Root2
) loop
7036 if Nkind
(Root2
) not in
7037 N_Selected_Component | N_Indexed_Component
7041 Root2
:= Prefix
(Root2
);
7044 Depth2
:= Depth2
+ 1;
7047 -- If both have the same depth and they do not denote the same
7048 -- object, they are disjoint and no warning is needed.
7050 if Depth1
= Depth2
then
7053 elsif Depth1
> Depth2
then
7054 Root1
:= Prefix
(A1
);
7055 for J
in 1 .. Depth1
- Depth2
- 1 loop
7056 Root1
:= Prefix
(Root1
);
7059 return Denotes_Same_Object
(Root1
, A2
);
7062 Root2
:= Prefix
(A2
);
7063 for J
in 1 .. Depth2
- Depth1
- 1 loop
7064 Root2
:= Prefix
(Root2
);
7067 return Denotes_Same_Object
(A1
, Root2
);
7074 end Denotes_Same_Prefix
;
7076 ----------------------
7077 -- Denotes_Variable --
7078 ----------------------
7080 function Denotes_Variable
(N
: Node_Id
) return Boolean is
7082 return Is_Variable
(N
) and then Paren_Count
(N
) = 0;
7083 end Denotes_Variable
;
7085 -----------------------------
7086 -- Depends_On_Discriminant --
7087 -----------------------------
7089 function Depends_On_Discriminant
(N
: Node_Id
) return Boolean is
7094 Get_Index_Bounds
(N
, L
, H
);
7095 return Denotes_Discriminant
(L
) or else Denotes_Discriminant
(H
);
7096 end Depends_On_Discriminant
;
7098 -------------------------------------
7099 -- Derivation_Too_Early_To_Inherit --
7100 -------------------------------------
7102 function Derivation_Too_Early_To_Inherit
7103 (Typ
: Entity_Id
; Streaming_Op
: TSS_Name_Type
) return Boolean is
7105 Btyp
: constant Entity_Id
:= Implementation_Base_Type
(Typ
);
7106 Parent_Type
: Entity_Id
;
7110 -- Start of processing for Derivation_Too_Early_To_Inherit
7113 if Is_Derived_Type
(Btyp
) then
7114 Parent_Type
:= Implementation_Base_Type
(Etype
(Btyp
));
7115 pragma Assert
(Parent_Type
/= Btyp
);
7117 if Has_Stream_Attribute_Definition
7118 (Parent_Type
, Streaming_Op
, Real_Rep
=> Real_Rep
)
7120 and then In_Same_Extended_Unit
(Btyp
, Parent_Type
)
7121 and then Instantiation
(Get_Source_File_Index
(Sloc
(Btyp
))) =
7122 Instantiation
(Get_Source_File_Index
(Sloc
(Parent_Type
)))
7124 return Earlier_In_Extended_Unit
(Btyp
, Real_Rep
);
7129 end Derivation_Too_Early_To_Inherit
;
7131 -------------------------
7132 -- Designate_Same_Unit --
7133 -------------------------
7135 function Designate_Same_Unit
7137 Name2
: Node_Id
) return Boolean
7139 K1
: constant Node_Kind
:= Nkind
(Name1
);
7140 K2
: constant Node_Kind
:= Nkind
(Name2
);
7142 function Prefix_Node
(N
: Node_Id
) return Node_Id
;
7143 -- Returns the parent unit name node of a defining program unit name
7144 -- or the prefix if N is a selected component or an expanded name.
7146 function Select_Node
(N
: Node_Id
) return Node_Id
;
7147 -- Returns the defining identifier node of a defining program unit
7148 -- name or the selector node if N is a selected component or an
7155 function Prefix_Node
(N
: Node_Id
) return Node_Id
is
7157 if Nkind
(N
) = N_Defining_Program_Unit_Name
then
7168 function Select_Node
(N
: Node_Id
) return Node_Id
is
7170 if Nkind
(N
) = N_Defining_Program_Unit_Name
then
7171 return Defining_Identifier
(N
);
7173 return Selector_Name
(N
);
7177 -- Start of processing for Designate_Same_Unit
7180 if K1
in N_Identifier | N_Defining_Identifier
7182 K2
in N_Identifier | N_Defining_Identifier
7184 return Chars
(Name1
) = Chars
(Name2
);
7186 elsif K1
in N_Expanded_Name
7187 | N_Selected_Component
7188 | N_Defining_Program_Unit_Name
7190 K2
in N_Expanded_Name
7191 | N_Selected_Component
7192 | N_Defining_Program_Unit_Name
7195 Chars
(Select_Node
(Name1
)) = Chars
(Select_Node
(Name2
))
7197 Designate_Same_Unit
(Prefix_Node
(Name1
), Prefix_Node
(Name2
));
7202 end Designate_Same_Unit
;
7204 ---------------------------------------------
7205 -- Diagnose_Iterated_Component_Association --
7206 ---------------------------------------------
7208 procedure Diagnose_Iterated_Component_Association
(N
: Node_Id
) is
7209 Def_Id
: constant Entity_Id
:= Defining_Identifier
(N
);
7213 -- Determine whether the iterated component association appears within
7214 -- an aggregate. If this is the case, raise Program_Error because the
7215 -- iterated component association cannot be left in the tree as is and
7216 -- must always be processed by the related aggregate.
7219 while Present
(Aggr
) loop
7220 if Nkind
(Aggr
) = N_Aggregate
then
7221 raise Program_Error
;
7223 -- Prevent the search from going too far
7225 elsif Is_Body_Or_Package_Declaration
(Aggr
) then
7229 Aggr
:= Parent
(Aggr
);
7232 -- At this point it is known that the iterated component association is
7233 -- not within an aggregate. This is really a quantified expression with
7234 -- a missing "all" or "some" quantifier.
7236 Error_Msg_N
("missing quantifier", Def_Id
);
7238 -- Rewrite the iterated component association as True to prevent any
7241 Rewrite
(N
, New_Occurrence_Of
(Standard_True
, Sloc
(N
)));
7243 end Diagnose_Iterated_Component_Association
;
7245 ------------------------
7246 -- Discriminated_Size --
7247 ------------------------
7249 function Discriminated_Size
(Comp
: Entity_Id
) return Boolean is
7250 function Non_Static_Bound
(Bound
: Node_Id
) return Boolean;
7251 -- Check whether the bound of an index is non-static and does denote
7252 -- a discriminant, in which case any object of the type (protected or
7253 -- otherwise) will have a non-static size.
7255 ----------------------
7256 -- Non_Static_Bound --
7257 ----------------------
7259 function Non_Static_Bound
(Bound
: Node_Id
) return Boolean is
7261 if Is_OK_Static_Expression
(Bound
) then
7264 -- If the bound is given by a discriminant it is non-static
7265 -- (A static constraint replaces the reference with the value).
7266 -- In an protected object the discriminant has been replaced by
7267 -- the corresponding discriminal within the protected operation.
7269 elsif Is_Entity_Name
(Bound
)
7271 (Ekind
(Entity
(Bound
)) = E_Discriminant
7272 or else Present
(Discriminal_Link
(Entity
(Bound
))))
7279 end Non_Static_Bound
;
7283 Typ
: constant Entity_Id
:= Etype
(Comp
);
7286 -- Start of processing for Discriminated_Size
7289 if not Is_Array_Type
(Typ
) then
7293 if Ekind
(Typ
) = E_Array_Subtype
then
7294 Index
:= First_Index
(Typ
);
7295 while Present
(Index
) loop
7296 if Non_Static_Bound
(Low_Bound
(Index
))
7297 or else Non_Static_Bound
(High_Bound
(Index
))
7309 end Discriminated_Size
;
7311 -----------------------------
7312 -- Effective_Reads_Enabled --
7313 -----------------------------
7315 function Effective_Reads_Enabled
(Id
: Entity_Id
) return Boolean is
7317 return Has_Enabled_Property
(Id
, Name_Effective_Reads
);
7318 end Effective_Reads_Enabled
;
7320 ------------------------------
7321 -- Effective_Writes_Enabled --
7322 ------------------------------
7324 function Effective_Writes_Enabled
(Id
: Entity_Id
) return Boolean is
7326 return Has_Enabled_Property
(Id
, Name_Effective_Writes
);
7327 end Effective_Writes_Enabled
;
7329 ------------------------------
7330 -- Enclosing_Comp_Unit_Node --
7331 ------------------------------
7333 function Enclosing_Comp_Unit_Node
(N
: Node_Id
) return Node_Id
is
7334 Current_Node
: Node_Id
;
7338 while Present
(Current_Node
)
7339 and then Nkind
(Current_Node
) /= N_Compilation_Unit
7341 Current_Node
:= Parent
(Current_Node
);
7344 return Current_Node
;
7345 end Enclosing_Comp_Unit_Node
;
7347 --------------------------
7348 -- Enclosing_CPP_Parent --
7349 --------------------------
7351 function Enclosing_CPP_Parent
(Typ
: Entity_Id
) return Entity_Id
is
7352 Parent_Typ
: Entity_Id
:= Typ
;
7355 while not Is_CPP_Class
(Parent_Typ
)
7356 and then Etype
(Parent_Typ
) /= Parent_Typ
7358 Parent_Typ
:= Etype
(Parent_Typ
);
7360 if Is_Private_Type
(Parent_Typ
) then
7361 Parent_Typ
:= Full_View
(Base_Type
(Parent_Typ
));
7365 pragma Assert
(Is_CPP_Class
(Parent_Typ
));
7367 end Enclosing_CPP_Parent
;
7369 ---------------------------
7370 -- Enclosing_Declaration --
7371 ---------------------------
7373 function Enclosing_Declaration
(N
: Node_Id
) return Node_Id
is
7374 Decl
: Node_Id
:= N
;
7377 while Present
(Decl
)
7378 and then not (Nkind
(Decl
) in N_Declaration
7380 Nkind
(Decl
) in N_Later_Decl_Item
7382 Nkind
(Decl
) in N_Renaming_Declaration
7384 Nkind
(Decl
) = N_Number_Declaration
)
7386 Decl
:= Parent
(Decl
);
7390 end Enclosing_Declaration
;
7392 ----------------------------------------
7393 -- Enclosing_Declaration_Or_Statement --
7394 ----------------------------------------
7396 function Enclosing_Declaration_Or_Statement
7397 (N
: Node_Id
) return Node_Id
7403 while Present
(Par
) loop
7404 if Is_Declaration
(Par
) or else Is_Statement
(Par
) then
7407 -- Prevent the search from going too far
7409 elsif Is_Body_Or_Package_Declaration
(Par
) then
7413 Par
:= Parent
(Par
);
7417 end Enclosing_Declaration_Or_Statement
;
7419 ----------------------------
7420 -- Enclosing_Generic_Body --
7421 ----------------------------
7423 function Enclosing_Generic_Body
(N
: Node_Id
) return Node_Id
is
7425 Spec_Id
: Entity_Id
;
7429 while Present
(Par
) loop
7430 if Nkind
(Par
) in N_Package_Body | N_Subprogram_Body
then
7431 Spec_Id
:= Corresponding_Spec
(Par
);
7433 if Present
(Spec_Id
)
7434 and then Nkind
(Unit_Declaration_Node
(Spec_Id
)) in
7435 N_Generic_Declaration
7441 Par
:= Parent
(Par
);
7445 end Enclosing_Generic_Body
;
7447 ----------------------------
7448 -- Enclosing_Generic_Unit --
7449 ----------------------------
7451 function Enclosing_Generic_Unit
(N
: Node_Id
) return Node_Id
is
7453 Spec_Decl
: Node_Id
;
7454 Spec_Id
: Entity_Id
;
7458 while Present
(Par
) loop
7459 if Nkind
(Par
) in N_Generic_Declaration
then
7462 elsif Nkind
(Par
) in N_Package_Body | N_Subprogram_Body
then
7463 Spec_Id
:= Corresponding_Spec
(Par
);
7465 if Present
(Spec_Id
) then
7466 Spec_Decl
:= Unit_Declaration_Node
(Spec_Id
);
7468 if Nkind
(Spec_Decl
) in N_Generic_Declaration
then
7474 Par
:= Parent
(Par
);
7478 end Enclosing_Generic_Unit
;
7484 function Enclosing_HSS
(Stmt
: Node_Id
) return Node_Id
is
7487 pragma Assert
(Is_Statement
(Stmt
));
7489 Par
:= Parent
(Stmt
);
7490 while Present
(Par
) loop
7492 if Nkind
(Par
) = N_Handled_Sequence_Of_Statements
then
7495 -- Prevent the search from going too far
7497 elsif Is_Body_Or_Package_Declaration
(Par
) then
7502 Par
:= Parent
(Par
);
7508 -------------------------------
7509 -- Enclosing_Lib_Unit_Entity --
7510 -------------------------------
7512 function Enclosing_Lib_Unit_Entity
7513 (E
: Entity_Id
:= Current_Scope
) return Entity_Id
7515 Unit_Entity
: Entity_Id
;
7518 -- Look for enclosing library unit entity by following scope links.
7519 -- Equivalent to, but faster than indexing through the scope stack.
7522 while (Present
(Scope
(Unit_Entity
))
7523 and then Scope
(Unit_Entity
) /= Standard_Standard
)
7524 and not Is_Child_Unit
(Unit_Entity
)
7526 Unit_Entity
:= Scope
(Unit_Entity
);
7530 end Enclosing_Lib_Unit_Entity
;
7532 -----------------------------
7533 -- Enclosing_Lib_Unit_Node --
7534 -----------------------------
7536 function Enclosing_Lib_Unit_Node
(N
: Node_Id
) return Node_Id
is
7537 Encl_Unit
: Node_Id
;
7540 Encl_Unit
:= Enclosing_Comp_Unit_Node
(N
);
7541 while Present
(Encl_Unit
)
7542 and then Nkind
(Unit
(Encl_Unit
)) = N_Subunit
7544 Encl_Unit
:= Library_Unit
(Encl_Unit
);
7547 pragma Assert
(Nkind
(Encl_Unit
) = N_Compilation_Unit
);
7549 end Enclosing_Lib_Unit_Node
;
7551 -----------------------
7552 -- Enclosing_Package --
7553 -----------------------
7555 function Enclosing_Package
(N
: Node_Or_Entity_Id
) return Entity_Id
is
7556 Dynamic_Scope
: Entity_Id
;
7559 -- Obtain the enclosing scope when N is a Node_Id - taking care to
7560 -- handle the case when the enclosing scope is already a package.
7562 if Nkind
(N
) not in N_Entity
then
7564 Encl_Scop
: constant Entity_Id
:= Find_Enclosing_Scope
(N
);
7566 if No
(Encl_Scop
) then
7568 elsif Ekind
(Encl_Scop
) in
7569 E_Generic_Package | E_Package | E_Package_Body
7574 return Enclosing_Package
(Encl_Scop
);
7578 -- When N is already an Entity_Id proceed
7580 Dynamic_Scope
:= Enclosing_Dynamic_Scope
(N
);
7581 if Dynamic_Scope
= Standard_Standard
then
7582 return Standard_Standard
;
7584 elsif Dynamic_Scope
= Empty
then
7587 elsif Ekind
(Dynamic_Scope
) in
7588 E_Generic_Package | E_Package | E_Package_Body
7590 return Dynamic_Scope
;
7593 return Enclosing_Package
(Dynamic_Scope
);
7595 end Enclosing_Package
;
7597 -------------------------------------
7598 -- Enclosing_Package_Or_Subprogram --
7599 -------------------------------------
7601 function Enclosing_Package_Or_Subprogram
(E
: Entity_Id
) return Entity_Id
is
7606 while Present
(S
) loop
7607 if Is_Package_Or_Generic_Package
(S
)
7608 or else Is_Subprogram_Or_Generic_Subprogram
(S
)
7618 end Enclosing_Package_Or_Subprogram
;
7620 --------------------------
7621 -- Enclosing_Subprogram --
7622 --------------------------
7624 function Enclosing_Subprogram
(N
: Node_Or_Entity_Id
) return Entity_Id
is
7625 Dyn_Scop
: Entity_Id
;
7626 Encl_Scop
: Entity_Id
;
7629 -- Obtain the enclosing scope when N is a Node_Id - taking care to
7630 -- handle the case when the enclosing scope is already a subprogram.
7632 if Nkind
(N
) not in N_Entity
then
7633 Encl_Scop
:= Find_Enclosing_Scope
(N
);
7635 if No
(Encl_Scop
) then
7637 elsif Ekind
(Encl_Scop
) in Subprogram_Kind
then
7641 return Enclosing_Subprogram
(Encl_Scop
);
7644 -- When N is already an Entity_Id proceed
7646 Dyn_Scop
:= Enclosing_Dynamic_Scope
(N
);
7647 if Dyn_Scop
= Standard_Standard
then
7650 elsif Dyn_Scop
= Empty
then
7653 elsif Ekind
(Dyn_Scop
) = E_Subprogram_Body
then
7654 return Corresponding_Spec
(Parent
(Parent
(Dyn_Scop
)));
7656 elsif Ekind
(Dyn_Scop
) in E_Block | E_Loop | E_Return_Statement
then
7657 return Enclosing_Subprogram
(Dyn_Scop
);
7659 elsif Ekind
(Dyn_Scop
) in E_Entry | E_Entry_Family
then
7661 -- For a task entry or entry family, return the enclosing subprogram
7662 -- of the task itself.
7664 if Ekind
(Scope
(Dyn_Scop
)) = E_Task_Type
then
7665 return Enclosing_Subprogram
(Dyn_Scop
);
7667 -- A protected entry or entry family is rewritten as a protected
7668 -- procedure which is the desired enclosing subprogram. This is
7669 -- relevant when unnesting a procedure local to an entry body.
7672 return Protected_Body_Subprogram
(Dyn_Scop
);
7675 elsif Ekind
(Dyn_Scop
) = E_Task_Type
then
7676 return Get_Task_Body_Procedure
(Dyn_Scop
);
7678 -- The scope may appear as a private type or as a private extension
7679 -- whose completion is a task or protected type.
7681 elsif Ekind
(Dyn_Scop
) in
7682 E_Limited_Private_Type | E_Record_Type_With_Private
7683 and then Present
(Full_View
(Dyn_Scop
))
7684 and then Ekind
(Full_View
(Dyn_Scop
)) in E_Task_Type | E_Protected_Type
7686 return Get_Task_Body_Procedure
(Full_View
(Dyn_Scop
));
7688 -- No body is generated if the protected operation is eliminated
7690 elsif not Is_Eliminated
(Dyn_Scop
)
7691 and then Present
(Protected_Body_Subprogram
(Dyn_Scop
))
7693 return Protected_Body_Subprogram
(Dyn_Scop
);
7698 end Enclosing_Subprogram
;
7700 --------------------------
7701 -- End_Keyword_Location --
7702 --------------------------
7704 function End_Keyword_Location
(N
: Node_Id
) return Source_Ptr
is
7705 function End_Label_Loc
(Nod
: Node_Id
) return Source_Ptr
;
7706 -- Return the source location of Nod's end label according to the
7707 -- following precedence rules:
7709 -- 1) If the end label exists, return its location
7710 -- 2) If Nod exists, return its location
7711 -- 3) Return the location of N
7717 function End_Label_Loc
(Nod
: Node_Id
) return Source_Ptr
is
7721 if Present
(Nod
) then
7722 Label
:= End_Label
(Nod
);
7724 if Present
(Label
) then
7725 return Sloc
(Label
);
7737 Owner
: Node_Id
:= Empty
;
7739 -- Start of processing for End_Keyword_Location
7742 if Nkind
(N
) in N_Block_Statement
7748 Owner
:= Handled_Statement_Sequence
(N
);
7750 elsif Nkind
(N
) = N_Package_Declaration
then
7751 Owner
:= Specification
(N
);
7753 elsif Nkind
(N
) = N_Protected_Body
then
7756 elsif Nkind
(N
) in N_Protected_Type_Declaration
7757 | N_Single_Protected_Declaration
7759 Owner
:= Protected_Definition
(N
);
7761 elsif Nkind
(N
) in N_Single_Task_Declaration | N_Task_Type_Declaration
7763 Owner
:= Task_Definition
(N
);
7765 -- This routine should not be called with other contexts
7768 pragma Assert
(False);
7772 return End_Label_Loc
(Owner
);
7773 end End_Keyword_Location
;
7775 ------------------------
7776 -- Ensure_Freeze_Node --
7777 ------------------------
7779 procedure Ensure_Freeze_Node
(E
: Entity_Id
) is
7782 if No
(Freeze_Node
(E
)) then
7783 FN
:= Make_Freeze_Entity
(Sloc
(E
));
7784 Set_Has_Delayed_Freeze
(E
);
7785 Set_Freeze_Node
(E
, FN
);
7786 Set_Access_Types_To_Process
(FN
, No_Elist
);
7787 Set_TSS_Elist
(FN
, No_Elist
);
7790 end Ensure_Freeze_Node
;
7796 procedure Enter_Name
(Def_Id
: Entity_Id
) is
7797 C
: constant Entity_Id
:= Current_Entity
(Def_Id
);
7798 E
: constant Entity_Id
:= Current_Entity_In_Scope
(Def_Id
);
7799 S
: constant Entity_Id
:= Current_Scope
;
7802 Generate_Definition
(Def_Id
);
7804 -- Add new name to current scope declarations. Check for duplicate
7805 -- declaration, which may or may not be a genuine error.
7809 -- Case of previous entity entered because of a missing declaration
7810 -- or else a bad subtype indication. Best is to use the new entity,
7811 -- and make the previous one invisible.
7813 if Etype
(E
) = Any_Type
then
7814 Set_Is_Immediately_Visible
(E
, False);
7816 -- Case of renaming declaration constructed for package instances.
7817 -- if there is an explicit declaration with the same identifier,
7818 -- the renaming is not immediately visible any longer, but remains
7819 -- visible through selected component notation.
7821 elsif Nkind
(Parent
(E
)) = N_Package_Renaming_Declaration
7822 and then not Comes_From_Source
(E
)
7824 Set_Is_Immediately_Visible
(E
, False);
7826 -- The new entity may be the package renaming, which has the same
7827 -- same name as a generic formal which has been seen already.
7829 elsif Nkind
(Parent
(Def_Id
)) = N_Package_Renaming_Declaration
7830 and then not Comes_From_Source
(Def_Id
)
7832 Set_Is_Immediately_Visible
(E
, False);
7834 -- For a fat pointer corresponding to a remote access to subprogram,
7835 -- we use the same identifier as the RAS type, so that the proper
7836 -- name appears in the stub. This type is only retrieved through
7837 -- the RAS type and never by visibility, and is not added to the
7838 -- visibility list (see below).
7840 elsif Nkind
(Parent
(Def_Id
)) = N_Full_Type_Declaration
7841 and then Ekind
(Def_Id
) = E_Record_Type
7842 and then Present
(Corresponding_Remote_Type
(Def_Id
))
7846 -- Case of an implicit operation or derived literal. The new entity
7847 -- hides the implicit one, which is removed from all visibility,
7848 -- i.e. the entity list of its scope, and homonym chain of its name.
7850 elsif (Is_Overloadable
(E
) and then Is_Inherited_Operation
(E
))
7851 or else Is_Internal
(E
)
7854 Decl
: constant Node_Id
:= Parent
(E
);
7856 Prev_Vis
: Entity_Id
;
7859 -- If E is an implicit declaration, it cannot be the first
7860 -- entity in the scope.
7862 Prev
:= First_Entity
(Current_Scope
);
7863 while Present
(Prev
) and then Next_Entity
(Prev
) /= E
loop
7869 -- If E is not on the entity chain of the current scope,
7870 -- it is an implicit declaration in the generic formal
7871 -- part of a generic subprogram. When analyzing the body,
7872 -- the generic formals are visible but not on the entity
7873 -- chain of the subprogram. The new entity will become
7874 -- the visible one in the body.
7877 (Nkind
(Parent
(Decl
)) = N_Generic_Subprogram_Declaration
);
7881 Link_Entities
(Prev
, Next_Entity
(E
));
7883 if No
(Next_Entity
(Prev
)) then
7884 Set_Last_Entity
(Current_Scope
, Prev
);
7887 if E
= Current_Entity
(E
) then
7891 Prev_Vis
:= Current_Entity
(E
);
7892 while Homonym
(Prev_Vis
) /= E
loop
7893 Prev_Vis
:= Homonym
(Prev_Vis
);
7897 if Present
(Prev_Vis
) then
7899 -- Skip E in the visibility chain
7901 Set_Homonym
(Prev_Vis
, Homonym
(E
));
7904 Set_Name_Entity_Id
(Chars
(E
), Homonym
(E
));
7907 -- The inherited operation cannot be retrieved
7908 -- by name, even though it may remain accesssible
7909 -- in some cases involving subprogram bodies without
7910 -- specs appearing in with_clauses..
7912 Set_Is_Immediately_Visible
(E
, False);
7916 -- This section of code could use a comment ???
7918 elsif Present
(Etype
(E
))
7919 and then Is_Concurrent_Type
(Etype
(E
))
7924 -- If the homograph is a protected component renaming, it should not
7925 -- be hiding the current entity. Such renamings are treated as weak
7928 elsif Is_Prival
(E
) then
7929 Set_Is_Immediately_Visible
(E
, False);
7931 -- In this case the current entity is a protected component renaming.
7932 -- Perform minimal decoration by setting the scope and return since
7933 -- the prival should not be hiding other visible entities.
7935 elsif Is_Prival
(Def_Id
) then
7936 Set_Scope
(Def_Id
, Current_Scope
);
7939 -- Analogous to privals, the discriminal generated for an entry index
7940 -- parameter acts as a weak declaration. Perform minimal decoration
7941 -- to avoid bogus errors.
7943 elsif Is_Discriminal
(Def_Id
)
7944 and then Ekind
(Discriminal_Link
(Def_Id
)) = E_Entry_Index_Parameter
7946 Set_Scope
(Def_Id
, Current_Scope
);
7949 -- In the body or private part of an instance, a type extension may
7950 -- introduce a component with the same name as that of an actual. The
7951 -- legality rule is not enforced, but the semantics of the full type
7952 -- with two components of same name are not clear at this point???
7954 elsif In_Instance_Not_Visible
then
7957 -- When compiling a package body, some child units may have become
7958 -- visible. They cannot conflict with local entities that hide them.
7960 elsif Is_Child_Unit
(E
)
7961 and then In_Open_Scopes
(Scope
(E
))
7962 and then not Is_Immediately_Visible
(E
)
7966 -- Conversely, with front-end inlining we may compile the parent body
7967 -- first, and a child unit subsequently. The context is now the
7968 -- parent spec, and body entities are not visible.
7970 elsif Is_Child_Unit
(Def_Id
)
7971 and then Is_Package_Body_Entity
(E
)
7972 and then not In_Package_Body
(Current_Scope
)
7976 -- Case of genuine duplicate declaration
7979 Error_Msg_Sloc
:= Sloc
(E
);
7981 -- If the previous declaration is an incomplete type declaration
7982 -- this may be an attempt to complete it with a private type. The
7983 -- following avoids confusing cascaded errors.
7985 if Nkind
(Parent
(E
)) = N_Incomplete_Type_Declaration
7986 and then Nkind
(Parent
(Def_Id
)) = N_Private_Type_Declaration
7989 ("incomplete type cannot be completed with a private " &
7990 "declaration", Parent
(Def_Id
));
7991 Set_Is_Immediately_Visible
(E
, False);
7992 Set_Full_View
(E
, Def_Id
);
7994 -- An inherited component of a record conflicts with a new
7995 -- discriminant. The discriminant is inserted first in the scope,
7996 -- but the error should be posted on it, not on the component.
7998 elsif Ekind
(E
) = E_Discriminant
7999 and then Present
(Scope
(Def_Id
))
8000 and then Scope
(Def_Id
) /= Current_Scope
8002 Error_Msg_Sloc
:= Sloc
(Def_Id
);
8003 Error_Msg_N
("& conflicts with declaration#", E
);
8006 -- If the name of the unit appears in its own context clause, a
8007 -- dummy package with the name has already been created, and the
8008 -- error emitted. Try to continue quietly.
8010 elsif Error_Posted
(E
)
8011 and then Sloc
(E
) = No_Location
8012 and then Nkind
(Parent
(E
)) = N_Package_Specification
8013 and then Current_Scope
= Standard_Standard
8015 Set_Scope
(Def_Id
, Current_Scope
);
8019 Error_Msg_N
("& conflicts with declaration#", Def_Id
);
8021 -- Avoid cascaded messages with duplicate components in
8024 if Ekind
(E
) in E_Component | E_Discriminant
then
8029 if Nkind
(Parent
(Parent
(Def_Id
))) =
8030 N_Generic_Subprogram_Declaration
8032 Defining_Entity
(Specification
(Parent
(Parent
(Def_Id
))))
8034 Error_Msg_N
("\generic units cannot be overloaded", Def_Id
);
8037 -- If entity is in standard, then we are in trouble, because it
8038 -- means that we have a library package with a duplicated name.
8039 -- That's hard to recover from, so abort.
8041 if S
= Standard_Standard
then
8042 raise Unrecoverable_Error
;
8044 -- Otherwise we continue with the declaration. Having two
8045 -- identical declarations should not cause us too much trouble.
8053 -- If we fall through, declaration is OK, at least OK enough to continue
8055 -- If Def_Id is a discriminant or a record component we are in the midst
8056 -- of inheriting components in a derived record definition. Preserve
8057 -- their Ekind and Etype.
8059 if Ekind
(Def_Id
) in E_Discriminant | E_Component
then
8062 -- If a type is already set, leave it alone (happens when a type
8063 -- declaration is reanalyzed following a call to the optimizer).
8065 elsif Present
(Etype
(Def_Id
)) then
8069 Set_Etype
(Def_Id
, Any_Type
); -- avoid cascaded errors
8072 -- All entities except Itypes are immediately visible
8074 if not Is_Itype
(Def_Id
) then
8075 Set_Is_Immediately_Visible
(Def_Id
);
8076 Set_Current_Entity
(Def_Id
);
8079 Set_Homonym
(Def_Id
, C
);
8080 Append_Entity
(Def_Id
, S
);
8081 Set_Public_Status
(Def_Id
);
8083 -- Warn if new entity hides an old one
8085 if Warn_On_Hiding
and then Present
(C
) then
8086 Warn_On_Hiding_Entity
(Def_Id
, Hidden
=> C
, Visible
=> Def_Id
,
8087 On_Use_Clause
=> False);
8095 function Entity_Of
(N
: Node_Id
) return Entity_Id
is
8100 -- Assume that the arbitrary node does not have an entity
8104 if Is_Entity_Name
(N
) then
8107 -- Follow a possible chain of renamings to reach the earliest renamed
8111 and then Is_Object
(Id
)
8112 and then Present
(Renamed_Object
(Id
))
8114 Ren
:= Renamed_Object
(Id
);
8116 -- The reference renames an abstract state or a whole object
8119 -- Ren : ... renames Obj;
8121 if Is_Entity_Name
(Ren
) then
8123 -- Do not follow a renaming that goes through a generic formal,
8124 -- because these entities are hidden and must not be referenced
8125 -- from outside the generic.
8127 if Is_Hidden
(Entity
(Ren
)) then
8134 -- The reference renames a function result. Check the original
8135 -- node in case expansion relocates the function call.
8137 -- Ren : ... renames Func_Call;
8139 elsif Nkind
(Original_Node
(Ren
)) = N_Function_Call
then
8142 -- Otherwise the reference renames something which does not yield
8143 -- an abstract state or a whole object. Treat the reference as not
8144 -- having a proper entity for SPARK legality purposes.
8156 --------------------------
8157 -- Examine_Array_Bounds --
8158 --------------------------
8160 procedure Examine_Array_Bounds
8162 All_Static
: out Boolean;
8163 Has_Empty
: out Boolean)
8165 function Is_OK_Static_Bound
(Bound
: Node_Id
) return Boolean;
8166 -- Determine whether bound Bound is a suitable static bound
8168 ------------------------
8169 -- Is_OK_Static_Bound --
8170 ------------------------
8172 function Is_OK_Static_Bound
(Bound
: Node_Id
) return Boolean is
8175 not Error_Posted
(Bound
)
8176 and then Is_OK_Static_Expression
(Bound
);
8177 end Is_OK_Static_Bound
;
8185 -- Start of processing for Examine_Array_Bounds
8188 -- An unconstrained array type does not have static bounds, and it is
8189 -- not known whether they are empty or not.
8191 if not Is_Constrained
(Typ
) then
8192 All_Static
:= False;
8195 -- A string literal has static bounds, and is not empty as long as it
8196 -- contains at least one character.
8198 elsif Ekind
(Typ
) = E_String_Literal_Subtype
then
8200 Has_Empty
:= String_Literal_Length
(Typ
) > 0;
8203 -- Assume that all bounds are static and not empty
8208 -- Examine each index
8210 Index
:= First_Index
(Typ
);
8211 while Present
(Index
) loop
8212 if Is_Discrete_Type
(Etype
(Index
)) then
8213 Get_Index_Bounds
(Index
, Lo_Bound
, Hi_Bound
);
8215 if Is_OK_Static_Bound
(Lo_Bound
)
8217 Is_OK_Static_Bound
(Hi_Bound
)
8219 -- The static bounds produce an empty range
8221 if Is_Null_Range
(Lo_Bound
, Hi_Bound
) then
8225 -- Otherwise at least one of the bounds is not static
8228 All_Static
:= False;
8231 -- Otherwise the index is non-discrete, therefore not static
8234 All_Static
:= False;
8239 end Examine_Array_Bounds
;
8245 function Exceptions_OK
return Boolean is
8248 not (Restriction_Active
(No_Exception_Handlers
) or else
8249 Restriction_Active
(No_Exception_Propagation
) or else
8250 Restriction_Active
(No_Exceptions
));
8253 --------------------------
8254 -- Explain_Limited_Type --
8255 --------------------------
8257 procedure Explain_Limited_Type
(T
: Entity_Id
; N
: Node_Id
) is
8261 -- For array, component type must be limited
8263 if Is_Array_Type
(T
) then
8264 Error_Msg_Node_2
:= T
;
8266 ("\component type& of type& is limited", N
, Component_Type
(T
));
8267 Explain_Limited_Type
(Component_Type
(T
), N
);
8269 elsif Is_Record_Type
(T
) then
8271 -- No need for extra messages if explicit limited record
8273 if Is_Limited_Record
(Base_Type
(T
)) then
8277 -- Otherwise find a limited component. Check only components that
8278 -- come from source, or inherited components that appear in the
8279 -- source of the ancestor.
8281 C
:= First_Component
(T
);
8282 while Present
(C
) loop
8283 if Is_Limited_Type
(Etype
(C
))
8285 (Comes_From_Source
(C
)
8287 (Present
(Original_Record_Component
(C
))
8289 Comes_From_Source
(Original_Record_Component
(C
))))
8291 Error_Msg_Node_2
:= T
;
8292 Error_Msg_NE
("\component& of type& has limited type", N
, C
);
8293 Explain_Limited_Type
(Etype
(C
), N
);
8300 -- The type may be declared explicitly limited, even if no component
8301 -- of it is limited, in which case we fall out of the loop.
8304 end Explain_Limited_Type
;
8306 ---------------------------------------
8307 -- Expression_Of_Expression_Function --
8308 ---------------------------------------
8310 function Expression_Of_Expression_Function
8311 (Subp
: Entity_Id
) return Node_Id
8313 Expr_Func
: Node_Id
:= Empty
;
8316 pragma Assert
(Is_Expression_Function_Or_Completion
(Subp
));
8318 if Nkind
(Original_Node
(Subprogram_Spec
(Subp
))) =
8319 N_Expression_Function
8321 Expr_Func
:= Original_Node
(Subprogram_Spec
(Subp
));
8323 elsif Nkind
(Original_Node
(Subprogram_Body
(Subp
))) =
8324 N_Expression_Function
8326 Expr_Func
:= Original_Node
(Subprogram_Body
(Subp
));
8329 pragma Assert
(False);
8333 return Original_Node
(Expression
(Expr_Func
));
8334 end Expression_Of_Expression_Function
;
8336 -------------------------------
8337 -- Extensions_Visible_Status --
8338 -------------------------------
8340 function Extensions_Visible_Status
8341 (Id
: Entity_Id
) return Extensions_Visible_Mode
8350 -- When a formal parameter is subject to Extensions_Visible, the pragma
8351 -- is stored in the contract of related subprogram.
8353 if Is_Formal
(Id
) then
8356 elsif Is_Subprogram_Or_Generic_Subprogram
(Id
) then
8359 -- No other construct carries this pragma
8362 return Extensions_Visible_None
;
8365 Prag
:= Get_Pragma
(Subp
, Pragma_Extensions_Visible
);
8367 -- In certain cases analysis may request the Extensions_Visible status
8368 -- of an expression function before the pragma has been analyzed yet.
8369 -- Inspect the declarative items after the expression function looking
8370 -- for the pragma (if any).
8372 if No
(Prag
) and then Is_Expression_Function
(Subp
) then
8373 Decl
:= Next
(Unit_Declaration_Node
(Subp
));
8374 while Present
(Decl
) loop
8375 if Nkind
(Decl
) = N_Pragma
8376 and then Pragma_Name
(Decl
) = Name_Extensions_Visible
8381 -- A source construct ends the region where Extensions_Visible may
8382 -- appear, stop the traversal. An expanded expression function is
8383 -- no longer a source construct, but it must still be recognized.
8385 elsif Comes_From_Source
(Decl
)
8387 (Nkind
(Decl
) in N_Subprogram_Body | N_Subprogram_Declaration
8388 and then Is_Expression_Function
(Defining_Entity
(Decl
)))
8397 -- Extract the value from the Boolean expression (if any)
8399 if Present
(Prag
) then
8400 Arg
:= First
(Pragma_Argument_Associations
(Prag
));
8402 if Present
(Arg
) then
8403 Expr
:= Get_Pragma_Arg
(Arg
);
8405 -- When the associated subprogram is an expression function, the
8406 -- argument of the pragma may not have been analyzed.
8408 if not Analyzed
(Expr
) then
8409 Preanalyze_And_Resolve
(Expr
, Standard_Boolean
);
8412 -- Guard against cascading errors when the argument of pragma
8413 -- Extensions_Visible is not a valid static Boolean expression.
8415 if Error_Posted
(Expr
) then
8416 return Extensions_Visible_None
;
8418 elsif Is_True
(Expr_Value
(Expr
)) then
8419 return Extensions_Visible_True
;
8422 return Extensions_Visible_False
;
8425 -- Otherwise the aspect or pragma defaults to True
8428 return Extensions_Visible_True
;
8431 -- Otherwise aspect or pragma Extensions_Visible is not inherited or
8432 -- directly specified. In SPARK code, its value defaults to "False".
8434 elsif SPARK_Mode
= On
then
8435 return Extensions_Visible_False
;
8437 -- In non-SPARK code, aspect or pragma Extensions_Visible defaults to
8441 return Extensions_Visible_True
;
8443 end Extensions_Visible_Status
;
8449 procedure Find_Actual
8451 Formal
: out Entity_Id
;
8454 Context
: constant Node_Id
:= Parent
(N
);
8457 Call_Ent
: Node_Id
:= Empty
;
8460 if Nkind
(Context
) in N_Indexed_Component | N_Selected_Component
8461 and then N
= Prefix
(Context
)
8463 Find_Actual
(Context
, Formal
, Call
);
8466 elsif Nkind
(Context
) = N_Parameter_Association
8467 and then N
= Explicit_Actual_Parameter
(Context
)
8469 Call
:= Parent
(Context
);
8471 elsif Nkind
(Context
) in N_Entry_Call_Statement
8473 | N_Procedure_Call_Statement
8483 -- If we have a call to a subprogram look for the parameter. Note that
8484 -- we exclude overloaded calls, since we don't know enough to be sure
8485 -- of giving the right answer in this case.
8487 if Nkind
(Call
) in N_Entry_Call_Statement
8489 | N_Procedure_Call_Statement
8491 Call_Nam
:= Name
(Call
);
8493 -- A call to an entry family may appear as an indexed component
8495 if Nkind
(Call_Nam
) = N_Indexed_Component
then
8496 Call_Nam
:= Prefix
(Call_Nam
);
8499 -- A call to a protected or task entry appears as a selected
8500 -- component rather than an expanded name.
8502 if Nkind
(Call_Nam
) = N_Selected_Component
then
8503 Call_Nam
:= Selector_Name
(Call_Nam
);
8506 -- If Call_Nam is an entity name, get its entity
8508 if Is_Entity_Name
(Call_Nam
) then
8509 Call_Ent
:= Entity
(Call_Nam
);
8511 -- If it is a dereference, get the designated subprogram type
8513 elsif Nkind
(Call_Nam
) = N_Explicit_Dereference
then
8515 Typ
: Entity_Id
:= Etype
(Prefix
(Call_Nam
));
8517 if Present
(Full_View
(Typ
)) then
8518 Typ
:= Full_View
(Typ
);
8519 elsif Is_Private_Type
(Typ
)
8520 and then Present
(Underlying_Full_View
(Typ
))
8522 Typ
:= Underlying_Full_View
(Typ
);
8525 if Is_Access_Type
(Typ
) then
8526 Call_Ent
:= Directly_Designated_Type
(Typ
);
8528 pragma Assert
(Has_Implicit_Dereference
(Typ
));
8536 if Present
(Call_Ent
)
8537 and then (Is_Generic_Subprogram
(Call_Ent
)
8538 or else Is_Overloadable
(Call_Ent
)
8539 or else Ekind
(Call_Ent
) in E_Entry_Family
8541 | E_Subprogram_Type
)
8542 and then not Is_Overloaded
(Call_Nam
)
8544 -- If node is name in call it is not an actual
8546 if N
= Call_Nam
then
8552 -- Fall here if we are definitely a parameter
8554 Actual
:= First_Actual
(Call
);
8555 Formal
:= First_Formal
(Call_Ent
);
8556 while Present
(Formal
) and then Present
(Actual
) loop
8560 -- An actual that is the prefix in a prefixed call may have
8561 -- been rewritten in the call. Check if sloc and kinds and
8564 elsif Sloc
(Actual
) = Sloc
(N
)
8565 and then Nkind
(Actual
) = N_Identifier
8566 and then Nkind
(Actual
) = Nkind
(N
)
8567 and then Chars
(Actual
) = Chars
(N
)
8572 Next_Actual
(Actual
);
8573 Next_Formal
(Formal
);
8579 -- Fall through here if we did not find matching actual
8585 ---------------------------
8586 -- Find_Body_Discriminal --
8587 ---------------------------
8589 function Find_Body_Discriminal
8590 (Spec_Discriminant
: Entity_Id
) return Entity_Id
8596 -- If expansion is suppressed, then the scope can be the concurrent type
8597 -- itself rather than a corresponding concurrent record type.
8599 if Is_Concurrent_Type
(Scope
(Spec_Discriminant
)) then
8600 Tsk
:= Scope
(Spec_Discriminant
);
8603 pragma Assert
(Is_Concurrent_Record_Type
(Scope
(Spec_Discriminant
)));
8605 Tsk
:= Corresponding_Concurrent_Type
(Scope
(Spec_Discriminant
));
8608 -- Find discriminant of original concurrent type, and use its current
8609 -- discriminal, which is the renaming within the task/protected body.
8611 Disc
:= First_Discriminant
(Tsk
);
8612 while Present
(Disc
) loop
8613 if Chars
(Disc
) = Chars
(Spec_Discriminant
) then
8614 return Discriminal
(Disc
);
8617 Next_Discriminant
(Disc
);
8620 -- That loop should always succeed in finding a matching entry and
8621 -- returning. Fatal error if not.
8623 raise Program_Error
;
8624 end Find_Body_Discriminal
;
8626 -------------------------------------
8627 -- Find_Corresponding_Discriminant --
8628 -------------------------------------
8630 function Find_Corresponding_Discriminant
8632 Typ
: Entity_Id
) return Entity_Id
8634 Par_Disc
: Entity_Id
;
8635 Old_Disc
: Entity_Id
;
8636 New_Disc
: Entity_Id
;
8639 Par_Disc
:= Original_Record_Component
(Original_Discriminant
(Id
));
8641 -- The original type may currently be private, and the discriminant
8642 -- only appear on its full view.
8644 if Is_Private_Type
(Scope
(Par_Disc
))
8645 and then not Has_Discriminants
(Scope
(Par_Disc
))
8646 and then Present
(Full_View
(Scope
(Par_Disc
)))
8648 Old_Disc
:= First_Discriminant
(Full_View
(Scope
(Par_Disc
)));
8650 Old_Disc
:= First_Discriminant
(Scope
(Par_Disc
));
8653 if Is_Class_Wide_Type
(Typ
) then
8654 New_Disc
:= First_Discriminant
(Root_Type
(Typ
));
8656 New_Disc
:= First_Discriminant
(Typ
);
8659 while Present
(Old_Disc
) and then Present
(New_Disc
) loop
8660 if Old_Disc
= Par_Disc
then
8664 Next_Discriminant
(Old_Disc
);
8665 Next_Discriminant
(New_Disc
);
8668 -- Should always find it
8670 raise Program_Error
;
8671 end Find_Corresponding_Discriminant
;
8677 function Find_DIC_Type
(Typ
: Entity_Id
) return Entity_Id
is
8678 Curr_Typ
: Entity_Id
;
8679 -- The current type being examined in the parent hierarchy traversal
8681 DIC_Typ
: Entity_Id
;
8682 -- The type which carries the DIC pragma. This variable denotes the
8683 -- partial view when private types are involved.
8685 Par_Typ
: Entity_Id
;
8686 -- The parent type of the current type. This variable denotes the full
8687 -- view when private types are involved.
8690 -- The input type defines its own DIC pragma, therefore it is the owner
8692 if Has_Own_DIC
(Typ
) then
8695 -- Otherwise the DIC pragma is inherited from a parent type
8698 pragma Assert
(Has_Inherited_DIC
(Typ
));
8700 -- Climb the parent chain
8704 -- Inspect the parent type. Do not consider subtypes as they
8705 -- inherit the DIC attributes from their base types.
8707 DIC_Typ
:= Base_Type
(Etype
(Curr_Typ
));
8709 -- Look at the full view of a private type because the type may
8710 -- have a hidden parent introduced in the full view.
8714 if Is_Private_Type
(Par_Typ
)
8715 and then Present
(Full_View
(Par_Typ
))
8717 Par_Typ
:= Full_View
(Par_Typ
);
8720 -- Stop the climb once the nearest parent type which defines a DIC
8721 -- pragma of its own is encountered or when the root of the parent
8722 -- chain is reached.
8724 exit when Has_Own_DIC
(DIC_Typ
) or else Curr_Typ
= Par_Typ
;
8726 Curr_Typ
:= Par_Typ
;
8733 ----------------------------------
8734 -- Find_Enclosing_Iterator_Loop --
8735 ----------------------------------
8737 function Find_Enclosing_Iterator_Loop
(Id
: Entity_Id
) return Entity_Id
is
8742 -- Traverse the scope chain looking for an iterator loop. Such loops are
8743 -- usually transformed into blocks, hence the use of Original_Node.
8746 while Present
(S
) and then S
/= Standard_Standard
loop
8747 if Ekind
(S
) = E_Loop
8748 and then Nkind
(Parent
(S
)) = N_Implicit_Label_Declaration
8750 Constr
:= Original_Node
(Label_Construct
(Parent
(S
)));
8752 if Nkind
(Constr
) = N_Loop_Statement
8753 and then Present
(Iteration_Scheme
(Constr
))
8754 and then Nkind
(Iterator_Specification
8755 (Iteration_Scheme
(Constr
))) =
8756 N_Iterator_Specification
8766 end Find_Enclosing_Iterator_Loop
;
8768 --------------------------
8769 -- Find_Enclosing_Scope --
8770 --------------------------
8772 function Find_Enclosing_Scope
(N
: Node_Id
) return Scope_Kind_Id
is
8776 -- If N is an entity, simply return its Scope
8778 if Nkind
(N
) in N_Entity
then
8782 -- Examine the parent chain looking for a construct which defines a
8786 while Present
(Par
) loop
8789 -- The construct denotes a declaration, the proper scope is its
8792 when N_Entry_Declaration
8793 | N_Expression_Function
8794 | N_Full_Type_Declaration
8795 | N_Generic_Package_Declaration
8796 | N_Generic_Subprogram_Declaration
8797 | N_Package_Declaration
8798 | N_Private_Extension_Declaration
8799 | N_Protected_Type_Declaration
8800 | N_Single_Protected_Declaration
8801 | N_Single_Task_Declaration
8802 | N_Subprogram_Declaration
8803 | N_Task_Type_Declaration
8805 return Defining_Entity
(Par
);
8807 -- The construct denotes a body, the proper scope is the entity of
8808 -- the corresponding spec or that of the body if the body does not
8809 -- complete a previous declaration.
8817 return Unique_Defining_Entity
(Par
);
8821 -- Blocks carry either a source or an internally-generated scope,
8822 -- unless the block is a byproduct of exception handling.
8824 when N_Block_Statement
=>
8825 if not Exception_Junk
(Par
) then
8826 return Entity
(Identifier
(Par
));
8829 -- Loops carry an internally-generated scope
8831 when N_Loop_Statement
=>
8832 return Entity
(Identifier
(Par
));
8834 -- Extended return statements carry an internally-generated scope
8836 when N_Extended_Return_Statement
=>
8837 return Return_Statement_Entity
(Par
);
8839 -- A traversal from a subunit continues via the corresponding stub
8842 Par
:= Corresponding_Stub
(Par
);
8848 Par
:= Parent
(Par
);
8851 return Standard_Standard
;
8852 end Find_Enclosing_Scope
;
8854 ------------------------------------
8855 -- Find_Loop_In_Conditional_Block --
8856 ------------------------------------
8858 function Find_Loop_In_Conditional_Block
(N
: Node_Id
) return Node_Id
is
8864 if Nkind
(Stmt
) = N_If_Statement
then
8865 Stmt
:= First
(Then_Statements
(Stmt
));
8868 pragma Assert
(Nkind
(Stmt
) = N_Block_Statement
);
8870 -- Inspect the statements of the conditional block. In general the loop
8871 -- should be the first statement in the statement sequence of the block,
8872 -- but the finalization machinery may have introduced extra object
8875 Stmt
:= First
(Statements
(Handled_Statement_Sequence
(Stmt
)));
8876 while Present
(Stmt
) loop
8877 if Nkind
(Stmt
) = N_Loop_Statement
then
8884 -- The expansion of attribute 'Loop_Entry produced a malformed block
8886 raise Program_Error
;
8887 end Find_Loop_In_Conditional_Block
;
8889 --------------------------
8890 -- Find_Overlaid_Entity --
8891 --------------------------
8893 procedure Find_Overlaid_Entity
8895 Ent
: out Entity_Id
;
8899 (Nkind
(N
) = N_Attribute_Definition_Clause
8900 and then Chars
(N
) = Name_Address
);
8905 -- We are looking for one of the two following forms:
8907 -- for X'Address use Y'Address
8911 -- Const : constant Address := expr;
8913 -- for X'Address use Const;
8915 -- In the second case, the expr is either Y'Address, or recursively a
8916 -- constant that eventually references Y'Address.
8921 Expr
:= Expression
(N
);
8923 -- This loop checks the form of the expression for Y'Address, using
8924 -- recursion to deal with intermediate constants.
8927 -- Check for Y'Address
8929 if Nkind
(Expr
) = N_Attribute_Reference
8930 and then Attribute_Name
(Expr
) = Name_Address
8932 Expr
:= Prefix
(Expr
);
8935 -- Check for Const where Const is a constant entity
8937 elsif Is_Entity_Name
(Expr
)
8938 and then Ekind
(Entity
(Expr
)) = E_Constant
8940 Expr
:= Constant_Value
(Entity
(Expr
));
8942 -- Anything else does not need checking
8949 -- This loop checks the form of the prefix for an entity, using
8950 -- recursion to deal with intermediate components.
8953 -- Check for Y where Y is an entity
8955 if Is_Entity_Name
(Expr
) then
8956 Ent
:= Entity
(Expr
);
8958 -- If expansion is disabled, then we might see an entity of a
8959 -- protected component or of a discriminant of a concurrent unit.
8960 -- Ignore such entities, because further warnings for overlays
8961 -- expect this routine to only collect entities of entire objects.
8963 if Ekind
(Ent
) in E_Component | E_Discriminant
then
8965 (not Expander_Active
8966 and then Is_Concurrent_Type
(Scope
(Ent
)));
8971 -- Check for components
8973 elsif Nkind
(Expr
) in N_Selected_Component | N_Indexed_Component
then
8974 Expr
:= Prefix
(Expr
);
8977 -- Anything else does not need checking
8983 end Find_Overlaid_Entity
;
8985 -------------------------
8986 -- Find_Parameter_Type --
8987 -------------------------
8989 function Find_Parameter_Type
(Param
: Node_Id
) return Entity_Id
is
8991 if Nkind
(Param
) /= N_Parameter_Specification
then
8994 -- For an access parameter, obtain the type from the formal entity
8995 -- itself, because access to subprogram nodes do not carry a type.
8996 -- Shouldn't we always use the formal entity ???
8998 elsif Nkind
(Parameter_Type
(Param
)) = N_Access_Definition
then
8999 return Etype
(Defining_Identifier
(Param
));
9002 return Etype
(Parameter_Type
(Param
));
9004 end Find_Parameter_Type
;
9006 -----------------------------------
9007 -- Find_Placement_In_State_Space --
9008 -----------------------------------
9010 procedure Find_Placement_In_State_Space
9011 (Item_Id
: Entity_Id
;
9012 Placement
: out State_Space_Kind
;
9013 Pack_Id
: out Entity_Id
)
9015 function Inside_Package_Body
(Id
: Entity_Id
) return Boolean;
9016 function Inside_Private_Part
(Id
: Entity_Id
) return Boolean;
9017 -- Return True if Id is declared directly within the package body
9018 -- and the package private parts, respectively. We cannot use
9019 -- In_Private_Part/In_Body_Part flags, as these are only set during the
9020 -- analysis of the package itself, while Find_Placement_In_State_Space
9021 -- can be called on an entity of another package.
9023 ------------------------
9024 -- Inside_Package_Body --
9025 ------------------------
9027 function Inside_Package_Body
(Id
: Entity_Id
) return Boolean is
9028 Spec_Id
: constant Entity_Id
:= Scope
(Id
);
9029 Body_Decl
: constant Opt_N_Package_Body_Id
:= Package_Body
(Spec_Id
);
9030 Decl
: constant Node_Id
:= Enclosing_Declaration
(Id
);
9032 if Present
(Body_Decl
)
9033 and then Is_List_Member
(Decl
)
9034 and then List_Containing
(Decl
) = Declarations
(Body_Decl
)
9040 end Inside_Package_Body
;
9042 -------------------------
9043 -- Inside_Private_Part --
9044 -------------------------
9046 function Inside_Private_Part
(Id
: Entity_Id
) return Boolean is
9047 Spec_Id
: constant Entity_Id
:= Scope
(Id
);
9048 Private_Decls
: constant List_Id
:=
9049 Private_Declarations
(Package_Specification
(Spec_Id
));
9050 Decl
: constant Node_Id
:= Enclosing_Declaration
(Id
);
9052 if Is_List_Member
(Decl
)
9053 and then List_Containing
(Decl
) = Private_Decls
9057 elsif Ekind
(Id
) = E_Package
9058 and then Is_Private_Library_Unit
(Id
)
9065 end Inside_Private_Part
;
9069 Context
: Entity_Id
;
9071 -- Start of processing for Find_Placement_In_State_Space
9074 -- Assume that the item does not appear in the state space of a package
9076 Placement
:= Not_In_Package
;
9078 -- Climb the scope stack and examine the enclosing context
9081 Pack_Id
:= Scope
(Context
);
9082 while Present
(Pack_Id
) and then Pack_Id
/= Standard_Standard
loop
9083 if Is_Package_Or_Generic_Package
(Pack_Id
) then
9085 -- A package body is a cut off point for the traversal as the
9086 -- item cannot be visible to the outside from this point on.
9088 if Inside_Package_Body
(Context
) then
9089 Placement
:= Body_State_Space
;
9092 -- The private part of a package is a cut off point for the
9093 -- traversal as the item cannot be visible to the outside
9094 -- from this point on.
9096 elsif Inside_Private_Part
(Context
) then
9097 Placement
:= Private_State_Space
;
9100 -- When the item appears in the visible state space of a package,
9101 -- continue to climb the scope stack as this may not be the final
9105 Placement
:= Visible_State_Space
;
9107 -- The visible state space of a child unit acts as the proper
9108 -- placement of an item, unless this is a private child unit.
9110 if Is_Child_Unit
(Pack_Id
)
9111 and then not Is_Private_Library_Unit
(Pack_Id
)
9117 -- The item or its enclosing package appear in a construct that has
9121 Placement
:= Not_In_Package
;
9126 Context
:= Scope
(Context
);
9127 Pack_Id
:= Scope
(Context
);
9129 end Find_Placement_In_State_Space
;
9131 -----------------------
9132 -- Find_Primitive_Eq --
9133 -----------------------
9135 function Find_Primitive_Eq
(Typ
: Entity_Id
) return Entity_Id
is
9136 function Find_Eq_Prim
(Prims_List
: Elist_Id
) return Entity_Id
;
9137 -- Search for the equality primitive; return Empty if the primitive is
9144 function Find_Eq_Prim
(Prims_List
: Elist_Id
) return Entity_Id
is
9146 Prim_Elmt
: Elmt_Id
;
9149 Prim_Elmt
:= First_Elmt
(Prims_List
);
9150 while Present
(Prim_Elmt
) loop
9151 Prim
:= Node
(Prim_Elmt
);
9153 -- Locate primitive equality with the right signature
9155 if Chars
(Prim
) = Name_Op_Eq
9156 and then Etype
(First_Formal
(Prim
)) =
9157 Etype
(Next_Formal
(First_Formal
(Prim
)))
9158 and then Base_Type
(Etype
(Prim
)) = Standard_Boolean
9163 Next_Elmt
(Prim_Elmt
);
9171 Eq_Prim
: Entity_Id
;
9172 Full_Type
: Entity_Id
;
9174 -- Start of processing for Find_Primitive_Eq
9177 if Is_Private_Type
(Typ
) then
9178 Full_Type
:= Underlying_Type
(Typ
);
9183 if No
(Full_Type
) then
9187 Full_Type
:= Base_Type
(Full_Type
);
9189 -- When the base type itself is private, use the full view
9191 if Is_Private_Type
(Full_Type
) then
9192 Full_Type
:= Underlying_Type
(Full_Type
);
9195 if Is_Class_Wide_Type
(Full_Type
) then
9196 Full_Type
:= Root_Type
(Full_Type
);
9199 if not Is_Tagged_Type
(Full_Type
) then
9200 Eq_Prim
:= Find_Eq_Prim
(Collect_Primitive_Operations
(Typ
));
9202 -- If this is an untagged private type completed with a derivation of
9203 -- an untagged private type whose full view is a tagged type, we use
9204 -- the primitive operations of the private parent type (since it does
9205 -- not have a full view, and also because its equality primitive may
9206 -- have been overridden in its untagged full view). If no equality was
9207 -- defined for it then take its dispatching equality primitive.
9209 elsif Inherits_From_Tagged_Full_View
(Typ
) then
9210 Eq_Prim
:= Find_Eq_Prim
(Collect_Primitive_Operations
(Typ
));
9212 if No
(Eq_Prim
) then
9213 Eq_Prim
:= Find_Eq_Prim
(Primitive_Operations
(Full_Type
));
9217 Eq_Prim
:= Find_Eq_Prim
(Primitive_Operations
(Full_Type
));
9221 end Find_Primitive_Eq
;
9223 ------------------------
9224 -- Find_Specific_Type --
9225 ------------------------
9227 function Find_Specific_Type
(CW
: Entity_Id
) return Entity_Id
is
9228 Typ
: Entity_Id
:= Root_Type
(CW
);
9231 if Ekind
(Typ
) = E_Incomplete_Type
then
9232 if From_Limited_With
(Typ
) then
9233 Typ
:= Non_Limited_View
(Typ
);
9235 Typ
:= Full_View
(Typ
);
9239 if Is_Private_Type
(Typ
)
9240 and then not Is_Tagged_Type
(Typ
)
9241 and then Present
(Full_View
(Typ
))
9243 return Full_View
(Typ
);
9247 end Find_Specific_Type
;
9249 -----------------------------
9250 -- Find_Static_Alternative --
9251 -----------------------------
9253 function Find_Static_Alternative
(N
: Node_Id
) return Node_Id
is
9254 Expr
: constant Node_Id
:= Expression
(N
);
9255 Val
: constant Uint
:= Expr_Value
(Expr
);
9260 Alt
:= First
(Alternatives
(N
));
9263 if Nkind
(Alt
) /= N_Pragma
then
9264 Choice
:= First
(Discrete_Choices
(Alt
));
9265 while Present
(Choice
) loop
9267 -- Others choice, always matches
9269 if Nkind
(Choice
) = N_Others_Choice
then
9272 -- Range, check if value is in the range
9274 elsif Nkind
(Choice
) = N_Range
then
9276 Val
>= Expr_Value
(Low_Bound
(Choice
))
9278 Val
<= Expr_Value
(High_Bound
(Choice
));
9280 -- Choice is a subtype name. Note that we know it must
9281 -- be a static subtype, since otherwise it would have
9282 -- been diagnosed as illegal.
9284 elsif Is_Entity_Name
(Choice
)
9285 and then Is_Type
(Entity
(Choice
))
9287 exit Search
when Is_In_Range
(Expr
, Etype
(Choice
),
9288 Assume_Valid
=> False);
9290 -- Choice is a subtype indication
9292 elsif Nkind
(Choice
) = N_Subtype_Indication
then
9294 C
: constant Node_Id
:= Constraint
(Choice
);
9295 R
: constant Node_Id
:= Range_Expression
(C
);
9299 Val
>= Expr_Value
(Low_Bound
(R
))
9301 Val
<= Expr_Value
(High_Bound
(R
));
9304 -- Choice is a simple expression
9307 exit Search
when Val
= Expr_Value
(Choice
);
9315 pragma Assert
(Present
(Alt
));
9318 -- The above loop *must* terminate by finding a match, since we know the
9319 -- case statement is valid, and the value of the expression is known at
9320 -- compile time. When we fall out of the loop, Alt points to the
9321 -- alternative that we know will be selected at run time.
9324 end Find_Static_Alternative
;
9330 function First_Actual
(Node
: Node_Id
) return Node_Id
is
9334 if No
(Parameter_Associations
(Node
)) then
9338 N
:= First
(Parameter_Associations
(Node
));
9340 if Nkind
(N
) = N_Parameter_Association
then
9341 return First_Named_Actual
(Node
);
9351 function First_Global
9353 Global_Mode
: Name_Id
;
9354 Refined
: Boolean := False) return Node_Id
9356 function First_From_Global_List
9358 Global_Mode
: Name_Id
:= Name_Input
) return Entity_Id
;
9359 -- Get the first item with suitable mode from List
9361 ----------------------------
9362 -- First_From_Global_List --
9363 ----------------------------
9365 function First_From_Global_List
9367 Global_Mode
: Name_Id
:= Name_Input
) return Entity_Id
9372 -- Empty list (no global items)
9374 if Nkind
(List
) = N_Null
then
9377 -- Single global item declaration (only input items)
9379 elsif Nkind
(List
) in N_Expanded_Name | N_Identifier
then
9380 if Global_Mode
= Name_Input
then
9386 -- Simple global list (only input items) or moded global list
9389 elsif Nkind
(List
) = N_Aggregate
then
9390 if Present
(Expressions
(List
)) then
9391 if Global_Mode
= Name_Input
then
9392 return First
(Expressions
(List
));
9398 Assoc
:= First
(Component_Associations
(List
));
9399 while Present
(Assoc
) loop
9401 -- When we find the desired mode in an association, call
9402 -- recursively First_From_Global_List as if the mode was
9403 -- Name_Input, in order to reuse the existing machinery
9404 -- for the other cases.
9406 if Chars
(First
(Choices
(Assoc
))) = Global_Mode
then
9407 return First_From_Global_List
(Expression
(Assoc
));
9416 -- To accommodate partial decoration of disabled SPARK features,
9417 -- this routine may be called with illegal input. If this is the
9418 -- case, do not raise Program_Error.
9423 end First_From_Global_List
;
9427 Global
: Node_Id
:= Empty
;
9428 Body_Id
: Entity_Id
;
9430 -- Start of processing for First_Global
9433 pragma Assert
(Global_Mode
in Name_In_Out
9438 -- Retrieve the suitable pragma Global or Refined_Global. In the second
9439 -- case, it can only be located on the body entity.
9442 if Is_Subprogram_Or_Generic_Subprogram
(Subp
) then
9443 Body_Id
:= Subprogram_Body_Entity
(Subp
);
9445 elsif Is_Entry
(Subp
) or else Is_Task_Type
(Subp
) then
9446 Body_Id
:= Corresponding_Body
(Parent
(Subp
));
9448 -- ??? It should be possible to retrieve the Refined_Global on the
9449 -- task body associated to the task object. This is not yet possible.
9451 elsif Is_Single_Task_Object
(Subp
) then
9458 if Present
(Body_Id
) then
9459 Global
:= Get_Pragma
(Body_Id
, Pragma_Refined_Global
);
9462 Global
:= Get_Pragma
(Subp
, Pragma_Global
);
9465 -- No corresponding global if pragma is not present
9470 -- Otherwise retrieve the corresponding list of items depending on the
9474 return First_From_Global_List
9475 (Expression
(Get_Argument
(Global
, Subp
)), Global_Mode
);
9483 function Fix_Msg
(Id
: Entity_Id
; Msg
: String) return String is
9484 Is_Task
: constant Boolean :=
9485 Ekind
(Id
) in E_Task_Body | E_Task_Type
9486 or else Is_Single_Task_Object
(Id
);
9487 Msg_Last
: constant Natural := Msg
'Last;
9488 Msg_Index
: Natural;
9489 Res
: String (Msg
'Range) := (others => ' ');
9490 Res_Index
: Natural;
9493 -- Copy all characters from the input message Msg to result Res with
9494 -- suitable replacements.
9496 Msg_Index
:= Msg
'First;
9497 Res_Index
:= Res
'First;
9498 while Msg_Index
<= Msg_Last
loop
9500 -- Replace "subprogram" with a different word
9502 if Msg_Index
<= Msg_Last
- 10
9503 and then Msg
(Msg_Index
.. Msg_Index
+ 9) = "subprogram"
9505 if Is_Entry
(Id
) then
9506 Res
(Res_Index
.. Res_Index
+ 4) := "entry";
9507 Res_Index
:= Res_Index
+ 5;
9510 Res
(Res_Index
.. Res_Index
+ 8) := "task type";
9511 Res_Index
:= Res_Index
+ 9;
9514 Res
(Res_Index
.. Res_Index
+ 9) := "subprogram";
9515 Res_Index
:= Res_Index
+ 10;
9518 Msg_Index
:= Msg_Index
+ 10;
9520 -- Replace "protected" with a different word
9522 elsif Msg_Index
<= Msg_Last
- 9
9523 and then Msg
(Msg_Index
.. Msg_Index
+ 8) = "protected"
9526 Res
(Res_Index
.. Res_Index
+ 3) := "task";
9527 Res_Index
:= Res_Index
+ 4;
9528 Msg_Index
:= Msg_Index
+ 9;
9530 -- Otherwise copy the character
9533 Res
(Res_Index
) := Msg
(Msg_Index
);
9534 Msg_Index
:= Msg_Index
+ 1;
9535 Res_Index
:= Res_Index
+ 1;
9539 return Res
(Res
'First .. Res_Index
- 1);
9542 -------------------------
9543 -- From_Nested_Package --
9544 -------------------------
9546 function From_Nested_Package
(T
: Entity_Id
) return Boolean is
9547 Pack
: constant Entity_Id
:= Scope
(T
);
9551 Ekind
(Pack
) = E_Package
9552 and then not Is_Frozen
(Pack
)
9553 and then not Scope_Within_Or_Same
(Current_Scope
, Pack
)
9554 and then In_Open_Scopes
(Scope
(Pack
));
9555 end From_Nested_Package
;
9557 -----------------------
9558 -- Gather_Components --
9559 -----------------------
9561 procedure Gather_Components
9563 Comp_List
: Node_Id
;
9564 Governed_By
: List_Id
;
9566 Report_Errors
: out Boolean;
9567 Allow_Compile_Time
: Boolean := False;
9568 Include_Interface_Tag
: Boolean := False)
9572 Discrete_Choice
: Node_Id
;
9573 Comp_Item
: Node_Id
;
9574 Discrim
: Entity_Id
;
9575 Discrim_Name
: Node_Id
;
9577 type Discriminant_Value_Status
is
9578 (Static_Expr
, Static_Subtype
, Bad
);
9579 subtype Good_Discrim_Value_Status
is Discriminant_Value_Status
9580 range Static_Expr
.. Static_Subtype
; -- range excludes Bad
9582 Discrim_Value
: Node_Id
;
9583 Discrim_Value_Subtype
: Node_Id
;
9584 Discrim_Value_Status
: Discriminant_Value_Status
:= Bad
;
9586 function OK_Scope_For_Discrim_Value_Error_Messages
return Boolean is
9587 (Scope
(Original_Record_Component
9588 (Entity
(First
(Choices
(Assoc
))))) = Typ
);
9589 -- Used to avoid generating error messages having a source position
9590 -- which refers to somewhere (e.g., a discriminant value in a derived
9591 -- tagged type declaration) unrelated to the offending construct. This
9592 -- is required for correctness - clients of Gather_Components such as
9593 -- Sem_Ch3.Create_Constrained_Components depend on this function
9594 -- returning True while processing semantically correct examples;
9595 -- generating an error message in this case would be wrong.
9598 Report_Errors
:= False;
9600 if No
(Comp_List
) or else Null_Present
(Comp_List
) then
9604 Comp_Item
:= First
(Component_Items
(Comp_List
));
9605 while Present
(Comp_Item
) loop
9607 -- Skip the tag of a tagged record, as well as all items that are not
9608 -- user components (anonymous types, rep clauses, Parent field,
9609 -- controller field).
9611 if Nkind
(Comp_Item
) = N_Component_Declaration
then
9613 Comp
: constant Entity_Id
:= Defining_Identifier
(Comp_Item
);
9615 if not (Is_Tag
(Comp
)
9617 (Include_Interface_Tag
9618 and then Etype
(Comp
) = RTE
(RE_Interface_Tag
)))
9619 and then Chars
(Comp
) /= Name_uParent
9621 Append_Elmt
(Comp
, Into
);
9629 if No
(Variant_Part
(Comp_List
)) then
9632 Discrim_Name
:= Name
(Variant_Part
(Comp_List
));
9633 Variant
:= First_Non_Pragma
(Variants
(Variant_Part
(Comp_List
)));
9636 -- Look for the discriminant that governs this variant part.
9637 -- The discriminant *must* be in the Governed_By List
9639 Assoc
:= First
(Governed_By
);
9640 Find_Constraint
: loop
9641 Discrim
:= First
(Choices
(Assoc
));
9642 pragma Assert
(No
(Next
(Discrim
)));
9644 exit Find_Constraint
when
9645 Chars
(Discrim_Name
) = Chars
(Discrim
)
9647 (Present
(Corresponding_Discriminant
(Entity
(Discrim
)))
9648 and then Chars
(Corresponding_Discriminant
9649 (Entity
(Discrim
))) = Chars
(Discrim_Name
))
9651 Chars
(Original_Record_Component
(Entity
(Discrim
))) =
9652 Chars
(Discrim_Name
);
9654 if No
(Next
(Assoc
)) then
9655 if not Is_Constrained
(Typ
) and then Is_Derived_Type
(Typ
) then
9657 -- If the type is a tagged type with inherited discriminants,
9658 -- use the stored constraint on the parent in order to find
9659 -- the values of discriminants that are otherwise hidden by an
9660 -- explicit constraint. Renamed discriminants are handled in
9663 -- If several parent discriminants are renamed by a single
9664 -- discriminant of the derived type, the call to obtain the
9665 -- Corresponding_Discriminant field only retrieves the last
9666 -- of them. We recover the constraint on the others from the
9667 -- Stored_Constraint as well.
9669 -- An inherited discriminant may have been constrained in a
9670 -- later ancestor (not the immediate parent) so we must examine
9671 -- the stored constraint of all of them to locate the inherited
9677 T
: Entity_Id
:= Typ
;
9680 while Is_Derived_Type
(T
) loop
9681 if Present
(Stored_Constraint
(T
)) then
9682 D
:= First_Discriminant
(Etype
(T
));
9683 C
:= First_Elmt
(Stored_Constraint
(T
));
9684 while Present
(D
) and then Present
(C
) loop
9685 if Chars
(Discrim_Name
) = Chars
(D
) then
9686 if Is_Entity_Name
(Node
(C
))
9687 and then Entity
(Node
(C
)) = Entity
(Discrim
)
9689 -- D is renamed by Discrim, whose value is
9696 Make_Component_Association
(Sloc
(Typ
),
9698 (New_Occurrence_Of
(D
, Sloc
(Typ
))),
9699 Duplicate_Subexpr_No_Checks
(Node
(C
)));
9702 exit Find_Constraint
;
9705 Next_Discriminant
(D
);
9710 -- Discriminant may be inherited from ancestor
9722 ("missing value for discriminant&",
9723 First
(Governed_By
), Discrim_Name
);
9725 Report_Errors
:= True;
9728 end loop Find_Constraint
;
9730 Discrim_Value
:= Expression
(Assoc
);
9732 if Is_OK_Static_Expression
(Discrim_Value
)
9733 or else (Allow_Compile_Time
9734 and then Compile_Time_Known_Value
(Discrim_Value
))
9736 Discrim_Value_Status
:= Static_Expr
;
9738 if Ada_Version
>= Ada_2022
then
9739 if Is_Rewrite_Substitution
(Discrim_Value
)
9740 and then Nkind
(Discrim_Value
) = N_Type_Conversion
9741 and then Etype
(Original_Node
(Discrim_Value
))
9742 = Etype
(Expression
(Discrim_Value
))
9744 Discrim_Value_Subtype
:= Etype
(Original_Node
(Discrim_Value
));
9745 -- An unhelpful (for this code) type conversion may be
9746 -- introduced in some cases; deal with it.
9748 Discrim_Value_Subtype
:= Etype
(Discrim_Value
);
9751 if Is_OK_Static_Subtype
(Discrim_Value_Subtype
) and then
9752 not Is_Null_Range
(Type_Low_Bound
(Discrim_Value_Subtype
),
9753 Type_High_Bound
(Discrim_Value_Subtype
))
9755 -- Is_Null_Range test doesn't account for predicates, as in
9756 -- subtype Null_By_Predicate is Natural
9757 -- with Static_Predicate => Null_By_Predicate < 0;
9758 -- so test for that null case separately.
9760 if not Has_Static_Predicate
(Discrim_Value_Subtype
)
9761 or else Present
(First
(Static_Discrete_Predicate
9762 (Discrim_Value_Subtype
)))
9764 Discrim_Value_Status
:= Static_Subtype
;
9769 if Discrim_Value_Status
= Bad
then
9771 -- If the variant part is governed by a discriminant of the type
9772 -- this is an error. If the variant part and the discriminant are
9773 -- inherited from an ancestor this is legal (AI05-220) unless the
9774 -- components are being gathered for an aggregate, in which case
9775 -- the caller must check Report_Errors.
9777 -- In Ada 2022 the above rules are relaxed. A nonstatic governing
9778 -- discriminant is OK as long as it has a static subtype and
9779 -- every value of that subtype (and there must be at least one)
9780 -- selects the same variant.
9782 if OK_Scope_For_Discrim_Value_Error_Messages
then
9783 if Ada_Version
>= Ada_2022
then
9785 ("value for discriminant & must be static or " &
9786 "discriminant's nominal subtype must be static " &
9788 Discrim_Value
, Discrim
);
9791 ("value for discriminant & must be static!",
9792 Discrim_Value
, Discrim
);
9794 Why_Not_Static
(Discrim_Value
);
9797 Report_Errors
:= True;
9802 Search_For_Discriminant_Value
: declare
9808 UI_Discrim_Value
: Uint
;
9811 case Good_Discrim_Value_Status
'(Discrim_Value_Status) is
9813 UI_Discrim_Value := Expr_Value (Discrim_Value);
9814 when Static_Subtype =>
9815 -- Arbitrarily pick one value of the subtype and look
9816 -- for the variant associated with that value; we will
9817 -- check later that the same variant is associated with
9818 -- all of the other values of the subtype.
9819 if Has_Static_Predicate (Discrim_Value_Subtype) then
9821 Range_Or_Expr : constant Node_Id :=
9822 First (Static_Discrete_Predicate
9823 (Discrim_Value_Subtype));
9825 if Nkind (Range_Or_Expr) = N_Range then
9827 Expr_Value (Low_Bound (Range_Or_Expr));
9829 UI_Discrim_Value := Expr_Value (Range_Or_Expr);
9834 := Expr_Value (Type_Low_Bound (Discrim_Value_Subtype));
9838 Find_Discrete_Value : while Present (Variant) loop
9840 -- If a choice is a subtype with a static predicate, it must
9841 -- be rewritten as an explicit list of non-predicated choices.
9843 Expand_Static_Predicates_In_Choices (Variant);
9845 Discrete_Choice := First (Discrete_Choices (Variant));
9846 while Present (Discrete_Choice) loop
9847 exit Find_Discrete_Value when
9848 Nkind (Discrete_Choice) = N_Others_Choice;
9850 Get_Index_Bounds (Discrete_Choice, Low, High);
9852 UI_Low := Expr_Value (Low);
9853 UI_High := Expr_Value (High);
9855 exit Find_Discrete_Value when
9856 UI_Low <= UI_Discrim_Value
9858 UI_High >= UI_Discrim_Value;
9860 Next (Discrete_Choice);
9863 Next_Non_Pragma (Variant);
9864 end loop Find_Discrete_Value;
9865 end Search_For_Discriminant_Value;
9867 -- The case statement must include a variant that corresponds to the
9868 -- value of the discriminant, unless the discriminant type has a
9869 -- static predicate. In that case the absence of an others_choice that
9870 -- would cover this value becomes a run-time error (3.8.1 (21.1/2)).
9873 and then not Has_Static_Predicate (Etype (Discrim_Name))
9876 ("value of discriminant & is out of range", Discrim_Value, Discrim);
9877 Report_Errors := True;
9881 -- If we have found the corresponding choice, recursively add its
9882 -- components to the Into list. The nested components are part of
9883 -- the same record type.
9885 if Present (Variant) then
9886 if Discrim_Value_Status = Static_Subtype then
9888 Discrim_Value_Subtype_Intervals
9889 : constant Interval_Lists.Discrete_Interval_List
9890 := Interval_Lists.Type_Intervals (Discrim_Value_Subtype);
9893 : constant Interval_Lists.Discrete_Interval_List
9894 := Interval_Lists.Choice_List_Intervals
9895 (Discrete_Choices => Discrete_Choices (Variant));
9897 if not Interval_Lists.Is_Subset
9898 (Subset => Discrim_Value_Subtype_Intervals,
9899 Of_Set => Variant_Intervals)
9901 if OK_Scope_For_Discrim_Value_Error_Messages then
9903 ("no single variant is associated with all values of " &
9904 "the subtype of discriminant value &",
9905 Discrim_Value, Discrim);
9907 Report_Errors := True;
9914 (Typ, Component_List (Variant), Governed_By, Into,
9915 Report_Errors, Allow_Compile_Time);
9917 end Gather_Components;
9919 ------------------------
9920 -- Get_Actual_Subtype --
9921 ------------------------
9923 function Get_Actual_Subtype (N : Node_Id) return Entity_Id is
9924 Typ : constant Entity_Id := Etype (N);
9925 Utyp : Entity_Id := Underlying_Type (Typ);
9934 -- If what we have is an identifier that references a subprogram
9935 -- formal, or a variable or constant object, then we get the actual
9936 -- subtype from the referenced entity if one has been built.
9938 if Nkind (N) in N_Identifier | N_Expanded_Name
9940 (Is_Formal (Entity (N))
9941 or else Ekind (Entity (N)) = E_Constant
9942 or else Ekind (Entity (N)) = E_Variable)
9943 and then Present (Actual_Subtype (Entity (N)))
9945 return Actual_Subtype (Entity (N));
9947 -- Similarly, if we have an explicit dereference, then we get the
9948 -- actual subtype from the node itself if one has been built.
9950 elsif Nkind (N) = N_Explicit_Dereference
9951 and then Present (Actual_Designated_Subtype (N))
9953 return Actual_Designated_Subtype (N);
9955 -- Actual subtype of unchecked union is always itself. We never need
9956 -- the "real" actual subtype. If we did, we couldn't get it anyway
9957 -- because the discriminant is not available. The restrictions on
9958 -- Unchecked_Union are designed to make sure that this is OK.
9960 elsif Is_Unchecked_Union (Base_Type (Utyp)) then
9963 -- Here for the unconstrained case, we must find actual subtype
9964 -- No actual subtype is available, so we must build it on the fly.
9966 -- Checking the type, not the underlying type, for constrainedness
9967 -- seems to be necessary. Maybe all the tests should be on the type???
9969 elsif not Is_Constrained (Typ)
9970 and then (Is_Array_Type (Utyp)
9971 or else (Is_Record_Type (Utyp)
9972 and then Has_Discriminants (Utyp)))
9973 and then not Has_Unknown_Discriminants (Utyp)
9974 and then not (Ekind (Utyp) = E_String_Literal_Subtype)
9976 -- Nothing to do if in spec expression (why not???)
9978 if In_Spec_Expression then
9981 elsif Is_Private_Type (Typ) and then not Has_Discriminants (Typ) then
9983 -- If the type has no discriminants, there is no subtype to
9984 -- build, even if the underlying type is discriminated.
9988 -- Else build the actual subtype
9991 Decl := Build_Actual_Subtype (Typ, N);
9993 -- The call may yield a declaration, or just return the entity
9999 Atyp := Defining_Identifier (Decl);
10001 -- If Build_Actual_Subtype generated a new declaration then use it
10003 if Atyp /= Typ then
10005 -- The actual subtype is an Itype, so analyze the declaration,
10006 -- but do not attach it to the tree, to get the type defined.
10008 Set_Parent (Decl, N);
10009 Set_Is_Itype (Atyp);
10010 Analyze (Decl, Suppress => All_Checks);
10011 Set_Associated_Node_For_Itype (Atyp, N);
10012 if Expander_Active then
10013 Set_Has_Delayed_Freeze (Atyp, False);
10015 -- We need to freeze the actual subtype immediately. This is
10016 -- needed because otherwise this Itype will not get frozen
10017 -- at all; it is always safe to freeze on creation because
10018 -- any associated types must be frozen at this point.
10020 -- On the other hand, if we are performing preanalysis on
10021 -- a conjured-up copy of a name (see calls to
10022 -- Preanalyze_Range in sem_ch5.adb) then we don't want
10023 -- to freeze Atyp, now or ever. In this case, the tree
10024 -- we eventually pass to the back end should contain no
10025 -- references to Atyp (and a freeze node would contain
10026 -- such a reference). That's why Expander_Active is tested.
10028 Freeze_Itype (Atyp, N);
10032 -- Otherwise we did not build a declaration, so return original
10039 -- For all remaining cases, the actual subtype is the same as
10040 -- the nominal type.
10045 end Get_Actual_Subtype;
10047 -------------------------------------
10048 -- Get_Actual_Subtype_If_Available --
10049 -------------------------------------
10051 function Get_Actual_Subtype_If_Available (N : Node_Id) return Entity_Id is
10053 -- If what we have is an identifier that references a subprogram
10054 -- formal, or a variable or constant object, then we get the actual
10055 -- subtype from the referenced entity if one has been built.
10057 if Nkind (N) in N_Identifier | N_Expanded_Name
10059 (Is_Formal (Entity (N))
10060 or else Ekind (Entity (N)) = E_Constant
10061 or else Ekind (Entity (N)) = E_Variable)
10062 and then Present (Actual_Subtype (Entity (N)))
10064 return Actual_Subtype (Entity (N));
10066 -- Similarly, if we have an explicit dereference, then we get the
10067 -- actual subtype from the node itself if one has been built.
10069 elsif Nkind (N) = N_Explicit_Dereference
10070 and then Present (Actual_Designated_Subtype (N))
10072 return Actual_Designated_Subtype (N);
10074 -- Otherwise the Etype of N is returned unchanged
10079 end Get_Actual_Subtype_If_Available;
10081 ------------------------
10082 -- Get_Body_From_Stub --
10083 ------------------------
10085 function Get_Body_From_Stub (N : Node_Id) return Node_Id is
10087 return Proper_Body (Unit (Library_Unit (N)));
10088 end Get_Body_From_Stub;
10090 ---------------------
10091 -- Get_Cursor_Type --
10092 ---------------------
10094 function Get_Cursor_Type
10096 Typ : Entity_Id) return Entity_Id
10100 First_Op : Entity_Id;
10101 Cursor : Entity_Id;
10104 -- If error already detected, return
10106 if Error_Posted (Aspect) then
10110 -- The cursor type for an Iterable aspect is the return type of a
10111 -- non-overloaded First primitive operation. Locate association for
10114 Assoc := First (Component_Associations (Expression (Aspect)));
10115 First_Op := Any_Id;
10116 while Present (Assoc) loop
10117 if Chars (First (Choices (Assoc))) = Name_First then
10118 First_Op := Expression (Assoc);
10125 if First_Op = Any_Id then
10126 Error_Msg_N ("aspect Iterable must specify First operation", Aspect);
10129 elsif not Analyzed (First_Op) then
10130 Analyze (First_Op);
10133 Cursor := Any_Type;
10135 -- Locate function with desired name and profile in scope of type
10136 -- In the rare case where the type is an integer type, a base type
10137 -- is created for it, check that the base type of the first formal
10138 -- of First matches the base type of the domain.
10140 Func := First_Entity (Scope (Typ));
10141 while Present (Func) loop
10142 if Chars (Func) = Chars (First_Op)
10143 and then Ekind (Func) = E_Function
10144 and then Present (First_Formal (Func))
10145 and then Base_Type (Etype (First_Formal (Func))) = Base_Type (Typ)
10146 and then No (Next_Formal (First_Formal (Func)))
10148 if Cursor /= Any_Type then
10150 ("operation First for iterable type must be unique", Aspect);
10153 Cursor := Etype (Func);
10157 Next_Entity (Func);
10160 -- If not found, no way to resolve remaining primitives
10162 if Cursor = Any_Type then
10164 ("primitive operation for Iterable type must appear in the same "
10165 & "list of declarations as the type", Aspect);
10169 end Get_Cursor_Type;
10171 function Get_Cursor_Type (Typ : Entity_Id) return Entity_Id is
10173 return Etype (Get_Iterable_Type_Primitive (Typ, Name_First));
10174 end Get_Cursor_Type;
10176 -------------------------------
10177 -- Get_Default_External_Name --
10178 -------------------------------
10180 function Get_Default_External_Name (E : Node_Or_Entity_Id) return Node_Id is
10182 Get_Decoded_Name_String (Chars (E));
10184 if Opt.External_Name_Imp_Casing = Uppercase then
10185 Set_Casing (All_Upper_Case);
10187 Set_Casing (All_Lower_Case);
10191 Make_String_Literal (Sloc (E),
10192 Strval => String_From_Name_Buffer);
10193 end Get_Default_External_Name;
10195 --------------------------
10196 -- Get_Enclosing_Object --
10197 --------------------------
10199 function Get_Enclosing_Object (N : Node_Id) return Entity_Id is
10201 if Is_Entity_Name (N) then
10205 when N_Indexed_Component
10206 | N_Selected_Component
10209 -- If not generating code, a dereference may be left implicit.
10210 -- In thoses cases, return Empty.
10212 if Is_Access_Type (Etype (Prefix (N))) then
10215 return Get_Enclosing_Object (Prefix (N));
10218 when N_Type_Conversion =>
10219 return Get_Enclosing_Object (Expression (N));
10225 end Get_Enclosing_Object;
10227 -------------------------------
10228 -- Get_Enclosing_Deep_Object --
10229 -------------------------------
10231 function Get_Enclosing_Deep_Object (N : Node_Id) return Entity_Id is
10233 if Is_Entity_Name (N) then
10237 when N_Explicit_Dereference
10238 | N_Indexed_Component
10239 | N_Selected_Component
10242 return Get_Enclosing_Deep_Object (Prefix (N));
10244 when N_Type_Conversion =>
10245 return Get_Enclosing_Deep_Object (Expression (N));
10251 end Get_Enclosing_Deep_Object;
10253 ---------------------------
10254 -- Get_Enum_Lit_From_Pos --
10255 ---------------------------
10257 function Get_Enum_Lit_From_Pos
10260 Loc : Source_Ptr) return Node_Id
10262 Btyp : Entity_Id := Base_Type (T);
10267 -- In the case where the literal is of type Character, Wide_Character
10268 -- or Wide_Wide_Character or of a type derived from them, there needs
10269 -- to be some special handling since there is no explicit chain of
10270 -- literals to search. Instead, an N_Character_Literal node is created
10271 -- with the appropriate Char_Code and Chars fields.
10273 if Is_Standard_Character_Type (T) then
10274 Set_Character_Literal_Name (UI_To_CC (Pos));
10277 Make_Character_Literal (Loc,
10278 Chars => Name_Find,
10279 Char_Literal_Value => Pos);
10281 -- For all other cases, we have a complete table of literals, and
10282 -- we simply iterate through the chain of literal until the one
10283 -- with the desired position value is found.
10286 if Is_Private_Type (Btyp) and then Present (Full_View (Btyp)) then
10287 Btyp := Full_View (Btyp);
10290 Lit := First_Literal (Btyp);
10292 -- Position in the enumeration type starts at 0
10295 raise Constraint_Error;
10298 for J in 1 .. UI_To_Int (Pos) loop
10299 Next_Literal (Lit);
10301 -- If Lit is Empty, Pos is not in range, so raise Constraint_Error
10302 -- inside the loop to avoid calling Next_Literal on Empty.
10305 raise Constraint_Error;
10309 -- Create a new node from Lit, with source location provided by Loc
10310 -- if not equal to No_Location, or by copying the source location of
10315 if LLoc = No_Location then
10316 LLoc := Sloc (Lit);
10319 return New_Occurrence_Of (Lit, LLoc);
10321 end Get_Enum_Lit_From_Pos;
10323 ----------------------
10324 -- Get_Fullest_View --
10325 ----------------------
10327 function Get_Fullest_View
10329 Include_PAT : Boolean := True;
10330 Recurse : Boolean := True) return Entity_Id
10332 New_E : Entity_Id := Empty;
10335 -- Prevent cascaded errors
10341 -- Look at each kind of entity to see where we may need to go deeper.
10344 when Incomplete_Kind =>
10345 if From_Limited_With (E) then
10346 New_E := Non_Limited_View (E);
10347 elsif Present (Full_View (E)) then
10348 New_E := Full_View (E);
10349 elsif Ekind (E) = E_Incomplete_Subtype then
10350 New_E := Etype (E);
10353 when Private_Kind =>
10354 if Present (Underlying_Full_View (E)) then
10355 New_E := Underlying_Full_View (E);
10356 elsif Present (Full_View (E)) then
10357 New_E := Full_View (E);
10358 elsif Etype (E) /= E then
10359 New_E := Etype (E);
10363 if Include_PAT and then Present (Packed_Array_Impl_Type (E)) then
10364 New_E := Packed_Array_Impl_Type (E);
10367 when E_Record_Subtype =>
10368 if Present (Cloned_Subtype (E)) then
10369 New_E := Cloned_Subtype (E);
10372 when E_Class_Wide_Type =>
10373 New_E := Root_Type (E);
10375 when E_Class_Wide_Subtype =>
10376 if Present (Equivalent_Type (E)) then
10377 New_E := Equivalent_Type (E);
10378 elsif Present (Cloned_Subtype (E)) then
10379 New_E := Cloned_Subtype (E);
10382 when E_Protected_Subtype
10387 if Present (Corresponding_Record_Type (E)) then
10388 New_E := Corresponding_Record_Type (E);
10391 when E_Access_Protected_Subprogram_Type
10392 | E_Anonymous_Access_Protected_Subprogram_Type
10394 if Present (Equivalent_Type (E)) then
10395 New_E := Equivalent_Type (E);
10398 when E_Access_Subtype =>
10399 New_E := Base_Type (E);
10405 -- If we found a fuller view, either return it or recurse. Otherwise,
10406 -- return our input.
10408 return (if No (New_E) then E
10409 elsif Recurse then Get_Fullest_View (New_E, Include_PAT, Recurse)
10411 end Get_Fullest_View;
10413 ------------------------
10414 -- Get_Generic_Entity --
10415 ------------------------
10417 function Get_Generic_Entity (N : Node_Id) return Entity_Id is
10418 Ent : constant Entity_Id := Entity (Name (N));
10420 if Present (Renamed_Entity (Ent)) then
10421 return Renamed_Entity (Ent);
10425 end Get_Generic_Entity;
10427 -------------------------------------
10428 -- Get_Incomplete_View_Of_Ancestor --
10429 -------------------------------------
10431 function Get_Incomplete_View_Of_Ancestor (E : Entity_Id) return Entity_Id is
10432 Cur_Unit : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
10433 Par_Scope : Entity_Id;
10434 Par_Type : Entity_Id;
10437 -- The incomplete view of an ancestor is only relevant for private
10438 -- derived types in child units.
10440 if not Is_Derived_Type (E)
10441 or else not Is_Child_Unit (Cur_Unit)
10446 Par_Scope := Scope (Cur_Unit);
10447 if No (Par_Scope) then
10451 Par_Type := Etype (Base_Type (E));
10453 -- Traverse list of ancestor types until we find one declared in
10454 -- a parent or grandparent unit (two levels seem sufficient).
10456 while Present (Par_Type) loop
10457 if Scope (Par_Type) = Par_Scope
10458 or else Scope (Par_Type) = Scope (Par_Scope)
10462 elsif not Is_Derived_Type (Par_Type) then
10466 Par_Type := Etype (Base_Type (Par_Type));
10470 -- If none found, there is no relevant ancestor type.
10474 end Get_Incomplete_View_Of_Ancestor;
10476 ----------------------
10477 -- Get_Index_Bounds --
10478 ----------------------
10480 procedure Get_Index_Bounds
10484 Use_Full_View : Boolean := False)
10486 function Scalar_Range_Of_Type (Typ : Entity_Id) return Node_Id;
10487 -- Obtain the scalar range of type Typ. If flag Use_Full_View is set and
10488 -- Typ qualifies, the scalar range is obtained from the full view of the
10491 --------------------------
10492 -- Scalar_Range_Of_Type --
10493 --------------------------
10495 function Scalar_Range_Of_Type (Typ : Entity_Id) return Node_Id is
10496 T : Entity_Id := Typ;
10499 if Use_Full_View and then Present (Full_View (T)) then
10500 T := Full_View (T);
10503 return Scalar_Range (T);
10504 end Scalar_Range_Of_Type;
10508 Kind : constant Node_Kind := Nkind (N);
10511 -- Start of processing for Get_Index_Bounds
10514 if Kind = N_Range then
10515 L := Low_Bound (N);
10516 H := High_Bound (N);
10518 elsif Kind = N_Subtype_Indication then
10519 Rng := Range_Expression (Constraint (N));
10521 if Rng = Error then
10527 L := Low_Bound (Range_Expression (Constraint (N)));
10528 H := High_Bound (Range_Expression (Constraint (N)));
10531 elsif Is_Entity_Name (N) and then Is_Type (Entity (N)) then
10532 Rng := Scalar_Range_Of_Type (Entity (N));
10534 if Error_Posted (Rng) then
10538 elsif Nkind (Rng) = N_Subtype_Indication then
10539 Get_Index_Bounds (Rng, L, H);
10542 L := Low_Bound (Rng);
10543 H := High_Bound (Rng);
10547 -- N is an expression, indicating a range with one value
10552 end Get_Index_Bounds;
10554 function Get_Index_Bounds
10556 Use_Full_View : Boolean := False) return Range_Nodes is
10557 Result : Range_Nodes;
10559 Get_Index_Bounds (N, Result.First, Result.Last, Use_Full_View);
10561 end Get_Index_Bounds;
10563 function Get_Index_Bounds
10565 Use_Full_View : Boolean := False) return Range_Values is
10566 Nodes : constant Range_Nodes := Get_Index_Bounds (N, Use_Full_View);
10568 return (Expr_Value (Nodes.First), Expr_Value (Nodes.Last));
10569 end Get_Index_Bounds;
10571 -----------------------------
10572 -- Get_Interfacing_Aspects --
10573 -----------------------------
10575 procedure Get_Interfacing_Aspects
10576 (Iface_Asp : Node_Id;
10577 Conv_Asp : out Node_Id;
10578 EN_Asp : out Node_Id;
10579 Expo_Asp : out Node_Id;
10580 Imp_Asp : out Node_Id;
10581 LN_Asp : out Node_Id;
10582 Do_Checks : Boolean := False)
10584 procedure Save_Or_Duplication_Error
10586 To : in out Node_Id);
10587 -- Save the value of aspect Asp in node To. If To already has a value,
10588 -- then this is considered a duplicate use of aspect. Emit an error if
10589 -- flag Do_Checks is set.
10591 -------------------------------
10592 -- Save_Or_Duplication_Error --
10593 -------------------------------
10595 procedure Save_Or_Duplication_Error
10597 To : in out Node_Id)
10600 -- Detect an extra aspect and issue an error
10602 if Present (To) then
10604 Error_Msg_Name_1 := Chars (Identifier (Asp));
10605 Error_Msg_Sloc := Sloc (To);
10606 Error_Msg_N ("aspect % previously given #", Asp);
10609 -- Otherwise capture the aspect
10614 end Save_Or_Duplication_Error;
10619 Asp_Id : Aspect_Id;
10621 -- The following variables capture each individual aspect
10623 Conv : Node_Id := Empty;
10624 EN : Node_Id := Empty;
10625 Expo : Node_Id := Empty;
10626 Imp : Node_Id := Empty;
10627 LN : Node_Id := Empty;
10629 -- Start of processing for Get_Interfacing_Aspects
10632 -- The input interfacing aspect should reside in an aspect specification
10635 pragma Assert (Is_List_Member (Iface_Asp));
10637 -- Examine the aspect specifications of the related entity. Find and
10638 -- capture all interfacing aspects. Detect duplicates and emit errors
10641 Asp := First (List_Containing (Iface_Asp));
10642 while Present (Asp) loop
10643 Asp_Id := Get_Aspect_Id (Asp);
10645 if Asp_Id = Aspect_Convention then
10646 Save_Or_Duplication_Error (Asp, Conv);
10648 elsif Asp_Id = Aspect_External_Name then
10649 Save_Or_Duplication_Error (Asp, EN);
10651 elsif Asp_Id = Aspect_Export then
10652 Save_Or_Duplication_Error (Asp, Expo);
10654 elsif Asp_Id = Aspect_Import then
10655 Save_Or_Duplication_Error (Asp, Imp);
10657 elsif Asp_Id = Aspect_Link_Name then
10658 Save_Or_Duplication_Error (Asp, LN);
10669 end Get_Interfacing_Aspects;
10671 ---------------------------------
10672 -- Get_Iterable_Type_Primitive --
10673 ---------------------------------
10675 function Get_Iterable_Type_Primitive
10677 Nam : Name_Id) return Entity_Id
10682 Nam in Name_Element
10689 Funcs : constant Node_Id := Find_Value_Of_Aspect (Typ, Aspect_Iterable);
10697 Assoc := First (Component_Associations (Funcs));
10698 while Present (Assoc) loop
10699 if Chars (First (Choices (Assoc))) = Nam then
10700 return Entity (Expression (Assoc));
10708 end Get_Iterable_Type_Primitive;
10710 ---------------------------
10711 -- Get_Library_Unit_Name --
10712 ---------------------------
10714 function Get_Library_Unit_Name (Decl_Node : Node_Id) return String_Id is
10715 Unit_Name_Id : constant Unit_Name_Type := Get_Unit_Name (Decl_Node);
10716 Buf : Bounded_String;
10718 Get_Unit_Name_String (Buf, Unit_Name_Id);
10720 -- Remove the last seven characters (" (spec)" or " (body)")
10722 Buf.Length := Buf.Length - 7;
10723 pragma Assert (Buf.Chars (Buf.Length + 1) = ' ');
10725 return String_From_Name_Buffer (Buf);
10726 end Get_Library_Unit_Name;
10728 --------------------------
10729 -- Get_Max_Queue_Length --
10730 --------------------------
10732 function Get_Max_Queue_Length (Id : Entity_Id) return Uint is
10733 pragma Assert (Is_Entry (Id));
10734 Prag : constant Entity_Id := Get_Pragma (Id, Pragma_Max_Queue_Length);
10738 -- A value of 0 or -1 represents no maximum specified, and entries and
10739 -- entry families with no Max_Queue_Length aspect or pragma default to
10747 (Expression (First (Pragma_Argument_Associations (Prag))));
10749 -- Since -1 and 0 are equivalent, return 0 for instances of -1 for
10757 end Get_Max_Queue_Length;
10759 ------------------------
10760 -- Get_Name_Entity_Id --
10761 ------------------------
10763 function Get_Name_Entity_Id (Id : Name_Id) return Entity_Id is
10765 return Entity_Id (Get_Name_Table_Int (Id));
10766 end Get_Name_Entity_Id;
10768 ------------------------------
10769 -- Get_Name_From_CTC_Pragma --
10770 ------------------------------
10772 function Get_Name_From_CTC_Pragma (N : Node_Id) return String_Id is
10773 Arg : constant Node_Id :=
10774 Get_Pragma_Arg (First (Pragma_Argument_Associations (N)));
10776 return Strval (Expr_Value_S (Arg));
10777 end Get_Name_From_CTC_Pragma;
10779 -----------------------
10780 -- Get_Parent_Entity --
10781 -----------------------
10783 function Get_Parent_Entity (Unit : Node_Id) return Entity_Id is
10785 if Nkind (Unit) = N_Package_Body
10786 and then Nkind (Original_Node (Unit)) = N_Package_Instantiation
10788 return Defining_Entity
10789 (Specification (Instance_Spec (Original_Node (Unit))));
10790 elsif Nkind (Unit) = N_Package_Instantiation then
10791 return Defining_Entity (Specification (Instance_Spec (Unit)));
10793 return Defining_Entity (Unit);
10795 end Get_Parent_Entity;
10797 -------------------
10798 -- Get_Pragma_Id --
10799 -------------------
10801 function Get_Pragma_Id (N : Node_Id) return Pragma_Id is
10803 return Get_Pragma_Id (Pragma_Name_Unmapped (N));
10806 ------------------------
10807 -- Get_Qualified_Name --
10808 ------------------------
10810 function Get_Qualified_Name
10812 Suffix : Entity_Id := Empty) return Name_Id
10814 Suffix_Nam : Name_Id := No_Name;
10817 if Present (Suffix) then
10818 Suffix_Nam := Chars (Suffix);
10821 return Get_Qualified_Name (Chars (Id), Suffix_Nam, Scope (Id));
10822 end Get_Qualified_Name;
10824 function Get_Qualified_Name
10826 Suffix : Name_Id := No_Name;
10827 Scop : Entity_Id := Current_Scope) return Name_Id
10829 procedure Add_Scope (S : Entity_Id);
10830 -- Add the fully qualified form of scope S to the name buffer. The
10838 procedure Add_Scope (S : Entity_Id) is
10843 elsif S = Standard_Standard then
10847 Add_Scope (Scope (S));
10848 Get_Name_String_And_Append (Chars (S));
10849 Add_Str_To_Name_Buffer ("__");
10853 -- Start of processing for Get_Qualified_Name
10859 -- Append the base name after all scopes have been chained
10861 Get_Name_String_And_Append (Nam);
10863 -- Append the suffix (if present)
10865 if Suffix /= No_Name then
10866 Add_Str_To_Name_Buffer ("__");
10867 Get_Name_String_And_Append (Suffix);
10871 end Get_Qualified_Name;
10873 -----------------------
10874 -- Get_Reason_String --
10875 -----------------------
10877 procedure Get_Reason_String (N : Node_Id) is
10879 if Nkind (N) = N_String_Literal then
10880 Store_String_Chars (Strval (N));
10882 elsif Nkind (N) = N_Op_Concat then
10883 Get_Reason_String (Left_Opnd (N));
10884 Get_Reason_String (Right_Opnd (N));
10886 -- If not of required form, error
10890 ("Reason for pragma Warnings has wrong form", N);
10892 ("\must be string literal or concatenation of string literals", N);
10895 end Get_Reason_String;
10897 --------------------------------
10898 -- Get_Reference_Discriminant --
10899 --------------------------------
10901 function Get_Reference_Discriminant (Typ : Entity_Id) return Entity_Id is
10905 D := First_Discriminant (Typ);
10906 while Present (D) loop
10907 if Has_Implicit_Dereference (D) then
10910 Next_Discriminant (D);
10914 end Get_Reference_Discriminant;
10916 ---------------------------
10917 -- Get_Referenced_Object --
10918 ---------------------------
10920 function Get_Referenced_Object (N : Node_Id) return Node_Id is
10925 while Is_Entity_Name (R)
10926 and then Is_Object (Entity (R))
10927 and then Present (Renamed_Object (Entity (R)))
10929 R := Renamed_Object (Entity (R));
10933 end Get_Referenced_Object;
10935 ------------------------
10936 -- Get_Renamed_Entity --
10937 ------------------------
10939 function Get_Renamed_Entity (E : Entity_Id) return Entity_Id is
10940 R : Entity_Id := E;
10942 while Present (Renamed_Entity (R)) loop
10943 R := Renamed_Entity (R);
10947 end Get_Renamed_Entity;
10949 -----------------------
10950 -- Get_Return_Object --
10951 -----------------------
10953 function Get_Return_Object (N : Node_Id) return Entity_Id is
10957 Decl := First (Return_Object_Declarations (N));
10958 while Present (Decl) loop
10959 exit when Nkind (Decl) = N_Object_Declaration
10960 and then Is_Return_Object (Defining_Identifier (Decl));
10964 pragma Assert (Present (Decl));
10965 return Defining_Identifier (Decl);
10966 end Get_Return_Object;
10968 ---------------------------
10969 -- Get_Subprogram_Entity --
10970 ---------------------------
10972 function Get_Subprogram_Entity (Nod : Node_Id) return Entity_Id is
10974 Subp_Id : Entity_Id;
10977 if Nkind (Nod) = N_Accept_Statement then
10978 Subp := Entry_Direct_Name (Nod);
10980 elsif Nkind (Nod) = N_Slice then
10981 Subp := Prefix (Nod);
10984 Subp := Name (Nod);
10987 -- Strip the subprogram call
10990 if Nkind (Subp) in N_Explicit_Dereference
10991 | N_Indexed_Component
10992 | N_Selected_Component
10994 Subp := Prefix (Subp);
10996 elsif Nkind (Subp) in N_Type_Conversion
10997 | N_Unchecked_Type_Conversion
10999 Subp := Expression (Subp);
11006 -- Extract the entity of the subprogram call
11008 if Is_Entity_Name (Subp) then
11009 Subp_Id := Entity (Subp);
11011 if Ekind (Subp_Id) = E_Access_Subprogram_Type then
11012 Subp_Id := Directly_Designated_Type (Subp_Id);
11015 if Is_Subprogram (Subp_Id) then
11021 -- The search did not find a construct that denotes a subprogram
11026 end Get_Subprogram_Entity;
11028 -----------------------------
11029 -- Get_Task_Body_Procedure --
11030 -----------------------------
11032 function Get_Task_Body_Procedure (E : Entity_Id) return Entity_Id is
11034 -- Note: A task type may be the completion of a private type with
11035 -- discriminants. When performing elaboration checks on a task
11036 -- declaration, the current view of the type may be the private one,
11037 -- and the procedure that holds the body of the task is held in its
11038 -- underlying type.
11040 -- This is an odd function, why not have Task_Body_Procedure do
11041 -- the following digging???
11043 return Task_Body_Procedure (Underlying_Type (Root_Type (E)));
11044 end Get_Task_Body_Procedure;
11046 -------------------------------
11047 -- Get_User_Defined_Equality --
11048 -------------------------------
11050 function Get_User_Defined_Equality (E : Entity_Id) return Entity_Id is
11054 Prim := First_Elmt (Collect_Primitive_Operations (E));
11055 while Present (Prim) loop
11056 if Is_User_Defined_Equality (Node (Prim)) then
11057 return Node (Prim);
11064 end Get_User_Defined_Equality;
11070 procedure Get_Views
11072 Priv_Typ : out Entity_Id;
11073 Full_Typ : out Entity_Id;
11074 UFull_Typ : out Entity_Id;
11075 CRec_Typ : out Entity_Id)
11077 IP_View : Entity_Id;
11080 -- Assume that none of the views can be recovered
11084 UFull_Typ := Empty;
11087 -- The input type is the corresponding record type of a protected or a
11090 if Ekind (Typ) = E_Record_Type
11091 and then Is_Concurrent_Record_Type (Typ)
11094 Full_Typ := Corresponding_Concurrent_Type (CRec_Typ);
11095 Priv_Typ := Incomplete_Or_Partial_View (Full_Typ);
11097 -- Otherwise the input type denotes an arbitrary type
11100 IP_View := Incomplete_Or_Partial_View (Typ);
11102 -- The input type denotes the full view of a private type
11104 if Present (IP_View) then
11105 Priv_Typ := IP_View;
11108 -- The input type is a private type
11110 elsif Is_Private_Type (Typ) then
11112 Full_Typ := Full_View (Priv_Typ);
11114 -- Otherwise the input type does not have any views
11120 if Present (Full_Typ) and then Is_Private_Type (Full_Typ) then
11121 UFull_Typ := Underlying_Full_View (Full_Typ);
11123 if Present (UFull_Typ)
11124 and then Ekind (UFull_Typ) in E_Protected_Type | E_Task_Type
11126 CRec_Typ := Corresponding_Record_Type (UFull_Typ);
11130 if Present (Full_Typ)
11131 and then Ekind (Full_Typ) in E_Protected_Type | E_Task_Type
11133 CRec_Typ := Corresponding_Record_Type (Full_Typ);
11139 ------------------------------
11140 -- Has_Compatible_Alignment --
11141 ------------------------------
11143 function Has_Compatible_Alignment
11146 Layout_Done : Boolean) return Alignment_Result
11148 function Has_Compatible_Alignment_Internal
11151 Layout_Done : Boolean;
11152 Default : Alignment_Result) return Alignment_Result;
11153 -- This is the internal recursive function that actually does the work.
11154 -- There is one additional parameter, which says what the result should
11155 -- be if no alignment information is found, and there is no definite
11156 -- indication of compatible alignments. At the outer level, this is set
11157 -- to Unknown, but for internal recursive calls in the case where types
11158 -- are known to be correct, it is set to Known_Compatible.
11160 ---------------------------------------
11161 -- Has_Compatible_Alignment_Internal --
11162 ---------------------------------------
11164 function Has_Compatible_Alignment_Internal
11167 Layout_Done : Boolean;
11168 Default : Alignment_Result) return Alignment_Result
11170 Result : Alignment_Result := Known_Compatible;
11171 -- Holds the current status of the result. Note that once a value of
11172 -- Known_Incompatible is set, it is sticky and does not get changed
11173 -- to Unknown (the value in Result only gets worse as we go along,
11176 Offs : Uint := No_Uint;
11177 -- Set to a factor of the offset from the base object when Expr is a
11178 -- selected or indexed component, based on Component_Bit_Offset and
11179 -- Component_Size respectively. A negative value is used to represent
11180 -- a value that is not known at compile time.
11182 procedure Check_Prefix;
11183 -- Checks the prefix recursively in the case where the expression
11184 -- is an indexed or selected component.
11186 procedure Set_Result (R : Alignment_Result);
11187 -- If R represents a worse outcome (unknown instead of known
11188 -- compatible, or known incompatible), then set Result to R.
11194 procedure Check_Prefix is
11196 -- The subtlety here is that in doing a recursive call to check
11197 -- the prefix, we have to decide what to do in the case where we
11198 -- don't find any specific indication of an alignment problem.
11200 -- At the outer level, we normally set Unknown as the result in
11201 -- this case, since we can only set Known_Compatible if we really
11202 -- know that the alignment value is OK, but for the recursive
11203 -- call, in the case where the types match, and we have not
11204 -- specified a peculiar alignment for the object, we are only
11205 -- concerned about suspicious rep clauses, the default case does
11206 -- not affect us, since the compiler will, in the absence of such
11207 -- rep clauses, ensure that the alignment is correct.
11209 if Default = Known_Compatible
11211 (Etype (Obj) = Etype (Expr)
11212 and then (not Known_Alignment (Obj)
11214 Alignment (Obj) = Alignment (Etype (Obj))))
11217 (Has_Compatible_Alignment_Internal
11218 (Obj, Prefix (Expr), Layout_Done, Known_Compatible));
11220 -- In all other cases, we need a full check on the prefix
11224 (Has_Compatible_Alignment_Internal
11225 (Obj, Prefix (Expr), Layout_Done, Unknown));
11233 procedure Set_Result (R : Alignment_Result) is
11240 -- Start of processing for Has_Compatible_Alignment_Internal
11243 -- If Expr is a selected component, we must make sure there is no
11244 -- potentially troublesome component clause and that the record is
11245 -- not packed if the layout is not done.
11247 if Nkind (Expr) = N_Selected_Component then
11249 -- Packing generates unknown alignment if layout is not done
11251 if Is_Packed (Etype (Prefix (Expr))) and then not Layout_Done then
11252 Set_Result (Unknown);
11255 -- Check prefix and component offset
11258 Offs := Component_Bit_Offset (Entity (Selector_Name (Expr)));
11260 -- If Expr is an indexed component, we must make sure there is no
11261 -- potentially troublesome Component_Size clause and that the array
11262 -- is not bit-packed if the layout is not done.
11264 elsif Nkind (Expr) = N_Indexed_Component then
11266 Typ : constant Entity_Id := Etype (Prefix (Expr));
11269 -- Packing generates unknown alignment if layout is not done
11271 if Is_Bit_Packed_Array (Typ) and then not Layout_Done then
11272 Set_Result (Unknown);
11275 -- Check prefix and component offset (or at least size)
11278 Offs := Indexed_Component_Bit_Offset (Expr);
11280 Offs := Component_Size (Typ);
11285 -- If we have a null offset, the result is entirely determined by
11286 -- the base object and has already been computed recursively.
11288 if Present (Offs) and then Offs = Uint_0 then
11291 -- Case where we know the alignment of the object
11293 elsif Known_Alignment (Obj) then
11295 ObjA : constant Uint := Alignment (Obj);
11296 ExpA : Uint := No_Uint;
11297 SizA : Uint := No_Uint;
11300 -- If alignment of Obj is 1, then we are always OK
11303 Set_Result (Known_Compatible);
11305 -- Alignment of Obj is greater than 1, so we need to check
11308 -- If we have an offset, see if it is compatible
11310 if Present (Offs) and then Offs > Uint_0 then
11311 if Offs mod (System_Storage_Unit * ObjA) /= 0 then
11312 Set_Result (Known_Incompatible);
11315 -- See if Expr is an object with known alignment
11317 elsif Is_Entity_Name (Expr)
11318 and then Known_Alignment (Entity (Expr))
11321 ExpA := Alignment (Entity (Expr));
11323 -- Otherwise, we can use the alignment of the type of Expr
11324 -- given that we already checked for discombobulating rep
11325 -- clauses for the cases of indexed and selected components
11328 elsif Known_Alignment (Etype (Expr)) then
11329 ExpA := Alignment (Etype (Expr));
11331 -- Otherwise the alignment is unknown
11334 Set_Result (Default);
11337 -- If we got an alignment, see if it is acceptable
11339 if Present (ExpA) and then ExpA < ObjA then
11340 Set_Result (Known_Incompatible);
11343 -- If Expr is a component or an entire object with a known
11344 -- alignment, then we are fine. Otherwise, if its size is
11345 -- known, it must be big enough for the required alignment.
11347 if Present (Offs) then
11350 -- See if Expr is an object with known size
11352 elsif Is_Entity_Name (Expr)
11353 and then Known_Static_Esize (Entity (Expr))
11355 SizA := Esize (Entity (Expr));
11357 -- Otherwise, we check the object size of the Expr type
11359 elsif Known_Static_Esize (Etype (Expr)) then
11360 SizA := Esize (Etype (Expr));
11363 -- If we got a size, see if it is a multiple of the Obj
11364 -- alignment; if not, then the alignment cannot be
11365 -- acceptable, since the size is always a multiple of the
11368 if Present (SizA) then
11369 if SizA mod (ObjA * Ttypes.System_Storage_Unit) /= 0 then
11370 Set_Result (Known_Incompatible);
11376 -- If we do not know required alignment, any non-zero offset is a
11377 -- potential problem (but certainly may be OK, so result is unknown).
11379 elsif Present (Offs) then
11380 Set_Result (Unknown);
11382 -- If we can't find the result by direct comparison of alignment
11383 -- values, then there is still one case that we can determine known
11384 -- result, and that is when we can determine that the types are the
11385 -- same, and no alignments are specified. Then we known that the
11386 -- alignments are compatible, even if we don't know the alignment
11387 -- value in the front end.
11389 elsif Etype (Obj) = Etype (Expr) then
11391 -- Types are the same, but we have to check for possible size
11392 -- and alignments on the Expr object that may make the alignment
11393 -- different, even though the types are the same.
11395 if Is_Entity_Name (Expr) then
11397 -- First check alignment of the Expr object. Any alignment less
11398 -- than Maximum_Alignment is worrisome since this is the case
11399 -- where we do not know the alignment of Obj.
11401 if Known_Alignment (Entity (Expr))
11402 and then Alignment (Entity (Expr)) < Ttypes.Maximum_Alignment
11404 Set_Result (Unknown);
11406 -- Now check size of Expr object. Any size that is not an even
11407 -- multiple of Maximum_Alignment is also worrisome since it
11408 -- may cause the alignment of the object to be less than the
11409 -- alignment of the type.
11411 elsif Known_Static_Esize (Entity (Expr))
11413 Esize (Entity (Expr)) mod
11414 (Ttypes.Maximum_Alignment * Ttypes.System_Storage_Unit)
11417 Set_Result (Unknown);
11419 -- Otherwise same type is decisive
11422 Set_Result (Known_Compatible);
11426 -- Another case to deal with is when there is an explicit size or
11427 -- alignment clause when the types are not the same. If so, then the
11428 -- result is Unknown. We don't need to do this test if the Default is
11429 -- Unknown, since that result will be set in any case.
11431 elsif Default /= Unknown
11432 and then (Has_Size_Clause (Etype (Expr))
11434 Has_Alignment_Clause (Etype (Expr)))
11436 Set_Result (Unknown);
11438 -- If no indication found, set default
11441 Set_Result (Default);
11444 -- Return worst result found
11447 end Has_Compatible_Alignment_Internal;
11449 -- Start of processing for Has_Compatible_Alignment
11452 -- If Obj has no specified alignment, then set alignment from the type
11453 -- alignment. Perhaps we should always do this, but for sure we should
11454 -- do it when there is an address clause since we can do more if the
11455 -- alignment is known.
11457 if not Known_Alignment (Obj) and then Known_Alignment (Etype (Obj)) then
11458 Set_Alignment (Obj, Alignment (Etype (Obj)));
11461 -- Now do the internal call that does all the work
11464 Has_Compatible_Alignment_Internal (Obj, Expr, Layout_Done, Unknown);
11465 end Has_Compatible_Alignment;
11467 ----------------------
11468 -- Has_Declarations --
11469 ----------------------
11471 function Has_Declarations (N : Node_Id) return Boolean is
11473 return Nkind (N) in N_Accept_Statement
11474 | N_Block_Statement
11475 | N_Compilation_Unit_Aux
11479 | N_Subprogram_Body
11481 | N_Package_Specification;
11482 end Has_Declarations;
11484 ---------------------------------
11485 -- Has_Defaulted_Discriminants --
11486 ---------------------------------
11488 function Has_Defaulted_Discriminants (Typ : Entity_Id) return Boolean is
11490 return Has_Discriminants (Typ)
11491 and then Present (Discriminant_Default_Value
11492 (First_Discriminant (Typ)));
11493 end Has_Defaulted_Discriminants;
11495 -------------------
11496 -- Has_Denormals --
11497 -------------------
11499 function Has_Denormals (E : Entity_Id) return Boolean is
11501 return Is_Floating_Point_Type (E) and then Denorm_On_Target;
11504 -------------------------------------------
11505 -- Has_Discriminant_Dependent_Constraint --
11506 -------------------------------------------
11508 function Has_Discriminant_Dependent_Constraint
11509 (Comp : Entity_Id) return Boolean
11511 Comp_Decl : constant Node_Id := Parent (Comp);
11512 Subt_Indic : Node_Id;
11517 -- Discriminants can't depend on discriminants
11519 if Ekind (Comp) = E_Discriminant then
11523 Subt_Indic := Subtype_Indication (Component_Definition (Comp_Decl));
11525 if Nkind (Subt_Indic) = N_Subtype_Indication then
11526 Constr := Constraint (Subt_Indic);
11528 if Nkind (Constr) = N_Index_Or_Discriminant_Constraint then
11529 Assn := First (Constraints (Constr));
11530 while Present (Assn) loop
11531 case Nkind (Assn) is
11534 | N_Subtype_Indication
11536 if Depends_On_Discriminant (Assn) then
11540 when N_Discriminant_Association =>
11541 if Depends_On_Discriminant (Expression (Assn)) then
11556 end Has_Discriminant_Dependent_Constraint;
11558 --------------------------------------
11559 -- Has_Effectively_Volatile_Profile --
11560 --------------------------------------
11562 function Has_Effectively_Volatile_Profile
11563 (Subp_Id : Entity_Id) return Boolean
11565 Formal : Entity_Id;
11568 -- Inspect the formal parameters looking for an effectively volatile
11569 -- type for reading.
11571 Formal := First_Formal (Subp_Id);
11572 while Present (Formal) loop
11573 if Is_Effectively_Volatile_For_Reading (Etype (Formal)) then
11577 Next_Formal (Formal);
11580 -- Inspect the return type of functions
11582 if Ekind (Subp_Id) in E_Function | E_Generic_Function
11583 and then Is_Effectively_Volatile_For_Reading (Etype (Subp_Id))
11589 end Has_Effectively_Volatile_Profile;
11591 --------------------------
11592 -- Has_Enabled_Property --
11593 --------------------------
11595 function Has_Enabled_Property
11596 (Item_Id : Entity_Id;
11597 Property : Name_Id) return Boolean
11599 function Protected_Type_Or_Variable_Has_Enabled_Property return Boolean;
11600 -- Determine whether a protected type or variable denoted by Item_Id
11601 -- has the property enabled.
11603 function State_Has_Enabled_Property return Boolean;
11604 -- Determine whether a state denoted by Item_Id has the property enabled
11606 function Type_Or_Variable_Has_Enabled_Property
11607 (Item_Id : Entity_Id) return Boolean;
11608 -- Determine whether type or variable denoted by Item_Id has the
11609 -- property enabled.
11611 -----------------------------------------------------
11612 -- Protected_Type_Or_Variable_Has_Enabled_Property --
11613 -----------------------------------------------------
11615 function Protected_Type_Or_Variable_Has_Enabled_Property return Boolean
11618 -- Protected entities always have the properties Async_Readers and
11619 -- Async_Writers (SPARK RM 7.1.2(16)).
11621 if Property = Name_Async_Readers
11622 or else Property = Name_Async_Writers
11626 -- Protected objects that have Part_Of components also inherit their
11627 -- properties Effective_Reads and Effective_Writes
11628 -- (SPARK RM 7.1.2(16)).
11630 elsif Is_Single_Protected_Object (Item_Id) then
11632 Constit_Elmt : Elmt_Id;
11633 Constit_Id : Entity_Id;
11634 Constits : constant Elist_Id
11635 := Part_Of_Constituents (Item_Id);
11637 if Present (Constits) then
11638 Constit_Elmt := First_Elmt (Constits);
11639 while Present (Constit_Elmt) loop
11640 Constit_Id := Node (Constit_Elmt);
11642 if Has_Enabled_Property (Constit_Id, Property) then
11646 Next_Elmt (Constit_Elmt);
11653 end Protected_Type_Or_Variable_Has_Enabled_Property;
11655 --------------------------------
11656 -- State_Has_Enabled_Property --
11657 --------------------------------
11659 function State_Has_Enabled_Property return Boolean is
11660 Decl : constant Node_Id := Parent (Item_Id);
11662 procedure Find_Simple_Properties
11663 (Has_External : out Boolean;
11664 Has_Synchronous : out Boolean);
11665 -- Extract the simple properties associated with declaration Decl
11667 function Is_Enabled_External_Property return Boolean;
11668 -- Determine whether property Property appears within the external
11669 -- property list of declaration Decl, and return its status.
11671 ----------------------------
11672 -- Find_Simple_Properties --
11673 ----------------------------
11675 procedure Find_Simple_Properties
11676 (Has_External : out Boolean;
11677 Has_Synchronous : out Boolean)
11682 -- Assume that none of the properties are available
11684 Has_External := False;
11685 Has_Synchronous := False;
11687 Opt := First (Expressions (Decl));
11688 while Present (Opt) loop
11689 if Nkind (Opt) = N_Identifier then
11690 if Chars (Opt) = Name_External then
11691 Has_External := True;
11693 elsif Chars (Opt) = Name_Synchronous then
11694 Has_Synchronous := True;
11700 end Find_Simple_Properties;
11702 ----------------------------------
11703 -- Is_Enabled_External_Property --
11704 ----------------------------------
11706 function Is_Enabled_External_Property return Boolean is
11710 Prop_Nam : Node_Id;
11714 Opt := First (Component_Associations (Decl));
11715 while Present (Opt) loop
11716 Opt_Nam := First (Choices (Opt));
11718 if Nkind (Opt_Nam) = N_Identifier
11719 and then Chars (Opt_Nam) = Name_External
11721 Props := Expression (Opt);
11723 -- Multiple properties appear as an aggregate
11725 if Nkind (Props) = N_Aggregate then
11727 -- Simple property form
11729 Prop := First (Expressions (Props));
11730 while Present (Prop) loop
11731 if Chars (Prop) = Property then
11738 -- Property with expression form
11740 Prop := First (Component_Associations (Props));
11741 while Present (Prop) loop
11742 Prop_Nam := First (Choices (Prop));
11744 -- The property can be represented in two ways:
11745 -- others => <value>
11746 -- <property> => <value>
11748 if Nkind (Prop_Nam) = N_Others_Choice
11749 or else (Nkind (Prop_Nam) = N_Identifier
11750 and then Chars (Prop_Nam) = Property)
11752 return Is_True (Expr_Value (Expression (Prop)));
11761 return Chars (Props) = Property;
11769 end Is_Enabled_External_Property;
11773 Has_External : Boolean;
11774 Has_Synchronous : Boolean;
11776 -- Start of processing for State_Has_Enabled_Property
11779 -- The declaration of an external abstract state appears as an
11780 -- extension aggregate. If this is not the case, properties can
11783 if Nkind (Decl) /= N_Extension_Aggregate then
11787 Find_Simple_Properties (Has_External, Has_Synchronous);
11789 -- Simple option External enables all properties (SPARK RM 7.1.2(2))
11791 if Has_External then
11794 -- Option External may enable or disable specific properties
11796 elsif Is_Enabled_External_Property then
11799 -- Simple option Synchronous
11801 -- enables disables
11802 -- Async_Readers Effective_Reads
11803 -- Async_Writers Effective_Writes
11805 -- Note that both forms of External have higher precedence than
11806 -- Synchronous (SPARK RM 7.1.4(9)).
11808 elsif Has_Synchronous then
11809 return Property in Name_Async_Readers | Name_Async_Writers;
11813 end State_Has_Enabled_Property;
11815 -------------------------------------------
11816 -- Type_Or_Variable_Has_Enabled_Property --
11817 -------------------------------------------
11819 function Type_Or_Variable_Has_Enabled_Property
11820 (Item_Id : Entity_Id) return Boolean
11822 AR : constant Node_Id :=
11823 Get_Pragma (Item_Id, Pragma_Async_Readers);
11824 AW : constant Node_Id :=
11825 Get_Pragma (Item_Id, Pragma_Async_Writers);
11826 ER : constant Node_Id :=
11827 Get_Pragma (Item_Id, Pragma_Effective_Reads);
11828 EW : constant Node_Id :=
11829 Get_Pragma (Item_Id, Pragma_Effective_Writes);
11831 Is_Derived_Type_With_Volatile_Parent_Type : constant Boolean :=
11832 Is_Derived_Type (Item_Id)
11833 and then Is_Effectively_Volatile (Etype (Base_Type (Item_Id)));
11836 -- A non-effectively volatile object can never possess external
11839 if not Is_Effectively_Volatile (Item_Id) then
11842 -- External properties related to variables come in two flavors -
11843 -- explicit and implicit. The explicit case is characterized by the
11844 -- presence of a property pragma with an optional Boolean flag. The
11845 -- property is enabled when the flag evaluates to True or the flag is
11846 -- missing altogether.
11848 elsif Property = Name_Async_Readers and then Present (AR) then
11849 return Is_Enabled_Pragma (AR);
11851 elsif Property = Name_Async_Writers and then Present (AW) then
11852 return Is_Enabled_Pragma (AW);
11854 elsif Property = Name_Effective_Reads and then Present (ER) then
11855 return Is_Enabled_Pragma (ER);
11857 elsif Property = Name_Effective_Writes and then Present (EW) then
11858 return Is_Enabled_Pragma (EW);
11860 -- If other properties are set explicitly, then this one is set
11861 -- implicitly to False, except in the case of a derived type
11862 -- whose parent type is volatile (in that case, we will inherit
11863 -- from the parent type, below).
11865 elsif (Present (AR)
11866 or else Present (AW)
11867 or else Present (ER)
11868 or else Present (EW))
11869 and then not Is_Derived_Type_With_Volatile_Parent_Type
11873 -- For a private type (including subtype of a private types), look at
11876 elsif Is_Private_Type (Item_Id) and then Present (Full_View (Item_Id))
11878 return Type_Or_Variable_Has_Enabled_Property (Full_View (Item_Id));
11880 -- For a derived type whose parent type is volatile, the
11881 -- property may be inherited (but ignore a non-volatile parent).
11883 elsif Is_Derived_Type_With_Volatile_Parent_Type then
11884 return Type_Or_Variable_Has_Enabled_Property
11885 (First_Subtype (Etype (Base_Type (Item_Id))));
11887 -- For a subtype, the property will be inherited from its base type.
11889 elsif Is_Type (Item_Id)
11890 and then not Is_Base_Type (Item_Id)
11892 return Type_Or_Variable_Has_Enabled_Property (Etype (Item_Id));
11894 -- If not specified explicitly for an object and its type
11895 -- is effectively volatile, then take result from the type.
11897 elsif Is_Object (Item_Id)
11898 and then Is_Effectively_Volatile (Etype (Item_Id))
11900 return Has_Enabled_Property (Etype (Item_Id), Property);
11902 -- The implicit case lacks all property pragmas
11904 elsif No (AR) and then No (AW) and then No (ER) and then No (EW) then
11905 if Is_Protected_Type (Etype (Item_Id)) then
11906 return Protected_Type_Or_Variable_Has_Enabled_Property;
11914 end Type_Or_Variable_Has_Enabled_Property;
11916 -- Start of processing for Has_Enabled_Property
11919 -- Abstract states and variables have a flexible scheme of specifying
11920 -- external properties.
11922 if Ekind (Item_Id) = E_Abstract_State then
11923 return State_Has_Enabled_Property;
11925 elsif Ekind (Item_Id) in E_Variable | E_Constant then
11926 return Type_Or_Variable_Has_Enabled_Property (Item_Id);
11928 -- Other objects can only inherit properties through their type. We
11929 -- cannot call directly Type_Or_Variable_Has_Enabled_Property on
11930 -- these as they don't have contracts attached, which is expected by
11933 elsif Is_Object (Item_Id) then
11934 return Type_Or_Variable_Has_Enabled_Property (Etype (Item_Id));
11936 elsif Is_Type (Item_Id) then
11937 return Type_Or_Variable_Has_Enabled_Property
11938 (Item_Id => First_Subtype (Item_Id));
11940 -- Otherwise a property is enabled when the related item is effectively
11944 return Is_Effectively_Volatile (Item_Id);
11946 end Has_Enabled_Property;
11948 -------------------------------------
11949 -- Has_Full_Default_Initialization --
11950 -------------------------------------
11952 function Has_Full_Default_Initialization (Typ : Entity_Id) return Boolean is
11956 -- A type subject to pragma Default_Initial_Condition may be fully
11957 -- default initialized depending on inheritance and the argument of
11958 -- the pragma. Since any type may act as the full view of a private
11959 -- type, this check must be performed prior to the specialized tests
11962 if Has_Fully_Default_Initializing_DIC_Pragma (Typ) then
11966 -- A scalar type is fully default initialized if it is subject to aspect
11969 if Is_Scalar_Type (Typ) then
11970 return Has_Default_Aspect (Typ);
11972 -- An access type is fully default initialized by default
11974 elsif Is_Access_Type (Typ) then
11977 -- An array type is fully default initialized if its element type is
11978 -- scalar and the array type carries aspect Default_Component_Value or
11979 -- the element type is fully default initialized.
11981 elsif Is_Array_Type (Typ) then
11983 Has_Default_Aspect (Typ)
11984 or else Has_Full_Default_Initialization (Component_Type (Typ));
11986 -- A protected type, record type, or type extension is fully default
11987 -- initialized if all its components either carry an initialization
11988 -- expression or have a type that is fully default initialized. The
11989 -- parent type of a type extension must be fully default initialized.
11991 elsif Is_Record_Type (Typ) or else Is_Protected_Type (Typ) then
11993 -- Inspect all entities defined in the scope of the type, looking for
11994 -- uninitialized components.
11996 Comp := First_Component (Typ);
11997 while Present (Comp) loop
11998 if Comes_From_Source (Comp)
11999 and then No (Expression (Parent (Comp)))
12000 and then not Has_Full_Default_Initialization (Etype (Comp))
12005 Next_Component (Comp);
12008 -- Ensure that the parent type of a type extension is fully default
12011 if Etype (Typ) /= Typ
12012 and then not Has_Full_Default_Initialization (Etype (Typ))
12017 -- If we get here, then all components and parent portion are fully
12018 -- default initialized.
12022 -- A task type is fully default initialized by default
12024 elsif Is_Task_Type (Typ) then
12027 -- Otherwise the type is not fully default initialized
12032 end Has_Full_Default_Initialization;
12034 -----------------------------------------------
12035 -- Has_Fully_Default_Initializing_DIC_Pragma --
12036 -----------------------------------------------
12038 function Has_Fully_Default_Initializing_DIC_Pragma
12039 (Typ : Entity_Id) return Boolean
12045 -- A type that inherits pragma Default_Initial_Condition from a parent
12046 -- type is automatically fully default initialized.
12048 if Has_Inherited_DIC (Typ) then
12051 -- Otherwise the type is fully default initialized only when the pragma
12052 -- appears without an argument, or the argument is non-null.
12054 elsif Has_Own_DIC (Typ) then
12055 Prag := Get_Pragma (Typ, Pragma_Default_Initial_Condition);
12056 pragma Assert (Present (Prag));
12057 Args := Pragma_Argument_Associations (Prag);
12059 -- The pragma appears without an argument in which case it defaults
12065 -- The pragma appears with a non-null expression
12067 elsif Nkind (Get_Pragma_Arg (First (Args))) /= N_Null then
12073 end Has_Fully_Default_Initializing_DIC_Pragma;
12075 ---------------------------------
12076 -- Has_Inferable_Discriminants --
12077 ---------------------------------
12079 function Has_Inferable_Discriminants (N : Node_Id) return Boolean is
12081 function Prefix_Is_Formal_Parameter (N : Node_Id) return Boolean;
12082 -- Determines whether the left-most prefix of a selected component is a
12083 -- formal parameter in a subprogram. Assumes N is a selected component.
12085 --------------------------------
12086 -- Prefix_Is_Formal_Parameter --
12087 --------------------------------
12089 function Prefix_Is_Formal_Parameter (N : Node_Id) return Boolean is
12090 Sel_Comp : Node_Id;
12093 -- Move to the left-most prefix by climbing up the tree
12096 while Present (Parent (Sel_Comp))
12097 and then Nkind (Parent (Sel_Comp)) = N_Selected_Component
12099 Sel_Comp := Parent (Sel_Comp);
12102 return Is_Formal (Entity (Prefix (Sel_Comp)));
12103 end Prefix_Is_Formal_Parameter;
12105 -- Start of processing for Has_Inferable_Discriminants
12108 -- For selected components, the subtype of the selector must be a
12109 -- constrained Unchecked_Union. If the component is subject to a
12110 -- per-object constraint, then the enclosing object must either be
12111 -- a regular discriminated type or must have inferable discriminants.
12113 if Nkind (N) = N_Selected_Component then
12114 -- The call to Has_Inferable_Discriminants will determine whether
12115 -- the selector has a constrained Unchecked_Union nominal type.
12117 if not Has_Inferable_Discriminants (Selector_Name (N)) then
12121 -- A small hack. If we have a per-object constrained selected
12122 -- component of a formal parameter, return True since we do not
12123 -- know the actual parameter association yet.
12125 return not Has_Per_Object_Constraint (Entity (Selector_Name (N)))
12126 or else not Is_Unchecked_Union (Etype (Prefix (N)))
12127 or else Has_Inferable_Discriminants (Prefix (N))
12128 or else Prefix_Is_Formal_Parameter (N);
12130 -- A qualified expression has inferable discriminants if its subtype
12131 -- mark is a constrained Unchecked_Union subtype.
12133 elsif Nkind (N) = N_Qualified_Expression then
12134 return Is_Unchecked_Union (Etype (Subtype_Mark (N)))
12135 and then Is_Constrained (Etype (Subtype_Mark (N)));
12137 -- For all other names, it is sufficient to have a constrained
12138 -- Unchecked_Union nominal subtype.
12141 return Is_Unchecked_Union (Etype (N))
12142 and then Is_Constrained (Etype (N));
12144 end Has_Inferable_Discriminants;
12146 --------------------
12147 -- Has_Infinities --
12148 --------------------
12150 function Has_Infinities (E : Entity_Id) return Boolean is
12153 Is_Floating_Point_Type (E)
12154 and then Nkind (Scalar_Range (E)) = N_Range
12155 and then Includes_Infinities (Scalar_Range (E));
12156 end Has_Infinities;
12158 --------------------
12159 -- Has_Interfaces --
12160 --------------------
12162 function Has_Interfaces
12164 Use_Full_View : Boolean := True) return Boolean
12166 Typ : Entity_Id := Base_Type (T);
12169 -- Handle concurrent types
12171 if Is_Concurrent_Type (Typ) then
12172 Typ := Corresponding_Record_Type (Typ);
12176 or else not Is_Record_Type (Typ)
12177 or else not Is_Tagged_Type (Typ)
12182 -- Handle private types
12184 if Use_Full_View and then Present (Full_View (Typ)) then
12185 Typ := Full_View (Typ);
12188 -- Handle concurrent record types
12190 if Is_Concurrent_Record_Type (Typ)
12191 and then Is_Non_Empty_List (Abstract_Interface_List (Typ))
12197 if Is_Interface (Typ)
12199 (Is_Record_Type (Typ)
12200 and then Present (Interfaces (Typ))
12201 and then not Is_Empty_Elmt_List (Interfaces (Typ)))
12206 exit when Etype (Typ) = Typ
12208 -- Handle private types
12210 or else (Present (Full_View (Etype (Typ)))
12211 and then Full_View (Etype (Typ)) = Typ)
12213 -- Protect frontend against wrong sources with cyclic derivations
12215 or else Etype (Typ) = T;
12217 -- Climb to the ancestor type handling private types
12219 if Present (Full_View (Etype (Typ))) then
12220 Typ := Full_View (Etype (Typ));
12222 Typ := Etype (Typ);
12227 end Has_Interfaces;
12229 --------------------------
12230 -- Has_Max_Queue_Length --
12231 --------------------------
12233 function Has_Max_Queue_Length (Id : Entity_Id) return Boolean is
12236 Ekind (Id) = E_Entry
12237 and then Present (Get_Pragma (Id, Pragma_Max_Queue_Length));
12238 end Has_Max_Queue_Length;
12240 ---------------------------------
12241 -- Has_No_Obvious_Side_Effects --
12242 ---------------------------------
12244 function Has_No_Obvious_Side_Effects (N : Node_Id) return Boolean is
12246 -- For now handle literals, constants, and non-volatile variables and
12247 -- expressions combining these with operators or short circuit forms.
12249 if Nkind (N) in N_Numeric_Or_String_Literal then
12252 elsif Nkind (N) = N_Character_Literal then
12255 elsif Nkind (N) in N_Unary_Op then
12256 return Has_No_Obvious_Side_Effects (Right_Opnd (N));
12258 elsif Nkind (N) in N_Binary_Op or else Nkind (N) in N_Short_Circuit then
12259 return Has_No_Obvious_Side_Effects (Left_Opnd (N))
12261 Has_No_Obvious_Side_Effects (Right_Opnd (N));
12263 elsif Nkind (N) = N_Expression_With_Actions
12264 and then Is_Empty_List (Actions (N))
12266 return Has_No_Obvious_Side_Effects (Expression (N));
12268 elsif Nkind (N) in N_Has_Entity then
12269 return Present (Entity (N))
12271 Ekind (Entity (N)) in
12272 E_Variable | E_Constant | E_Enumeration_Literal |
12273 E_In_Parameter | E_Out_Parameter | E_In_Out_Parameter
12274 and then not Is_Volatile (Entity (N));
12279 end Has_No_Obvious_Side_Effects;
12281 -----------------------------
12282 -- Has_Non_Null_Refinement --
12283 -----------------------------
12285 function Has_Non_Null_Refinement (Id : Entity_Id) return Boolean is
12286 Constits : Elist_Id;
12289 pragma Assert (Ekind (Id) = E_Abstract_State);
12290 Constits := Refinement_Constituents (Id);
12292 -- For a refinement to be non-null, the first constituent must be
12293 -- anything other than null.
12297 and then Nkind (Node (First_Elmt (Constits))) /= N_Null;
12298 end Has_Non_Null_Refinement;
12300 -----------------------------
12301 -- Has_Non_Null_Statements --
12302 -----------------------------
12304 function Has_Non_Null_Statements (L : List_Id) return Boolean is
12310 while Present (Node) loop
12311 if Nkind (Node) not in N_Null_Statement | N_Call_Marker then
12319 end Has_Non_Null_Statements;
12321 ----------------------------------
12322 -- Is_Access_Subprogram_Wrapper --
12323 ----------------------------------
12325 function Is_Access_Subprogram_Wrapper (E : Entity_Id) return Boolean is
12326 Formal : constant Entity_Id := Last_Formal (E);
12328 return Present (Formal)
12329 and then Ekind (Etype (Formal)) in Access_Subprogram_Kind
12330 and then Access_Subprogram_Wrapper
12331 (Directly_Designated_Type (Etype (Formal))) = E;
12332 end Is_Access_Subprogram_Wrapper;
12334 ---------------------------
12335 -- Is_Explicitly_Aliased --
12336 ---------------------------
12338 function Is_Explicitly_Aliased (N : Node_Id) return Boolean is
12340 return Is_Formal (N)
12341 and then Present (Parent (N))
12342 and then Nkind (Parent (N)) = N_Parameter_Specification
12343 and then Aliased_Present (Parent (N));
12344 end Is_Explicitly_Aliased;
12346 ----------------------------
12347 -- Is_Container_Aggregate --
12348 ----------------------------
12350 function Is_Container_Aggregate (Exp : Node_Id) return Boolean is
12352 function Is_Record_Aggregate return Boolean is
12353 (Is_Parenthesis_Aggregate (Exp));
12354 -- Given an aggregate whose type is a record type with specified
12355 -- Aggregate aspect, we determine whether it is a record aggregate or
12356 -- a container aggregate by ckecking whether it uses parentheses () or
12357 -- square brackets []. If the code where the aggregate occurs can see
12358 -- only a partial view of the aggregate's type then the aggregate cannot
12359 -- be a record type and must then use []; an aggregate of a private type
12360 -- has to be a container aggregate and must then use [].
12363 return Nkind (Exp) = N_Aggregate
12364 and then Has_Aspect (Etype (Exp), Aspect_Aggregate)
12365 and then not Is_Record_Aggregate;
12366 end Is_Container_Aggregate;
12368 ---------------------------------
12369 -- Side_Effect_Free_Statements --
12370 ---------------------------------
12372 function Side_Effect_Free_Statements (L : List_Id) return Boolean is
12378 while Present (Node) loop
12379 case Nkind (Node) is
12380 when N_Null_Statement | N_Call_Marker | N_Raise_xxx_Error =>
12383 when N_Object_Declaration =>
12384 if Present (Expression (Node))
12385 and then not Side_Effect_Free (Expression (Node))
12398 end Side_Effect_Free_Statements;
12400 ---------------------------
12401 -- Side_Effect_Free_Loop --
12402 ---------------------------
12404 function Side_Effect_Free_Loop (N : Node_Id) return Boolean is
12410 -- If this is not a loop (e.g. because the loop has been rewritten),
12411 -- then return false.
12413 if Nkind (N) /= N_Loop_Statement then
12417 -- First check the statements
12419 if Side_Effect_Free_Statements (Statements (N)) then
12421 -- Then check the loop condition/indexes
12423 if Present (Iteration_Scheme (N)) then
12424 Scheme := Iteration_Scheme (N);
12426 if Present (Condition (Scheme))
12427 or else Present (Iterator_Specification (Scheme))
12430 elsif Present (Loop_Parameter_Specification (Scheme)) then
12431 Spec := Loop_Parameter_Specification (Scheme);
12432 Subt := Discrete_Subtype_Definition (Spec);
12434 if Present (Subt) then
12435 if Nkind (Subt) = N_Range then
12436 return Side_Effect_Free (Low_Bound (Subt))
12437 and then Side_Effect_Free (High_Bound (Subt));
12439 -- subtype indication
12449 end Side_Effect_Free_Loop;
12451 ----------------------------------
12452 -- Has_Non_Trivial_Precondition --
12453 ----------------------------------
12455 function Has_Non_Trivial_Precondition (Subp : Entity_Id) return Boolean is
12456 Pre : constant Node_Id := Find_Aspect (Subp, Aspect_Pre,
12457 Class_Present => True);
12461 and then not Is_Entity_Name (Expression (Pre));
12462 end Has_Non_Trivial_Precondition;
12464 -------------------
12465 -- Has_Null_Body --
12466 -------------------
12468 function Has_Null_Body (Proc_Id : Entity_Id) return Boolean is
12469 Body_Id : Entity_Id;
12476 Spec := Parent (Proc_Id);
12477 Decl := Parent (Spec);
12479 -- Retrieve the entity of the procedure body (e.g. invariant proc).
12481 if Nkind (Spec) = N_Procedure_Specification
12482 and then Nkind (Decl) = N_Subprogram_Declaration
12484 Body_Id := Corresponding_Body (Decl);
12486 -- The body acts as a spec
12489 Body_Id := Proc_Id;
12492 -- The body will be generated later
12494 if No (Body_Id) then
12498 Spec := Parent (Body_Id);
12499 Decl := Parent (Spec);
12502 (Nkind (Spec) = N_Procedure_Specification
12503 and then Nkind (Decl) = N_Subprogram_Body);
12505 Stmt1 := First (Statements (Handled_Statement_Sequence (Decl)));
12507 -- Look for a null statement followed by an optional return
12510 if Nkind (Stmt1) = N_Null_Statement then
12511 Stmt2 := Next (Stmt1);
12513 if Present (Stmt2) then
12514 return Nkind (Stmt2) = N_Simple_Return_Statement;
12523 ------------------------
12524 -- Has_Null_Exclusion --
12525 ------------------------
12527 function Has_Null_Exclusion (N : Node_Id) return Boolean is
12530 when N_Access_Definition
12531 | N_Access_Function_Definition
12532 | N_Access_Procedure_Definition
12533 | N_Access_To_Object_Definition
12535 | N_Derived_Type_Definition
12536 | N_Function_Specification
12537 | N_Subtype_Declaration
12539 return Null_Exclusion_Present (N);
12541 when N_Component_Definition
12542 | N_Formal_Object_Declaration
12544 if Present (Subtype_Mark (N)) then
12545 return Null_Exclusion_Present (N);
12546 else pragma Assert (Present (Access_Definition (N)));
12547 return Null_Exclusion_Present (Access_Definition (N));
12550 when N_Object_Renaming_Declaration =>
12551 if Present (Subtype_Mark (N)) then
12552 return Null_Exclusion_Present (N);
12553 elsif Present (Access_Definition (N)) then
12554 return Null_Exclusion_Present (Access_Definition (N));
12556 return False; -- Case of no subtype in renaming (AI12-0275)
12559 when N_Discriminant_Specification =>
12560 if Nkind (Discriminant_Type (N)) = N_Access_Definition then
12561 return Null_Exclusion_Present (Discriminant_Type (N));
12563 return Null_Exclusion_Present (N);
12566 when N_Object_Declaration =>
12567 if Nkind (Object_Definition (N)) = N_Access_Definition then
12568 return Null_Exclusion_Present (Object_Definition (N));
12570 return Null_Exclusion_Present (N);
12573 when N_Parameter_Specification =>
12574 if Nkind (Parameter_Type (N)) = N_Access_Definition then
12575 return Null_Exclusion_Present (Parameter_Type (N))
12576 or else Null_Exclusion_Present (N);
12578 return Null_Exclusion_Present (N);
12584 end Has_Null_Exclusion;
12586 ------------------------
12587 -- Has_Null_Extension --
12588 ------------------------
12590 function Has_Null_Extension (T : Entity_Id) return Boolean is
12591 B : constant Entity_Id := Base_Type (T);
12596 if Nkind (Parent (B)) = N_Full_Type_Declaration
12597 and then Present (Record_Extension_Part (Type_Definition (Parent (B))))
12599 Ext := Record_Extension_Part (Type_Definition (Parent (B)));
12601 if Present (Ext) then
12602 if Null_Present (Ext) then
12605 Comps := Component_List (Ext);
12607 -- The null component list is rewritten during analysis to
12608 -- include the parent component. Any other component indicates
12609 -- that the extension was not originally null.
12611 return Null_Present (Comps)
12612 or else No (Next (First (Component_Items (Comps))));
12621 end Has_Null_Extension;
12623 -------------------------
12624 -- Has_Null_Refinement --
12625 -------------------------
12627 function Has_Null_Refinement (Id : Entity_Id) return Boolean is
12628 Constits : Elist_Id;
12631 pragma Assert (Ekind (Id) = E_Abstract_State);
12632 Constits := Refinement_Constituents (Id);
12634 -- For a refinement to be null, the state's sole constituent must be a
12639 and then Nkind (Node (First_Elmt (Constits))) = N_Null;
12640 end Has_Null_Refinement;
12642 ------------------------------------------
12643 -- Has_Nonstatic_Class_Wide_Pre_Or_Post --
12644 ------------------------------------------
12646 function Is_Prim_Of_Abst_Type_With_Nonstatic_CW_Pre_Post
12647 (Subp : Entity_Id) return Boolean
12649 Disp_Type : constant Entity_Id := Find_Dispatching_Type (Subp);
12651 Pragma_Arg : Node_Id;
12654 if Present (Disp_Type)
12655 and then Is_Abstract_Type (Disp_Type)
12656 and then Present (Contract (Subp))
12658 Prag := Pre_Post_Conditions (Contract (Subp));
12660 while Present (Prag) loop
12661 if Pragma_Name (Prag) in Name_Precondition | Name_Postcondition
12662 and then Class_Present (Prag)
12666 (Pragma_Argument_Associations (Prag));
12668 if not Is_Static_Expression (Expression (Pragma_Arg)) then
12673 Prag := Next_Pragma (Prag);
12678 end Is_Prim_Of_Abst_Type_With_Nonstatic_CW_Pre_Post;
12680 -------------------------------
12681 -- Has_Overriding_Initialize --
12682 -------------------------------
12684 function Has_Overriding_Initialize (T : Entity_Id) return Boolean is
12685 BT : constant Entity_Id := Base_Type (T);
12689 if Is_Controlled (BT) then
12690 if Is_RTU (Scope (BT), Ada_Finalization) then
12693 elsif Present (Primitive_Operations (BT)) then
12694 P := First_Elmt (Primitive_Operations (BT));
12695 while Present (P) loop
12697 Init : constant Entity_Id := Node (P);
12698 Formal : constant Entity_Id := First_Formal (Init);
12700 if Ekind (Init) = E_Procedure
12701 and then Chars (Init) = Name_Initialize
12702 and then Comes_From_Source (Init)
12703 and then Present (Formal)
12704 and then Etype (Formal) = BT
12705 and then No (Next_Formal (Formal))
12706 and then (Ada_Version < Ada_2012
12707 or else not Null_Present (Parent (Init)))
12717 -- Here if type itself does not have a non-null Initialize operation:
12718 -- check immediate ancestor.
12720 if Is_Derived_Type (BT)
12721 and then Has_Overriding_Initialize (Etype (BT))
12728 end Has_Overriding_Initialize;
12730 --------------------------------------
12731 -- Has_Preelaborable_Initialization --
12732 --------------------------------------
12734 function Has_Preelaborable_Initialization
12736 Preelab_Init_Expr : Node_Id := Empty) return Boolean
12740 procedure Check_Components (E : Entity_Id);
12741 -- Check component/discriminant chain, sets Has_PE False if a component
12742 -- or discriminant does not meet the preelaborable initialization rules.
12744 function Type_Named_In_Preelab_Init_Expression
12746 Expr : Node_Id) return Boolean;
12747 -- Returns True iff Typ'Preelaborable_Initialization occurs in Expr
12748 -- (where Expr may be a conjunction of one or more P_I attributes).
12750 ----------------------
12751 -- Check_Components --
12752 ----------------------
12754 procedure Check_Components (E : Entity_Id) is
12759 -- Loop through components and discriminants of record or protected
12762 Ent := First_Component_Or_Discriminant (E);
12763 while Present (Ent) loop
12765 case Ekind (Ent) is
12766 when E_Component =>
12768 -- Get default expression if any. If there is no declaration
12769 -- node, it means we have an internal entity. The parent and
12770 -- tag fields are examples of such entities. For such cases,
12771 -- we just test the type of the entity.
12773 if Present (Declaration_Node (Ent)) then
12774 Exp := Expression (Declaration_Node (Ent));
12779 when E_Discriminant =>
12781 -- Note: for a renamed discriminant, the Declaration_Node
12782 -- may point to the one from the ancestor, and have a
12783 -- different expression, so use the proper attribute to
12784 -- retrieve the expression from the derived constraint.
12786 Exp := Discriminant_Default_Value (Ent);
12789 raise Program_Error;
12792 -- A component has PI if it has no default expression and the
12793 -- component type has PI.
12796 if not Has_Preelaborable_Initialization
12797 (Etype (Ent), Preelab_Init_Expr)
12803 -- Require the default expression to be preelaborable
12805 elsif not Is_Preelaborable_Construct (Exp) then
12810 Next_Component_Or_Discriminant (Ent);
12812 end Check_Components;
12814 --------------------------------------
12815 -- Type_Named_In_Preelab_Expression --
12816 --------------------------------------
12818 function Type_Named_In_Preelab_Init_Expression
12820 Expr : Node_Id) return Boolean
12823 -- Return True if Expr is a Preelaborable_Initialization attribute
12824 -- and the prefix is a subtype that has the same type as Typ.
12826 if Nkind (Expr) = N_Attribute_Reference
12827 and then Attribute_Name (Expr) = Name_Preelaborable_Initialization
12828 and then Is_Entity_Name (Prefix (Expr))
12829 and then Base_Type (Entity (Prefix (Expr))) = Base_Type (Typ)
12833 -- In the case where Expr is a conjunction, test whether either
12834 -- operand is a Preelaborable_Initialization attribute whose prefix
12835 -- has the same type as Typ, and return True if so.
12837 elsif Nkind (Expr) = N_Op_And
12839 (Type_Named_In_Preelab_Init_Expression (Typ, Left_Opnd (Expr))
12841 Type_Named_In_Preelab_Init_Expression (Typ, Right_Opnd (Expr)))
12845 -- Typ not named in a Preelaborable_Initialization attribute of Expr
12850 end Type_Named_In_Preelab_Init_Expression;
12852 -- Start of processing for Has_Preelaborable_Initialization
12855 -- Immediate return if already marked as known preelaborable init. This
12856 -- covers types for which this function has already been called once
12857 -- and returned True (in which case the result is cached), and also
12858 -- types to which a pragma Preelaborable_Initialization applies.
12860 if Known_To_Have_Preelab_Init (E) then
12864 -- If the type is a subtype representing a generic actual type, then
12865 -- test whether its base type has preelaborable initialization since
12866 -- the subtype representing the actual does not inherit this attribute
12867 -- from the actual or formal. (but maybe it should???)
12869 if Is_Generic_Actual_Type (E) then
12870 return Has_Preelaborable_Initialization (Base_Type (E));
12873 -- All elementary types have preelaborable initialization
12875 if Is_Elementary_Type (E) then
12878 -- Array types have PI if the component type has PI
12880 elsif Is_Array_Type (E) then
12881 Has_PE := Has_Preelaborable_Initialization
12882 (Component_Type (E), Preelab_Init_Expr);
12884 -- A derived type has preelaborable initialization if its parent type
12885 -- has preelaborable initialization and (in the case of a derived record
12886 -- extension) if the non-inherited components all have preelaborable
12887 -- initialization. However, a user-defined controlled type with an
12888 -- overriding Initialize procedure does not have preelaborable
12891 elsif Is_Derived_Type (E) then
12893 -- When the rule of RM 10.2.1(11.8/5) applies, we presume a component
12894 -- of a generic formal derived type has preelaborable initialization.
12895 -- (See comment on spec of Has_Preelaborable_Initialization.)
12897 if Is_Generic_Type (E)
12898 and then Present (Preelab_Init_Expr)
12900 Type_Named_In_Preelab_Init_Expression (E, Preelab_Init_Expr)
12905 -- If the derived type is a private extension then it doesn't have
12906 -- preelaborable initialization.
12908 if Ekind (Base_Type (E)) = E_Record_Type_With_Private then
12912 -- First check whether ancestor type has preelaborable initialization
12914 Has_PE := Has_Preelaborable_Initialization
12915 (Etype (Base_Type (E)), Preelab_Init_Expr);
12917 -- If OK, check extension components (if any)
12919 if Has_PE and then Is_Record_Type (E) then
12920 Check_Components (E);
12923 -- Check specifically for 10.2.1(11.4/2) exception: a controlled type
12924 -- with a user defined Initialize procedure does not have PI. If
12925 -- the type is untagged, the control primitives come from a component
12926 -- that has already been checked.
12929 and then Is_Controlled (E)
12930 and then Is_Tagged_Type (E)
12931 and then Has_Overriding_Initialize (E)
12936 -- Private types not derived from a type having preelaborable init and
12937 -- that are not marked with pragma Preelaborable_Initialization do not
12938 -- have preelaborable initialization.
12940 elsif Is_Private_Type (E) then
12942 -- When the rule of RM 10.2.1(11.8/5) applies, we presume a component
12943 -- of a generic formal private type has preelaborable initialization.
12944 -- (See comment on spec of Has_Preelaborable_Initialization.)
12946 if Is_Generic_Type (E)
12947 and then Present (Preelab_Init_Expr)
12949 Type_Named_In_Preelab_Init_Expression (E, Preelab_Init_Expr)
12956 -- Record type has PI if it is non private and all components have PI
12958 elsif Is_Record_Type (E) then
12960 Check_Components (E);
12962 -- Protected types must not have entries, and components must meet
12963 -- same set of rules as for record components.
12965 elsif Is_Protected_Type (E) then
12966 if Has_Entries (E) then
12970 Check_Components (E);
12973 -- Type System.Address always has preelaborable initialization
12975 elsif Is_RTE (E, RE_Address) then
12978 -- In all other cases, type does not have preelaborable initialization
12984 -- If type has preelaborable initialization, cache result
12987 Set_Known_To_Have_Preelab_Init (E);
12991 end Has_Preelaborable_Initialization;
12997 function Has_Prefix (N : Node_Id) return Boolean is
12999 return Nkind (N) in
13000 N_Attribute_Reference | N_Expanded_Name | N_Explicit_Dereference |
13001 N_Indexed_Component | N_Reference | N_Selected_Component |
13005 ---------------------------
13006 -- Has_Private_Component --
13007 ---------------------------
13009 function Has_Private_Component (Type_Id : Entity_Id) return Boolean is
13010 Btype : Entity_Id := Base_Type (Type_Id);
13011 Component : Entity_Id;
13014 if Error_Posted (Type_Id)
13015 or else Error_Posted (Btype)
13020 if Is_Class_Wide_Type (Btype) then
13021 Btype := Root_Type (Btype);
13024 if Is_Private_Type (Btype) then
13026 UT : constant Entity_Id := Underlying_Type (Btype);
13029 if No (Full_View (Btype)) then
13030 return not Is_Generic_Type (Btype)
13032 not Is_Generic_Type (Root_Type (Btype));
13034 return not Is_Generic_Type (Root_Type (Full_View (Btype)));
13037 return not Is_Frozen (UT) and then Has_Private_Component (UT);
13041 elsif Is_Array_Type (Btype) then
13042 return Has_Private_Component (Component_Type (Btype));
13044 elsif Is_Record_Type (Btype) then
13045 Component := First_Component (Btype);
13046 while Present (Component) loop
13047 if Has_Private_Component (Etype (Component)) then
13051 Next_Component (Component);
13056 elsif Is_Protected_Type (Btype)
13057 and then Present (Corresponding_Record_Type (Btype))
13059 return Has_Private_Component (Corresponding_Record_Type (Btype));
13064 end Has_Private_Component;
13066 --------------------------------
13067 -- Has_Relaxed_Initialization --
13068 --------------------------------
13070 function Has_Relaxed_Initialization (E : Entity_Id) return Boolean is
13072 function Denotes_Relaxed_Parameter
13076 -- Returns True iff expression Expr denotes a formal parameter or
13077 -- function Param (through its attribute Result).
13079 -------------------------------
13080 -- Denotes_Relaxed_Parameter --
13081 -------------------------------
13083 function Denotes_Relaxed_Parameter
13085 Param : Entity_Id) return Boolean is
13087 if Nkind (Expr) in N_Identifier | N_Expanded_Name then
13088 return Entity (Expr) = Param;
13090 pragma Assert (Is_Attribute_Result (Expr));
13091 return Entity (Prefix (Expr)) = Param;
13093 end Denotes_Relaxed_Parameter;
13095 -- Start of processing for Has_Relaxed_Initialization
13098 -- When analyzing, we checked all syntax legality rules for the aspect
13099 -- Relaxed_Initialization, but didn't store the property anywhere (e.g.
13100 -- as an Einfo flag). To query the property we look directly at the AST,
13101 -- but now without any syntactic checks.
13104 -- Abstract states have option Relaxed_Initialization
13106 when E_Abstract_State =>
13107 return Is_Relaxed_Initialization_State (E);
13109 -- Constants have this aspect attached directly; for deferred
13110 -- constants, the aspect is attached to the partial view.
13113 return Has_Aspect (E, Aspect_Relaxed_Initialization);
13115 -- Variables have this aspect attached directly
13118 return Has_Aspect (E, Aspect_Relaxed_Initialization);
13120 -- Types have this aspect attached directly (though we only allow it
13121 -- to be specified for the first subtype). For private types, the
13122 -- aspect is attached to the partial view.
13125 pragma Assert (Is_First_Subtype (E));
13126 return Has_Aspect (E, Aspect_Relaxed_Initialization);
13128 -- Formal parameters and functions have the Relaxed_Initialization
13129 -- aspect attached to the subprogram entity and must be listed in
13130 -- the aspect expression.
13136 Subp_Id : Entity_Id;
13137 Aspect_Expr : Node_Id;
13138 Param_Expr : Node_Id;
13142 if Is_Formal (E) then
13143 Subp_Id := Scope (E);
13148 if Has_Aspect (Subp_Id, Aspect_Relaxed_Initialization) then
13150 Find_Value_Of_Aspect
13151 (Subp_Id, Aspect_Relaxed_Initialization);
13153 -- Aspect expression is either an aggregate with an optional
13154 -- Boolean expression (which defaults to True), e.g.:
13156 -- function F (X : Integer) return Integer
13157 -- with Relaxed_Initialization => (X => True, F'Result);
13159 if Nkind (Aspect_Expr) = N_Aggregate then
13161 if Present (Component_Associations (Aspect_Expr)) then
13162 Assoc := First (Component_Associations (Aspect_Expr));
13164 while Present (Assoc) loop
13165 if Denotes_Relaxed_Parameter
13166 (First (Choices (Assoc)), E)
13170 (Static_Boolean (Expression (Assoc)));
13177 Param_Expr := First (Expressions (Aspect_Expr));
13179 while Present (Param_Expr) loop
13180 if Denotes_Relaxed_Parameter (Param_Expr, E) then
13189 -- or it is a single identifier, e.g.:
13191 -- function F (X : Integer) return Integer
13192 -- with Relaxed_Initialization => X;
13195 return Denotes_Relaxed_Parameter (Aspect_Expr, E);
13203 raise Program_Error;
13205 end Has_Relaxed_Initialization;
13207 ----------------------
13208 -- Has_Signed_Zeros --
13209 ----------------------
13211 function Has_Signed_Zeros (E : Entity_Id) return Boolean is
13213 return Is_Floating_Point_Type (E) and then Signed_Zeros_On_Target;
13214 end Has_Signed_Zeros;
13216 ------------------------------
13217 -- Has_Significant_Contract --
13218 ------------------------------
13220 function Has_Significant_Contract (Subp_Id : Entity_Id) return Boolean is
13221 Subp_Nam : constant Name_Id := Chars (Subp_Id);
13224 -- _Finalizer procedure
13226 if Subp_Nam = Name_uFinalizer then
13229 -- _Wrapped_Statements procedure which gets generated as part of the
13230 -- expansion of postconditions.
13232 elsif Subp_Nam = Name_uWrapped_Statements then
13235 -- Predicate function
13237 elsif Ekind (Subp_Id) = E_Function
13238 and then Is_Predicate_Function (Subp_Id)
13244 elsif Get_TSS_Name (Subp_Id) /= TSS_Null then
13250 end Has_Significant_Contract;
13252 -----------------------------
13253 -- Has_Static_Array_Bounds --
13254 -----------------------------
13256 function Has_Static_Array_Bounds (Typ : Node_Id) return Boolean is
13257 All_Static : Boolean;
13261 Examine_Array_Bounds (Typ, All_Static, Dummy);
13264 end Has_Static_Array_Bounds;
13266 ---------------------------------------
13267 -- Has_Static_Non_Empty_Array_Bounds --
13268 ---------------------------------------
13270 function Has_Static_Non_Empty_Array_Bounds (Typ : Node_Id) return Boolean is
13271 All_Static : Boolean;
13272 Has_Empty : Boolean;
13275 Examine_Array_Bounds (Typ, All_Static, Has_Empty);
13277 return All_Static and not Has_Empty;
13278 end Has_Static_Non_Empty_Array_Bounds;
13284 function Has_Stream (T : Entity_Id) return Boolean is
13291 elsif Is_RTE (Root_Type (T), RE_Root_Stream_Type) then
13294 elsif Is_Array_Type (T) then
13295 return Has_Stream (Component_Type (T));
13297 elsif Is_Record_Type (T) then
13298 E := First_Component (T);
13299 while Present (E) loop
13300 if Has_Stream (Etype (E)) then
13303 Next_Component (E);
13309 elsif Is_Private_Type (T) then
13310 return Has_Stream (Underlying_Type (T));
13321 function Has_Suffix (E : Entity_Id; Suffix : Character) return Boolean is
13323 Get_Name_String (Chars (E));
13324 return Name_Buffer (Name_Len) = Suffix;
13331 function Add_Suffix (E : Entity_Id; Suffix : Character) return Name_Id is
13333 Get_Name_String (Chars (E));
13334 Add_Char_To_Name_Buffer (Suffix);
13338 -------------------
13339 -- Remove_Suffix --
13340 -------------------
13342 function Remove_Suffix (E : Entity_Id; Suffix : Character) return Name_Id is
13344 pragma Assert (Has_Suffix (E, Suffix));
13345 Get_Name_String (Chars (E));
13346 Name_Len := Name_Len - 1;
13350 ----------------------------------
13351 -- Replace_Null_By_Null_Address --
13352 ----------------------------------
13354 procedure Replace_Null_By_Null_Address (N : Node_Id) is
13355 procedure Replace_Null_Operand (Op : Node_Id; Other_Op : Node_Id);
13356 -- Replace operand Op with a reference to Null_Address when the operand
13357 -- denotes a null Address. Other_Op denotes the other operand.
13359 --------------------------
13360 -- Replace_Null_Operand --
13361 --------------------------
13363 procedure Replace_Null_Operand (Op : Node_Id; Other_Op : Node_Id) is
13365 -- Check the type of the complementary operand since the N_Null node
13366 -- has not been decorated yet.
13368 if Nkind (Op) = N_Null
13369 and then Is_Descendant_Of_Address (Etype (Other_Op))
13371 Rewrite (Op, New_Occurrence_Of (RTE (RE_Null_Address), Sloc (Op)));
13373 end Replace_Null_Operand;
13375 -- Start of processing for Replace_Null_By_Null_Address
13378 pragma Assert (Relaxed_RM_Semantics);
13379 pragma Assert (Nkind (N) in N_Null | N_Op_Compare);
13381 if Nkind (N) = N_Null then
13382 Rewrite (N, New_Occurrence_Of (RTE (RE_Null_Address), Sloc (N)));
13386 L : constant Node_Id := Left_Opnd (N);
13387 R : constant Node_Id := Right_Opnd (N);
13390 Replace_Null_Operand (L, Other_Op => R);
13391 Replace_Null_Operand (R, Other_Op => L);
13394 end Replace_Null_By_Null_Address;
13396 --------------------------
13397 -- Has_Tagged_Component --
13398 --------------------------
13400 function Has_Tagged_Component (Typ : Entity_Id) return Boolean is
13404 if Is_Private_Type (Typ) and then Present (Underlying_Type (Typ)) then
13405 return Has_Tagged_Component (Underlying_Type (Typ));
13407 elsif Is_Array_Type (Typ) then
13408 return Has_Tagged_Component (Component_Type (Typ));
13410 elsif Is_Tagged_Type (Typ) then
13413 elsif Is_Record_Type (Typ) then
13414 Comp := First_Component (Typ);
13415 while Present (Comp) loop
13416 if Has_Tagged_Component (Etype (Comp)) then
13420 Next_Component (Comp);
13428 end Has_Tagged_Component;
13430 -----------------------------
13431 -- Has_Undefined_Reference --
13432 -----------------------------
13434 function Has_Undefined_Reference (Expr : Node_Id) return Boolean is
13435 Has_Undef_Ref : Boolean := False;
13436 -- Flag set when expression Expr contains at least one undefined
13439 function Is_Undefined_Reference (N : Node_Id) return Traverse_Result;
13440 -- Determine whether N denotes a reference and if it does, whether it is
13443 ----------------------------
13444 -- Is_Undefined_Reference --
13445 ----------------------------
13447 function Is_Undefined_Reference (N : Node_Id) return Traverse_Result is
13449 if Is_Entity_Name (N)
13450 and then Present (Entity (N))
13451 and then Entity (N) = Any_Id
13453 Has_Undef_Ref := True;
13458 end Is_Undefined_Reference;
13460 procedure Find_Undefined_References is
13461 new Traverse_Proc (Is_Undefined_Reference);
13463 -- Start of processing for Has_Undefined_Reference
13466 Find_Undefined_References (Expr);
13468 return Has_Undef_Ref;
13469 end Has_Undefined_Reference;
13471 ----------------------------------------
13472 -- Has_Effectively_Volatile_Component --
13473 ----------------------------------------
13475 function Has_Effectively_Volatile_Component
13476 (Typ : Entity_Id) return Boolean
13481 if Has_Volatile_Components (Typ) then
13484 elsif Is_Array_Type (Typ) then
13485 return Is_Effectively_Volatile (Component_Type (Typ));
13487 elsif Is_Record_Type (Typ) then
13488 Comp := First_Component (Typ);
13489 while Present (Comp) loop
13490 if Is_Effectively_Volatile (Etype (Comp)) then
13494 Next_Component (Comp);
13499 end Has_Effectively_Volatile_Component;
13501 ----------------------------
13502 -- Has_Volatile_Component --
13503 ----------------------------
13505 function Has_Volatile_Component (Typ : Entity_Id) return Boolean is
13509 if Has_Volatile_Components (Typ) then
13512 elsif Is_Array_Type (Typ) then
13513 return Is_Volatile (Component_Type (Typ));
13515 elsif Is_Record_Type (Typ) then
13516 Comp := First_Component (Typ);
13517 while Present (Comp) loop
13518 if Is_Volatile_Object_Ref (Comp) then
13522 Next_Component (Comp);
13527 end Has_Volatile_Component;
13529 -------------------------
13530 -- Implementation_Kind --
13531 -------------------------
13533 function Implementation_Kind (Subp : Entity_Id) return Name_Id is
13534 Impl_Prag : constant Node_Id := Get_Rep_Pragma (Subp, Name_Implemented);
13537 pragma Assert (Present (Impl_Prag));
13538 Arg := Last (Pragma_Argument_Associations (Impl_Prag));
13539 return Chars (Get_Pragma_Arg (Arg));
13540 end Implementation_Kind;
13542 --------------------------
13543 -- Implements_Interface --
13544 --------------------------
13546 function Implements_Interface
13547 (Typ_Ent : Entity_Id;
13548 Iface_Ent : Entity_Id;
13549 Exclude_Parents : Boolean := False) return Boolean
13551 Ifaces_List : Elist_Id;
13553 Iface : Entity_Id := Base_Type (Iface_Ent);
13554 Typ : Entity_Id := Base_Type (Typ_Ent);
13557 if Is_Class_Wide_Type (Typ) then
13558 Typ := Root_Type (Typ);
13561 if not Has_Interfaces (Typ) then
13565 if Is_Class_Wide_Type (Iface) then
13566 Iface := Root_Type (Iface);
13569 Collect_Interfaces (Typ, Ifaces_List);
13571 Elmt := First_Elmt (Ifaces_List);
13572 while Present (Elmt) loop
13573 if Is_Ancestor (Node (Elmt), Typ, Use_Full_View => True)
13574 and then Exclude_Parents
13578 elsif Node (Elmt) = Iface then
13586 end Implements_Interface;
13588 --------------------------------
13589 -- Implicitly_Designated_Type --
13590 --------------------------------
13592 function Implicitly_Designated_Type (Typ : Entity_Id) return Entity_Id is
13593 Desig : constant Entity_Id := Designated_Type (Typ);
13596 -- An implicit dereference is a legal occurrence of an incomplete type
13597 -- imported through a limited_with clause, if the full view is visible.
13599 if Is_Incomplete_Type (Desig)
13600 and then From_Limited_With (Desig)
13601 and then not From_Limited_With (Scope (Desig))
13603 (Is_Immediately_Visible (Scope (Desig))
13605 (Is_Child_Unit (Scope (Desig))
13606 and then Is_Visible_Lib_Unit (Scope (Desig))))
13608 return Available_View (Desig);
13612 end Implicitly_Designated_Type;
13614 ------------------------------------
13615 -- In_Assertion_Expression_Pragma --
13616 ------------------------------------
13618 function In_Assertion_Expression_Pragma (N : Node_Id) return Boolean is
13620 Prag : Node_Id := Empty;
13623 -- Climb the parent chain looking for an enclosing pragma
13626 while Present (Par) loop
13627 if Nkind (Par) = N_Pragma then
13631 -- Precondition-like pragmas are expanded into if statements, check
13632 -- the original node instead.
13634 elsif Nkind (Original_Node (Par)) = N_Pragma then
13635 Prag := Original_Node (Par);
13638 -- The expansion of attribute 'Old generates a
constant to capture
13639 -- the result of the prefix. If the parent traversal reaches
13640 -- one of these constants, then the node technically came from a
13641 -- postcondition-like pragma. Note that the Ekind is not tested here
13642 -- because N may be the expression of an object declaration which is
13643 -- currently being analyzed. Such objects carry Ekind of E_Void.
13645 elsif Nkind
(Par
) = N_Object_Declaration
13646 and then Constant_Present
(Par
)
13647 and then Stores_Attribute_Old_Prefix
(Defining_Entity
(Par
))
13651 -- Prevent the search from going too far
13653 elsif Is_Body_Or_Package_Declaration
(Par
) then
13657 Par
:= Parent
(Par
);
13662 and then Assertion_Expression_Pragma
(Get_Pragma_Id
(Prag
));
13663 end In_Assertion_Expression_Pragma
;
13665 -------------------
13666 -- In_Check_Node --
13667 -------------------
13669 function In_Check_Node
(N
: Node_Id
) return Boolean is
13670 Par
: Node_Id
:= Parent
(N
);
13672 while Present
(Par
) loop
13673 if Nkind
(Par
) in N_Raise_xxx_Error
then
13676 -- Prevent the search from going too far
13678 elsif Is_Body_Or_Package_Declaration
(Par
) then
13682 Par
:= Parent
(Par
);
13689 -------------------------------
13690 -- In_Generic_Formal_Package --
13691 -------------------------------
13693 function In_Generic_Formal_Package
(E
: Entity_Id
) return Boolean is
13698 while Present
(Par
) loop
13699 if Nkind
(Par
) = N_Formal_Package_Declaration
13700 or else Nkind
(Original_Node
(Par
)) = N_Formal_Package_Declaration
13705 Par
:= Parent
(Par
);
13709 end In_Generic_Formal_Package
;
13711 ----------------------
13712 -- In_Generic_Scope --
13713 ----------------------
13715 function In_Generic_Scope
(E
: Entity_Id
) return Boolean is
13720 while Present
(S
) and then S
/= Standard_Standard
loop
13721 if Is_Generic_Unit
(S
) then
13729 end In_Generic_Scope
;
13735 function In_Instance
return Boolean is
13736 Curr_Unit
: constant Entity_Id
:= Cunit_Entity
(Current_Sem_Unit
);
13740 S
:= Current_Scope
;
13741 while Present
(S
) and then S
/= Standard_Standard
loop
13742 if Is_Generic_Instance
(S
) then
13744 -- A child instance is always compiled in the context of a parent
13745 -- instance. Nevertheless, its actuals must not be analyzed in an
13746 -- instance context. We detect this case by examining the current
13747 -- compilation unit, which must be a child instance, and checking
13748 -- that it has not been analyzed yet.
13750 if Is_Child_Unit
(Curr_Unit
)
13751 and then Nkind
(Unit
(Cunit
(Current_Sem_Unit
))) =
13752 N_Package_Instantiation
13753 and then Ekind
(Curr_Unit
) = E_Void
13767 ----------------------
13768 -- In_Instance_Body --
13769 ----------------------
13771 function In_Instance_Body
return Boolean is
13775 S
:= Current_Scope
;
13776 while Present
(S
) and then S
/= Standard_Standard
loop
13777 if Ekind
(S
) in E_Function | E_Procedure
13778 and then Is_Generic_Instance
(S
)
13782 elsif Ekind
(S
) = E_Package
13783 and then In_Package_Body
(S
)
13784 and then Is_Generic_Instance
(S
)
13793 end In_Instance_Body
;
13795 -----------------------------
13796 -- In_Instance_Not_Visible --
13797 -----------------------------
13799 function In_Instance_Not_Visible
return Boolean is
13803 S
:= Current_Scope
;
13804 while Present
(S
) and then S
/= Standard_Standard
loop
13805 if Ekind
(S
) in E_Function | E_Procedure
13806 and then Is_Generic_Instance
(S
)
13810 elsif Ekind
(S
) = E_Package
13811 and then (In_Package_Body
(S
) or else In_Private_Part
(S
))
13812 and then Is_Generic_Instance
(S
)
13821 end In_Instance_Not_Visible
;
13823 ------------------------------
13824 -- In_Instance_Visible_Part --
13825 ------------------------------
13827 function In_Instance_Visible_Part
13828 (Id
: Entity_Id
:= Current_Scope
) return Boolean
13834 while Present
(Inst
) and then Inst
/= Standard_Standard
loop
13835 if Ekind
(Inst
) = E_Package
13836 and then Is_Generic_Instance
(Inst
)
13837 and then not In_Package_Body
(Inst
)
13838 and then not In_Private_Part
(Inst
)
13843 Inst
:= Scope
(Inst
);
13847 end In_Instance_Visible_Part
;
13849 ---------------------
13850 -- In_Package_Body --
13851 ---------------------
13853 function In_Package_Body
return Boolean is
13857 S
:= Current_Scope
;
13858 while Present
(S
) and then S
/= Standard_Standard
loop
13859 if Ekind
(S
) = E_Package
and then In_Package_Body
(S
) then
13867 end In_Package_Body
;
13869 --------------------------
13870 -- In_Pragma_Expression --
13871 --------------------------
13873 function In_Pragma_Expression
(N
: Node_Id
; Nam
: Name_Id
) return Boolean is
13881 -- Prevent the search from going too far
13883 elsif Is_Body_Or_Package_Declaration
(P
) then
13886 elsif Nkind
(P
) = N_Pragma
and then Pragma_Name
(P
) = Nam
then
13893 end In_Pragma_Expression
;
13895 ---------------------------
13896 -- In_Pre_Post_Condition --
13897 ---------------------------
13899 function In_Pre_Post_Condition
13900 (N
: Node_Id
; Class_Wide_Only
: Boolean := False) return Boolean
13903 Prag
: Node_Id
:= Empty
;
13904 Prag_Id
: Pragma_Id
;
13907 -- Climb the parent chain looking for an enclosing pragma
13910 while Present
(Par
) loop
13911 if Nkind
(Par
) = N_Pragma
then
13915 -- Prevent the search from going too far
13917 elsif Is_Body_Or_Package_Declaration
(Par
) then
13921 Par
:= Parent
(Par
);
13924 if Present
(Prag
) then
13925 Prag_Id
:= Get_Pragma_Id
(Prag
);
13927 if Class_Wide_Only
then
13929 Prag_Id
= Pragma_Post_Class
13930 or else Prag_Id
= Pragma_Pre_Class
13931 or else (Class_Present
(Prag
)
13932 and then (Prag_Id
= Pragma_Post
13933 or else Prag_Id
= Pragma_Postcondition
13934 or else Prag_Id
= Pragma_Pre
13935 or else Prag_Id
= Pragma_Precondition
));
13938 Prag_Id
= Pragma_Post
13939 or else Prag_Id
= Pragma_Post_Class
13940 or else Prag_Id
= Pragma_Postcondition
13941 or else Prag_Id
= Pragma_Pre
13942 or else Prag_Id
= Pragma_Pre_Class
13943 or else Prag_Id
= Pragma_Precondition
;
13946 -- Otherwise the node is not enclosed by a pre/postcondition pragma
13951 end In_Pre_Post_Condition
;
13953 ------------------------------
13954 -- In_Quantified_Expression --
13955 ------------------------------
13957 function In_Quantified_Expression
(N
: Node_Id
) return Boolean is
13965 -- Prevent the search from going too far
13967 elsif Is_Body_Or_Package_Declaration
(P
) then
13970 elsif Nkind
(P
) = N_Quantified_Expression
then
13976 end In_Quantified_Expression
;
13978 -------------------------------------
13979 -- In_Reverse_Storage_Order_Object --
13980 -------------------------------------
13982 function In_Reverse_Storage_Order_Object
(N
: Node_Id
) return Boolean is
13984 Btyp
: Entity_Id
:= Empty
;
13987 -- Climb up indexed components
13991 case Nkind
(Pref
) is
13992 when N_Selected_Component
=>
13993 Pref
:= Prefix
(Pref
);
13996 when N_Indexed_Component
=>
13997 Pref
:= Prefix
(Pref
);
14005 if Present
(Pref
) then
14006 Btyp
:= Base_Type
(Etype
(Pref
));
14009 return Present
(Btyp
)
14010 and then (Is_Record_Type
(Btyp
) or else Is_Array_Type
(Btyp
))
14011 and then Reverse_Storage_Order
(Btyp
);
14012 end In_Reverse_Storage_Order_Object
;
14014 ------------------------------
14015 -- In_Same_Declarative_Part --
14016 ------------------------------
14018 function In_Same_Declarative_Part
14019 (Context
: Node_Id
;
14020 N
: Node_Id
) return Boolean
14022 Cont
: Node_Id
:= Context
;
14026 if Nkind
(Cont
) = N_Compilation_Unit_Aux
then
14027 Cont
:= Parent
(Cont
);
14031 while Present
(Nod
) loop
14035 elsif Nkind
(Nod
) in N_Accept_Statement
14036 | N_Block_Statement
14037 | N_Compilation_Unit
14040 | N_Package_Declaration
14042 | N_Subprogram_Body
14047 elsif Nkind
(Nod
) = N_Subunit
then
14048 Nod
:= Corresponding_Stub
(Nod
);
14051 Nod
:= Parent
(Nod
);
14056 end In_Same_Declarative_Part
;
14058 --------------------------------------
14059 -- In_Subprogram_Or_Concurrent_Unit --
14060 --------------------------------------
14062 function In_Subprogram_Or_Concurrent_Unit
return Boolean is
14067 -- Use scope chain to check successively outer scopes
14069 E
:= Current_Scope
;
14073 if K
in Subprogram_Kind
14074 or else K
in Concurrent_Kind
14075 or else K
in Generic_Subprogram_Kind
14079 elsif E
= Standard_Standard
then
14085 end In_Subprogram_Or_Concurrent_Unit
;
14091 function In_Subtree
(N
: Node_Id
; Root
: Node_Id
) return Boolean is
14096 while Present
(Curr
) loop
14097 if Curr
= Root
then
14101 Curr
:= Parent
(Curr
);
14111 function In_Subtree
14114 Root2
: Node_Id
) return Boolean
14120 while Present
(Curr
) loop
14121 if Curr
= Root1
or else Curr
= Root2
then
14125 Curr
:= Parent
(Curr
);
14131 ---------------------
14132 -- In_Return_Value --
14133 ---------------------
14135 function In_Return_Value
(Expr
: Node_Id
) return Boolean is
14137 Prev_Par
: Node_Id
;
14139 In_Function_Call
: Boolean := False;
14142 -- Move through parent nodes to determine if Expr contributes to the
14143 -- return value of the current subprogram.
14147 while Present
(Par
) loop
14149 case Nkind
(Par
) is
14150 -- Ignore ranges and they don't contribute to the result
14155 -- An object declaration whose parent is an extended return
14156 -- statement is a return object.
14158 when N_Object_Declaration
=>
14159 if Present
(Parent
(Par
))
14160 and then Nkind
(Parent
(Par
)) = N_Extended_Return_Statement
14165 -- We hit a simple return statement, so we know we are in one
14167 when N_Simple_Return_Statement
=>
14170 -- Only include one nexting level of function calls
14172 when N_Function_Call
=>
14173 if not In_Function_Call
then
14174 In_Function_Call
:= True;
14176 -- When the function return type has implicit dereference
14177 -- specified we know it cannot directly contribute to the
14180 if Present
(Etype
(Par
))
14181 and then Has_Implicit_Dereference
14182 (Get_Full_View
(Etype
(Par
)))
14190 -- Check if we are on the right-hand side of an assignment
14191 -- statement to a return object.
14193 -- This is not specified in the RM ???
14195 when N_Assignment_Statement
=>
14196 if Prev_Par
= Name
(Par
) then
14201 while Present
(Pre
) loop
14202 if Is_Entity_Name
(Pre
)
14203 and then Is_Return_Object
(Entity
(Pre
))
14208 exit when Nkind
(Pre
) not in N_Selected_Component
14209 | N_Indexed_Component
14212 Pre
:= Prefix
(Pre
);
14215 -- Otherwise, we hit a master which was not relevant
14218 if Is_Master
(Par
) then
14223 -- Iterate up to the next parent, keeping track of the previous one
14226 Par
:= Parent
(Par
);
14230 end In_Return_Value
;
14232 -----------------------------------------
14233 -- In_Statement_Condition_With_Actions --
14234 -----------------------------------------
14236 function In_Statement_Condition_With_Actions
(N
: Node_Id
) return Boolean is
14237 Prev
: Node_Id
:= N
;
14238 P
: Node_Id
:= Parent
(N
);
14239 -- P and Prev will be used for traversing the AST, while maintaining an
14240 -- invariant that P = Parent (Prev).
14242 while Present
(P
) loop
14243 if Nkind
(P
) = N_Iteration_Scheme
14244 and then Prev
= Condition
(P
)
14248 elsif Nkind
(P
) = N_Elsif_Part
14249 and then Prev
= Condition
(P
)
14253 -- No point in going beyond statements
14255 elsif Nkind
(N
) in N_Statement_Other_Than_Procedure_Call
14256 | N_Procedure_Call_Statement
14260 -- Prevent the search from going too far
14262 elsif Is_Body_Or_Package_Declaration
(P
) then
14271 end In_Statement_Condition_With_Actions
;
14273 ---------------------
14274 -- In_Visible_Part --
14275 ---------------------
14277 function In_Visible_Part
(Scope_Id
: Entity_Id
) return Boolean is
14279 return Is_Package_Or_Generic_Package
(Scope_Id
)
14280 and then In_Open_Scopes
(Scope_Id
)
14281 and then not In_Package_Body
(Scope_Id
)
14282 and then not In_Private_Part
(Scope_Id
);
14283 end In_Visible_Part
;
14285 --------------------------------
14286 -- Incomplete_Or_Partial_View --
14287 --------------------------------
14289 function Incomplete_Or_Partial_View
(Id
: Entity_Id
) return Entity_Id
is
14290 S
: constant Entity_Id
:= Scope
(Id
);
14292 function Inspect_Decls
14294 Taft
: Boolean := False) return Entity_Id
;
14295 -- Check whether a declarative region contains the incomplete or partial
14298 -------------------
14299 -- Inspect_Decls --
14300 -------------------
14302 function Inspect_Decls
14304 Taft
: Boolean := False) return Entity_Id
14310 Decl
:= First
(Decls
);
14311 while Present
(Decl
) loop
14314 -- The partial view of a Taft-amendment type is an incomplete
14318 if Nkind
(Decl
) = N_Incomplete_Type_Declaration
then
14319 Match
:= Defining_Identifier
(Decl
);
14322 -- Otherwise look for a private type whose full view matches the
14323 -- input type. Note that this checks full_type_declaration nodes
14324 -- to account for derivations from a private type where the type
14325 -- declaration hold the partial view and the full view is an
14328 elsif Nkind
(Decl
) in N_Full_Type_Declaration
14329 | N_Private_Extension_Declaration
14330 | N_Private_Type_Declaration
14332 Match
:= Defining_Identifier
(Decl
);
14335 -- Guard against unanalyzed entities
14338 and then Is_Type
(Match
)
14339 and then Present
(Full_View
(Match
))
14340 and then Full_View
(Match
) = Id
14355 -- Start of processing for Incomplete_Or_Partial_View
14358 -- Deferred constant or incomplete type case
14360 Prev
:= Current_Entity
(Id
);
14362 while Present
(Prev
) loop
14363 exit when Scope
(Prev
) = S
;
14365 Prev
:= Homonym
(Prev
);
14369 and then (Is_Incomplete_Type
(Prev
) or else Ekind
(Prev
) = E_Constant
)
14370 and then Present
(Full_View
(Prev
))
14371 and then Full_View
(Prev
) = Id
14376 -- Private or Taft amendment type case
14378 if Present
(S
) and then Is_Package_Or_Generic_Package
(S
) then
14380 Pkg_Decl
: constant Node_Id
:= Package_Specification
(S
);
14383 -- It is knows that Typ has a private view, look for it in the
14384 -- visible declarations of the enclosing scope. A special case
14385 -- of this is when the two views have been exchanged - the full
14386 -- appears earlier than the private.
14388 if Has_Private_Declaration
(Id
) then
14389 Prev
:= Inspect_Decls
(Visible_Declarations
(Pkg_Decl
));
14391 -- Exchanged view case, look in the private declarations
14394 Prev
:= Inspect_Decls
(Private_Declarations
(Pkg_Decl
));
14399 -- Otherwise if this is the package body, then Typ is a potential
14400 -- Taft amendment type. The incomplete view should be located in
14401 -- the private declarations of the enclosing scope.
14403 elsif In_Package_Body
(S
) then
14404 return Inspect_Decls
(Private_Declarations
(Pkg_Decl
), True);
14409 -- The type has no incomplete or private view
14412 end Incomplete_Or_Partial_View
;
14414 ---------------------------------------
14415 -- Incomplete_View_From_Limited_With --
14416 ---------------------------------------
14418 function Incomplete_View_From_Limited_With
14419 (Typ
: Entity_Id
) return Entity_Id
14422 -- It might make sense to make this an attribute in Einfo, and set it
14423 -- in Sem_Ch10 in Build_Shadow_Entity. However, we're running short on
14424 -- slots for new attributes, and it seems a bit simpler to just search
14425 -- the Limited_View (if it exists) for an incomplete type whose
14426 -- Non_Limited_View is Typ.
14428 if Ekind
(Scope
(Typ
)) = E_Package
14429 and then Present
(Limited_View
(Scope
(Typ
)))
14432 Ent
: Entity_Id
:= First_Entity
(Limited_View
(Scope
(Typ
)));
14434 while Present
(Ent
) loop
14435 if Is_Incomplete_Type
(Ent
)
14436 and then Non_Limited_View
(Ent
) = Typ
14447 end Incomplete_View_From_Limited_With
;
14449 ----------------------------------
14450 -- Indexed_Component_Bit_Offset --
14451 ----------------------------------
14453 function Indexed_Component_Bit_Offset
(N
: Node_Id
) return Uint
is
14454 Exp
: constant Node_Id
:= First
(Expressions
(N
));
14455 Typ
: constant Entity_Id
:= Etype
(Prefix
(N
));
14456 Off
: constant Uint
:= Component_Size
(Typ
);
14460 -- Return early if the component size is not known or variable
14462 if No
(Off
) or else Off
< Uint_0
then
14466 -- Deal with the degenerate case of an empty component
14468 if Off
= Uint_0
then
14472 -- Check that both the index value and the low bound are known
14474 if not Compile_Time_Known_Value
(Exp
) then
14478 Ind
:= First_Index
(Typ
);
14483 -- Do not attempt to compute offsets within multi-dimensional arrays
14485 if Present
(Next_Index
(Ind
)) then
14489 if Nkind
(Ind
) = N_Subtype_Indication
then
14490 Ind
:= Constraint
(Ind
);
14492 if Nkind
(Ind
) = N_Range_Constraint
then
14493 Ind
:= Range_Expression
(Ind
);
14497 if Nkind
(Ind
) /= N_Range
14498 or else not Compile_Time_Known_Value
(Low_Bound
(Ind
))
14503 -- Return the scaled offset
14505 return Off
* (Expr_Value
(Exp
) - Expr_Value
(Low_Bound
(Ind
)));
14506 end Indexed_Component_Bit_Offset
;
14508 -----------------------------
14509 -- Inherit_Predicate_Flags --
14510 -----------------------------
14512 procedure Inherit_Predicate_Flags
14513 (Subt
, Par
: Entity_Id
;
14514 Only_Flags
: Boolean := False)
14517 if Ada_Version
< Ada_2012
14518 or else Present
(Predicate_Function
(Subt
))
14523 Set_Has_Predicates
(Subt
, Has_Predicates
(Par
));
14524 Set_Has_Static_Predicate_Aspect
14525 (Subt
, Has_Static_Predicate_Aspect
(Par
));
14526 Set_Has_Dynamic_Predicate_Aspect
14527 (Subt
, Has_Dynamic_Predicate_Aspect
(Par
));
14528 Set_Has_Ghost_Predicate_Aspect
14529 (Subt
, Has_Ghost_Predicate_Aspect
(Par
));
14531 -- A named subtype does not inherit the predicate function of its
14532 -- parent but an itype declared for a loop index needs the discrete
14533 -- predicate information of its parent to execute the loop properly.
14534 -- Moreover, a named private subtype whose full view is an itype also
14535 -- needs to inherit a predicate function because it will not be frozen.
14536 -- A non-discrete type may has a static predicate (for example True)
14537 -- but has no static_discrete_predicate.
14540 and then (Is_Itype
(Subt
)
14541 or else (Ekind
(Subt
) = E_Private_Subtype
14542 and then Present
(Full_View
(Subt
))
14543 and then Is_Itype
(Full_View
(Subt
))))
14544 and then Present
(Predicate_Function
(Par
))
14546 Set_Subprograms_For_Type
(Subt
, Subprograms_For_Type
(Par
));
14548 if Has_Static_Predicate
(Par
) and then Is_Discrete_Type
(Par
) then
14549 Set_Static_Discrete_Predicate
14550 (Subt
, Static_Discrete_Predicate
(Par
));
14553 end Inherit_Predicate_Flags
;
14555 ----------------------------
14556 -- Inherit_Rep_Item_Chain --
14557 ----------------------------
14559 procedure Inherit_Rep_Item_Chain
(Typ
: Entity_Id
; From_Typ
: Entity_Id
) is
14561 Next_Item
: Node_Id
;
14564 -- There are several inheritance scenarios to consider depending on
14565 -- whether both types have rep item chains and whether the destination
14566 -- type already inherits part of the source type's rep item chain.
14568 -- 1) The source type lacks a rep item chain
14569 -- From_Typ ---> Empty
14571 -- Typ --------> Item (or Empty)
14573 -- In this case inheritance cannot take place because there are no items
14576 -- 2) The destination type lacks a rep item chain
14577 -- From_Typ ---> Item ---> ...
14579 -- Typ --------> Empty
14581 -- Inheritance takes place by setting the First_Rep_Item of the
14582 -- destination type to the First_Rep_Item of the source type.
14583 -- From_Typ ---> Item ---> ...
14585 -- Typ -----------+
14587 -- 3.1) Both source and destination types have at least one rep item.
14588 -- The destination type does NOT inherit a rep item from the source
14590 -- From_Typ ---> Item ---> Item
14592 -- Typ --------> Item ---> Item
14594 -- Inheritance takes place by setting the Next_Rep_Item of the last item
14595 -- of the destination type to the First_Rep_Item of the source type.
14596 -- From_Typ -------------------> Item ---> Item
14598 -- Typ --------> Item ---> Item --+
14600 -- 3.2) Both source and destination types have at least one rep item.
14601 -- The destination type DOES inherit part of the rep item chain of the
14603 -- From_Typ ---> Item ---> Item ---> Item
14605 -- Typ --------> Item ------+
14607 -- This rare case arises when the full view of a private extension must
14608 -- inherit the rep item chain from the full view of its parent type and
14609 -- the full view of the parent type contains extra rep items. Currently
14610 -- only invariants may lead to such form of inheritance.
14612 -- type From_Typ is tagged private
14613 -- with Type_Invariant'Class => Item_2;
14615 -- type Typ is new From_Typ with private
14616 -- with Type_Invariant => Item_4;
14618 -- At this point the rep item chains contain the following items
14620 -- From_Typ -----------> Item_2 ---> Item_3
14622 -- Typ --------> Item_4 --+
14624 -- The full views of both types may introduce extra invariants
14626 -- type From_Typ is tagged null record
14627 -- with Type_Invariant => Item_1;
14629 -- type Typ is new From_Typ with null record;
14631 -- The full view of Typ would have to inherit any new rep items added to
14632 -- the full view of From_Typ.
14634 -- From_Typ -----------> Item_1 ---> Item_2 ---> Item_3
14636 -- Typ --------> Item_4 --+
14638 -- To achieve this form of inheritance, the destination type must first
14639 -- sever the link between its own rep chain and that of the source type,
14640 -- then inheritance 3.1 takes place.
14642 -- Case 1: The source type lacks a rep item chain
14644 if No
(First_Rep_Item
(From_Typ
)) then
14647 -- Case 2: The destination type lacks a rep item chain
14649 elsif No
(First_Rep_Item
(Typ
)) then
14650 Set_First_Rep_Item
(Typ
, First_Rep_Item
(From_Typ
));
14652 -- Case 3: Both the source and destination types have at least one rep
14653 -- item. Traverse the rep item chain of the destination type to find the
14658 Next_Item
:= First_Rep_Item
(Typ
);
14659 while Present
(Next_Item
) loop
14661 -- Detect a link between the destination type's rep chain and that
14662 -- of the source type. There are two possibilities:
14667 -- From_Typ ---> Item_1 --->
14669 -- Typ -----------+
14676 -- From_Typ ---> Item_1 ---> Item_2 --->
14678 -- Typ --------> Item_3 ------+
14682 if Present_In_Rep_Item
(From_Typ
, Next_Item
) then
14687 Next_Item
:= Next_Rep_Item
(Next_Item
);
14690 -- Inherit the source type's rep item chain
14692 if Present
(Item
) then
14693 Set_Next_Rep_Item
(Item
, First_Rep_Item
(From_Typ
));
14695 Set_First_Rep_Item
(Typ
, First_Rep_Item
(From_Typ
));
14698 end Inherit_Rep_Item_Chain
;
14700 ------------------------------------
14701 -- Inherits_From_Tagged_Full_View --
14702 ------------------------------------
14704 function Inherits_From_Tagged_Full_View
(Typ
: Entity_Id
) return Boolean is
14706 return Is_Private_Type
(Typ
)
14707 and then Present
(Full_View
(Typ
))
14708 and then Is_Private_Type
(Full_View
(Typ
))
14709 and then not Is_Tagged_Type
(Full_View
(Typ
))
14710 and then Present
(Underlying_Type
(Full_View
(Typ
)))
14711 and then Is_Tagged_Type
(Underlying_Type
(Full_View
(Typ
)));
14712 end Inherits_From_Tagged_Full_View
;
14714 ---------------------------------
14715 -- Insert_Explicit_Dereference --
14716 ---------------------------------
14718 procedure Insert_Explicit_Dereference
(N
: Node_Id
) is
14719 New_Prefix
: constant Node_Id
:= Relocate_Node
(N
);
14720 Ent
: Entity_Id
:= Empty
;
14721 Pref
: Node_Id
:= Empty
;
14727 Save_Interps
(N
, New_Prefix
);
14730 Make_Explicit_Dereference
(Sloc
(Parent
(N
)),
14731 Prefix
=> New_Prefix
));
14733 Set_Etype
(N
, Designated_Type
(Etype
(New_Prefix
)));
14735 if Is_Overloaded
(New_Prefix
) then
14737 -- The dereference is also overloaded, and its interpretations are
14738 -- the designated types of the interpretations of the original node.
14740 Set_Etype
(N
, Any_Type
);
14742 Get_First_Interp
(New_Prefix
, I
, It
);
14743 while Present
(It
.Nam
) loop
14746 if Is_Access_Type
(T
) then
14747 Add_One_Interp
(N
, Designated_Type
(T
), Designated_Type
(T
));
14750 Get_Next_Interp
(I
, It
);
14754 -- Prefix is unambiguous: mark the original prefix (which might
14755 -- Come_From_Source) as a reference, since the new (relocated) one
14756 -- won't be taken into account.
14758 if Is_Entity_Name
(New_Prefix
) then
14759 Ent
:= Entity
(New_Prefix
);
14760 Pref
:= New_Prefix
;
14762 -- For a retrieval of a subcomponent of some composite object,
14763 -- retrieve the ultimate entity if there is one.
14765 elsif Nkind
(New_Prefix
) in N_Selected_Component | N_Indexed_Component
14767 Pref
:= Prefix
(New_Prefix
);
14768 while Present
(Pref
)
14769 and then Nkind
(Pref
) in
14770 N_Selected_Component | N_Indexed_Component
14772 Pref
:= Prefix
(Pref
);
14775 if Present
(Pref
) and then Is_Entity_Name
(Pref
) then
14776 Ent
:= Entity
(Pref
);
14780 -- Place the reference on the entity node
14782 if Present
(Ent
) then
14783 Generate_Reference
(Ent
, Pref
);
14786 end Insert_Explicit_Dereference
;
14788 ------------------------------------------
14789 -- Inspect_Deferred_Constant_Completion --
14790 ------------------------------------------
14792 procedure Inspect_Deferred_Constant_Completion
(Decls
: List_Id
) is
14796 Decl
:= First
(Decls
);
14797 while Present
(Decl
) loop
14799 -- Deferred constant signature
14801 if Nkind
(Decl
) = N_Object_Declaration
14802 and then Constant_Present
(Decl
)
14803 and then No
(Expression
(Decl
))
14805 -- No need to check internally generated constants
14807 and then Comes_From_Source
(Decl
)
14809 -- The constant is not completed. A full object declaration or a
14810 -- pragma Import complete a deferred constant.
14812 and then not Has_Completion
(Defining_Identifier
(Decl
))
14815 ("constant declaration requires initialization expression",
14816 Defining_Identifier
(Decl
));
14821 end Inspect_Deferred_Constant_Completion
;
14823 -------------------------------
14824 -- Install_Elaboration_Model --
14825 -------------------------------
14827 procedure Install_Elaboration_Model
(Unit_Id
: Entity_Id
) is
14828 function Find_Elaboration_Checks_Pragma
(L
: List_Id
) return Node_Id
;
14829 -- Try to find pragma Elaboration_Checks in arbitrary list L. Return
14830 -- Empty if there is no such pragma.
14832 ------------------------------------
14833 -- Find_Elaboration_Checks_Pragma --
14834 ------------------------------------
14836 function Find_Elaboration_Checks_Pragma
(L
: List_Id
) return Node_Id
is
14841 while Present
(Item
) loop
14842 if Nkind
(Item
) = N_Pragma
14843 and then Pragma_Name
(Item
) = Name_Elaboration_Checks
14852 end Find_Elaboration_Checks_Pragma
;
14861 -- Start of processing for Install_Elaboration_Model
14864 -- Nothing to do when the unit does not exist
14866 if No
(Unit_Id
) then
14870 Unit
:= Parent
(Unit_Declaration_Node
(Unit_Id
));
14872 -- Nothing to do when the unit is not a library unit
14874 if Nkind
(Unit
) /= N_Compilation_Unit
then
14878 Prag
:= Find_Elaboration_Checks_Pragma
(Context_Items
(Unit
));
14880 -- The compilation unit is subject to pragma Elaboration_Checks. Set the
14881 -- elaboration model as specified by the pragma.
14883 if Present
(Prag
) then
14884 Args
:= Pragma_Argument_Associations
(Prag
);
14886 -- Guard against an illegal pragma. The sole argument must be an
14887 -- identifier which specifies either Dynamic or Static model.
14889 if Present
(Args
) then
14890 Model
:= Get_Pragma_Arg
(First
(Args
));
14892 if Nkind
(Model
) = N_Identifier
then
14893 Dynamic_Elaboration_Checks
:= Chars
(Model
) = Name_Dynamic
;
14897 end Install_Elaboration_Model
;
14899 -----------------------------
14900 -- Install_Generic_Formals --
14901 -----------------------------
14903 procedure Install_Generic_Formals
(Subp_Id
: Entity_Id
) is
14907 pragma Assert
(Is_Generic_Subprogram
(Subp_Id
));
14909 E
:= First_Entity
(Subp_Id
);
14910 while Present
(E
) loop
14911 Install_Entity
(E
);
14914 end Install_Generic_Formals
;
14916 ------------------------
14917 -- Install_SPARK_Mode --
14918 ------------------------
14920 procedure Install_SPARK_Mode
(Mode
: SPARK_Mode_Type
; Prag
: Node_Id
) is
14922 SPARK_Mode
:= Mode
;
14923 SPARK_Mode_Pragma
:= Prag
;
14924 end Install_SPARK_Mode
;
14926 --------------------------
14927 -- Invalid_Scalar_Value --
14928 --------------------------
14930 function Invalid_Scalar_Value
14932 Scal_Typ
: Scalar_Id
) return Node_Id
14934 function Invalid_Binder_Value
return Node_Id
;
14935 -- Return a reference to the corresponding invalid value for type
14936 -- Scal_Typ as defined in unit System.Scalar_Values.
14938 function Invalid_Float_Value
return Node_Id
;
14939 -- Return the invalid value of float type Scal_Typ
14941 function Invalid_Integer_Value
return Node_Id
;
14942 -- Return the invalid value of integer type Scal_Typ
14944 procedure Set_Invalid_Binder_Values
;
14945 -- Set the contents of collection Invalid_Binder_Values
14947 --------------------------
14948 -- Invalid_Binder_Value --
14949 --------------------------
14951 function Invalid_Binder_Value
return Node_Id
is
14952 Val_Id
: Entity_Id
;
14955 -- Initialize the collection of invalid binder values the first time
14958 Set_Invalid_Binder_Values
;
14960 -- Obtain the corresponding variable from System.Scalar_Values which
14961 -- holds the invalid value for this type.
14963 Val_Id
:= Invalid_Binder_Values
(Scal_Typ
);
14964 pragma Assert
(Present
(Val_Id
));
14966 return New_Occurrence_Of
(Val_Id
, Loc
);
14967 end Invalid_Binder_Value
;
14969 -------------------------
14970 -- Invalid_Float_Value --
14971 -------------------------
14973 function Invalid_Float_Value
return Node_Id
is
14974 Value
: constant Ureal
:= Invalid_Floats
(Scal_Typ
);
14977 -- Pragma Invalid_Scalars did not specify an invalid value for this
14978 -- type. Fall back to the value provided by the binder.
14980 if Value
= No_Ureal
then
14981 return Invalid_Binder_Value
;
14983 return Make_Real_Literal
(Loc
, Realval
=> Value
);
14985 end Invalid_Float_Value
;
14987 ---------------------------
14988 -- Invalid_Integer_Value --
14989 ---------------------------
14991 function Invalid_Integer_Value
return Node_Id
is
14992 Value
: constant Uint
:= Invalid_Integers
(Scal_Typ
);
14995 -- Pragma Invalid_Scalars did not specify an invalid value for this
14996 -- type. Fall back to the value provided by the binder.
14999 return Invalid_Binder_Value
;
15001 return Make_Integer_Literal
(Loc
, Intval
=> Value
);
15003 end Invalid_Integer_Value
;
15005 -------------------------------
15006 -- Set_Invalid_Binder_Values --
15007 -------------------------------
15009 procedure Set_Invalid_Binder_Values
is
15011 if not Invalid_Binder_Values_Set
then
15012 Invalid_Binder_Values_Set
:= True;
15014 -- Initialize the contents of the collection once since RTE calls
15017 Invalid_Binder_Values
:=
15018 (Name_Short_Float
=> RTE
(RE_IS_Isf
),
15019 Name_Float
=> RTE
(RE_IS_Ifl
),
15020 Name_Long_Float
=> RTE
(RE_IS_Ilf
),
15021 Name_Long_Long_Float
=> RTE
(RE_IS_Ill
),
15022 Name_Signed_8
=> RTE
(RE_IS_Is1
),
15023 Name_Signed_16
=> RTE
(RE_IS_Is2
),
15024 Name_Signed_32
=> RTE
(RE_IS_Is4
),
15025 Name_Signed_64
=> RTE
(RE_IS_Is8
),
15026 Name_Signed_128
=> Empty
,
15027 Name_Unsigned_8
=> RTE
(RE_IS_Iu1
),
15028 Name_Unsigned_16
=> RTE
(RE_IS_Iu2
),
15029 Name_Unsigned_32
=> RTE
(RE_IS_Iu4
),
15030 Name_Unsigned_64
=> RTE
(RE_IS_Iu8
),
15031 Name_Unsigned_128
=> Empty
);
15033 if System_Max_Integer_Size
< 128 then
15034 Invalid_Binder_Values
(Name_Signed_128
) := RTE
(RE_IS_Is8
);
15035 Invalid_Binder_Values
(Name_Unsigned_128
) := RTE
(RE_IS_Iu8
);
15037 Invalid_Binder_Values
(Name_Signed_128
) := RTE
(RE_IS_Is16
);
15038 Invalid_Binder_Values
(Name_Unsigned_128
) := RTE
(RE_IS_Iu16
);
15041 end Set_Invalid_Binder_Values
;
15043 -- Start of processing for Invalid_Scalar_Value
15046 if Scal_Typ
in Float_Scalar_Id
then
15047 return Invalid_Float_Value
;
15049 else pragma Assert
(Scal_Typ
in Integer_Scalar_Id
);
15050 return Invalid_Integer_Value
;
15052 end Invalid_Scalar_Value
;
15054 ------------------------
15055 -- Is_Access_Variable --
15056 ------------------------
15058 function Is_Access_Variable
(E
: Entity_Id
) return Boolean is
15060 return Is_Access_Type
(E
)
15061 and then not Is_Access_Constant
(E
)
15062 and then Ekind
(Directly_Designated_Type
(E
)) /= E_Subprogram_Type
;
15063 end Is_Access_Variable
;
15065 -----------------------------
15066 -- Is_Actual_Out_Parameter --
15067 -----------------------------
15069 function Is_Actual_Out_Parameter
(N
: Node_Id
) return Boolean is
15070 Formal
: Entity_Id
;
15073 Find_Actual
(N
, Formal
, Call
);
15074 return Present
(Formal
) and then Ekind
(Formal
) = E_Out_Parameter
;
15075 end Is_Actual_Out_Parameter
;
15077 --------------------------------
15078 -- Is_Actual_In_Out_Parameter --
15079 --------------------------------
15081 function Is_Actual_In_Out_Parameter
(N
: Node_Id
) return Boolean is
15082 Formal
: Entity_Id
;
15085 Find_Actual
(N
, Formal
, Call
);
15086 return Present
(Formal
) and then Ekind
(Formal
) = E_In_Out_Parameter
;
15087 end Is_Actual_In_Out_Parameter
;
15089 ---------------------------------------
15090 -- Is_Actual_Out_Or_In_Out_Parameter --
15091 ---------------------------------------
15093 function Is_Actual_Out_Or_In_Out_Parameter
(N
: Node_Id
) return Boolean is
15094 Formal
: Entity_Id
;
15097 Find_Actual
(N
, Formal
, Call
);
15098 return Present
(Formal
)
15099 and then Ekind
(Formal
) in E_Out_Parameter | E_In_Out_Parameter
;
15100 end Is_Actual_Out_Or_In_Out_Parameter
;
15102 -------------------------
15103 -- Is_Actual_Parameter --
15104 -------------------------
15106 function Is_Actual_Parameter
(N
: Node_Id
) return Boolean is
15107 PK
: constant Node_Kind
:= Nkind
(Parent
(N
));
15111 when N_Parameter_Association
=>
15112 return N
= Explicit_Actual_Parameter
(Parent
(N
));
15114 when N_Entry_Call_Statement
15115 | N_Subprogram_Call
15117 return Is_List_Member
(N
)
15119 List_Containing
(N
) = Parameter_Associations
(Parent
(N
));
15124 end Is_Actual_Parameter
;
15126 ---------------------
15127 -- Is_Aliased_View --
15128 ---------------------
15130 function Is_Aliased_View
(Obj
: Node_Id
) return Boolean is
15134 if Is_Entity_Name
(Obj
) then
15141 or else (Present
(Renamed_Object
(E
))
15142 and then Is_Aliased_View
(Renamed_Object
(E
)))))
15144 or else ((Is_Formal
(E
) or else Is_Formal_Object
(E
))
15145 and then Is_Tagged_Type
(Etype
(E
)))
15147 or else (Is_Concurrent_Type
(E
) and then In_Open_Scopes
(E
))
15149 -- Current instance of type, either directly or as rewritten
15150 -- reference to the current object.
15152 or else (Is_Entity_Name
(Original_Node
(Obj
))
15153 and then Present
(Entity
(Original_Node
(Obj
)))
15154 and then Is_Type
(Entity
(Original_Node
(Obj
))))
15156 or else (Is_Type
(E
) and then E
= Current_Scope
)
15158 or else (Is_Incomplete_Or_Private_Type
(E
)
15159 and then Full_View
(E
) = Current_Scope
)
15161 -- Ada 2012 AI05-0053: the return object of an extended return
15162 -- statement is aliased if its type is immutably limited.
15164 or else (Is_Return_Object
(E
)
15165 and then Is_Inherently_Limited_Type
(Etype
(E
)))
15167 -- The current instance of a limited type is aliased, so
15168 -- we want to allow uses of T'Access in the init proc for
15169 -- a limited type T. However, we don't want to mark the formal
15170 -- parameter as being aliased since that could impact callers.
15172 or else (Is_Formal
(E
)
15173 and then Chars
(E
) = Name_uInit
15174 and then Is_Inherently_Limited_Type
(Etype
(E
)));
15176 elsif Nkind
(Obj
) = N_Selected_Component
then
15177 return Is_Aliased
(Entity
(Selector_Name
(Obj
)));
15179 elsif Nkind
(Obj
) = N_Indexed_Component
then
15180 return Has_Aliased_Components
(Etype
(Prefix
(Obj
)))
15182 (Is_Access_Type
(Etype
(Prefix
(Obj
)))
15183 and then Has_Aliased_Components
15184 (Designated_Type
(Etype
(Prefix
(Obj
)))));
15186 elsif Nkind
(Obj
) in N_Unchecked_Type_Conversion | N_Type_Conversion
then
15187 return Is_Tagged_Type
(Etype
(Obj
))
15188 and then Is_Aliased_View
(Expression
(Obj
));
15190 -- Ada 2022 AI12-0228
15192 elsif Nkind
(Obj
) = N_Qualified_Expression
15193 and then Ada_Version
>= Ada_2012
15195 return Is_Aliased_View
(Expression
(Obj
));
15197 -- The dereference of an access-to-object value denotes an aliased view,
15198 -- but this routine uses the rules of the language so we need to exclude
15199 -- rewritten constructs that introduce artificial dereferences.
15201 elsif Nkind
(Obj
) = N_Explicit_Dereference
then
15202 return not Is_Captured_Function_Call
(Obj
)
15204 (Nkind
(Parent
(Obj
)) = N_Object_Renaming_Declaration
15205 and then Is_Return_Object
(Defining_Entity
(Parent
(Obj
))));
15210 end Is_Aliased_View
;
15212 -------------------------
15213 -- Is_Ancestor_Package --
15214 -------------------------
15216 function Is_Ancestor_Package
15218 E2
: Entity_Id
) return Boolean
15224 while Present
(Par
) and then Par
/= Standard_Standard
loop
15229 Par
:= Scope
(Par
);
15233 end Is_Ancestor_Package
;
15235 ----------------------
15236 -- Is_Atomic_Object --
15237 ----------------------
15239 function Is_Atomic_Object
(N
: Node_Id
) return Boolean is
15240 function Prefix_Has_Atomic_Components
(P
: Node_Id
) return Boolean;
15241 -- Determine whether prefix P has atomic components. This requires the
15242 -- presence of an Atomic_Components aspect/pragma.
15244 ---------------------------------
15245 -- Prefix_Has_Atomic_Components --
15246 ---------------------------------
15248 function Prefix_Has_Atomic_Components
(P
: Node_Id
) return Boolean is
15249 Typ
: constant Entity_Id
:= Etype
(P
);
15252 if Is_Access_Type
(Typ
) then
15253 return Has_Atomic_Components
(Designated_Type
(Typ
));
15255 elsif Has_Atomic_Components
(Typ
) then
15258 elsif Is_Entity_Name
(P
)
15259 and then Has_Atomic_Components
(Entity
(P
))
15266 end Prefix_Has_Atomic_Components
;
15268 -- Start of processing for Is_Atomic_Object
15271 if Is_Entity_Name
(N
) then
15272 return Is_Atomic_Object_Entity
(Entity
(N
));
15274 elsif Is_Atomic
(Etype
(N
)) then
15277 elsif Nkind
(N
) = N_Indexed_Component
then
15278 return Prefix_Has_Atomic_Components
(Prefix
(N
));
15280 elsif Nkind
(N
) = N_Selected_Component
then
15281 return Is_Atomic
(Entity
(Selector_Name
(N
)));
15286 end Is_Atomic_Object
;
15288 -----------------------------
15289 -- Is_Atomic_Object_Entity --
15290 -----------------------------
15292 function Is_Atomic_Object_Entity
(Id
: Entity_Id
) return Boolean is
15296 and then (Is_Atomic
(Id
) or else Is_Atomic
(Etype
(Id
)));
15297 end Is_Atomic_Object_Entity
;
15299 -----------------------------
15300 -- Is_Attribute_Loop_Entry --
15301 -----------------------------
15303 function Is_Attribute_Loop_Entry
(N
: Node_Id
) return Boolean is
15305 return Nkind
(N
) = N_Attribute_Reference
15306 and then Attribute_Name
(N
) = Name_Loop_Entry
;
15307 end Is_Attribute_Loop_Entry
;
15309 ----------------------
15310 -- Is_Attribute_Old --
15311 ----------------------
15313 function Is_Attribute_Old
(N
: Node_Id
) return Boolean is
15315 return Nkind
(N
) = N_Attribute_Reference
15316 and then Attribute_Name
(N
) = Name_Old
;
15317 end Is_Attribute_Old
;
15319 -------------------------
15320 -- Is_Attribute_Result --
15321 -------------------------
15323 function Is_Attribute_Result
(N
: Node_Id
) return Boolean is
15325 return Nkind
(N
) = N_Attribute_Reference
15326 and then Attribute_Name
(N
) = Name_Result
;
15327 end Is_Attribute_Result
;
15329 -------------------------
15330 -- Is_Attribute_Update --
15331 -------------------------
15333 function Is_Attribute_Update
(N
: Node_Id
) return Boolean is
15335 return Nkind
(N
) = N_Attribute_Reference
15336 and then Attribute_Name
(N
) = Name_Update
;
15337 end Is_Attribute_Update
;
15339 ------------------------------------
15340 -- Is_Body_Or_Package_Declaration --
15341 ------------------------------------
15343 function Is_Body_Or_Package_Declaration
(N
: Node_Id
) return Boolean is
15345 return Is_Body
(N
) or else Nkind
(N
) = N_Package_Declaration
;
15346 end Is_Body_Or_Package_Declaration
;
15348 -----------------------
15349 -- Is_Bounded_String --
15350 -----------------------
15352 function Is_Bounded_String
(T
: Entity_Id
) return Boolean is
15353 Under
: constant Entity_Id
:= Underlying_Type
(Root_Type
(T
));
15356 -- Check whether T is ultimately derived from Ada.Strings.Superbounded.
15357 -- Super_String, or one of the [Wide_]Wide_ versions. This will
15358 -- be True for all the Bounded_String types in instances of the
15359 -- Generic_Bounded_Length generics, and for types derived from those.
15361 return Present
(Under
)
15362 and then (Is_RTE
(Root_Type
(Under
), RO_SU_Super_String
) or else
15363 Is_RTE
(Root_Type
(Under
), RO_WI_Super_String
) or else
15364 Is_RTE
(Root_Type
(Under
), RO_WW_Super_String
));
15365 end Is_Bounded_String
;
15367 -------------------------------
15368 -- Is_By_Protected_Procedure --
15369 -------------------------------
15371 function Is_By_Protected_Procedure
(Id
: Entity_Id
) return Boolean is
15373 return Ekind
(Id
) = E_Procedure
15374 and then Present
(Get_Rep_Pragma
(Id
, Name_Implemented
))
15375 and then Implementation_Kind
(Id
) = Name_By_Protected_Procedure
;
15376 end Is_By_Protected_Procedure
;
15378 ---------------------
15379 -- Is_CCT_Instance --
15380 ---------------------
15382 function Is_CCT_Instance
15383 (Ref_Id
: Entity_Id
;
15384 Context_Id
: Entity_Id
) return Boolean
15387 pragma Assert
(Ekind
(Ref_Id
) in E_Protected_Type | E_Task_Type
);
15389 if Is_Single_Task_Object
(Context_Id
) then
15390 return Scope_Within_Or_Same
(Etype
(Context_Id
), Ref_Id
);
15394 (Ekind
(Context_Id
) in
15395 E_Entry | E_Entry_Family | E_Function | E_Package |
15396 E_Procedure | E_Protected_Type | E_Task_Type
15397 or else Is_Record_Type
(Context_Id
));
15398 return Scope_Within_Or_Same
(Context_Id
, Ref_Id
);
15400 end Is_CCT_Instance
;
15402 -------------------------
15403 -- Is_Child_Or_Sibling --
15404 -------------------------
15406 function Is_Child_Or_Sibling
15407 (Pack_1
: Entity_Id
;
15408 Pack_2
: Entity_Id
) return Boolean
15410 function Distance_From_Standard
(Pack
: Entity_Id
) return Nat
;
15411 -- Given an arbitrary package, return the number of "climbs" necessary
15412 -- to reach scope Standard_Standard.
15414 procedure Equalize_Depths
15415 (Pack
: in out Entity_Id
;
15416 Depth
: in out Nat
;
15417 Depth_To_Reach
: Nat
);
15418 -- Given an arbitrary package, its depth and a target depth to reach,
15419 -- climb the scope chain until the said depth is reached. The pointer
15420 -- to the package and its depth a modified during the climb.
15422 ----------------------------
15423 -- Distance_From_Standard --
15424 ----------------------------
15426 function Distance_From_Standard
(Pack
: Entity_Id
) return Nat
is
15433 while Present
(Scop
) and then Scop
/= Standard_Standard
loop
15435 Scop
:= Scope
(Scop
);
15439 end Distance_From_Standard
;
15441 ---------------------
15442 -- Equalize_Depths --
15443 ---------------------
15445 procedure Equalize_Depths
15446 (Pack
: in out Entity_Id
;
15447 Depth
: in out Nat
;
15448 Depth_To_Reach
: Nat
)
15451 -- The package must be at a greater or equal depth
15453 if Depth
< Depth_To_Reach
then
15454 raise Program_Error
;
15457 -- Climb the scope chain until the desired depth is reached
15459 while Present
(Pack
) and then Depth
/= Depth_To_Reach
loop
15460 Pack
:= Scope
(Pack
);
15461 Depth
:= Depth
- 1;
15463 end Equalize_Depths
;
15467 P_1
: Entity_Id
:= Pack_1
;
15468 P_1_Child
: Boolean := False;
15469 P_1_Depth
: Nat
:= Distance_From_Standard
(P_1
);
15470 P_2
: Entity_Id
:= Pack_2
;
15471 P_2_Child
: Boolean := False;
15472 P_2_Depth
: Nat
:= Distance_From_Standard
(P_2
);
15474 -- Start of processing for Is_Child_Or_Sibling
15478 (Ekind
(Pack_1
) = E_Package
and then Ekind
(Pack_2
) = E_Package
);
15480 -- Both packages denote the same entity, therefore they cannot be
15481 -- children or siblings.
15486 -- One of the packages is at a deeper level than the other. Note that
15487 -- both may still come from different hierarchies.
15495 elsif P_1_Depth
> P_2_Depth
then
15498 Depth
=> P_1_Depth
,
15499 Depth_To_Reach
=> P_2_Depth
);
15508 elsif P_2_Depth
> P_1_Depth
then
15511 Depth
=> P_2_Depth
,
15512 Depth_To_Reach
=> P_1_Depth
);
15516 -- At this stage the package pointers have been elevated to the same
15517 -- depth. If the related entities are the same, then one package is a
15518 -- potential child of the other:
15522 -- X became P_1 P_2 or vice versa
15528 return Is_Child_Unit
(Pack_1
);
15530 else pragma Assert
(P_2_Child
);
15531 return Is_Child_Unit
(Pack_2
);
15534 -- The packages may come from the same package chain or from entirely
15535 -- different hierarchies. To determine this, climb the scope stack until
15536 -- a common root is found.
15538 -- (root) (root 1) (root 2)
15543 while Present
(P_1
) and then Present
(P_2
) loop
15545 -- The two packages may be siblings
15548 return Is_Child_Unit
(Pack_1
) and then Is_Child_Unit
(Pack_2
);
15551 P_1
:= Scope
(P_1
);
15552 P_2
:= Scope
(P_2
);
15557 end Is_Child_Or_Sibling
;
15559 -------------------
15560 -- Is_Confirming --
15561 -------------------
15563 function Is_Confirming
(Aspect
: Nonoverridable_Aspect_Id
;
15564 Aspect_Spec_1
, Aspect_Spec_2
: Node_Id
)
15566 function Names_Match
(Nm1
, Nm2
: Node_Id
) return Boolean;
15572 function Names_Match
(Nm1
, Nm2
: Node_Id
) return Boolean is
15574 if Nkind
(Nm1
) /= Nkind
(Nm2
) then
15576 -- This may be too restrictive given that visibility
15577 -- may allow an identifier in one case and an expanded
15578 -- name in the other.
15580 case Nkind
(Nm1
) is
15581 when N_Identifier
=>
15582 return Name_Equals
(Chars
(Nm1
), Chars
(Nm2
));
15584 when N_Expanded_Name
=>
15585 -- An inherited operation has the same name as its
15586 -- ancestor, but they may have different scopes.
15587 -- This may be too permissive for Iterator_Element, which
15588 -- is intended to be identical in parent and derived type.
15590 return Names_Match
(Selector_Name
(Nm1
),
15591 Selector_Name
(Nm2
));
15594 return True; -- needed for Aggregate aspect checking
15597 -- e.g., 'Class attribute references
15598 if Is_Entity_Name
(Nm1
) and Is_Entity_Name
(Nm2
) then
15599 return Entity
(Nm1
) = Entity
(Nm2
);
15602 raise Program_Error
;
15606 -- allow users to disable "shall be confirming" check, at least for now
15607 if Relaxed_RM_Semantics
then
15611 -- ??? Type conversion here (along with "when others =>" below) is a
15612 -- workaround for a bootstrapping problem related to casing on a
15613 -- static-predicate-bearing subtype.
15615 case Aspect_Id
(Aspect
) is
15616 -- name-valued aspects; compare text of names, not resolution.
15617 when Aspect_Default_Iterator
15618 | Aspect_Iterator_Element
15619 | Aspect_Constant_Indexing
15620 | Aspect_Variable_Indexing
=>
15622 Item_1
: constant Node_Id
:= Aspect_Rep_Item
(Aspect_Spec_1
);
15623 Item_2
: constant Node_Id
:= Aspect_Rep_Item
(Aspect_Spec_2
);
15625 if Nkind
(Item_1
) /= N_Attribute_Definition_Clause
15626 or Nkind
(Item_2
) /= N_Attribute_Definition_Clause
15628 pragma Assert
(Serious_Errors_Detected
> 0);
15632 return Names_Match
(Expression
(Item_1
),
15633 Expression
(Item_2
));
15636 -- A confirming aspect for Implicit_Derenfence on a derived type
15637 -- has already been checked in Analyze_Aspect_Implicit_Dereference,
15638 -- including the presence of renamed discriminants.
15640 when Aspect_Implicit_Dereference
=>
15644 when Aspect_Aggregate
=>
15655 Assign_Indexed_2
: Node_Id
:= Empty
;
15657 Parse_Aspect_Aggregate
15658 (N
=> Expression
(Aspect_Spec_1
),
15659 Empty_Subp
=> Empty_1
,
15660 Add_Named_Subp
=> Add_Named_1
,
15661 Add_Unnamed_Subp
=> Add_Unnamed_1
,
15662 New_Indexed_Subp
=> New_Indexed_1
,
15663 Assign_Indexed_Subp
=> Assign_Indexed_1
);
15664 Parse_Aspect_Aggregate
15665 (N
=> Expression
(Aspect_Spec_2
),
15666 Empty_Subp
=> Empty_2
,
15667 Add_Named_Subp
=> Add_Named_2
,
15668 Add_Unnamed_Subp
=> Add_Unnamed_2
,
15669 New_Indexed_Subp
=> New_Indexed_2
,
15670 Assign_Indexed_Subp
=> Assign_Indexed_2
);
15672 Names_Match
(Empty_1
, Empty_2
) and then
15673 Names_Match
(Add_Named_1
, Add_Named_2
) and then
15674 Names_Match
(Add_Unnamed_1
, Add_Unnamed_2
) and then
15675 Names_Match
(New_Indexed_1
, New_Indexed_2
) and then
15676 Names_Match
(Assign_Indexed_1
, Assign_Indexed_2
);
15679 -- Checking for this aspect is performed elsewhere during freezing
15680 when Aspect_No_Controlled_Parts
=>
15683 -- scalar-valued aspects; compare (static) values.
15684 when Aspect_Max_Entry_Queue_Length
=>
15685 -- This should be unreachable. Max_Entry_Queue_Length is
15686 -- supported only for protected entries, not for types.
15687 pragma Assert
(Serious_Errors_Detected
/= 0);
15691 raise Program_Error
;
15695 -----------------------------
15696 -- Is_Concurrent_Interface --
15697 -----------------------------
15699 function Is_Concurrent_Interface
(T
: Entity_Id
) return Boolean is
15701 return Is_Protected_Interface
(T
)
15702 or else Is_Synchronized_Interface
(T
)
15703 or else Is_Task_Interface
(T
);
15704 end Is_Concurrent_Interface
;
15706 ------------------------------------------------------
15707 -- Is_Conjunction_Of_Formal_Preelab_Init_Attributes --
15708 ------------------------------------------------------
15710 function Is_Conjunction_Of_Formal_Preelab_Init_Attributes
15711 (Expr
: Node_Id
) return Boolean
15714 function Is_Formal_Preelab_Init_Attribute
15715 (N
: Node_Id
) return Boolean;
15716 -- Returns True if N is a Preelaborable_Initialization attribute
15717 -- applied to a generic formal type, or N's Original_Node is such
15720 --------------------------------------
15721 -- Is_Formal_Preelab_Init_Attribute --
15722 --------------------------------------
15724 function Is_Formal_Preelab_Init_Attribute
15725 (N
: Node_Id
) return Boolean
15727 Orig_N
: constant Node_Id
:= Original_Node
(N
);
15730 return Nkind
(Orig_N
) = N_Attribute_Reference
15731 and then Attribute_Name
(Orig_N
) = Name_Preelaborable_Initialization
15732 and then Is_Entity_Name
(Prefix
(Orig_N
))
15733 and then Is_Generic_Type
(Entity
(Prefix
(Orig_N
)));
15734 end Is_Formal_Preelab_Init_Attribute
;
15736 -- Start of Is_Conjunction_Of_Formal_Preelab_Init_Attributes
15739 return Is_Formal_Preelab_Init_Attribute
(Expr
)
15740 or else (Nkind
(Expr
) = N_Op_And
15742 Is_Conjunction_Of_Formal_Preelab_Init_Attributes
15745 Is_Conjunction_Of_Formal_Preelab_Init_Attributes
15746 (Right_Opnd
(Expr
)));
15747 end Is_Conjunction_Of_Formal_Preelab_Init_Attributes
;
15749 -----------------------
15750 -- Is_Constant_Bound --
15751 -----------------------
15753 function Is_Constant_Bound
(Exp
: Node_Id
) return Boolean is
15755 if Compile_Time_Known_Value
(Exp
) then
15758 elsif Is_Entity_Name
(Exp
) and then Present
(Entity
(Exp
)) then
15759 return Is_Constant_Object
(Entity
(Exp
))
15760 or else Ekind
(Entity
(Exp
)) = E_Enumeration_Literal
;
15762 elsif Nkind
(Exp
) in N_Binary_Op
then
15763 return Is_Constant_Bound
(Left_Opnd
(Exp
))
15764 and then Is_Constant_Bound
(Right_Opnd
(Exp
))
15765 and then Scope
(Entity
(Exp
)) = Standard_Standard
;
15770 end Is_Constant_Bound
;
15772 ---------------------------
15773 -- Is_Container_Element --
15774 ---------------------------
15776 function Is_Container_Element
(Exp
: Node_Id
) return Boolean is
15777 Loc
: constant Source_Ptr
:= Sloc
(Exp
);
15778 Pref
: constant Node_Id
:= Prefix
(Exp
);
15781 -- Call to an indexing aspect
15783 Cont_Typ
: Entity_Id
;
15784 -- The type of the container being accessed
15786 Elem_Typ
: Entity_Id
;
15787 -- Its element type
15789 Indexing
: Entity_Id
;
15790 Is_Const
: Boolean;
15791 -- Indicates that constant indexing is used, and the element is thus
15794 Ref_Typ
: Entity_Id
;
15795 -- The reference type returned by the indexing operation
15798 -- If C is a container, in a context that imposes the element type of
15799 -- that container, the indexing notation C (X) is rewritten as:
15801 -- Indexing (C, X).Discr.all
15803 -- where Indexing is one of the indexing aspects of the container.
15804 -- If the context does not require a reference, the construct can be
15809 -- First, verify that the construct has the proper form
15811 if not Expander_Active
then
15814 elsif Nkind
(Pref
) /= N_Selected_Component
then
15817 elsif Nkind
(Prefix
(Pref
)) /= N_Function_Call
then
15821 Call
:= Prefix
(Pref
);
15822 Ref_Typ
:= Etype
(Call
);
15825 if not Has_Implicit_Dereference
(Ref_Typ
)
15826 or else No
(First
(Parameter_Associations
(Call
)))
15827 or else not Is_Entity_Name
(Name
(Call
))
15832 -- Retrieve type of container object, and its iterator aspects
15834 Cont_Typ
:= Etype
(First
(Parameter_Associations
(Call
)));
15835 Indexing
:= Find_Value_Of_Aspect
(Cont_Typ
, Aspect_Constant_Indexing
);
15838 if No
(Indexing
) then
15840 -- Container should have at least one indexing operation
15844 elsif Entity
(Name
(Call
)) /= Entity
(Indexing
) then
15846 -- This may be a variable indexing operation
15848 Indexing
:= Find_Value_Of_Aspect
(Cont_Typ
, Aspect_Variable_Indexing
);
15851 or else Entity
(Name
(Call
)) /= Entity
(Indexing
)
15860 Elem_Typ
:= Find_Value_Of_Aspect
(Cont_Typ
, Aspect_Iterator_Element
);
15862 if No
(Elem_Typ
) or else Entity
(Elem_Typ
) /= Etype
(Exp
) then
15866 -- Check that the expression is not the target of an assignment, in
15867 -- which case the rewriting is not possible.
15869 if not Is_Const
then
15875 while Present
(Par
)
15877 if Nkind
(Parent
(Par
)) = N_Assignment_Statement
15878 and then Par
= Name
(Parent
(Par
))
15882 -- A renaming produces a reference, and the transformation
15885 elsif Nkind
(Parent
(Par
)) = N_Object_Renaming_Declaration
then
15888 elsif Nkind
(Parent
(Par
)) in
15890 N_Procedure_Call_Statement |
15891 N_Entry_Call_Statement
15893 -- Check that the element is not part of an actual for an
15894 -- in-out parameter.
15901 F
:= First_Formal
(Entity
(Name
(Parent
(Par
))));
15902 A
:= First
(Parameter_Associations
(Parent
(Par
)));
15903 while Present
(F
) loop
15904 if A
= Par
and then Ekind
(F
) /= E_In_Parameter
then
15913 -- E_In_Parameter in a call: element is not modified.
15918 Par
:= Parent
(Par
);
15923 -- The expression has the proper form and the context requires the
15924 -- element type. Retrieve the Element function of the container and
15925 -- rewrite the construct as a call to it.
15931 Op
:= First_Elmt
(Primitive_Operations
(Cont_Typ
));
15932 while Present
(Op
) loop
15933 exit when Chars
(Node
(Op
)) = Name_Element
;
15942 Make_Function_Call
(Loc
,
15943 Name
=> New_Occurrence_Of
(Node
(Op
), Loc
),
15944 Parameter_Associations
=> Parameter_Associations
(Call
)));
15945 Analyze_And_Resolve
(Exp
, Entity
(Elem_Typ
));
15949 end Is_Container_Element
;
15951 ----------------------------
15952 -- Is_Contract_Annotation --
15953 ----------------------------
15955 function Is_Contract_Annotation
(Item
: Node_Id
) return Boolean is
15957 return Is_Package_Contract_Annotation
(Item
)
15959 Is_Subprogram_Contract_Annotation
(Item
);
15960 end Is_Contract_Annotation
;
15962 --------------------------------------
15963 -- Is_Controlling_Limited_Procedure --
15964 --------------------------------------
15966 function Is_Controlling_Limited_Procedure
15967 (Proc_Nam
: Entity_Id
) return Boolean
15970 Param_Typ
: Entity_Id
:= Empty
;
15973 if Ekind
(Proc_Nam
) = E_Procedure
15974 and then Present
(Parameter_Specifications
(Parent
(Proc_Nam
)))
15978 (First
(Parameter_Specifications
(Parent
(Proc_Nam
))));
15980 -- The formal may be an anonymous access type
15982 if Nkind
(Param
) = N_Access_Definition
then
15983 Param_Typ
:= Entity
(Subtype_Mark
(Param
));
15985 Param_Typ
:= Etype
(Param
);
15988 -- In the case where an Itype was created for a dispatching call, the
15989 -- procedure call has been rewritten. The actual may be an access to
15990 -- interface type in which case it is the designated type that is the
15991 -- controlling type.
15993 elsif Present
(Associated_Node_For_Itype
(Proc_Nam
))
15994 and then Present
(Original_Node
(Associated_Node_For_Itype
(Proc_Nam
)))
15996 Present
(Parameter_Associations
15997 (Associated_Node_For_Itype
(Proc_Nam
)))
16000 Etype
(First
(Parameter_Associations
16001 (Associated_Node_For_Itype
(Proc_Nam
))));
16003 if Ekind
(Param_Typ
) = E_Anonymous_Access_Type
then
16004 Param_Typ
:= Directly_Designated_Type
(Param_Typ
);
16008 if Present
(Param_Typ
) then
16010 Is_Interface
(Param_Typ
)
16011 and then Is_Limited_Record
(Param_Typ
);
16015 end Is_Controlling_Limited_Procedure
;
16017 -----------------------------
16018 -- Is_CPP_Constructor_Call --
16019 -----------------------------
16021 function Is_CPP_Constructor_Call
(N
: Node_Id
) return Boolean is
16022 Ret_Typ
: Entity_Id
;
16025 if Nkind
(N
) /= N_Function_Call
then
16029 Ret_Typ
:= Base_Type
(Etype
(N
));
16031 if Is_Class_Wide_Type
(Ret_Typ
) then
16032 Ret_Typ
:= Root_Type
(Ret_Typ
);
16035 if Is_Private_Type
(Ret_Typ
) then
16036 Ret_Typ
:= Underlying_Type
(Ret_Typ
);
16039 return Present
(Ret_Typ
)
16040 and then Is_CPP_Class
(Ret_Typ
)
16041 and then Is_Constructor
(Entity
(Name
(N
)))
16042 and then Is_Imported
(Entity
(Name
(N
)));
16043 end Is_CPP_Constructor_Call
;
16045 -------------------------
16046 -- Is_Current_Instance --
16047 -------------------------
16049 function Is_Current_Instance
(N
: Node_Id
) return Boolean is
16050 Typ
: constant Entity_Id
:= Entity
(N
);
16054 -- Simplest case: entity is a concurrent type and we are currently
16055 -- inside the body. This will eventually be expanded into a call to
16056 -- Self (for tasks) or _object (for protected objects).
16058 if Is_Concurrent_Type
(Typ
) and then In_Open_Scopes
(Typ
) then
16062 -- Check whether the context is a (sub)type declaration for the
16066 while Present
(P
) loop
16067 if Nkind
(P
) in N_Full_Type_Declaration
16068 | N_Private_Type_Declaration
16069 | N_Subtype_Declaration
16070 and then Comes_From_Source
(P
)
16072 -- If the type has a previous incomplete declaration, the
16073 -- reference in the type definition may have the incomplete
16074 -- view. So, here we detect if this incomplete view is a current
16075 -- instance by checking if its full view is the entity of the
16076 -- full declaration begin analyzed.
16079 (Defining_Entity
(P
) = Typ
16081 (Ekind
(Typ
) = E_Incomplete_Type
16082 and then Full_View
(Typ
) = Defining_Entity
(P
)))
16086 -- A subtype name may appear in an aspect specification for a
16087 -- Predicate_Failure aspect, for which we do not construct a
16088 -- wrapper procedure. The subtype will be replaced by the
16089 -- expression being tested when the corresponding predicate
16090 -- check is expanded. It may also appear in the pragma Predicate
16091 -- expression during legality checking.
16093 elsif Nkind
(P
) = N_Aspect_Specification
16094 and then Nkind
(Parent
(P
)) = N_Subtype_Declaration
16095 and then Underlying_Type
(Defining_Identifier
(Parent
(P
))) =
16096 Underlying_Type
(Typ
)
16100 elsif Nkind
(P
) = N_Pragma
16101 and then Get_Pragma_Id
(P
) in Pragma_Predicate
16102 | Pragma_Predicate_Failure
16105 Arg
: constant Entity_Id
:=
16106 Entity
(Expression
(Get_Argument
(P
)));
16108 if Underlying_Type
(Arg
) = Underlying_Type
(Typ
) then
16118 -- In any other context this is not a current occurrence
16121 end Is_Current_Instance
;
16123 --------------------------------------------------
16124 -- Is_Current_Instance_Reference_In_Type_Aspect --
16125 --------------------------------------------------
16127 function Is_Current_Instance_Reference_In_Type_Aspect
16128 (N
: Node_Id
) return Boolean
16131 -- When a current_instance is referenced within an aspect_specification
16132 -- of a type or subtype, it will show up as a reference to the formal
16133 -- parameter of the aspect's associated subprogram rather than as a
16134 -- reference to the type or subtype itself (in fact, the original name
16135 -- is never even analyzed). We check for predicate, invariant, and
16136 -- Default_Initial_Condition subprograms (in theory there could be
16137 -- other cases added, in which case this function will need updating).
16139 if Is_Entity_Name
(N
) then
16140 return Present
(Entity
(N
))
16141 and then Ekind
(Entity
(N
)) = E_In_Parameter
16142 and then Ekind
(Scope
(Entity
(N
))) in E_Function | E_Procedure
16144 (Is_Predicate_Function
(Scope
(Entity
(N
)))
16145 or else Is_Invariant_Procedure
(Scope
(Entity
(N
)))
16146 or else Is_Partial_Invariant_Procedure
(Scope
(Entity
(N
)))
16147 or else Is_DIC_Procedure
(Scope
(Entity
(N
))));
16151 when N_Indexed_Component
16155 Is_Current_Instance_Reference_In_Type_Aspect
(Prefix
(N
));
16157 when N_Selected_Component
=>
16159 Is_Current_Instance_Reference_In_Type_Aspect
(Prefix
(N
));
16161 when N_Type_Conversion
=>
16162 return Is_Current_Instance_Reference_In_Type_Aspect
16165 when N_Qualified_Expression
=>
16166 return Is_Current_Instance_Reference_In_Type_Aspect
16173 end Is_Current_Instance_Reference_In_Type_Aspect
;
16175 --------------------
16176 -- Is_Declaration --
16177 --------------------
16179 function Is_Declaration
16181 Body_OK
: Boolean := True;
16182 Concurrent_OK
: Boolean := True;
16183 Formal_OK
: Boolean := True;
16184 Generic_OK
: Boolean := True;
16185 Instantiation_OK
: Boolean := True;
16186 Renaming_OK
: Boolean := True;
16187 Stub_OK
: Boolean := True;
16188 Subprogram_OK
: Boolean := True;
16189 Type_OK
: Boolean := True) return Boolean
16194 -- Body declarations
16196 when N_Proper_Body
=>
16199 -- Concurrent type declarations
16201 when N_Protected_Type_Declaration
16202 | N_Single_Protected_Declaration
16203 | N_Single_Task_Declaration
16204 | N_Task_Type_Declaration
16206 return Concurrent_OK
or Type_OK
;
16208 -- Formal declarations
16210 when N_Formal_Abstract_Subprogram_Declaration
16211 | N_Formal_Concrete_Subprogram_Declaration
16212 | N_Formal_Object_Declaration
16213 | N_Formal_Package_Declaration
16214 | N_Formal_Type_Declaration
16218 -- Generic declarations
16220 when N_Generic_Package_Declaration
16221 | N_Generic_Subprogram_Declaration
16225 -- Generic instantiations
16227 when N_Function_Instantiation
16228 | N_Package_Instantiation
16229 | N_Procedure_Instantiation
16231 return Instantiation_OK
;
16233 -- Generic renaming declarations
16235 when N_Generic_Renaming_Declaration
=>
16236 return Generic_OK
or Renaming_OK
;
16238 -- Renaming declarations
16240 when N_Exception_Renaming_Declaration
16241 | N_Object_Renaming_Declaration
16242 | N_Package_Renaming_Declaration
16243 | N_Subprogram_Renaming_Declaration
16245 return Renaming_OK
;
16247 -- Stub declarations
16249 when N_Body_Stub
=>
16252 -- Subprogram declarations
16254 when N_Abstract_Subprogram_Declaration
16255 | N_Entry_Declaration
16256 | N_Expression_Function
16257 | N_Subprogram_Declaration
16259 return Subprogram_OK
;
16261 -- Type declarations
16263 when N_Full_Type_Declaration
16264 | N_Incomplete_Type_Declaration
16265 | N_Private_Extension_Declaration
16266 | N_Private_Type_Declaration
16267 | N_Subtype_Declaration
16273 when N_Component_Declaration
16274 | N_Exception_Declaration
16275 | N_Implicit_Label_Declaration
16276 | N_Number_Declaration
16277 | N_Object_Declaration
16278 | N_Package_Declaration
16285 end Is_Declaration
;
16287 --------------------------------
16288 -- Is_Declared_Within_Variant --
16289 --------------------------------
16291 function Is_Declared_Within_Variant
(Comp
: Entity_Id
) return Boolean is
16292 Comp_Decl
: constant Node_Id
:= Parent
(Comp
);
16293 Comp_List
: constant Node_Id
:= Parent
(Comp_Decl
);
16295 return Nkind
(Parent
(Comp_List
)) = N_Variant
;
16296 end Is_Declared_Within_Variant
;
16298 ----------------------------------------------
16299 -- Is_Dependent_Component_Of_Mutable_Object --
16300 ----------------------------------------------
16302 function Is_Dependent_Component_Of_Mutable_Object
16303 (Object
: Node_Id
) return Boolean
16306 Prefix_Type
: Entity_Id
;
16307 P_Aliased
: Boolean := False;
16310 Deref
: Node_Id
:= Original_Node
(Object
);
16311 -- Dereference node, in something like X.all.Y(2)
16313 -- Start of processing for Is_Dependent_Component_Of_Mutable_Object
16316 -- Find the dereference node if any
16318 while Nkind
(Deref
) in
16319 N_Indexed_Component | N_Selected_Component | N_Slice
16321 Deref
:= Original_Node
(Prefix
(Deref
));
16324 -- If the prefix is a qualified expression of a variable, then function
16325 -- Is_Variable will return False for that because a qualified expression
16326 -- denotes a constant view, so we need to get the name being qualified
16327 -- so we can test below whether that's a variable (or a dereference).
16329 if Nkind
(Deref
) = N_Qualified_Expression
then
16330 Deref
:= Expression
(Deref
);
16333 -- Ada 2005: If we have a component or slice of a dereference, something
16334 -- like X.all.Y (2) and the type of X is access-to-constant, Is_Variable
16335 -- will return False, because it is indeed a constant view. But it might
16336 -- be a view of a variable object, so we want the following condition to
16337 -- be True in that case.
16339 if Is_Variable
(Object
)
16340 or else Is_Variable
(Deref
)
16342 (Ada_Version
>= Ada_2005
16343 and then (Nkind
(Deref
) = N_Explicit_Dereference
16344 or else (Present
(Etype
(Deref
))
16345 and then Is_Access_Type
(Etype
(Deref
)))))
16347 if Nkind
(Object
) = N_Selected_Component
then
16349 -- If the selector is not a component, then we definitely return
16350 -- False (it could be a function selector in a prefix form call
16351 -- occurring in an iterator specification).
16353 if (Present
(Entity
(Selector_Name
(Object
)))
16354 and then Ekind
(Entity
(Selector_Name
(Object
))) not in
16355 E_Component | E_Discriminant
)
16358 and then Nkind
(Parent
(Selector_Name
(Object
)))
16364 -- Get the original node of the prefix in case it has been
16365 -- rewritten, which can occur, for example, in qualified
16366 -- expression cases. Also, a discriminant check on a selected
16367 -- component may be expanded into a dereference when removing
16368 -- side effects, and the subtype of the original node may be
16371 P
:= Original_Node
(Prefix
(Object
));
16372 Prefix_Type
:= Etype
(P
);
16374 -- If the prefix is a qualified expression, we want to look at its
16377 if Nkind
(P
) = N_Qualified_Expression
then
16378 P
:= Expression
(P
);
16379 Prefix_Type
:= Etype
(P
);
16382 if Is_Entity_Name
(P
) then
16383 -- The Etype may not be set on P (which is wrong) in certain
16384 -- corner cases involving the deprecated front-end inlining of
16385 -- subprograms (via -gnatN), so use the Etype set on the
16386 -- the entity for these instances since we know it is present.
16388 if No
(Prefix_Type
) then
16389 Prefix_Type
:= Etype
(Entity
(P
));
16392 if Ekind
(Entity
(P
)) = E_Generic_In_Out_Parameter
then
16393 Prefix_Type
:= Base_Type
(Prefix_Type
);
16396 if Is_Aliased
(Entity
(P
)) then
16400 -- For explicit dereferences we get the access prefix so we can
16401 -- treat this similarly to implicit dereferences and examine the
16402 -- kind of the access type and its designated subtype further
16405 elsif Nkind
(P
) = N_Explicit_Dereference
then
16407 Prefix_Type
:= Etype
(P
);
16410 -- Check for prefix being an aliased component???
16415 -- A heap object is constrained by its initial value
16417 -- Ada 2005 (AI-363): Always assume the object could be mutable in
16418 -- the dereferenced case, since the access value might denote an
16419 -- unconstrained aliased object, whereas in Ada 95 the designated
16420 -- object is guaranteed to be constrained. A worst-case assumption
16421 -- has to apply in Ada 2005 because we can't tell at compile
16422 -- time whether the object is "constrained by its initial value",
16423 -- despite the fact that 3.10.2(26/2) and 8.5.1(5/2) are semantic
16424 -- rules (these rules are acknowledged to need fixing). We don't
16425 -- impose this more stringent checking for earlier Ada versions or
16426 -- when Relaxed_RM_Semantics applies (the latter for CodePeer's
16427 -- benefit, though it's unclear on why using -gnat95 would not be
16430 if Ada_Version
< Ada_2005
or else Relaxed_RM_Semantics
then
16431 if Is_Access_Type
(Prefix_Type
)
16432 or else Nkind
(P
) = N_Explicit_Dereference
16437 else pragma Assert
(Ada_Version
>= Ada_2005
);
16438 if Is_Access_Type
(Prefix_Type
) then
16439 -- We need to make sure we have the base subtype, in case
16440 -- this is actually an access subtype (whose Ekind will be
16441 -- E_Access_Subtype).
16443 Prefix_Type
:= Etype
(Prefix_Type
);
16445 -- If the access type is pool-specific, and there is no
16446 -- constrained partial view of the designated type, then the
16447 -- designated object is known to be constrained. If it's a
16448 -- formal access type and the renaming is in the generic
16449 -- spec, we also treat it as pool-specific (known to be
16450 -- constrained), but assume the worst if in the generic body
16451 -- (see RM 3.3(23.3/3)).
16453 if Ekind
(Prefix_Type
) = E_Access_Type
16454 and then (not Is_Generic_Type
(Prefix_Type
)
16455 or else not In_Generic_Body
(Current_Scope
))
16456 and then not Object_Type_Has_Constrained_Partial_View
16457 (Typ
=> Designated_Type
(Prefix_Type
),
16458 Scop
=> Current_Scope
)
16462 -- Otherwise (general access type, or there is a constrained
16463 -- partial view of the designated type), we need to check
16464 -- based on the designated type.
16467 Prefix_Type
:= Designated_Type
(Prefix_Type
);
16473 Original_Record_Component
(Entity
(Selector_Name
(Object
)));
16475 -- As per AI-0017, the renaming is illegal in a generic body, even
16476 -- if the subtype is indefinite (only applies to prefixes of an
16477 -- untagged formal type, see RM 3.3 (23.11/3)).
16479 -- Ada 2005 (AI-363): In Ada 2005 an aliased object can be mutable
16481 if not Is_Constrained
(Prefix_Type
)
16482 and then (Is_Definite_Subtype
(Prefix_Type
)
16484 (not Is_Tagged_Type
(Prefix_Type
)
16485 and then Is_Generic_Type
(Prefix_Type
)
16486 and then In_Generic_Body
(Current_Scope
)))
16488 and then (Is_Declared_Within_Variant
(Comp
)
16489 or else Has_Discriminant_Dependent_Constraint
(Comp
))
16490 and then (not P_Aliased
or else Ada_Version
>= Ada_2005
)
16494 -- If the prefix is of an access type at this point, then we want
16495 -- to return False, rather than calling this function recursively
16496 -- on the access object (which itself might be a discriminant-
16497 -- dependent component of some other object, but that isn't
16498 -- relevant to checking the object passed to us). This avoids
16499 -- issuing wrong errors when compiling with -gnatc, where there
16500 -- can be implicit dereferences that have not been expanded.
16502 elsif Is_Access_Type
(Etype
(Prefix
(Object
))) then
16507 Is_Dependent_Component_Of_Mutable_Object
(Prefix
(Object
));
16510 elsif Nkind
(Object
) = N_Indexed_Component
16511 or else Nkind
(Object
) = N_Slice
16513 return Is_Dependent_Component_Of_Mutable_Object
16514 (Original_Node
(Prefix
(Object
)));
16516 -- A type conversion that Is_Variable is a view conversion:
16517 -- go back to the denoted object.
16519 elsif Nkind
(Object
) = N_Type_Conversion
then
16521 Is_Dependent_Component_Of_Mutable_Object
16522 (Original_Node
(Expression
(Object
)));
16527 end Is_Dependent_Component_Of_Mutable_Object
;
16529 ---------------------
16530 -- Is_Dereferenced --
16531 ---------------------
16533 function Is_Dereferenced
(N
: Node_Id
) return Boolean is
16534 P
: constant Node_Id
:= Parent
(N
);
16536 return Nkind
(P
) in N_Selected_Component
16537 | N_Explicit_Dereference
16538 | N_Indexed_Component
16540 and then Prefix
(P
) = N
;
16541 end Is_Dereferenced
;
16543 ----------------------
16544 -- Is_Descendant_Of --
16545 ----------------------
16547 function Is_Descendant_Of
(T1
: Entity_Id
; T2
: Entity_Id
) return Boolean is
16552 pragma Assert
(Nkind
(T1
) in N_Entity
);
16553 pragma Assert
(Nkind
(T2
) in N_Entity
);
16555 T
:= Base_Type
(T1
);
16557 -- Immediate return if the types match
16562 -- Comment needed here ???
16564 elsif Ekind
(T
) = E_Class_Wide_Type
then
16565 return Etype
(T
) = T2
;
16573 -- Done if we found the type we are looking for
16578 -- Done if no more derivations to check
16585 -- Following test catches error cases resulting from prev errors
16587 elsif No
(Etyp
) then
16590 elsif Is_Private_Type
(T
) and then Etyp
= Full_View
(T
) then
16593 elsif Is_Private_Type
(Etyp
) and then Full_View
(Etyp
) = T
then
16597 T
:= Base_Type
(Etyp
);
16600 end Is_Descendant_Of
;
16602 ----------------------------------------
16603 -- Is_Descendant_Of_Suspension_Object --
16604 ----------------------------------------
16606 function Is_Descendant_Of_Suspension_Object
16607 (Typ
: Entity_Id
) return Boolean
16609 Cur_Typ
: Entity_Id
;
16610 Par_Typ
: Entity_Id
;
16613 -- Climb the type derivation chain checking each parent type against
16614 -- Suspension_Object.
16616 Cur_Typ
:= Base_Type
(Typ
);
16617 while Present
(Cur_Typ
) loop
16618 Par_Typ
:= Etype
(Cur_Typ
);
16620 -- The current type is a match
16622 if Is_RTE
(Cur_Typ
, RE_Suspension_Object
) then
16625 -- Stop the traversal once the root of the derivation chain has been
16626 -- reached. In that case the current type is its own base type.
16628 elsif Cur_Typ
= Par_Typ
then
16632 Cur_Typ
:= Base_Type
(Par_Typ
);
16636 end Is_Descendant_Of_Suspension_Object
;
16638 ---------------------------------------------
16639 -- Is_Double_Precision_Floating_Point_Type --
16640 ---------------------------------------------
16642 function Is_Double_Precision_Floating_Point_Type
16643 (E
: Entity_Id
) return Boolean is
16645 return Is_Floating_Point_Type
(E
)
16646 and then Machine_Radix_Value
(E
) = Uint_2
16647 and then Machine_Mantissa_Value
(E
) = UI_From_Int
(53)
16648 and then Machine_Emax_Value
(E
) = Uint_2
** Uint_10
16649 and then Machine_Emin_Value
(E
) = Uint_3
- (Uint_2
** Uint_10
);
16650 end Is_Double_Precision_Floating_Point_Type
;
16652 -----------------------------
16653 -- Is_Effectively_Volatile --
16654 -----------------------------
16656 function Is_Effectively_Volatile
16658 Ignore_Protected
: Boolean := False) return Boolean is
16660 if Is_Type
(Id
) then
16662 -- An arbitrary type is effectively volatile when it is subject to
16663 -- pragma Atomic or Volatile, unless No_Caching is enabled.
16665 if Is_Volatile
(Id
)
16666 and then not No_Caching_Enabled
(Id
)
16670 -- An array type is effectively volatile when it is subject to pragma
16671 -- Atomic_Components or Volatile_Components or its component type is
16672 -- effectively volatile.
16674 elsif Is_Array_Type
(Id
) then
16675 if Has_Volatile_Components
(Id
) then
16679 Anc
: Entity_Id
:= Base_Type
(Id
);
16681 if Is_Private_Type
(Anc
) then
16682 Anc
:= Full_View
(Anc
);
16685 -- Test for presence of ancestor, as the full view of a
16686 -- private type may be missing in case of error.
16688 return Present
(Anc
)
16689 and then Is_Effectively_Volatile
16690 (Component_Type
(Anc
), Ignore_Protected
);
16694 -- A protected type is always volatile unless Ignore_Protected is
16697 elsif Is_Protected_Type
(Id
) and then not Ignore_Protected
then
16700 -- A descendant of Ada.Synchronous_Task_Control.Suspension_Object is
16701 -- automatically volatile.
16703 elsif Is_Descendant_Of_Suspension_Object
(Id
) then
16706 -- Otherwise the type is not effectively volatile
16712 -- Otherwise Id denotes an object
16714 else pragma Assert
(Is_Object
(Id
));
16715 -- A volatile object for which No_Caching is enabled is not
16716 -- effectively volatile.
16721 (Ekind
(Id
) = E_Variable
and then No_Caching_Enabled
(Id
)))
16722 or else Has_Volatile_Components
(Id
)
16723 or else Is_Effectively_Volatile
(Etype
(Id
), Ignore_Protected
);
16725 end Is_Effectively_Volatile
;
16727 -----------------------------------------
16728 -- Is_Effectively_Volatile_For_Reading --
16729 -----------------------------------------
16731 function Is_Effectively_Volatile_For_Reading
16733 Ignore_Protected
: Boolean := False) return Boolean
16736 -- A concurrent type is effectively volatile for reading, except for a
16737 -- protected type when Ignore_Protected is True.
16739 if Is_Task_Type
(Id
)
16740 or else (Is_Protected_Type
(Id
) and then not Ignore_Protected
)
16744 elsif Is_Effectively_Volatile
(Id
, Ignore_Protected
) then
16746 -- Other volatile types and objects are effectively volatile for
16747 -- reading when they have property Async_Writers or Effective_Reads
16748 -- set to True. This includes the case of an array type whose
16749 -- Volatile_Components aspect is True (hence it is effectively
16750 -- volatile) which does not have the properties Async_Writers
16751 -- and Effective_Reads set to False.
16753 if Async_Writers_Enabled
(Id
)
16754 or else Effective_Reads_Enabled
(Id
)
16758 -- In addition, an array type is effectively volatile for reading
16759 -- when its component type is effectively volatile for reading.
16761 elsif Is_Array_Type
(Id
) then
16763 Anc
: Entity_Id
:= Base_Type
(Id
);
16765 if Is_Private_Type
(Anc
) then
16766 Anc
:= Full_View
(Anc
);
16769 -- Test for presence of ancestor, as the full view of a
16770 -- private type may be missing in case of error.
16772 return Present
(Anc
)
16773 and then Is_Effectively_Volatile_For_Reading
16774 (Component_Type
(Anc
), Ignore_Protected
);
16781 end Is_Effectively_Volatile_For_Reading
;
16783 ------------------------------------
16784 -- Is_Effectively_Volatile_Object --
16785 ------------------------------------
16787 function Is_Effectively_Volatile_Object
(N
: Node_Id
) return Boolean is
16788 function Is_Effectively_Volatile
(E
: Entity_Id
) return Boolean is
16789 (Is_Effectively_Volatile
(E
, Ignore_Protected
=> False));
16791 function Is_Effectively_Volatile_Object_Inst
16792 is new Is_Effectively_Volatile_Object_Shared
(Is_Effectively_Volatile
);
16794 return Is_Effectively_Volatile_Object_Inst
(N
);
16795 end Is_Effectively_Volatile_Object
;
16797 ------------------------------------------------
16798 -- Is_Effectively_Volatile_Object_For_Reading --
16799 ------------------------------------------------
16801 function Is_Effectively_Volatile_Object_For_Reading
16802 (N
: Node_Id
) return Boolean
16804 function Is_Effectively_Volatile_For_Reading
16805 (E
: Entity_Id
) return Boolean
16806 is (Is_Effectively_Volatile_For_Reading
(E
, Ignore_Protected
=> False));
16808 function Is_Effectively_Volatile_Object_For_Reading_Inst
16809 is new Is_Effectively_Volatile_Object_Shared
16810 (Is_Effectively_Volatile_For_Reading
);
16812 return Is_Effectively_Volatile_Object_For_Reading_Inst
(N
);
16813 end Is_Effectively_Volatile_Object_For_Reading
;
16815 -------------------------------------------
16816 -- Is_Effectively_Volatile_Object_Shared --
16817 -------------------------------------------
16819 function Is_Effectively_Volatile_Object_Shared
16820 (N
: Node_Id
) return Boolean
16823 if Is_Entity_Name
(N
) then
16824 return Is_Object
(Entity
(N
))
16825 and then Is_Effectively_Volatile_Entity
(Entity
(N
));
16827 elsif Nkind
(N
) in N_Indexed_Component | N_Slice
then
16828 return Is_Effectively_Volatile_Object_Shared
(Prefix
(N
));
16830 elsif Nkind
(N
) = N_Selected_Component
then
16832 Is_Effectively_Volatile_Object_Shared
(Prefix
(N
))
16834 Is_Effectively_Volatile_Object_Shared
(Selector_Name
(N
));
16836 elsif Nkind
(N
) in N_Qualified_Expression
16837 | N_Unchecked_Type_Conversion
16838 | N_Type_Conversion
16840 return Is_Effectively_Volatile_Object_Shared
(Expression
(N
));
16845 end Is_Effectively_Volatile_Object_Shared
;
16847 ----------------------------------------
16848 -- Is_Entity_Of_Quantified_Expression --
16849 ----------------------------------------
16851 function Is_Entity_Of_Quantified_Expression
(Id
: Entity_Id
) return Boolean
16853 Par
: constant Node_Id
:= Parent
(Id
);
16856 return (Nkind
(Par
) = N_Loop_Parameter_Specification
16857 or else Nkind
(Par
) = N_Iterator_Specification
)
16858 and then Defining_Identifier
(Par
) = Id
16859 and then Nkind
(Parent
(Par
)) = N_Quantified_Expression
;
16860 end Is_Entity_Of_Quantified_Expression
;
16862 -------------------
16863 -- Is_Entry_Body --
16864 -------------------
16866 function Is_Entry_Body
(Id
: Entity_Id
) return Boolean is
16870 and then Nkind
(Unit_Declaration_Node
(Id
)) = N_Entry_Body
;
16873 --------------------------
16874 -- Is_Entry_Declaration --
16875 --------------------------
16877 function Is_Entry_Declaration
(Id
: Entity_Id
) return Boolean is
16881 and then Nkind
(Unit_Declaration_Node
(Id
)) = N_Entry_Declaration
;
16882 end Is_Entry_Declaration
;
16884 ------------------------------------
16885 -- Is_Expanded_Priority_Attribute --
16886 ------------------------------------
16888 function Is_Expanded_Priority_Attribute
(E
: Entity_Id
) return Boolean is
16891 Nkind
(E
) = N_Function_Call
16892 and then not Configurable_Run_Time_Mode
16893 and then Nkind
(Original_Node
(E
)) = N_Attribute_Reference
16894 and then (Is_RTE
(Entity
(Name
(E
)), RE_Get_Ceiling
)
16895 or else Is_RTE
(Entity
(Name
(E
)), RO_PE_Get_Ceiling
));
16896 end Is_Expanded_Priority_Attribute
;
16898 ----------------------------
16899 -- Is_Expression_Function --
16900 ----------------------------
16902 function Is_Expression_Function
(Subp
: Entity_Id
) return Boolean is
16904 if Ekind
(Subp
) in E_Function | E_Subprogram_Body
then
16906 Nkind
(Original_Node
(Unit_Declaration_Node
(Subp
))) =
16907 N_Expression_Function
;
16911 end Is_Expression_Function
;
16913 ------------------------------------------
16914 -- Is_Expression_Function_Or_Completion --
16915 ------------------------------------------
16917 function Is_Expression_Function_Or_Completion
16918 (Subp
: Entity_Id
) return Boolean
16920 Subp_Decl
: Node_Id
;
16923 if Ekind
(Subp
) = E_Function
then
16924 Subp_Decl
:= Unit_Declaration_Node
(Subp
);
16926 -- The function declaration is either an expression function or is
16927 -- completed by an expression function body.
16930 Is_Expression_Function
(Subp
)
16931 or else (Nkind
(Subp_Decl
) = N_Subprogram_Declaration
16932 and then Present
(Corresponding_Body
(Subp_Decl
))
16933 and then Is_Expression_Function
16934 (Corresponding_Body
(Subp_Decl
)));
16936 elsif Ekind
(Subp
) = E_Subprogram_Body
then
16937 return Is_Expression_Function
(Subp
);
16942 end Is_Expression_Function_Or_Completion
;
16944 -----------------------------------------------
16945 -- Is_Extended_Precision_Floating_Point_Type --
16946 -----------------------------------------------
16948 function Is_Extended_Precision_Floating_Point_Type
16949 (E
: Entity_Id
) return Boolean is
16951 return Is_Floating_Point_Type
(E
)
16952 and then Machine_Radix_Value
(E
) = Uint_2
16953 and then Machine_Mantissa_Value
(E
) = Uint_64
16954 and then Machine_Emax_Value
(E
) = Uint_2
** Uint_14
16955 and then Machine_Emin_Value
(E
) = Uint_3
- (Uint_2
** Uint_14
);
16956 end Is_Extended_Precision_Floating_Point_Type
;
16958 -----------------------
16959 -- Is_EVF_Expression --
16960 -----------------------
16962 function Is_EVF_Expression
(N
: Node_Id
) return Boolean is
16963 Orig_N
: constant Node_Id
:= Original_Node
(N
);
16969 -- Detect a reference to a formal parameter of a specific tagged type
16970 -- whose related subprogram is subject to pragma Expresions_Visible with
16973 if Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
16978 and then Is_Specific_Tagged_Type
(Etype
(Id
))
16979 and then Extensions_Visible_Status
(Id
) =
16980 Extensions_Visible_False
;
16982 -- A case expression is an EVF expression when it contains at least one
16983 -- EVF dependent_expression. Note that a case expression may have been
16984 -- expanded, hence the use of Original_Node.
16986 elsif Nkind
(Orig_N
) = N_Case_Expression
then
16987 Alt
:= First
(Alternatives
(Orig_N
));
16988 while Present
(Alt
) loop
16989 if Is_EVF_Expression
(Expression
(Alt
)) then
16996 -- An if expression is an EVF expression when it contains at least one
16997 -- EVF dependent_expression. Note that an if expression may have been
16998 -- expanded, hence the use of Original_Node.
17000 elsif Nkind
(Orig_N
) = N_If_Expression
then
17001 Expr
:= Next
(First
(Expressions
(Orig_N
)));
17002 while Present
(Expr
) loop
17003 if Is_EVF_Expression
(Expr
) then
17010 -- A qualified expression or a type conversion is an EVF expression when
17011 -- its operand is an EVF expression.
17013 elsif Nkind
(N
) in N_Qualified_Expression
17014 | N_Unchecked_Type_Conversion
17015 | N_Type_Conversion
17017 return Is_EVF_Expression
(Expression
(N
));
17019 -- Attributes 'Loop_Entry, 'Old, and 'Update are EVF expressions when
17020 -- their prefix denotes an EVF expression.
17022 elsif Nkind
(N
) = N_Attribute_Reference
17023 and then Attribute_Name
(N
) in Name_Loop_Entry
17027 return Is_EVF_Expression
(Prefix
(N
));
17031 end Is_EVF_Expression
;
17037 function Is_False
(U
: Opt_Ubool
) return Boolean is
17039 return not Is_True
(U
);
17042 ---------------------------
17043 -- Is_Fixed_Model_Number --
17044 ---------------------------
17046 function Is_Fixed_Model_Number
(U
: Ureal
; T
: Entity_Id
) return Boolean is
17047 S
: constant Ureal
:= Small_Value
(T
);
17048 M
: Urealp
.Save_Mark
;
17053 R
:= (U
= UR_Trunc
(U
/ S
) * S
);
17054 Urealp
.Release
(M
);
17056 end Is_Fixed_Model_Number
;
17058 -----------------------------
17059 -- Is_Full_Access_Object --
17060 -----------------------------
17062 function Is_Full_Access_Object
(N
: Node_Id
) return Boolean is
17064 return Is_Atomic_Object
(N
)
17065 or else Is_Volatile_Full_Access_Object_Ref
(N
);
17066 end Is_Full_Access_Object
;
17068 -------------------------------
17069 -- Is_Fully_Initialized_Type --
17070 -------------------------------
17072 function Is_Fully_Initialized_Type
(Typ
: Entity_Id
) return Boolean is
17076 if Is_Scalar_Type
(Typ
) then
17078 -- A scalar type with an aspect Default_Value is fully initialized
17080 -- Note: Iniitalize/Normalize_Scalars also ensure full initialization
17081 -- of a scalar type, but we don't take that into account here, since
17082 -- we don't want these to affect warnings.
17084 return Has_Default_Aspect
(Typ
);
17086 elsif Is_Access_Type
(Typ
) then
17089 elsif Is_Array_Type
(Typ
) then
17090 if Is_Fully_Initialized_Type
(Component_Type
(Typ
))
17091 or else (Ada_Version
>= Ada_2012
and then Has_Default_Aspect
(Typ
))
17096 -- An interesting case, if we have a constrained type one of whose
17097 -- bounds is known to be null, then there are no elements to be
17098 -- initialized, so all the elements are initialized.
17100 if Is_Constrained
(Typ
) then
17103 Indx_Typ
: Entity_Id
;
17104 Lbd
, Hbd
: Node_Id
;
17107 Indx
:= First_Index
(Typ
);
17108 while Present
(Indx
) loop
17109 if Etype
(Indx
) = Any_Type
then
17112 -- If index is a range, use directly
17114 elsif Nkind
(Indx
) = N_Range
then
17115 Lbd
:= Low_Bound
(Indx
);
17116 Hbd
:= High_Bound
(Indx
);
17119 Indx_Typ
:= Etype
(Indx
);
17121 if Is_Private_Type
(Indx_Typ
) then
17122 Indx_Typ
:= Full_View
(Indx_Typ
);
17125 if No
(Indx_Typ
) or else Etype
(Indx_Typ
) = Any_Type
then
17128 Lbd
:= Type_Low_Bound
(Indx_Typ
);
17129 Hbd
:= Type_High_Bound
(Indx_Typ
);
17133 if Compile_Time_Known_Value
(Lbd
)
17135 Compile_Time_Known_Value
(Hbd
)
17137 if Expr_Value
(Hbd
) < Expr_Value
(Lbd
) then
17147 -- If no null indexes, then type is not fully initialized
17153 elsif Is_Record_Type
(Typ
) then
17154 if Has_Defaulted_Discriminants
(Typ
)
17155 and then Is_Fully_Initialized_Variant
(Typ
)
17160 -- We consider bounded string types to be fully initialized, because
17161 -- otherwise we get false alarms when the Data component is not
17162 -- default-initialized.
17164 if Is_Bounded_String
(Typ
) then
17168 -- Controlled records are considered to be fully initialized if
17169 -- there is a user defined Initialize routine. This may not be
17170 -- entirely correct, but as the spec notes, we are guessing here
17171 -- what is best from the point of view of issuing warnings.
17173 if Is_Controlled
(Typ
) then
17175 Utyp
: constant Entity_Id
:= Underlying_Type
(Typ
);
17178 if Present
(Utyp
) then
17180 Init
: constant Entity_Id
:=
17181 (Find_Optional_Prim_Op
17182 (Utyp
, Name_Initialize
));
17186 and then Comes_From_Source
(Init
)
17187 and then not In_Predefined_Unit
(Init
)
17191 elsif Has_Null_Extension
(Typ
)
17193 Is_Fully_Initialized_Type
17194 (Etype
(Base_Type
(Typ
)))
17203 -- Otherwise see if all record components are initialized
17209 Comp
:= First_Component
(Typ
);
17210 while Present
(Comp
) loop
17211 if (No
(Parent
(Comp
))
17212 or else No
(Expression
(Parent
(Comp
))))
17213 and then not Is_Fully_Initialized_Type
(Etype
(Comp
))
17215 -- Special VM case for tag components, which need to be
17216 -- defined in this case, but are never initialized as VMs
17217 -- are using other dispatching mechanisms. Ignore this
17218 -- uninitialized case. Note that this applies both to the
17219 -- uTag entry and the main vtable pointer (CPP_Class case).
17221 and then (Tagged_Type_Expansion
or else not Is_Tag
(Comp
))
17226 Next_Component
(Comp
);
17230 -- No uninitialized components, so type is fully initialized.
17231 -- Note that this catches the case of no components as well.
17235 elsif Is_Concurrent_Type
(Typ
) then
17238 elsif Is_Private_Type
(Typ
) then
17240 U
: constant Entity_Id
:= Underlying_Type
(Typ
);
17246 return Is_Fully_Initialized_Type
(U
);
17253 end Is_Fully_Initialized_Type
;
17255 ----------------------------------
17256 -- Is_Fully_Initialized_Variant --
17257 ----------------------------------
17259 function Is_Fully_Initialized_Variant
(Typ
: Entity_Id
) return Boolean is
17260 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
17261 Constraints
: constant List_Id
:= New_List
;
17262 Components
: constant Elist_Id
:= New_Elmt_List
;
17263 Comp_Elmt
: Elmt_Id
;
17265 Comp_List
: Node_Id
;
17267 Discr_Val
: Node_Id
;
17269 Report_Errors
: Boolean;
17270 pragma Warnings
(Off
, Report_Errors
);
17273 if Serious_Errors_Detected
> 0 then
17277 if Is_Record_Type
(Typ
)
17278 and then Nkind
(Parent
(Typ
)) = N_Full_Type_Declaration
17279 and then Nkind
(Type_Definition
(Parent
(Typ
))) = N_Record_Definition
17281 Comp_List
:= Component_List
(Type_Definition
(Parent
(Typ
)));
17283 Discr
:= First_Discriminant
(Typ
);
17284 while Present
(Discr
) loop
17285 if Nkind
(Parent
(Discr
)) = N_Discriminant_Specification
then
17286 Discr_Val
:= Expression
(Parent
(Discr
));
17288 if Present
(Discr_Val
)
17289 and then Is_OK_Static_Expression
(Discr_Val
)
17291 Append_To
(Constraints
,
17292 Make_Component_Association
(Loc
,
17293 Choices
=> New_List
(New_Occurrence_Of
(Discr
, Loc
)),
17294 Expression
=> New_Copy
(Discr_Val
)));
17302 Next_Discriminant
(Discr
);
17307 Comp_List
=> Comp_List
,
17308 Governed_By
=> Constraints
,
17309 Into
=> Components
,
17310 Report_Errors
=> Report_Errors
);
17312 -- Check that each component present is fully initialized
17314 Comp_Elmt
:= First_Elmt
(Components
);
17315 while Present
(Comp_Elmt
) loop
17316 Comp_Id
:= Node
(Comp_Elmt
);
17318 if Ekind
(Comp_Id
) = E_Component
17319 and then (No
(Parent
(Comp_Id
))
17320 or else No
(Expression
(Parent
(Comp_Id
))))
17321 and then not Is_Fully_Initialized_Type
(Etype
(Comp_Id
))
17326 Next_Elmt
(Comp_Elmt
);
17331 elsif Is_Private_Type
(Typ
) then
17333 U
: constant Entity_Id
:= Underlying_Type
(Typ
);
17339 return Is_Fully_Initialized_Variant
(U
);
17346 end Is_Fully_Initialized_Variant
;
17348 -----------------------------------
17349 -- Is_Function_With_Side_Effects --
17350 -----------------------------------
17352 function Is_Function_With_Side_Effects
(Subp
: Entity_Id
) return Boolean is
17355 Prag
: constant Node_Id
:= Get_Pragma
(Subp
, Pragma_Side_Effects
);
17358 -- Extract the value from the Boolean expression (if any)
17360 if Present
(Prag
) then
17361 Arg
:= First
(Pragma_Argument_Associations
(Prag
));
17363 if Present
(Arg
) then
17364 Expr
:= Get_Pragma_Arg
(Arg
);
17366 return Is_True
(Expr_Value
(Expr
));
17368 -- Otherwise the aspect or pragma defaults to True
17376 end Is_Function_With_Side_Effects
;
17378 ------------------------------------
17379 -- Is_Generic_Declaration_Or_Body --
17380 ------------------------------------
17382 function Is_Generic_Declaration_Or_Body
(Decl
: Node_Id
) return Boolean is
17383 Spec_Decl
: Node_Id
;
17386 -- Package/subprogram body
17388 if Nkind
(Decl
) in N_Package_Body | N_Subprogram_Body
17389 and then Present
(Corresponding_Spec
(Decl
))
17391 Spec_Decl
:= Unit_Declaration_Node
(Corresponding_Spec
(Decl
));
17393 -- Package/subprogram body stub
17395 elsif Nkind
(Decl
) in N_Package_Body_Stub | N_Subprogram_Body_Stub
17396 and then Present
(Corresponding_Spec_Of_Stub
(Decl
))
17399 Unit_Declaration_Node
(Corresponding_Spec_Of_Stub
(Decl
));
17407 -- Rather than inspecting the defining entity of the spec declaration,
17408 -- look at its Nkind. This takes care of the case where the analysis of
17409 -- a generic body modifies the Ekind of its spec to allow for recursive
17412 return Nkind
(Spec_Decl
) in N_Generic_Declaration
;
17413 end Is_Generic_Declaration_Or_Body
;
17415 ---------------------------
17416 -- Is_Independent_Object --
17417 ---------------------------
17419 function Is_Independent_Object
(N
: Node_Id
) return Boolean is
17420 function Is_Independent_Object_Entity
(Id
: Entity_Id
) return Boolean;
17421 -- Determine whether arbitrary entity Id denotes an object that is
17424 function Prefix_Has_Independent_Components
(P
: Node_Id
) return Boolean;
17425 -- Determine whether prefix P has independent components. This requires
17426 -- the presence of an Independent_Components aspect/pragma.
17428 ------------------------------------
17429 -- Is_Independent_Object_Entity --
17430 ------------------------------------
17432 function Is_Independent_Object_Entity
(Id
: Entity_Id
) return Boolean is
17436 and then (Is_Independent
(Id
)
17438 Is_Independent
(Etype
(Id
)));
17439 end Is_Independent_Object_Entity
;
17441 -------------------------------------
17442 -- Prefix_Has_Independent_Components --
17443 -------------------------------------
17445 function Prefix_Has_Independent_Components
(P
: Node_Id
) return Boolean
17447 Typ
: constant Entity_Id
:= Etype
(P
);
17450 if Is_Access_Type
(Typ
) then
17451 return Has_Independent_Components
(Designated_Type
(Typ
));
17453 elsif Has_Independent_Components
(Typ
) then
17456 elsif Is_Entity_Name
(P
)
17457 and then Has_Independent_Components
(Entity
(P
))
17464 end Prefix_Has_Independent_Components
;
17466 -- Start of processing for Is_Independent_Object
17469 if Is_Entity_Name
(N
) then
17470 return Is_Independent_Object_Entity
(Entity
(N
));
17472 elsif Is_Independent
(Etype
(N
)) then
17475 elsif Nkind
(N
) = N_Indexed_Component
then
17476 return Prefix_Has_Independent_Components
(Prefix
(N
));
17478 elsif Nkind
(N
) = N_Selected_Component
then
17479 return Prefix_Has_Independent_Components
(Prefix
(N
))
17480 or else Is_Independent
(Entity
(Selector_Name
(N
)));
17485 end Is_Independent_Object
;
17487 ----------------------------
17488 -- Is_Inherited_Operation --
17489 ----------------------------
17491 function Is_Inherited_Operation
(E
: Entity_Id
) return Boolean is
17492 pragma Assert
(Is_Overloadable
(E
));
17493 Kind
: constant Node_Kind
:= Nkind
(Parent
(E
));
17495 return Kind
= N_Full_Type_Declaration
17496 or else Kind
= N_Private_Extension_Declaration
17497 or else Kind
= N_Subtype_Declaration
17498 or else (Ekind
(E
) = E_Enumeration_Literal
17499 and then Is_Derived_Type
(Etype
(E
)));
17500 end Is_Inherited_Operation
;
17502 --------------------------------------
17503 -- Is_Inlinable_Expression_Function --
17504 --------------------------------------
17506 function Is_Inlinable_Expression_Function
17507 (Subp
: Entity_Id
) return Boolean
17509 Return_Expr
: Node_Id
;
17512 if Is_Expression_Function_Or_Completion
(Subp
)
17513 and then Has_Pragma_Inline_Always
(Subp
)
17514 and then Needs_No_Actuals
(Subp
)
17515 and then No
(Contract
(Subp
))
17516 and then not Is_Dispatching_Operation
(Subp
)
17517 and then Needs_Finalization
(Etype
(Subp
))
17518 and then not Is_Class_Wide_Type
(Etype
(Subp
))
17519 and then not Has_Invariants
(Etype
(Subp
))
17520 and then Present
(Subprogram_Body
(Subp
))
17521 and then Was_Expression_Function
(Subprogram_Body
(Subp
))
17523 Return_Expr
:= Expression_Of_Expression_Function
(Subp
);
17525 -- The returned object must not have a qualified expression and its
17526 -- nominal subtype must be statically compatible with the result
17527 -- subtype of the expression function.
17530 Nkind
(Return_Expr
) = N_Identifier
17531 and then Etype
(Return_Expr
) = Etype
(Subp
);
17535 end Is_Inlinable_Expression_Function
;
17537 -----------------------
17538 -- Is_Internal_Block --
17539 -----------------------
17541 function Is_Internal_Block
(N
: Node_Id
) return Boolean is
17543 return Nkind
(N
) = N_Block_Statement
17544 and then Is_Internal
(Entity
(Identifier
(N
)));
17545 end Is_Internal_Block
;
17551 function Is_Iterator
(Typ
: Entity_Id
) return Boolean is
17552 function Denotes_Iterator
(Iter_Typ
: Entity_Id
) return Boolean;
17553 -- Determine whether type Iter_Typ is a predefined forward or reversible
17556 ----------------------
17557 -- Denotes_Iterator --
17558 ----------------------
17560 function Denotes_Iterator
(Iter_Typ
: Entity_Id
) return Boolean is
17562 -- Check that the name matches, and that the ultimate ancestor is in
17563 -- a predefined unit, i.e the one that declares iterator interfaces.
17566 Chars
(Iter_Typ
) in Name_Forward_Iterator | Name_Reversible_Iterator
17567 and then In_Predefined_Unit
(Root_Type
(Iter_Typ
));
17568 end Denotes_Iterator
;
17572 Iface_Elmt
: Elmt_Id
;
17575 -- Start of processing for Is_Iterator
17578 -- The type may be a subtype of a descendant of the proper instance of
17579 -- the predefined interface type, so we must use the root type of the
17580 -- given type. The same is done for Is_Reversible_Iterator.
17582 if Is_Class_Wide_Type
(Typ
)
17583 and then Denotes_Iterator
(Root_Type
(Typ
))
17587 elsif not Is_Tagged_Type
(Typ
) or else not Is_Derived_Type
(Typ
) then
17590 elsif Present
(Find_Value_Of_Aspect
(Typ
, Aspect_Iterable
)) then
17594 Collect_Interfaces
(Typ
, Ifaces
);
17596 Iface_Elmt
:= First_Elmt
(Ifaces
);
17597 while Present
(Iface_Elmt
) loop
17598 if Denotes_Iterator
(Node
(Iface_Elmt
)) then
17602 Next_Elmt
(Iface_Elmt
);
17609 ----------------------------
17610 -- Is_Iterator_Over_Array --
17611 ----------------------------
17613 function Is_Iterator_Over_Array
(N
: Node_Id
) return Boolean is
17614 Container
: constant Node_Id
:= Name
(N
);
17615 Container_Typ
: constant Entity_Id
:= Base_Type
(Etype
(Container
));
17617 return Is_Array_Type
(Container_Typ
);
17618 end Is_Iterator_Over_Array
;
17620 --------------------------
17621 -- Known_To_Be_Assigned --
17622 --------------------------
17624 function Known_To_Be_Assigned
17626 Only_LHS
: Boolean := False) return Boolean
17628 function Known_Assn
(N
: Node_Id
) return Boolean is
17629 (Known_To_Be_Assigned
(N
, Only_LHS
));
17630 -- Local function to simplify the passing of parameters for recursive
17633 P
: constant Node_Id
:= Parent
(N
);
17634 Form
: Entity_Id
:= Empty
;
17635 Call
: Node_Id
:= Empty
;
17637 -- Start of processing for Known_To_Be_Assigned
17640 -- Check for out parameters
17642 Find_Actual
(N
, Form
, Call
);
17644 if Present
(Form
) then
17645 return Ekind
(Form
) /= E_In_Parameter
and then not Only_LHS
;
17648 -- Otherwise look at the parent
17652 -- Test left side of assignment
17654 when N_Assignment_Statement
=>
17655 return N
= Name
(P
);
17657 -- Test prefix of component or attribute. Note that the prefix of an
17658 -- explicit or implicit dereference cannot be an l-value. In the case
17659 -- of a 'Read attribute, the reference can be an actual in the
17660 -- argument list of the attribute.
17662 when N_Attribute_Reference
=>
17664 not Only_LHS
and then
17666 and then Name_Implies_Lvalue_Prefix
(Attribute_Name
(P
)))
17668 Attribute_Name
(P
) = Name_Read
);
17670 -- For an expanded name, the name is an lvalue if the expanded name
17671 -- is an lvalue, but the prefix is never an lvalue, since it is just
17672 -- the scope where the name is found.
17674 when N_Expanded_Name
=>
17675 if N
= Prefix
(P
) then
17676 return Known_Assn
(P
);
17681 -- For a selected component A.B, A is certainly an lvalue if A.B is.
17682 -- B is a little interesting, if we have A.B := 3, there is some
17683 -- discussion as to whether B is an lvalue or not, we choose to say
17684 -- it is. Note however that A is not an lvalue if it is of an access
17685 -- type since this is an implicit dereference.
17687 when N_Selected_Component
=>
17689 and then Present
(Etype
(N
))
17690 and then Is_Access_Type
(Etype
(N
))
17694 return Known_Assn
(P
);
17697 -- For an indexed component or slice, the index or slice bounds is
17698 -- never an lvalue. The prefix is an lvalue if the indexed component
17699 -- or slice is an lvalue, except if it is an access type, where we
17700 -- have an implicit dereference.
17702 when N_Indexed_Component | N_Slice
=>
17704 or else (Present
(Etype
(N
)) and then Is_Access_Type
(Etype
(N
)))
17708 return Known_Assn
(P
);
17711 -- Prefix of a reference is an lvalue if the reference is an lvalue
17713 when N_Reference
=>
17714 return Known_Assn
(P
);
17716 -- Prefix of explicit dereference is never an lvalue
17718 when N_Explicit_Dereference
=>
17721 -- Test for appearing in a conversion that itself appears in an
17722 -- lvalue context, since this should be an lvalue.
17724 when N_Type_Conversion
=>
17725 return Known_Assn
(P
);
17727 -- Test for appearance in object renaming declaration
17729 when N_Object_Renaming_Declaration
=>
17730 return not Only_LHS
;
17732 -- All other references are definitely not lvalues
17737 end Known_To_Be_Assigned
;
17739 -----------------------------
17740 -- Is_Library_Level_Entity --
17741 -----------------------------
17743 function Is_Library_Level_Entity
(E
: Entity_Id
) return Boolean is
17745 -- The following is a small optimization, and it also properly handles
17746 -- discriminals, which in task bodies might appear in expressions before
17747 -- the corresponding procedure has been created, and which therefore do
17748 -- not have an assigned scope.
17750 if Is_Formal
(E
) then
17753 -- If we somehow got an empty value for Scope, the tree must be
17754 -- malformed. Rather than blow up we return True in this case.
17756 elsif No
(Scope
(E
)) then
17759 -- Handle loops since Enclosing_Dynamic_Scope skips them; required to
17760 -- properly handle entities local to quantified expressions in library
17761 -- level specifications.
17763 elsif Ekind
(Scope
(E
)) = E_Loop
then
17767 -- Normal test is simply that the enclosing dynamic scope is Standard
17769 return Enclosing_Dynamic_Scope
(E
) = Standard_Standard
;
17770 end Is_Library_Level_Entity
;
17772 --------------------------------
17773 -- Is_Limited_Class_Wide_Type --
17774 --------------------------------
17776 function Is_Limited_Class_Wide_Type
(Typ
: Entity_Id
) return Boolean is
17779 Is_Class_Wide_Type
(Typ
)
17780 and then (Is_Limited_Type
(Typ
) or else From_Limited_With
(Typ
));
17781 end Is_Limited_Class_Wide_Type
;
17783 ---------------------------------
17784 -- Is_Local_Variable_Reference --
17785 ---------------------------------
17787 function Is_Local_Variable_Reference
(Expr
: Node_Id
) return Boolean is
17789 if not Is_Entity_Name
(Expr
) then
17794 Ent
: constant Entity_Id
:= Entity
(Expr
);
17795 Sub
: constant Entity_Id
:= Enclosing_Subprogram
(Ent
);
17798 not in E_Variable | E_In_Out_Parameter | E_Out_Parameter
17802 return Present
(Sub
) and then Sub
= Current_Subprogram
;
17806 end Is_Local_Variable_Reference
;
17812 function Is_Master
(N
: Node_Id
) return Boolean is
17813 Disable_Subexpression_Masters
: constant Boolean := True;
17816 if Nkind
(N
) in N_Subprogram_Body | N_Task_Body | N_Entry_Body
17817 or else Is_Statement
(N
)
17822 -- We avoid returning True when the master is a subexpression described
17823 -- in RM 7.6.1(3/2) for the proposes of accessibility level calculation
17824 -- in Accessibility_Level_Helper.Innermost_Master_Scope_Depth ???
17826 if not Disable_Subexpression_Masters
17827 and then Nkind
(N
) in N_Subexpr
17830 Par
: Node_Id
:= N
;
17832 subtype N_Simple_Statement_Other_Than_Simple_Return
17833 is Node_Kind
with Static_Predicate
=>
17834 N_Simple_Statement_Other_Than_Simple_Return
17835 in N_Abort_Statement
17836 | N_Assignment_Statement
17838 | N_Delay_Statement
17839 | N_Entry_Call_Statement
17843 | N_Raise_Statement
17844 | N_Requeue_Statement
17846 | N_Procedure_Call_Statement
;
17848 while Present
(Par
) loop
17849 Par
:= Parent
(Par
);
17850 if Nkind
(Par
) in N_Subexpr |
17851 N_Simple_Statement_Other_Than_Simple_Return
17864 -----------------------
17865 -- Is_Name_Reference --
17866 -----------------------
17868 function Is_Name_Reference
(N
: Node_Id
) return Boolean is
17870 if Is_Entity_Name
(N
) then
17871 return Present
(Entity
(N
)) and then Is_Object
(Entity
(N
));
17875 when N_Indexed_Component
17879 Is_Name_Reference
(Prefix
(N
))
17880 or else Is_Access_Type
(Etype
(Prefix
(N
)));
17882 -- Attributes 'Input, 'Old and 'Result produce objects
17884 when N_Attribute_Reference
=>
17885 return Attribute_Name
(N
) in Name_Input | Name_Old | Name_Result
;
17887 when N_Selected_Component
=>
17889 Is_Name_Reference
(Selector_Name
(N
))
17891 (Is_Name_Reference
(Prefix
(N
))
17892 or else Is_Access_Type
(Etype
(Prefix
(N
))));
17894 when N_Explicit_Dereference
=>
17897 -- A view conversion of a tagged name is a name reference
17899 when N_Type_Conversion
=>
17901 Is_Tagged_Type
(Etype
(Subtype_Mark
(N
)))
17902 and then Is_Tagged_Type
(Etype
(Expression
(N
)))
17903 and then Is_Name_Reference
(Expression
(N
));
17905 -- An unchecked type conversion is considered to be a name if the
17906 -- operand is a name (this construction arises only as a result of
17907 -- expansion activities).
17909 when N_Unchecked_Type_Conversion
=>
17910 return Is_Name_Reference
(Expression
(N
));
17915 end Is_Name_Reference
;
17917 --------------------------
17918 -- Is_Newly_Constructed --
17919 --------------------------
17921 function Is_Newly_Constructed
17922 (Exp
: Node_Id
; Context_Requires_NC
: Boolean) return Boolean
17924 Original_Exp
: constant Node_Id
:= Original_Node
(Exp
);
17926 function Is_NC
(Exp
: Node_Id
) return Boolean is
17927 (Is_Newly_Constructed
(Exp
, Context_Requires_NC
));
17929 -- If the context requires that the expression shall be newly
17930 -- constructed, then "True" is a good result in the sense that the
17931 -- expression satisfies the requirements of the context (and "False"
17932 -- is analogously a bad result). If the context requires that the
17933 -- expression shall *not* be newly constructed, then things are
17934 -- reversed: "False" is the good value and "True" is the bad value.
17936 Good_Result
: constant Boolean := Context_Requires_NC
;
17937 Bad_Result
: constant Boolean := not Good_Result
;
17939 case Nkind
(Original_Exp
) is
17941 | N_Extension_Aggregate
17947 when N_Identifier
=>
17948 return Present
(Entity
(Original_Exp
))
17949 and then Ekind
(Entity
(Original_Exp
)) = E_Function
;
17951 when N_Qualified_Expression
=>
17952 return Is_NC
(Expression
(Original_Exp
));
17954 when N_Type_Conversion
17955 | N_Unchecked_Type_Conversion
17957 if Is_View_Conversion
(Original_Exp
) then
17958 return Is_NC
(Expression
(Original_Exp
));
17959 elsif not Comes_From_Source
(Exp
) then
17960 if Exp
/= Original_Exp
then
17961 return Is_NC
(Original_Exp
);
17963 return Is_NC
(Expression
(Original_Exp
));
17969 when N_Explicit_Dereference
17970 | N_Indexed_Component
17971 | N_Selected_Component
17973 return Nkind
(Exp
) = N_Function_Call
;
17975 -- A use of 'Input is a function call, hence allowed. Normally the
17976 -- attribute will be changed to a call, but the attribute by itself
17977 -- can occur with -gnatc.
17979 when N_Attribute_Reference
=>
17980 return Attribute_Name
(Original_Exp
) = Name_Input
;
17982 -- "return raise ..." is OK
17984 when N_Raise_Expression
=>
17985 return Good_Result
;
17987 -- For a case expression, all dependent expressions must be legal
17989 when N_Case_Expression
=>
17994 Alt
:= First
(Alternatives
(Original_Exp
));
17995 while Present
(Alt
) loop
17996 if Is_NC
(Expression
(Alt
)) = Bad_Result
then
18003 return Good_Result
;
18006 -- For an if expression, all dependent expressions must be legal
18008 when N_If_Expression
=>
18010 Then_Expr
: constant Node_Id
:=
18011 Next
(First
(Expressions
(Original_Exp
)));
18012 Else_Expr
: constant Node_Id
:= Next
(Then_Expr
);
18014 if Is_NC
(Then_Expr
) = Bad_Result
18015 or else Is_NC
(Else_Expr
) = Bad_Result
18019 return Good_Result
;
18026 end Is_Newly_Constructed
;
18028 ------------------------------------
18029 -- Is_Non_Preelaborable_Construct --
18030 ------------------------------------
18032 function Is_Non_Preelaborable_Construct
(N
: Node_Id
) return Boolean is
18034 -- NOTE: the routines within Is_Non_Preelaborable_Construct are
18035 -- intentionally unnested to avoid deep indentation of code.
18037 Non_Preelaborable
: exception;
18038 -- This exception is raised when the construct violates preelaborability
18039 -- to terminate the recursion.
18041 procedure Visit
(Nod
: Node_Id
);
18042 -- Semantically inspect construct Nod to determine whether it violates
18043 -- preelaborability. This routine raises Non_Preelaborable.
18045 procedure Visit_List
(List
: List_Id
);
18046 pragma Inline
(Visit_List
);
18047 -- Invoke Visit on each element of list List. This routine raises
18048 -- Non_Preelaborable.
18050 procedure Visit_Pragma
(Prag
: Node_Id
);
18051 pragma Inline
(Visit_Pragma
);
18052 -- Semantically inspect pragma Prag to determine whether it violates
18053 -- preelaborability. This routine raises Non_Preelaborable.
18055 procedure Visit_Subexpression
(Expr
: Node_Id
);
18056 pragma Inline
(Visit_Subexpression
);
18057 -- Semantically inspect expression Expr to determine whether it violates
18058 -- preelaborability. This routine raises Non_Preelaborable.
18064 procedure Visit
(Nod
: Node_Id
) is
18066 case Nkind
(Nod
) is
18070 when N_Component_Declaration
=>
18072 -- Defining_Identifier is left out because it is not relevant
18073 -- for preelaborability.
18075 Visit
(Component_Definition
(Nod
));
18076 Visit
(Expression
(Nod
));
18078 when N_Derived_Type_Definition
=>
18080 -- Interface_List is left out because it is not relevant for
18081 -- preelaborability.
18083 Visit
(Record_Extension_Part
(Nod
));
18084 Visit
(Subtype_Indication
(Nod
));
18086 when N_Entry_Declaration
=>
18088 -- A protected type with at leat one entry is not preelaborable
18089 -- while task types are never preelaborable. This renders entry
18090 -- declarations non-preelaborable.
18092 raise Non_Preelaborable
;
18094 when N_Full_Type_Declaration
=>
18096 -- Defining_Identifier and Discriminant_Specifications are left
18097 -- out because they are not relevant for preelaborability.
18099 Visit
(Type_Definition
(Nod
));
18101 when N_Function_Instantiation
18102 | N_Package_Instantiation
18103 | N_Procedure_Instantiation
18105 -- Defining_Unit_Name and Name are left out because they are
18106 -- not relevant for preelaborability.
18108 Visit_List
(Generic_Associations
(Nod
));
18110 when N_Object_Declaration
=>
18112 -- Defining_Identifier is left out because it is not relevant
18113 -- for preelaborability.
18115 Visit
(Object_Definition
(Nod
));
18117 if Has_Init_Expression
(Nod
) then
18118 Visit
(Expression
(Nod
));
18120 elsif not Constant_Present
(Nod
)
18121 and then not Has_Preelaborable_Initialization
18122 (Etype
(Defining_Entity
(Nod
)))
18124 raise Non_Preelaborable
;
18127 when N_Private_Extension_Declaration
18128 | N_Subtype_Declaration
18130 -- Defining_Identifier, Discriminant_Specifications, and
18131 -- Interface_List are left out because they are not relevant
18132 -- for preelaborability.
18134 Visit
(Subtype_Indication
(Nod
));
18136 when N_Protected_Type_Declaration
18137 | N_Single_Protected_Declaration
18139 -- Defining_Identifier, Discriminant_Specifications, and
18140 -- Interface_List are left out because they are not relevant
18141 -- for preelaborability.
18143 Visit
(Protected_Definition
(Nod
));
18145 -- A [single] task type is never preelaborable
18147 when N_Single_Task_Declaration
18148 | N_Task_Type_Declaration
18150 raise Non_Preelaborable
;
18155 Visit_Pragma
(Nod
);
18159 when N_Statement_Other_Than_Procedure_Call
=>
18160 if Nkind
(Nod
) /= N_Null_Statement
then
18161 raise Non_Preelaborable
;
18167 Visit_Subexpression
(Nod
);
18171 when N_Access_To_Object_Definition
=>
18172 Visit
(Subtype_Indication
(Nod
));
18174 when N_Case_Expression_Alternative
=>
18175 Visit
(Expression
(Nod
));
18176 Visit_List
(Discrete_Choices
(Nod
));
18178 when N_Component_Definition
=>
18179 Visit
(Access_Definition
(Nod
));
18180 Visit
(Subtype_Indication
(Nod
));
18182 when N_Component_List
=>
18183 Visit_List
(Component_Items
(Nod
));
18184 Visit
(Variant_Part
(Nod
));
18186 when N_Constrained_Array_Definition
=>
18187 Visit_List
(Discrete_Subtype_Definitions
(Nod
));
18188 Visit
(Component_Definition
(Nod
));
18190 when N_Delta_Constraint
18191 | N_Digits_Constraint
18193 -- Delta_Expression and Digits_Expression are left out because
18194 -- they are not relevant for preelaborability.
18196 Visit
(Range_Constraint
(Nod
));
18198 when N_Discriminant_Specification
=>
18200 -- Defining_Identifier and Expression are left out because they
18201 -- are not relevant for preelaborability.
18203 Visit
(Discriminant_Type
(Nod
));
18205 when N_Generic_Association
=>
18207 -- Selector_Name is left out because it is not relevant for
18208 -- preelaborability.
18210 Visit
(Explicit_Generic_Actual_Parameter
(Nod
));
18212 when N_Index_Or_Discriminant_Constraint
=>
18213 Visit_List
(Constraints
(Nod
));
18215 when N_Iterator_Specification
=>
18217 -- Defining_Identifier is left out because it is not relevant
18218 -- for preelaborability.
18220 Visit
(Name
(Nod
));
18221 Visit
(Subtype_Indication
(Nod
));
18223 when N_Loop_Parameter_Specification
=>
18225 -- Defining_Identifier is left out because it is not relevant
18226 -- for preelaborability.
18228 Visit
(Discrete_Subtype_Definition
(Nod
));
18230 when N_Parameter_Association
=>
18231 Visit
(Explicit_Actual_Parameter
(N
));
18233 when N_Protected_Definition
=>
18235 -- End_Label is left out because it is not relevant for
18236 -- preelaborability.
18238 Visit_List
(Private_Declarations
(Nod
));
18239 Visit_List
(Visible_Declarations
(Nod
));
18241 when N_Range_Constraint
=>
18242 Visit
(Range_Expression
(Nod
));
18244 when N_Record_Definition
18247 -- End_Label, Discrete_Choices, and Interface_List are left out
18248 -- because they are not relevant for preelaborability.
18250 Visit
(Component_List
(Nod
));
18252 when N_Subtype_Indication
=>
18254 -- Subtype_Mark is left out because it is not relevant for
18255 -- preelaborability.
18257 Visit
(Constraint
(Nod
));
18259 when N_Unconstrained_Array_Definition
=>
18261 -- Subtype_Marks is left out because it is not relevant for
18262 -- preelaborability.
18264 Visit
(Component_Definition
(Nod
));
18266 when N_Variant_Part
=>
18268 -- Name is left out because it is not relevant for
18269 -- preelaborability.
18271 Visit_List
(Variants
(Nod
));
18284 procedure Visit_List
(List
: List_Id
) is
18288 Nod
:= First
(List
);
18289 while Present
(Nod
) loop
18299 procedure Visit_Pragma
(Prag
: Node_Id
) is
18301 case Get_Pragma_Id
(Prag
) is
18303 | Pragma_Assert_And_Cut
18305 | Pragma_Async_Readers
18306 | Pragma_Async_Writers
18307 | Pragma_Attribute_Definition
18309 | Pragma_Constant_After_Elaboration
18311 | Pragma_Deadline_Floor
18312 | Pragma_Dispatching_Domain
18313 | Pragma_Effective_Reads
18314 | Pragma_Effective_Writes
18315 | Pragma_Extensions_Visible
18317 | Pragma_Secondary_Stack_Size
18319 | Pragma_Volatile_Function
18321 Visit_List
(Pragma_Argument_Associations
(Prag
));
18330 -------------------------
18331 -- Visit_Subexpression --
18332 -------------------------
18334 procedure Visit_Subexpression
(Expr
: Node_Id
) is
18335 procedure Visit_Aggregate
(Aggr
: Node_Id
);
18336 pragma Inline
(Visit_Aggregate
);
18337 -- Semantically inspect aggregate Aggr to determine whether it
18338 -- violates preelaborability.
18340 ---------------------
18341 -- Visit_Aggregate --
18342 ---------------------
18344 procedure Visit_Aggregate
(Aggr
: Node_Id
) is
18346 if not Is_Preelaborable_Aggregate
(Aggr
) then
18347 raise Non_Preelaborable
;
18349 end Visit_Aggregate
;
18351 -- Start of processing for Visit_Subexpression
18354 case Nkind
(Expr
) is
18356 | N_Qualified_Expression
18357 | N_Type_Conversion
18358 | N_Unchecked_Expression
18359 | N_Unchecked_Type_Conversion
18361 -- Subpool_Handle_Name and Subtype_Mark are left out because
18362 -- they are not relevant for preelaborability.
18364 Visit
(Expression
(Expr
));
18367 | N_Extension_Aggregate
18369 Visit_Aggregate
(Expr
);
18371 when N_Attribute_Reference
18372 | N_Explicit_Dereference
18375 -- Attribute_Name and Expressions are left out because they are
18376 -- not relevant for preelaborability.
18378 Visit
(Prefix
(Expr
));
18380 when N_Case_Expression
=>
18382 -- End_Span is left out because it is not relevant for
18383 -- preelaborability.
18385 Visit_List
(Alternatives
(Expr
));
18386 Visit
(Expression
(Expr
));
18388 when N_Delta_Aggregate
=>
18389 Visit_Aggregate
(Expr
);
18390 Visit
(Expression
(Expr
));
18392 when N_Expression_With_Actions
=>
18393 Visit_List
(Actions
(Expr
));
18394 Visit
(Expression
(Expr
));
18396 when N_Function_Call
=>
18398 -- Ada 2022 (AI12-0175): Calls to certain functions that are
18399 -- essentially unchecked conversions are preelaborable.
18401 if Ada_Version
>= Ada_2022
18402 and then Nkind
(Expr
) = N_Function_Call
18403 and then Is_Entity_Name
(Name
(Expr
))
18404 and then Is_Preelaborable_Function
(Entity
(Name
(Expr
)))
18406 Visit_List
(Parameter_Associations
(Expr
));
18408 raise Non_Preelaborable
;
18411 when N_If_Expression
=>
18412 Visit_List
(Expressions
(Expr
));
18414 when N_Quantified_Expression
=>
18415 Visit
(Condition
(Expr
));
18416 Visit
(Iterator_Specification
(Expr
));
18417 Visit
(Loop_Parameter_Specification
(Expr
));
18420 Visit
(High_Bound
(Expr
));
18421 Visit
(Low_Bound
(Expr
));
18424 Visit
(Discrete_Range
(Expr
));
18425 Visit
(Prefix
(Expr
));
18431 -- The evaluation of an object name is not preelaborable,
18432 -- unless the name is a static expression (checked further
18433 -- below), or statically denotes a discriminant.
18435 if Is_Entity_Name
(Expr
) then
18436 Object_Name
: declare
18437 Id
: constant Entity_Id
:= Entity
(Expr
);
18440 if Is_Object
(Id
) then
18441 if Ekind
(Id
) = E_Discriminant
then
18444 elsif Ekind
(Id
) in E_Constant | E_In_Parameter
18445 and then Present
(Discriminal_Link
(Id
))
18450 raise Non_Preelaborable
;
18455 -- A non-static expression is not preelaborable
18457 elsif not Is_OK_Static_Expression
(Expr
) then
18458 raise Non_Preelaborable
;
18461 end Visit_Subexpression
;
18463 -- Start of processing for Is_Non_Preelaborable_Construct
18468 -- At this point it is known that the construct is preelaborable
18474 -- The elaboration of the construct performs an action which violates
18475 -- preelaborability.
18477 when Non_Preelaborable
=>
18479 end Is_Non_Preelaborable_Construct
;
18481 ---------------------------------
18482 -- Is_Nontrivial_DIC_Procedure --
18483 ---------------------------------
18485 function Is_Nontrivial_DIC_Procedure
(Id
: Entity_Id
) return Boolean is
18486 Body_Decl
: Node_Id
;
18490 if Ekind
(Id
) = E_Procedure
and then Is_DIC_Procedure
(Id
) then
18492 Unit_Declaration_Node
18493 (Corresponding_Body
(Unit_Declaration_Node
(Id
)));
18495 -- The body of the Default_Initial_Condition procedure must contain
18496 -- at least one statement, otherwise the generation of the subprogram
18499 pragma Assert
(Present
(Handled_Statement_Sequence
(Body_Decl
)));
18501 -- To qualify as nontrivial, the first statement of the procedure
18502 -- must be a check in the form of an if statement. If the original
18503 -- Default_Initial_Condition expression was folded, then the first
18504 -- statement is not a check.
18506 Stmt
:= First
(Statements
(Handled_Statement_Sequence
(Body_Decl
)));
18509 Nkind
(Stmt
) = N_If_Statement
18510 and then Nkind
(Original_Node
(Stmt
)) = N_Pragma
;
18514 end Is_Nontrivial_DIC_Procedure
;
18516 -----------------------
18517 -- Is_Null_Extension --
18518 -----------------------
18520 function Is_Null_Extension
18521 (T
: Entity_Id
; Ignore_Privacy
: Boolean := False) return Boolean
18523 Type_Decl
: Node_Id
;
18524 Type_Def
: Node_Id
;
18526 pragma Assert
(not Is_Class_Wide_Type
(T
));
18528 if Ignore_Privacy
then
18529 Type_Decl
:= Parent
(Underlying_Type
(Base_Type
(T
)));
18531 Type_Decl
:= Parent
(Base_Type
(T
));
18532 if Nkind
(Type_Decl
) /= N_Full_Type_Declaration
then
18536 pragma Assert
(Nkind
(Type_Decl
) = N_Full_Type_Declaration
);
18537 Type_Def
:= Type_Definition
(Type_Decl
);
18538 if Present
(Discriminant_Specifications
(Type_Decl
))
18539 or else Nkind
(Type_Def
) /= N_Derived_Type_Definition
18540 or else not Is_Tagged_Type
(T
)
18541 or else No
(Record_Extension_Part
(Type_Def
))
18546 return Is_Null_Record_Definition
(Record_Extension_Part
(Type_Def
));
18547 end Is_Null_Extension
;
18549 --------------------------
18550 -- Is_Null_Extension_Of --
18551 --------------------------
18553 function Is_Null_Extension_Of
18554 (Descendant
, Ancestor
: Entity_Id
) return Boolean
18556 Ancestor_Type
: constant Entity_Id
18557 := Underlying_Type
(Base_Type
(Ancestor
));
18558 Descendant_Type
: Entity_Id
:= Underlying_Type
(Base_Type
(Descendant
));
18560 pragma Assert
(not Is_Class_Wide_Type
(Descendant
));
18561 pragma Assert
(not Is_Class_Wide_Type
(Ancestor
));
18562 pragma Assert
(Descendant_Type
/= Ancestor_Type
);
18564 while Descendant_Type
/= Ancestor_Type
loop
18565 if not Is_Null_Extension
18566 (Descendant_Type
, Ignore_Privacy
=> True)
18570 Descendant_Type
:= Etype
(Subtype_Indication
18571 (Type_Definition
(Parent
(Descendant_Type
))));
18572 Descendant_Type
:= Underlying_Type
(Base_Type
(Descendant_Type
));
18575 end Is_Null_Extension_Of
;
18577 -------------------------------
18578 -- Is_Null_Record_Definition --
18579 -------------------------------
18581 function Is_Null_Record_Definition
(Record_Def
: Node_Id
) return Boolean is
18584 -- Testing Null_Present is just an optimization, not required.
18586 if Null_Present
(Record_Def
) then
18588 elsif Present
(Variant_Part
(Component_List
(Record_Def
))) then
18590 elsif No
(Component_List
(Record_Def
)) then
18594 Item
:= First_Non_Pragma
(Component_Items
(Component_List
(Record_Def
)));
18596 while Present
(Item
) loop
18597 if Nkind
(Item
) = N_Component_Declaration
18598 and then Is_Internal_Name
(Chars
(Defining_Identifier
(Item
)))
18604 Next_Non_Pragma
(Item
);
18608 end Is_Null_Record_Definition
;
18610 -------------------------
18611 -- Is_Null_Record_Type --
18612 -------------------------
18614 function Is_Null_Record_Type
18615 (T
: Entity_Id
; Ignore_Privacy
: Boolean := False) return Boolean
18618 Type_Def
: Node_Id
;
18620 if not Is_Record_Type
(T
) then
18624 if Ignore_Privacy
then
18625 Decl
:= Parent
(Underlying_Type
(Base_Type
(T
)));
18627 Decl
:= Parent
(Base_Type
(T
));
18628 if Nkind
(Decl
) /= N_Full_Type_Declaration
then
18632 pragma Assert
(Nkind
(Decl
) = N_Full_Type_Declaration
);
18633 Type_Def
:= Type_Definition
(Decl
);
18635 if Has_Discriminants
(Defining_Identifier
(Decl
)) then
18639 case Nkind
(Type_Def
) is
18640 when N_Record_Definition
=>
18641 return Is_Null_Record_Definition
(Type_Def
);
18642 when N_Derived_Type_Definition
=>
18643 if not Is_Null_Record_Type
18644 (Etype
(Subtype_Indication
(Type_Def
)),
18645 Ignore_Privacy
=> Ignore_Privacy
)
18648 elsif not Is_Tagged_Type
(T
) then
18651 return Is_Null_Extension
(T
, Ignore_Privacy
=> Ignore_Privacy
);
18656 end Is_Null_Record_Type
;
18658 ---------------------
18659 -- Is_Object_Image --
18660 ---------------------
18662 function Is_Object_Image
(Prefix
: Node_Id
) return Boolean is
18664 -- Here we test for the case that the prefix is not a type and assume
18665 -- if it is not then it must be a named value or an object reference.
18666 -- This is because the parser always checks that prefixes of attributes
18669 return not (Is_Entity_Name
(Prefix
)
18670 and then Is_Type
(Entity
(Prefix
))
18671 and then not Is_Current_Instance
(Prefix
));
18672 end Is_Object_Image
;
18674 -------------------------
18675 -- Is_Object_Reference --
18676 -------------------------
18678 function Is_Object_Reference
(N
: Node_Id
) return Boolean is
18679 function Safe_Prefix
(N
: Node_Id
) return Node_Id
;
18680 -- Return Prefix (N) unless it has been rewritten as an
18681 -- N_Raise_xxx_Error node, in which case return its original node.
18687 function Safe_Prefix
(N
: Node_Id
) return Node_Id
is
18689 if Nkind
(Prefix
(N
)) in N_Raise_xxx_Error
then
18690 return Original_Node
(Prefix
(N
));
18697 -- AI12-0068: Note that a current instance reference in a type or
18698 -- subtype's aspect_specification is considered a value, not an object
18699 -- (see RM 8.6(18/5)).
18701 if Is_Entity_Name
(N
) then
18702 return Present
(Entity
(N
)) and then Is_Object
(Entity
(N
))
18703 and then not Is_Current_Instance_Reference_In_Type_Aspect
(N
);
18707 when N_Indexed_Component
18711 Is_Object_Reference
(Safe_Prefix
(N
))
18712 or else Is_Access_Type
(Etype
(Safe_Prefix
(N
)));
18714 -- In Ada 95, a function call is a constant object; a procedure
18717 -- Note that predefined operators are functions as well, and so
18718 -- are attributes that are (can be renamed as) functions.
18720 when N_Function_Call
18723 return Etype
(N
) /= Standard_Void_Type
;
18725 -- Attributes references 'Loop_Entry, 'Old, 'Priority and 'Result
18726 -- yield objects, even though they are not functions.
18728 when N_Attribute_Reference
=>
18730 Attribute_Name
(N
) in Name_Loop_Entry
18734 or else Is_Function_Attribute_Name
(Attribute_Name
(N
));
18736 when N_Selected_Component
=>
18738 Is_Object_Reference
(Selector_Name
(N
))
18740 (Is_Object_Reference
(Safe_Prefix
(N
))
18741 or else Is_Access_Type
(Etype
(Safe_Prefix
(N
))));
18743 -- An explicit dereference denotes an object, except that a
18744 -- conditional expression gets turned into an explicit dereference
18745 -- in some cases, and conditional expressions are not object
18748 when N_Explicit_Dereference
=>
18749 return Nkind
(Original_Node
(N
)) not in
18750 N_Case_Expression | N_If_Expression
;
18752 -- A view conversion of a tagged object is an object reference
18754 when N_Type_Conversion
=>
18755 if Ada_Version
<= Ada_2012
then
18756 -- A view conversion of a tagged object is an object
18758 return Is_Tagged_Type
(Etype
(Subtype_Mark
(N
)))
18759 and then Is_Tagged_Type
(Etype
(Expression
(N
)))
18760 and then Is_Object_Reference
(Expression
(N
));
18763 -- AI12-0226: In Ada 2022 a value conversion of an object is
18766 return Is_Object_Reference
(Expression
(N
));
18769 -- An unchecked type conversion is considered to be an object if
18770 -- the operand is an object (this construction arises only as a
18771 -- result of expansion activities).
18773 when N_Unchecked_Type_Conversion
=>
18776 -- AI05-0003: In Ada 2012 a qualified expression is a name.
18777 -- This allows disambiguation of function calls and the use
18778 -- of aggregates in more contexts.
18780 when N_Qualified_Expression
=>
18781 return Ada_Version
>= Ada_2012
18782 and then Is_Object_Reference
(Expression
(N
));
18784 -- In Ada 95 an aggregate is an object reference
18787 | N_Delta_Aggregate
18788 | N_Extension_Aggregate
18790 return Ada_Version
>= Ada_95
;
18792 -- A string literal is not an object reference, but it might come
18793 -- from rewriting of an object reference, e.g. from folding of an
18796 when N_String_Literal
=>
18797 return Is_Rewrite_Substitution
(N
)
18798 and then Is_Object_Reference
(Original_Node
(N
));
18800 -- AI12-0125: Target name represents a constant object
18802 when N_Target_Name
=>
18809 end Is_Object_Reference
;
18811 -----------------------------------
18812 -- Is_OK_Variable_For_Out_Formal --
18813 -----------------------------------
18815 function Is_OK_Variable_For_Out_Formal
(AV
: Node_Id
) return Boolean is
18817 Note_Possible_Modification
(AV
, Sure
=> True);
18819 -- We must reject parenthesized variable names. Comes_From_Source is
18820 -- checked because there are currently cases where the compiler violates
18821 -- this rule (e.g. passing a task object to its controlled Initialize
18822 -- routine). This should be properly documented in sinfo???
18824 if Paren_Count
(AV
) > 0 and then Comes_From_Source
(AV
) then
18827 -- A variable is always allowed
18829 elsif Is_Variable
(AV
) then
18832 -- Generalized indexing operations are rewritten as explicit
18833 -- dereferences, and it is only during resolution that we can
18834 -- check whether the context requires an access_to_variable type.
18836 elsif Nkind
(AV
) = N_Explicit_Dereference
18837 and then Present
(Etype
(Original_Node
(AV
)))
18838 and then Has_Implicit_Dereference
(Etype
(Original_Node
(AV
)))
18839 and then Ada_Version
>= Ada_2012
18841 return not Is_Access_Constant
(Etype
(Prefix
(AV
)));
18843 -- Unchecked conversions are allowed only if they come from the
18844 -- generated code, which sometimes uses unchecked conversions for out
18845 -- parameters in cases where code generation is unaffected. We tell
18846 -- source unchecked conversions by seeing if they are rewrites of
18847 -- an original Unchecked_Conversion function call, or of an explicit
18848 -- conversion of a function call or an aggregate (as may happen in the
18849 -- expansion of a packed array aggregate).
18851 elsif Nkind
(AV
) = N_Unchecked_Type_Conversion
then
18852 if Nkind
(Original_Node
(AV
)) in N_Function_Call | N_Aggregate
then
18855 elsif Nkind
(Original_Node
(Expression
(AV
))) = N_Function_Call
then
18858 elsif Nkind
(Original_Node
(AV
)) = N_Type_Conversion
then
18859 return Is_OK_Variable_For_Out_Formal
(Expression
(AV
));
18865 -- Normal type conversions are allowed if argument is a variable
18867 elsif Nkind
(AV
) = N_Type_Conversion
then
18868 if Is_Variable
(Expression
(AV
))
18869 and then Paren_Count
(Expression
(AV
)) = 0
18871 Note_Possible_Modification
(Expression
(AV
), Sure
=> True);
18874 -- We also allow a non-parenthesized expression that raises
18875 -- constraint error if it rewrites what used to be a variable
18877 elsif Raises_Constraint_Error
(Expression
(AV
))
18878 and then Paren_Count
(Expression
(AV
)) = 0
18879 and then Is_Variable
(Original_Node
(Expression
(AV
)))
18883 -- Type conversion of something other than a variable
18889 -- If this node is rewritten, then test the original form, if that is
18890 -- OK, then we consider the rewritten node OK (for example, if the
18891 -- original node is a conversion, then Is_Variable will not be true
18892 -- but we still want to allow the conversion if it converts a variable).
18894 elsif Is_Rewrite_Substitution
(AV
) then
18895 return Is_OK_Variable_For_Out_Formal
(Original_Node
(AV
));
18897 -- All other non-variables are rejected
18902 end Is_OK_Variable_For_Out_Formal
;
18904 ----------------------------
18905 -- Is_OK_Volatile_Context --
18906 ----------------------------
18908 function Is_OK_Volatile_Context
18909 (Context
: Node_Id
;
18911 Check_Actuals
: Boolean) return Boolean
18913 function Is_Protected_Operation_Call
(Nod
: Node_Id
) return Boolean;
18914 -- Determine whether an arbitrary node denotes a call to a protected
18915 -- entry, function, or procedure in prefixed form where the prefix is
18918 function Within_Check
(Nod
: Node_Id
) return Boolean;
18919 -- Determine whether an arbitrary node appears in a check node
18921 function Within_Volatile_Function
(Id
: Entity_Id
) return Boolean;
18922 -- Determine whether an arbitrary entity appears in a volatile function
18924 ---------------------------------
18925 -- Is_Protected_Operation_Call --
18926 ---------------------------------
18928 function Is_Protected_Operation_Call
(Nod
: Node_Id
) return Boolean is
18933 -- A call to a protected operations retains its selected component
18934 -- form as opposed to other prefixed calls that are transformed in
18937 if Nkind
(Nod
) = N_Selected_Component
then
18938 Pref
:= Prefix
(Nod
);
18939 Subp
:= Selector_Name
(Nod
);
18943 and then Present
(Etype
(Pref
))
18944 and then Is_Protected_Type
(Etype
(Pref
))
18945 and then Is_Entity_Name
(Subp
)
18946 and then Present
(Entity
(Subp
))
18947 and then Ekind
(Entity
(Subp
)) in
18948 E_Entry | E_Entry_Family | E_Function | E_Procedure
;
18952 end Is_Protected_Operation_Call
;
18958 function Within_Check
(Nod
: Node_Id
) return Boolean is
18962 -- Climb the parent chain looking for a check node
18965 while Present
(Par
) loop
18966 if Nkind
(Par
) in N_Raise_xxx_Error
then
18969 -- Prevent the search from going too far
18971 elsif Is_Body_Or_Package_Declaration
(Par
) then
18975 Par
:= Parent
(Par
);
18981 ------------------------------
18982 -- Within_Volatile_Function --
18983 ------------------------------
18985 function Within_Volatile_Function
(Id
: Entity_Id
) return Boolean is
18986 pragma Assert
(Ekind
(Id
) = E_Return_Statement
);
18988 Func_Id
: constant Entity_Id
:= Return_Applies_To
(Id
);
18991 pragma Assert
(Ekind
(Func_Id
) in E_Function | E_Generic_Function
);
18993 return Is_Volatile_Function
(Func_Id
);
18994 end Within_Volatile_Function
;
18998 Obj_Id
: Entity_Id
;
19000 -- Start of processing for Is_OK_Volatile_Context
19003 -- Ignore context restriction when doing preanalysis, e.g. on a copy of
19004 -- an expression function, because this copy is not fully decorated and
19005 -- it is not possible to reliably decide the legality of the context.
19006 -- Any violations will be reported anyway when doing the full analysis.
19008 if not Full_Analysis
then
19012 -- For actual parameters within explicit parameter associations switch
19013 -- the context to the corresponding subprogram call.
19015 if Nkind
(Context
) = N_Parameter_Association
then
19016 return Is_OK_Volatile_Context
(Context
=> Parent
(Context
),
19017 Obj_Ref
=> Obj_Ref
,
19018 Check_Actuals
=> Check_Actuals
);
19020 -- The volatile object appears on either side of an assignment
19022 elsif Nkind
(Context
) = N_Assignment_Statement
then
19025 -- The volatile object is part of the initialization expression of
19028 elsif Nkind
(Context
) = N_Object_Declaration
19029 and then Present
(Expression
(Context
))
19030 and then Expression
(Context
) = Obj_Ref
19031 and then Nkind
(Parent
(Context
)) /= N_Expression_With_Actions
19033 Obj_Id
:= Defining_Entity
(Context
);
19035 -- The volatile object acts as the initialization expression of an
19036 -- extended return statement. This is valid context as long as the
19037 -- function is volatile.
19039 if Is_Return_Object
(Obj_Id
) then
19040 return Within_Volatile_Function
(Scope
(Obj_Id
));
19042 -- Otherwise this is a normal object initialization
19048 -- The volatile object acts as the name of a renaming declaration
19050 elsif Nkind
(Context
) = N_Object_Renaming_Declaration
19051 and then Name
(Context
) = Obj_Ref
19055 -- The volatile object appears as an actual parameter in a call to an
19056 -- instance of Unchecked_Conversion whose result is renamed.
19058 elsif Nkind
(Context
) = N_Function_Call
19059 and then Is_Entity_Name
(Name
(Context
))
19060 and then Is_Unchecked_Conversion_Instance
(Entity
(Name
(Context
)))
19061 and then Nkind
(Parent
(Context
)) = N_Object_Renaming_Declaration
19065 -- The volatile object is actually the prefix in a protected entry,
19066 -- function, or procedure call.
19068 elsif Is_Protected_Operation_Call
(Context
) then
19071 -- The volatile object appears as the expression of a simple return
19072 -- statement that applies to a volatile function.
19074 elsif Nkind
(Context
) = N_Simple_Return_Statement
19075 and then Expression
(Context
) = Obj_Ref
19078 Within_Volatile_Function
(Return_Statement_Entity
(Context
));
19080 -- The volatile object appears as the prefix of a name occurring in a
19081 -- non-interfering context.
19083 elsif Nkind
(Context
) in
19084 N_Attribute_Reference |
19085 N_Explicit_Dereference |
19086 N_Indexed_Component |
19087 N_Selected_Component |
19089 and then Prefix
(Context
) = Obj_Ref
19090 and then Is_OK_Volatile_Context
19091 (Context
=> Parent
(Context
),
19092 Obj_Ref
=> Context
,
19093 Check_Actuals
=> Check_Actuals
)
19097 -- The volatile object appears as the prefix of attributes Address,
19098 -- Alignment, Component_Size, First, First_Bit, Last, Last_Bit, Length,
19099 -- Position, Size, Storage_Size.
19101 elsif Nkind
(Context
) = N_Attribute_Reference
19102 and then Prefix
(Context
) = Obj_Ref
19103 and then Attribute_Name
(Context
) in Name_Address
19105 | Name_Component_Size
19113 | Name_Storage_Size
19117 -- The volatile object appears as the expression of a type conversion
19118 -- occurring in a non-interfering context.
19120 elsif Nkind
(Context
) in N_Qualified_Expression
19121 | N_Type_Conversion
19122 | N_Unchecked_Type_Conversion
19123 and then Expression
(Context
) = Obj_Ref
19124 and then Is_OK_Volatile_Context
19125 (Context
=> Parent
(Context
),
19126 Obj_Ref
=> Context
,
19127 Check_Actuals
=> Check_Actuals
)
19131 -- The volatile object appears as the expression in a delay statement
19133 elsif Nkind
(Context
) in N_Delay_Statement
then
19136 -- Allow references to volatile objects in various checks. This is not a
19137 -- direct SPARK 2014 requirement.
19139 elsif Within_Check
(Context
) then
19142 -- References to effectively volatile objects that appear as actual
19143 -- parameters in subprogram calls can be examined only after call itself
19144 -- has been resolved. Before that, assume such references to be legal.
19146 elsif Nkind
(Context
) in N_Subprogram_Call | N_Entry_Call_Statement
then
19147 if Check_Actuals
then
19150 Formal
: Entity_Id
;
19151 Subp
: constant Entity_Id
:= Get_Called_Entity
(Context
);
19153 Find_Actual
(Obj_Ref
, Formal
, Call
);
19154 pragma Assert
(Call
= Context
);
19156 -- An effectively volatile object may act as an actual when the
19157 -- corresponding formal is of a non-scalar effectively volatile
19158 -- type (SPARK RM 7.1.3(9)).
19160 if not Is_Scalar_Type
(Etype
(Formal
))
19161 and then Is_Effectively_Volatile_For_Reading
(Etype
(Formal
))
19165 -- An effectively volatile object may act as an actual in a
19166 -- call to an instance of Unchecked_Conversion. (SPARK RM
19169 elsif Is_Unchecked_Conversion_Instance
(Subp
) then
19182 end Is_OK_Volatile_Context
;
19184 ------------------------------------
19185 -- Is_Package_Contract_Annotation --
19186 ------------------------------------
19188 function Is_Package_Contract_Annotation
(Item
: Node_Id
) return Boolean is
19192 if Nkind
(Item
) = N_Aspect_Specification
then
19193 Nam
:= Chars
(Identifier
(Item
));
19195 else pragma Assert
(Nkind
(Item
) = N_Pragma
);
19196 Nam
:= Pragma_Name
(Item
);
19199 return Nam
= Name_Abstract_State
19200 or else Nam
= Name_Initial_Condition
19201 or else Nam
= Name_Initializes
19202 or else Nam
= Name_Refined_State
;
19203 end Is_Package_Contract_Annotation
;
19205 -----------------------------------
19206 -- Is_Partially_Initialized_Type --
19207 -----------------------------------
19209 function Is_Partially_Initialized_Type
19211 Include_Implicit
: Boolean := True) return Boolean
19214 if Is_Scalar_Type
(Typ
) then
19215 return Has_Default_Aspect
(Base_Type
(Typ
));
19217 elsif Is_Access_Type
(Typ
) then
19218 return Include_Implicit
;
19220 elsif Is_Array_Type
(Typ
) then
19222 -- If component type is partially initialized, so is array type
19224 if Has_Default_Aspect
(Base_Type
(Typ
))
19225 or else Is_Partially_Initialized_Type
19226 (Component_Type
(Typ
), Include_Implicit
)
19230 -- Otherwise we are only partially initialized if we are fully
19231 -- initialized (this is the empty array case, no point in us
19232 -- duplicating that code here).
19235 return Is_Fully_Initialized_Type
(Typ
);
19238 elsif Is_Record_Type
(Typ
) then
19240 -- A discriminated type is always partially initialized if in
19243 if Has_Discriminants
(Typ
) and then Include_Implicit
then
19246 -- A tagged type is always partially initialized
19248 elsif Is_Tagged_Type
(Typ
) then
19251 -- Case of nondiscriminated record
19257 Component_Present
: Boolean := False;
19258 -- Set True if at least one component is present. If no
19259 -- components are present, then record type is fully
19260 -- initialized (another odd case, like the null array).
19263 -- Loop through components
19265 Comp
:= First_Component
(Typ
);
19266 while Present
(Comp
) loop
19267 Component_Present
:= True;
19269 -- If a component has an initialization expression then the
19270 -- enclosing record type is partially initialized
19272 if Present
(Parent
(Comp
))
19273 and then Present
(Expression
(Parent
(Comp
)))
19277 -- If a component is of a type which is itself partially
19278 -- initialized, then the enclosing record type is also.
19280 elsif Is_Partially_Initialized_Type
19281 (Etype
(Comp
), Include_Implicit
)
19286 Next_Component
(Comp
);
19289 -- No initialized components found. If we found any components
19290 -- they were all uninitialized so the result is false.
19292 if Component_Present
then
19295 -- But if we found no components, then all the components are
19296 -- initialized so we consider the type to be initialized.
19304 -- Concurrent types are always fully initialized
19306 elsif Is_Concurrent_Type
(Typ
) then
19309 -- For a private type, go to underlying type. If there is no underlying
19310 -- type then just assume this partially initialized. Not clear if this
19311 -- can happen in a non-error case, but no harm in testing for this.
19313 elsif Is_Private_Type
(Typ
) then
19315 U
: constant Entity_Id
:= Underlying_Type
(Typ
);
19320 return Is_Partially_Initialized_Type
(U
, Include_Implicit
);
19324 -- For any other type (are there any?) assume partially initialized
19329 end Is_Partially_Initialized_Type
;
19331 ------------------------------------
19332 -- Is_Potentially_Persistent_Type --
19333 ------------------------------------
19335 function Is_Potentially_Persistent_Type
(T
: Entity_Id
) return Boolean is
19340 -- For private type, test corresponding full type
19342 if Is_Private_Type
(T
) then
19343 return Is_Potentially_Persistent_Type
(Full_View
(T
));
19345 -- Scalar types are potentially persistent
19347 elsif Is_Scalar_Type
(T
) then
19350 -- Record type is potentially persistent if not tagged and the types of
19351 -- all it components are potentially persistent, and no component has
19352 -- an initialization expression.
19354 elsif Is_Record_Type
(T
)
19355 and then not Is_Tagged_Type
(T
)
19356 and then not Is_Partially_Initialized_Type
(T
)
19358 Comp
:= First_Component
(T
);
19359 while Present
(Comp
) loop
19360 if not Is_Potentially_Persistent_Type
(Etype
(Comp
)) then
19363 Next_Entity
(Comp
);
19369 -- Array type is potentially persistent if its component type is
19370 -- potentially persistent and if all its constraints are static.
19372 elsif Is_Array_Type
(T
) then
19373 if not Is_Potentially_Persistent_Type
(Component_Type
(T
)) then
19377 Indx
:= First_Index
(T
);
19378 while Present
(Indx
) loop
19379 if not Is_OK_Static_Subtype
(Etype
(Indx
)) then
19388 -- All other types are not potentially persistent
19393 end Is_Potentially_Persistent_Type
;
19395 --------------------------------
19396 -- Is_Potentially_Unevaluated --
19397 --------------------------------
19399 function Is_Potentially_Unevaluated
(N
: Node_Id
) return Boolean is
19400 function Has_Null_Others_Choice
(Aggr
: Node_Id
) return Boolean;
19401 -- Aggr is an array aggregate with static bounds and an others clause;
19402 -- return True if the others choice of the given array aggregate does
19403 -- not cover any component (i.e. is null).
19405 function Immediate_Context_Implies_Is_Potentially_Unevaluated
19406 (Expr
: Node_Id
) return Boolean;
19407 -- Return True if the *immediate* context of this expression tells us
19408 -- that it is potentially unevaluated; return False if the *immediate*
19409 -- context doesn't provide an answer to this question and we need to
19412 function Non_Static_Or_Null_Range
(N
: Node_Id
) return Boolean;
19413 -- Return True if the given range is nonstatic or null
19415 ----------------------------
19416 -- Has_Null_Others_Choice --
19417 ----------------------------
19419 function Has_Null_Others_Choice
(Aggr
: Node_Id
) return Boolean is
19420 Idx
: constant Node_Id
:= First_Index
(Etype
(Aggr
));
19421 Hiv
: constant Uint
:= Expr_Value
(Type_High_Bound
(Etype
(Idx
)));
19422 Lov
: constant Uint
:= Expr_Value
(Type_Low_Bound
(Etype
(Idx
)));
19426 Intervals
: constant Interval_Lists
.Discrete_Interval_List
:=
19427 Interval_Lists
.Aggregate_Intervals
(Aggr
);
19430 -- The others choice is null if, after normalization, we
19431 -- have a single interval covering the whole aggregate.
19433 return Intervals
'Length = 1
19435 Intervals
(Intervals
'First).Low
= Lov
19437 Intervals
(Intervals
'First).High
= Hiv
;
19440 -- If the aggregate is malformed (that is, indexes are not disjoint)
19441 -- then no action is needed at this stage; the error will be reported
19442 -- later by the frontend.
19445 when Interval_Lists
.Intervals_Error
=>
19447 end Has_Null_Others_Choice
;
19449 ----------------------------------------------------------
19450 -- Immediate_Context_Implies_Is_Potentially_Unevaluated --
19451 ----------------------------------------------------------
19453 function Immediate_Context_Implies_Is_Potentially_Unevaluated
19454 (Expr
: Node_Id
) return Boolean
19456 Par
: constant Node_Id
:= Parent
(Expr
);
19458 function Aggregate_Type
return Node_Id
is (Etype
(Parent
(Par
)));
19460 if Nkind
(Par
) = N_If_Expression
then
19461 return Is_Elsif
(Par
) or else Expr
/= First
(Expressions
(Par
));
19463 elsif Nkind
(Par
) = N_Case_Expression
then
19464 return Expr
/= Expression
(Par
);
19466 elsif Nkind
(Par
) in N_And_Then | N_Or_Else
then
19467 return Expr
= Right_Opnd
(Par
);
19469 elsif Nkind
(Par
) in N_In | N_Not_In
then
19471 -- If the membership includes several alternatives, only the first
19472 -- is definitely evaluated.
19474 if Present
(Alternatives
(Par
)) then
19475 return Expr
/= First
(Alternatives
(Par
));
19477 -- If this is a range membership both bounds are evaluated
19483 elsif Nkind
(Par
) = N_Quantified_Expression
then
19484 return Expr
= Condition
(Par
);
19486 elsif Nkind
(Par
) in N_Component_Association
19487 | N_Iterated_Component_Association
19488 and then Expr
= Expression
(Par
)
19489 and then Nkind
(Parent
(Par
))
19490 in N_Aggregate | N_Delta_Aggregate | N_Extension_Aggregate
19491 and then Present
(Aggregate_Type
)
19492 and then Aggregate_Type
/= Any_Composite
19494 if Is_Array_Type
(Aggregate_Type
) then
19495 if Ada_Version
>= Ada_2022
then
19496 -- For Ada 2022, this predicate returns True for
19497 -- any "repeatedly evaluated" expression.
19503 In_Others_Choice
: Boolean := False;
19504 Array_Agg
: constant Node_Id
:= Parent
(Par
);
19506 -- The expression of an array_component_association is
19507 -- potentially unevaluated if the associated choice is a
19508 -- subtype_indication or range that defines a nonstatic or
19511 Choice
:= First
(Choices
(Par
));
19512 while Present
(Choice
) loop
19513 if Nkind
(Choice
) = N_Range
19514 and then Non_Static_Or_Null_Range
(Choice
)
19518 elsif Nkind
(Choice
) = N_Identifier
19519 and then Present
(Scalar_Range
(Etype
(Choice
)))
19521 Non_Static_Or_Null_Range
19522 (Scalar_Range
(Etype
(Choice
)))
19526 elsif Nkind
(Choice
) = N_Others_Choice
then
19527 In_Others_Choice
:= True;
19533 -- It is also potentially unevaluated if the associated
19534 -- choice is an others choice and the applicable index
19535 -- constraint is nonstatic or null.
19537 if In_Others_Choice
then
19538 if not Compile_Time_Known_Bounds
(Aggregate_Type
) then
19541 return Has_Null_Others_Choice
(Array_Agg
);
19546 elsif Is_Container_Aggregate
(Parent
(Par
)) then
19547 -- a component of a container aggregate
19556 end Immediate_Context_Implies_Is_Potentially_Unevaluated
;
19558 ------------------------------
19559 -- Non_Static_Or_Null_Range --
19560 ------------------------------
19562 function Non_Static_Or_Null_Range
(N
: Node_Id
) return Boolean is
19563 Low
, High
: Node_Id
;
19566 Get_Index_Bounds
(N
, Low
, High
);
19568 -- Check static bounds
19570 if not Compile_Time_Known_Value
(Low
)
19571 or else not Compile_Time_Known_Value
(High
)
19575 -- Check null range
19577 elsif Expr_Value
(High
) < Expr_Value
(Low
) then
19582 end Non_Static_Or_Null_Range
;
19589 -- Start of processing for Is_Potentially_Unevaluated
19595 -- A postcondition whose expression is a short-circuit is broken down
19596 -- into individual aspects for better exception reporting. The original
19597 -- short-circuit expression is rewritten as the second operand, and an
19598 -- occurrence of 'Old in that operand is potentially unevaluated.
19599 -- See sem_ch13.adb for details of this transformation. The reference
19600 -- to 'Old may appear within an expression, so we must look for the
19601 -- enclosing pragma argument in the tree that contains the reference.
19603 while Present
(Par
)
19604 and then Nkind
(Par
) /= N_Pragma_Argument_Association
19606 if Is_Rewrite_Substitution
(Par
)
19607 and then Nkind
(Original_Node
(Par
)) = N_And_Then
19612 Par
:= Parent
(Par
);
19615 -- Other cases; 'Old appears within other expression (not the top-level
19616 -- conjunct in a postcondition) with a potentially unevaluated operand.
19618 Par
:= Parent
(Expr
);
19620 while Present
(Par
)
19621 and then Nkind
(Par
) /= N_Pragma_Argument_Association
19623 if Comes_From_Source
(Par
)
19625 Immediate_Context_Implies_Is_Potentially_Unevaluated
(Expr
)
19629 -- For component associations continue climbing; it may be part of an
19630 -- array aggregate. For iterated component association we know that
19631 -- it belongs to an array aggreate, but only its expression is
19632 -- potentially unevaluated, not discrete choice list or iterator
19635 elsif Nkind
(Par
) in N_Component_Association
19636 | N_Iterated_Component_Association
19640 -- If the context is not an expression, or if is the result of
19641 -- expansion of an enclosing construct (such as another attribute)
19642 -- the predicate does not apply.
19644 elsif Nkind
(Par
) = N_Case_Expression_Alternative
then
19647 elsif Nkind
(Par
) not in N_Subexpr
19648 or else not Comes_From_Source
(Par
)
19654 Par
:= Parent
(Par
);
19658 end Is_Potentially_Unevaluated
;
19660 -----------------------------------------
19661 -- Is_Predefined_Dispatching_Operation --
19662 -----------------------------------------
19664 function Is_Predefined_Dispatching_Operation
19665 (E
: Entity_Id
) return Boolean
19667 TSS_Name
: TSS_Name_Type
;
19670 if not Is_Dispatching_Operation
(E
) then
19674 Get_Name_String
(Chars
(E
));
19676 -- Most predefined primitives have internally generated names. Equality
19677 -- must be treated differently; the predefined operation is recognized
19678 -- as a homogeneous binary operator that returns Boolean.
19680 if Name_Len
> TSS_Name_Type
'Last then
19683 (Name_Buffer
(Name_Len
- TSS_Name
'Length + 1 .. Name_Len
));
19685 if Chars
(E
) in Name_uAssign | Name_uSize
19687 (Chars
(E
) = Name_Op_Eq
19688 and then Etype
(First_Formal
(E
)) = Etype
(Last_Formal
(E
)))
19689 or else TSS_Name
= TSS_Deep_Adjust
19690 or else TSS_Name
= TSS_Deep_Finalize
19691 or else TSS_Name
= TSS_Stream_Input
19692 or else TSS_Name
= TSS_Stream_Output
19693 or else TSS_Name
= TSS_Stream_Read
19694 or else TSS_Name
= TSS_Stream_Write
19695 or else TSS_Name
= TSS_Put_Image
19696 or else Is_Predefined_Interface_Primitive
(E
)
19703 end Is_Predefined_Dispatching_Operation
;
19705 ---------------------------------------
19706 -- Is_Predefined_Interface_Primitive --
19707 ---------------------------------------
19709 function Is_Predefined_Interface_Primitive
(E
: Entity_Id
) return Boolean is
19711 -- In VM targets we don't restrict the functionality of this test to
19712 -- compiling in Ada 2005 mode since in VM targets any tagged type has
19713 -- these primitives.
19715 return (Ada_Version
>= Ada_2005
or else not Tagged_Type_Expansion
)
19716 and then Chars
(E
) in Name_uDisp_Asynchronous_Select
19717 | Name_uDisp_Conditional_Select
19718 | Name_uDisp_Get_Prim_Op_Kind
19719 | Name_uDisp_Get_Task_Id
19720 | Name_uDisp_Requeue
19721 | Name_uDisp_Timed_Select
;
19722 end Is_Predefined_Interface_Primitive
;
19724 ---------------------------------------
19725 -- Is_Predefined_Internal_Operation --
19726 ---------------------------------------
19728 function Is_Predefined_Internal_Operation
19729 (E
: Entity_Id
) return Boolean
19731 TSS_Name
: TSS_Name_Type
;
19734 if not Is_Dispatching_Operation
(E
) then
19738 Get_Name_String
(Chars
(E
));
19740 -- Most predefined primitives have internally generated names. Equality
19741 -- must be treated differently; the predefined operation is recognized
19742 -- as a homogeneous binary operator that returns Boolean.
19744 if Name_Len
> TSS_Name_Type
'Last then
19747 (Name_Buffer
(Name_Len
- TSS_Name
'Length + 1 .. Name_Len
));
19749 if Chars
(E
) in Name_uSize | Name_uAssign
19751 (Chars
(E
) = Name_Op_Eq
19752 and then Etype
(First_Formal
(E
)) = Etype
(Last_Formal
(E
)))
19753 or else TSS_Name
= TSS_Deep_Adjust
19754 or else TSS_Name
= TSS_Deep_Finalize
19755 or else Is_Predefined_Interface_Primitive
(E
)
19762 end Is_Predefined_Internal_Operation
;
19764 --------------------------------
19765 -- Is_Preelaborable_Aggregate --
19766 --------------------------------
19768 function Is_Preelaborable_Aggregate
(Aggr
: Node_Id
) return Boolean is
19769 Aggr_Typ
: constant Entity_Id
:= Etype
(Aggr
);
19770 Array_Aggr
: constant Boolean := Is_Array_Type
(Aggr_Typ
);
19772 Anc_Part
: Node_Id
;
19775 Comp_Typ
: Entity_Id
:= Empty
; -- init to avoid warning
19780 Comp_Typ
:= Component_Type
(Aggr_Typ
);
19783 -- Inspect the ancestor part
19785 if Nkind
(Aggr
) = N_Extension_Aggregate
then
19786 Anc_Part
:= Ancestor_Part
(Aggr
);
19788 -- The ancestor denotes a subtype mark
19790 if Is_Entity_Name
(Anc_Part
)
19791 and then Is_Type
(Entity
(Anc_Part
))
19793 if not Has_Preelaborable_Initialization
(Entity
(Anc_Part
)) then
19797 -- Otherwise the ancestor denotes an expression
19799 elsif not Is_Preelaborable_Construct
(Anc_Part
) then
19804 -- Inspect the positional associations
19806 Expr
:= First
(Expressions
(Aggr
));
19807 while Present
(Expr
) loop
19808 if not Is_Preelaborable_Construct
(Expr
) then
19815 -- Inspect the named associations
19817 Assoc
:= First
(Component_Associations
(Aggr
));
19818 while Present
(Assoc
) loop
19820 -- Inspect the choices of the current named association
19822 Choice
:= First
(Choices
(Assoc
));
19823 while Present
(Choice
) loop
19826 -- For a choice to be preelaborable, it must denote either a
19827 -- static range or a static expression.
19829 if Nkind
(Choice
) = N_Others_Choice
then
19832 elsif Nkind
(Choice
) = N_Range
then
19833 if not Is_OK_Static_Range
(Choice
) then
19837 elsif not Is_OK_Static_Expression
(Choice
) then
19842 Comp_Typ
:= Etype
(Choice
);
19848 -- The type of the choice must have preelaborable initialization if
19849 -- the association carries a <>.
19851 pragma Assert
(Present
(Comp_Typ
));
19852 if Box_Present
(Assoc
) then
19853 if not Has_Preelaborable_Initialization
(Comp_Typ
) then
19857 -- The type of the expression must have preelaborable initialization
19859 elsif not Is_Preelaborable_Construct
(Expression
(Assoc
)) then
19866 -- At this point the aggregate is preelaborable
19869 end Is_Preelaborable_Aggregate
;
19871 --------------------------------
19872 -- Is_Preelaborable_Construct --
19873 --------------------------------
19875 function Is_Preelaborable_Construct
(N
: Node_Id
) return Boolean is
19879 if Nkind
(N
) in N_Aggregate | N_Extension_Aggregate
then
19880 return Is_Preelaborable_Aggregate
(N
);
19882 -- Attributes are allowed in general, even if their prefix is a formal
19883 -- type. It seems that certain attributes known not to be static might
19884 -- not be allowed, but there are no rules to prevent them.
19886 elsif Nkind
(N
) = N_Attribute_Reference
then
19891 elsif Nkind
(N
) in N_Subexpr
and then Is_OK_Static_Expression
(N
) then
19894 elsif Nkind
(N
) = N_Qualified_Expression
then
19895 return Is_Preelaborable_Construct
(Expression
(N
));
19897 -- Names are preelaborable when they denote a discriminant of an
19898 -- enclosing type. Discriminals are also considered for this check.
19900 elsif Is_Entity_Name
(N
)
19901 and then Present
(Entity
(N
))
19903 (Ekind
(Entity
(N
)) = E_Discriminant
19904 or else (Ekind
(Entity
(N
)) in E_Constant | E_In_Parameter
19905 and then Present
(Discriminal_Link
(Entity
(N
)))))
19911 elsif Nkind
(N
) = N_Null
then
19914 -- Ada 2022 (AI12-0175): Calls to certain functions that are essentially
19915 -- unchecked conversions are preelaborable.
19917 elsif Ada_Version
>= Ada_2022
19918 and then Nkind
(N
) = N_Function_Call
19919 and then Is_Entity_Name
(Name
(N
))
19920 and then Is_Preelaborable_Function
(Entity
(Name
(N
)))
19925 A
:= First_Actual
(N
);
19927 while Present
(A
) loop
19928 if not Is_Preelaborable_Construct
(A
) then
19938 -- Otherwise the construct is not preelaborable
19943 end Is_Preelaborable_Construct
;
19945 -------------------------------
19946 -- Is_Preelaborable_Function --
19947 -------------------------------
19949 function Is_Preelaborable_Function
(Id
: Entity_Id
) return Boolean is
19950 SATAC
: constant Rtsfind
.RTU_Id
:= System_Address_To_Access_Conversions
;
19951 Scop
: constant Entity_Id
:= Scope
(Id
);
19954 -- Small optimization: every allowed function has convention Intrinsic
19955 -- (see Analyze_Subprogram_Instantiation for the subtlety in the test).
19957 if not Is_Intrinsic_Subprogram
(Id
)
19958 and then Convention
(Id
) /= Convention_Intrinsic
19963 -- An instance of Unchecked_Conversion
19965 if Is_Unchecked_Conversion_Instance
(Id
) then
19969 -- A function declared in System.Storage_Elements
19971 if Is_RTU
(Scop
, System_Storage_Elements
) then
19975 -- The functions To_Pointer and To_Address declared in an instance of
19976 -- System.Address_To_Access_Conversions (they are the only ones).
19978 if Ekind
(Scop
) = E_Package
19979 and then Nkind
(Parent
(Scop
)) = N_Package_Specification
19980 and then Present
(Generic_Parent
(Parent
(Scop
)))
19981 and then Is_RTU
(Generic_Parent
(Parent
(Scop
)), SATAC
)
19987 end Is_Preelaborable_Function
;
19989 -----------------------------
19990 -- Is_Private_Library_Unit --
19991 -----------------------------
19993 function Is_Private_Library_Unit
(Unit
: Entity_Id
) return Boolean is
19994 Comp_Unit
: constant Node_Id
:= Parent
(Unit_Declaration_Node
(Unit
));
19996 return Nkind
(Comp_Unit
) = N_Compilation_Unit
19997 and then Private_Present
(Comp_Unit
);
19998 end Is_Private_Library_Unit
;
20000 ---------------------------------
20001 -- Is_Protected_Self_Reference --
20002 ---------------------------------
20004 function Is_Protected_Self_Reference
(N
: Node_Id
) return Boolean is
20006 function In_Access_Definition
(N
: Node_Id
) return Boolean;
20007 -- Returns true if N belongs to an access definition
20009 --------------------------
20010 -- In_Access_Definition --
20011 --------------------------
20013 function In_Access_Definition
(N
: Node_Id
) return Boolean is
20018 while Present
(P
) loop
20019 if Nkind
(P
) = N_Access_Definition
then
20027 end In_Access_Definition
;
20029 -- Start of processing for Is_Protected_Self_Reference
20032 -- Verify that prefix is analyzed and has the proper form. Note that
20033 -- the attributes Elab_Spec, Elab_Body, and Elab_Subp_Body, which also
20034 -- produce the address of an entity, do not analyze their prefix
20035 -- because they denote entities that are not necessarily visible.
20036 -- Neither of them can apply to a protected type.
20038 return Ada_Version
>= Ada_2005
20039 and then Is_Entity_Name
(N
)
20040 and then Present
(Entity
(N
))
20041 and then Is_Protected_Type
(Entity
(N
))
20042 and then In_Open_Scopes
(Entity
(N
))
20043 and then not In_Access_Definition
(N
);
20044 end Is_Protected_Self_Reference
;
20046 -----------------------------
20047 -- Is_RCI_Pkg_Spec_Or_Body --
20048 -----------------------------
20050 function Is_RCI_Pkg_Spec_Or_Body
(Cunit
: Node_Id
) return Boolean is
20052 function Is_RCI_Pkg_Decl_Cunit
(Cunit
: Node_Id
) return Boolean;
20053 -- Return True if the unit of Cunit is an RCI package declaration
20055 ---------------------------
20056 -- Is_RCI_Pkg_Decl_Cunit --
20057 ---------------------------
20059 function Is_RCI_Pkg_Decl_Cunit
(Cunit
: Node_Id
) return Boolean is
20060 The_Unit
: constant Node_Id
:= Unit
(Cunit
);
20063 if Nkind
(The_Unit
) /= N_Package_Declaration
then
20067 return Is_Remote_Call_Interface
(Defining_Entity
(The_Unit
));
20068 end Is_RCI_Pkg_Decl_Cunit
;
20070 -- Start of processing for Is_RCI_Pkg_Spec_Or_Body
20073 return Is_RCI_Pkg_Decl_Cunit
(Cunit
)
20075 (Nkind
(Unit
(Cunit
)) = N_Package_Body
20076 and then Is_RCI_Pkg_Decl_Cunit
(Library_Unit
(Cunit
)));
20077 end Is_RCI_Pkg_Spec_Or_Body
;
20079 -----------------------------------------
20080 -- Is_Remote_Access_To_Class_Wide_Type --
20081 -----------------------------------------
20083 function Is_Remote_Access_To_Class_Wide_Type
20084 (E
: Entity_Id
) return Boolean
20087 -- A remote access to class-wide type is a general access to object type
20088 -- declared in the visible part of a Remote_Types or Remote_Call_
20091 return Ekind
(E
) = E_General_Access_Type
20092 and then (Is_Remote_Call_Interface
(E
) or else Is_Remote_Types
(E
));
20093 end Is_Remote_Access_To_Class_Wide_Type
;
20095 -----------------------------------------
20096 -- Is_Remote_Access_To_Subprogram_Type --
20097 -----------------------------------------
20099 function Is_Remote_Access_To_Subprogram_Type
20100 (E
: Entity_Id
) return Boolean
20103 return (Ekind
(E
) = E_Access_Subprogram_Type
20104 or else (Ekind
(E
) = E_Record_Type
20105 and then Present
(Corresponding_Remote_Type
(E
))))
20106 and then (Is_Remote_Call_Interface
(E
) or else Is_Remote_Types
(E
));
20107 end Is_Remote_Access_To_Subprogram_Type
;
20109 --------------------
20110 -- Is_Remote_Call --
20111 --------------------
20113 function Is_Remote_Call
(N
: Node_Id
) return Boolean is
20115 if Nkind
(N
) not in N_Subprogram_Call
then
20117 -- An entry call cannot be remote
20121 elsif Nkind
(Name
(N
)) in N_Has_Entity
20122 and then Is_Remote_Call_Interface
(Entity
(Name
(N
)))
20124 -- A subprogram declared in the spec of a RCI package is remote
20128 elsif Nkind
(Name
(N
)) = N_Explicit_Dereference
20129 and then Is_Remote_Access_To_Subprogram_Type
20130 (Etype
(Prefix
(Name
(N
))))
20132 -- The dereference of a RAS is a remote call
20136 elsif Present
(Controlling_Argument
(N
))
20137 and then Is_Remote_Access_To_Class_Wide_Type
20138 (Etype
(Controlling_Argument
(N
)))
20140 -- Any primitive operation call with a controlling argument of
20141 -- a RACW type is a remote call.
20146 -- All other calls are local calls
20149 end Is_Remote_Call
;
20151 ----------------------
20152 -- Is_Renamed_Entry --
20153 ----------------------
20155 function Is_Renamed_Entry
(Proc_Nam
: Entity_Id
) return Boolean is
20156 Orig_Node
: Node_Id
:= Empty
;
20157 Subp_Decl
: Node_Id
:=
20158 (if No
(Parent
(Proc_Nam
)) then Empty
else Parent
(Parent
(Proc_Nam
)));
20160 function Is_Entry
(Nam
: Node_Id
) return Boolean;
20161 -- Determine whether Nam is an entry. Traverse selectors if there are
20162 -- nested selected components.
20168 function Is_Entry
(Nam
: Node_Id
) return Boolean is
20170 if Nkind
(Nam
) = N_Selected_Component
then
20171 return Is_Entry
(Selector_Name
(Nam
));
20174 return Ekind
(Entity
(Nam
)) = E_Entry
;
20177 -- Start of processing for Is_Renamed_Entry
20180 if Present
(Alias
(Proc_Nam
)) then
20181 Subp_Decl
:= Parent
(Parent
(Alias
(Proc_Nam
)));
20184 -- Look for a rewritten subprogram renaming declaration
20186 if Nkind
(Subp_Decl
) = N_Subprogram_Declaration
20187 and then Present
(Original_Node
(Subp_Decl
))
20189 Orig_Node
:= Original_Node
(Subp_Decl
);
20192 -- The rewritten subprogram is actually an entry
20194 if Present
(Orig_Node
)
20195 and then Nkind
(Orig_Node
) = N_Subprogram_Renaming_Declaration
20196 and then Is_Entry
(Name
(Orig_Node
))
20202 end Is_Renamed_Entry
;
20204 ----------------------------
20205 -- Is_Reversible_Iterator --
20206 ----------------------------
20208 function Is_Reversible_Iterator
(Typ
: Entity_Id
) return Boolean is
20209 Ifaces_List
: Elist_Id
;
20210 Iface_Elmt
: Elmt_Id
;
20214 if Is_Class_Wide_Type
(Typ
)
20215 and then Chars
(Root_Type
(Typ
)) = Name_Reversible_Iterator
20216 and then In_Predefined_Unit
(Root_Type
(Typ
))
20220 elsif not Is_Tagged_Type
(Typ
) or else not Is_Derived_Type
(Typ
) then
20224 Collect_Interfaces
(Typ
, Ifaces_List
);
20226 Iface_Elmt
:= First_Elmt
(Ifaces_List
);
20227 while Present
(Iface_Elmt
) loop
20228 Iface
:= Node
(Iface_Elmt
);
20229 if Chars
(Iface
) = Name_Reversible_Iterator
20230 and then In_Predefined_Unit
(Iface
)
20235 Next_Elmt
(Iface_Elmt
);
20240 end Is_Reversible_Iterator
;
20242 ---------------------------------
20243 -- Is_Single_Concurrent_Object --
20244 ---------------------------------
20246 function Is_Single_Concurrent_Object
(Id
: Entity_Id
) return Boolean is
20249 Is_Single_Protected_Object
(Id
) or else Is_Single_Task_Object
(Id
);
20250 end Is_Single_Concurrent_Object
;
20252 -------------------------------
20253 -- Is_Single_Concurrent_Type --
20254 -------------------------------
20256 function Is_Single_Concurrent_Type
(Id
: Entity_Id
) return Boolean is
20259 Ekind
(Id
) in E_Protected_Type | E_Task_Type
20260 and then Is_Single_Concurrent_Type_Declaration
20261 (Declaration_Node
(Id
));
20262 end Is_Single_Concurrent_Type
;
20264 -------------------------------------------
20265 -- Is_Single_Concurrent_Type_Declaration --
20266 -------------------------------------------
20268 function Is_Single_Concurrent_Type_Declaration
20269 (N
: Node_Id
) return Boolean
20272 return Nkind
(Original_Node
(N
)) in
20273 N_Single_Protected_Declaration | N_Single_Task_Declaration
;
20274 end Is_Single_Concurrent_Type_Declaration
;
20276 ---------------------------------------------
20277 -- Is_Single_Precision_Floating_Point_Type --
20278 ---------------------------------------------
20280 function Is_Single_Precision_Floating_Point_Type
20281 (E
: Entity_Id
) return Boolean is
20283 return Is_Floating_Point_Type
(E
)
20284 and then Machine_Radix_Value
(E
) = Uint_2
20285 and then Machine_Mantissa_Value
(E
) = Uint_24
20286 and then Machine_Emax_Value
(E
) = Uint_2
** Uint_7
20287 and then Machine_Emin_Value
(E
) = Uint_3
- (Uint_2
** Uint_7
);
20288 end Is_Single_Precision_Floating_Point_Type
;
20290 --------------------------------
20291 -- Is_Single_Protected_Object --
20292 --------------------------------
20294 function Is_Single_Protected_Object
(Id
: Entity_Id
) return Boolean is
20297 Ekind
(Id
) = E_Variable
20298 and then Ekind
(Etype
(Id
)) = E_Protected_Type
20299 and then Is_Single_Concurrent_Type
(Etype
(Id
));
20300 end Is_Single_Protected_Object
;
20302 ---------------------------
20303 -- Is_Single_Task_Object --
20304 ---------------------------
20306 function Is_Single_Task_Object
(Id
: Entity_Id
) return Boolean is
20309 Ekind
(Id
) = E_Variable
20310 and then Ekind
(Etype
(Id
)) = E_Task_Type
20311 and then Is_Single_Concurrent_Type
(Etype
(Id
));
20312 end Is_Single_Task_Object
;
20314 -----------------------------
20315 -- Is_Specific_Tagged_Type --
20316 -----------------------------
20318 function Is_Specific_Tagged_Type
(Typ
: Entity_Id
) return Boolean is
20319 Full_Typ
: Entity_Id
;
20322 -- Handle private types
20324 if Is_Private_Type
(Typ
) and then Present
(Full_View
(Typ
)) then
20325 Full_Typ
:= Full_View
(Typ
);
20330 -- A specific tagged type is a non-class-wide tagged type
20332 return Is_Tagged_Type
(Full_Typ
) and not Is_Class_Wide_Type
(Full_Typ
);
20333 end Is_Specific_Tagged_Type
;
20339 function Is_Statement
(N
: Node_Id
) return Boolean is
20342 Nkind
(N
) in N_Statement_Other_Than_Procedure_Call
20343 or else Nkind
(N
) = N_Procedure_Call_Statement
;
20346 --------------------------------------
20347 -- Is_Static_Discriminant_Component --
20348 --------------------------------------
20350 function Is_Static_Discriminant_Component
(N
: Node_Id
) return Boolean is
20352 return Nkind
(N
) = N_Selected_Component
20353 and then not Is_In_Discriminant_Check
(N
)
20354 and then Present
(Etype
(Prefix
(N
)))
20355 and then Ekind
(Etype
(Prefix
(N
))) = E_Record_Subtype
20356 and then Has_Static_Discriminants
(Etype
(Prefix
(N
)))
20357 and then Present
(Entity
(Selector_Name
(N
)))
20358 and then Ekind
(Entity
(Selector_Name
(N
))) = E_Discriminant
20359 and then not In_Check_Node
(N
);
20360 end Is_Static_Discriminant_Component
;
20362 ------------------------
20363 -- Is_Static_Function --
20364 ------------------------
20366 function Is_Static_Function
(Subp
: Entity_Id
) return Boolean is
20368 -- Always return False for pre Ada 2022 to e.g. ignore the Static
20369 -- aspect in package Interfaces for Ada_Version < 2022 and also
20372 return Ada_Version
>= Ada_2022
20373 and then Has_Aspect
(Subp
, Aspect_Static
)
20375 (No
(Find_Value_Of_Aspect
(Subp
, Aspect_Static
))
20376 or else Is_True
(Static_Boolean
20377 (Find_Value_Of_Aspect
(Subp
, Aspect_Static
))));
20378 end Is_Static_Function
;
20380 -----------------------------
20381 -- Is_Static_Function_Call --
20382 -----------------------------
20384 function Is_Static_Function_Call
(Call
: Node_Id
) return Boolean is
20385 function Has_All_Static_Actuals
(Call
: Node_Id
) return Boolean;
20386 -- Return whether all actual parameters of Call are static expressions
20388 ----------------------------
20389 -- Has_All_Static_Actuals --
20390 ----------------------------
20392 function Has_All_Static_Actuals
(Call
: Node_Id
) return Boolean is
20393 Actual
: Node_Id
:= First_Actual
(Call
);
20394 String_Result
: constant Boolean :=
20395 Is_String_Type
(Etype
(Entity
(Name
(Call
))));
20398 while Present
(Actual
) loop
20399 if not Is_Static_Expression
(Actual
) then
20401 -- ??? In the string-returning case we want to avoid a call
20402 -- being made to Establish_Transient_Scope in Resolve_Call,
20403 -- but at the point where that's tested for (which now includes
20404 -- a call to test Is_Static_Function_Call), the actuals of the
20405 -- call haven't been resolved, so expressions of the actuals
20406 -- may not have been marked Is_Static_Expression yet, so we
20407 -- force them to be resolved here, so we can tell if they're
20408 -- static. Calling Resolve here is admittedly a kludge, and we
20409 -- limit this call to string-returning cases.
20411 if String_Result
then
20415 -- Test flag again in case it's now True due to above Resolve
20417 if not Is_Static_Expression
(Actual
) then
20422 Next_Actual
(Actual
);
20426 end Has_All_Static_Actuals
;
20429 return Nkind
(Call
) = N_Function_Call
20430 and then Is_Entity_Name
(Name
(Call
))
20431 and then Is_Static_Function
(Entity
(Name
(Call
)))
20432 and then Has_All_Static_Actuals
(Call
);
20433 end Is_Static_Function_Call
;
20435 -------------------------------------------
20436 -- Is_Subcomponent_Of_Full_Access_Object --
20437 -------------------------------------------
20439 function Is_Subcomponent_Of_Full_Access_Object
(N
: Node_Id
) return Boolean
20444 R
:= Get_Referenced_Object
(N
);
20446 while Nkind
(R
) in N_Indexed_Component | N_Selected_Component | N_Slice
20448 R
:= Get_Referenced_Object
(Prefix
(R
));
20450 -- If the prefix is an access value, only the designated type matters
20452 if Is_Access_Type
(Etype
(R
)) then
20453 if Is_Full_Access
(Designated_Type
(Etype
(R
))) then
20458 if Is_Full_Access_Object
(R
) then
20465 end Is_Subcomponent_Of_Full_Access_Object
;
20467 ---------------------------------------
20468 -- Is_Subprogram_Contract_Annotation --
20469 ---------------------------------------
20471 function Is_Subprogram_Contract_Annotation
20472 (Item
: Node_Id
) return Boolean
20477 if Nkind
(Item
) = N_Aspect_Specification
then
20478 Nam
:= Chars
(Identifier
(Item
));
20480 else pragma Assert
(Nkind
(Item
) = N_Pragma
);
20481 Nam
:= Pragma_Name
(Item
);
20484 return Nam
= Name_Always_Terminates
20485 or else Nam
= Name_Contract_Cases
20486 or else Nam
= Name_Depends
20487 or else Nam
= Name_Exceptional_Cases
20488 or else Nam
= Name_Extensions_Visible
20489 or else Nam
= Name_Global
20490 or else Nam
= Name_Post
20491 or else Nam
= Name_Post_Class
20492 or else Nam
= Name_Postcondition
20493 or else Nam
= Name_Pre
20494 or else Nam
= Name_Pre_Class
20495 or else Nam
= Name_Precondition
20496 or else Nam
= Name_Refined_Depends
20497 or else Nam
= Name_Refined_Global
20498 or else Nam
= Name_Refined_Post
20499 or else Nam
= Name_Subprogram_Variant
20500 or else Nam
= Name_Test_Case
;
20501 end Is_Subprogram_Contract_Annotation
;
20503 --------------------------------------------------
20504 -- Is_Subprogram_Stub_Without_Prior_Declaration --
20505 --------------------------------------------------
20507 function Is_Subprogram_Stub_Without_Prior_Declaration
20508 (N
: Node_Id
) return Boolean
20511 pragma Assert
(Nkind
(N
) = N_Subprogram_Body_Stub
);
20513 case Ekind
(Defining_Entity
(N
)) is
20515 -- A subprogram stub without prior declaration serves as declaration
20516 -- for the actual subprogram body. As such, it has an attached
20517 -- defining entity of E_Function or E_Procedure.
20524 -- Otherwise, it is completes a [generic] subprogram declaration
20526 when E_Generic_Function
20527 | E_Generic_Procedure
20528 | E_Subprogram_Body
20533 raise Program_Error
;
20535 end Is_Subprogram_Stub_Without_Prior_Declaration
;
20537 ---------------------------
20538 -- Is_Suitable_Primitive --
20539 ---------------------------
20541 function Is_Suitable_Primitive
(Subp_Id
: Entity_Id
) return Boolean is
20543 -- The Default_Initial_Condition and invariant procedures must not be
20544 -- treated as primitive operations even when they apply to a tagged
20545 -- type. These routines must not act as targets of dispatching calls
20546 -- because they already utilize class-wide-precondition semantics to
20547 -- handle inheritance and overriding.
20549 if Ekind
(Subp_Id
) = E_Procedure
20550 and then (Is_DIC_Procedure
(Subp_Id
)
20552 Is_Invariant_Procedure
(Subp_Id
))
20558 end Is_Suitable_Primitive
;
20560 ----------------------------
20561 -- Is_Synchronized_Object --
20562 ----------------------------
20564 function Is_Synchronized_Object
(Id
: Entity_Id
) return Boolean is
20568 if Is_Object
(Id
) then
20570 -- The object is synchronized if it is of a type that yields a
20571 -- synchronized object.
20573 if Yields_Synchronized_Object
(Etype
(Id
)) then
20576 -- The object is synchronized if it is atomic and Async_Writers is
20579 elsif Is_Atomic_Object_Entity
(Id
)
20580 and then Async_Writers_Enabled
(Id
)
20584 -- A constant is a synchronized object by default, unless its type is
20585 -- access-to-variable type.
20587 elsif Ekind
(Id
) = E_Constant
20588 and then not Is_Access_Variable
(Etype
(Id
))
20592 -- A variable is a synchronized object if it is subject to pragma
20593 -- Constant_After_Elaboration.
20595 elsif Ekind
(Id
) = E_Variable
then
20596 Prag
:= Get_Pragma
(Id
, Pragma_Constant_After_Elaboration
);
20598 return Present
(Prag
) and then Is_Enabled_Pragma
(Prag
);
20602 -- Otherwise the input is not an object or it does not qualify as a
20603 -- synchronized object.
20606 end Is_Synchronized_Object
;
20608 ---------------------------------
20609 -- Is_Synchronized_Tagged_Type --
20610 ---------------------------------
20612 function Is_Synchronized_Tagged_Type
(E
: Entity_Id
) return Boolean is
20613 Kind
: constant Entity_Kind
:= Ekind
(Base_Type
(E
));
20616 -- A task or protected type derived from an interface is a tagged type.
20617 -- Such a tagged type is called a synchronized tagged type, as are
20618 -- synchronized interfaces and private extensions whose declaration
20619 -- includes the reserved word synchronized.
20621 return (Is_Tagged_Type
(E
)
20622 and then (Kind
= E_Task_Type
20624 Kind
= E_Protected_Type
))
20627 and then Is_Synchronized_Interface
(E
))
20629 (Ekind
(E
) = E_Record_Type_With_Private
20630 and then Nkind
(Parent
(E
)) = N_Private_Extension_Declaration
20631 and then (Synchronized_Present
(Parent
(E
))
20632 or else Is_Synchronized_Interface
(Etype
(E
))));
20633 end Is_Synchronized_Tagged_Type
;
20639 function Is_Transfer
(N
: Node_Id
) return Boolean is
20640 Kind
: constant Node_Kind
:= Nkind
(N
);
20643 if Kind
in N_Simple_Return_Statement
20644 | N_Extended_Return_Statement
20646 | N_Raise_Statement
20647 | N_Requeue_Statement
20651 elsif Kind
in N_Exit_Statement | N_Raise_xxx_Error
20652 and then No
(Condition
(N
))
20656 elsif Kind
= N_Procedure_Call_Statement
20657 and then Is_Entity_Name
(Name
(N
))
20658 and then Present
(Entity
(Name
(N
)))
20659 and then No_Return
(Entity
(Name
(N
)))
20663 elsif Nkind
(Original_Node
(N
)) = N_Raise_Statement
then
20675 function Is_True
(U
: Opt_Ubool
) return Boolean is
20677 return No
(U
) or else U
= Uint_1
;
20680 ------------------------
20681 -- Is_Trivial_Boolean --
20682 ------------------------
20684 function Is_Trivial_Boolean
(N
: Node_Id
) return Boolean is
20686 return Comes_From_Source
(N
)
20687 and then Nkind
(N
) in N_Identifier | N_Expanded_Name
20688 and then Entity
(N
) in Standard_True | Standard_False
;
20689 end Is_Trivial_Boolean
;
20691 --------------------------------------
20692 -- Is_Unchecked_Conversion_Instance --
20693 --------------------------------------
20695 function Is_Unchecked_Conversion_Instance
(Id
: Entity_Id
) return Boolean is
20699 -- Look for a function whose generic parent is the predefined intrinsic
20700 -- function Unchecked_Conversion, or for one that renames such an
20703 if Ekind
(Id
) = E_Function
then
20704 Par
:= Parent
(Id
);
20706 if Nkind
(Par
) = N_Function_Specification
then
20707 Par
:= Generic_Parent
(Par
);
20709 if Present
(Par
) then
20711 Chars
(Par
) = Name_Unchecked_Conversion
20712 and then Is_Intrinsic_Subprogram
(Par
)
20713 and then In_Predefined_Unit
(Par
);
20716 Present
(Alias
(Id
))
20717 and then Is_Unchecked_Conversion_Instance
(Alias
(Id
));
20723 end Is_Unchecked_Conversion_Instance
;
20725 -------------------------------
20726 -- Is_Universal_Numeric_Type --
20727 -------------------------------
20729 function Is_Universal_Numeric_Type
(T
: Entity_Id
) return Boolean is
20731 return T
= Universal_Integer
or else T
= Universal_Real
;
20732 end Is_Universal_Numeric_Type
;
20734 ------------------------------
20735 -- Is_User_Defined_Equality --
20736 ------------------------------
20738 function Is_User_Defined_Equality
(Id
: Entity_Id
) return Boolean is
20739 F1
, F2
: Entity_Id
;
20742 -- An equality operator is a function that carries the name "=", returns
20743 -- Boolean, and has exactly two formal parameters of an identical type.
20745 if Ekind
(Id
) = E_Function
20746 and then Chars
(Id
) = Name_Op_Eq
20747 and then Base_Type
(Etype
(Id
)) = Standard_Boolean
20749 F1
:= First_Formal
(Id
);
20755 F2
:= Next_Formal
(F1
);
20757 return Present
(F2
)
20758 and then No
(Next_Formal
(F2
))
20759 and then Base_Type
(Etype
(F1
)) = Base_Type
(Etype
(F2
));
20764 end Is_User_Defined_Equality
;
20766 -----------------------------
20767 -- Is_User_Defined_Literal --
20768 -----------------------------
20770 function Is_User_Defined_Literal
20772 Typ
: Entity_Id
) return Boolean
20774 Literal_Aspect_Map
:
20775 constant array (N_Numeric_Or_String_Literal
) of Aspect_Id
:=
20776 (N_Integer_Literal
=> Aspect_Integer_Literal
,
20777 N_Interpolated_String_Literal
=> No_Aspect
,
20778 N_Real_Literal
=> Aspect_Real_Literal
,
20779 N_String_Literal
=> Aspect_String_Literal
);
20782 -- Return True when N is either a literal or a named number and the
20783 -- type has the appropriate user-defined literal aspect.
20785 return (Nkind
(N
) in N_Numeric_Or_String_Literal
20786 and then Has_Aspect
(Typ
, Literal_Aspect_Map
(Nkind
(N
))))
20788 (Is_Entity_Name
(N
)
20789 and then Present
(Entity
(N
))
20791 ((Ekind
(Entity
(N
)) = E_Named_Integer
20792 and then Has_Aspect
(Typ
, Aspect_Integer_Literal
))
20794 (Ekind
(Entity
(N
)) = E_Named_Real
20795 and then Has_Aspect
(Typ
, Aspect_Real_Literal
))));
20796 end Is_User_Defined_Literal
;
20798 --------------------------------------
20799 -- Is_Validation_Variable_Reference --
20800 --------------------------------------
20802 function Is_Validation_Variable_Reference
(N
: Node_Id
) return Boolean is
20803 Var
: constant Node_Id
:= Unqual_Conv
(N
);
20804 Var_Id
: Entity_Id
;
20809 if Is_Entity_Name
(Var
) then
20810 Var_Id
:= Entity
(Var
);
20815 and then Ekind
(Var_Id
) = E_Variable
20816 and then Present
(Validated_Object
(Var_Id
));
20817 end Is_Validation_Variable_Reference
;
20819 ----------------------------
20820 -- Is_Variable_Size_Array --
20821 ----------------------------
20823 function Is_Variable_Size_Array
(E
: Entity_Id
) return Boolean is
20827 pragma Assert
(Is_Array_Type
(E
));
20829 -- Check if some index is initialized with a non-constant value
20831 Idx
:= First_Index
(E
);
20832 while Present
(Idx
) loop
20833 if Nkind
(Idx
) = N_Range
then
20834 if not Is_Constant_Bound
(Low_Bound
(Idx
))
20835 or else not Is_Constant_Bound
(High_Bound
(Idx
))
20845 end Is_Variable_Size_Array
;
20847 -----------------------------
20848 -- Is_Variable_Size_Record --
20849 -----------------------------
20851 function Is_Variable_Size_Record
(E
: Entity_Id
) return Boolean is
20853 Comp_Typ
: Entity_Id
;
20856 pragma Assert
(Is_Record_Type
(E
));
20858 Comp
:= First_Component
(E
);
20859 while Present
(Comp
) loop
20860 Comp_Typ
:= Underlying_Type
(Etype
(Comp
));
20862 -- Recursive call if the record type has discriminants
20864 if Is_Record_Type
(Comp_Typ
)
20865 and then Has_Discriminants
(Comp_Typ
)
20866 and then Is_Variable_Size_Record
(Comp_Typ
)
20870 elsif Is_Array_Type
(Comp_Typ
)
20871 and then Is_Variable_Size_Array
(Comp_Typ
)
20876 Next_Component
(Comp
);
20880 end Is_Variable_Size_Record
;
20886 -- Should Is_Variable be refactored to better handle dereferences and
20887 -- technical debt ???
20889 function Is_Variable
20891 Use_Original_Node
: Boolean := True) return Boolean
20893 Orig_Node
: Node_Id
;
20895 function In_Protected_Function
(E
: Entity_Id
) return Boolean;
20896 -- Within a protected function, the private components of the enclosing
20897 -- protected type are constants. A function nested within a (protected)
20898 -- procedure is not itself protected. Within the body of a protected
20899 -- function the current instance of the protected type is a constant.
20901 function Is_Variable_Prefix
(P
: Node_Id
) return Boolean;
20902 -- Prefixes can involve implicit dereferences, in which case we must
20903 -- test for the case of a reference of a constant access type, which can
20904 -- can never be a variable.
20906 ---------------------------
20907 -- In_Protected_Function --
20908 ---------------------------
20910 function In_Protected_Function
(E
: Entity_Id
) return Boolean is
20915 -- E is the current instance of a type
20917 if Is_Type
(E
) then
20926 if not Is_Protected_Type
(Prot
) then
20930 S
:= Current_Scope
;
20931 while Present
(S
) and then S
/= Prot
loop
20932 if Ekind
(S
) = E_Function
and then Scope
(S
) = Prot
then
20941 end In_Protected_Function
;
20943 ------------------------
20944 -- Is_Variable_Prefix --
20945 ------------------------
20947 function Is_Variable_Prefix
(P
: Node_Id
) return Boolean is
20949 if Is_Access_Type
(Etype
(P
)) then
20950 return not Is_Access_Constant
(Root_Type
(Etype
(P
)));
20952 -- For the case of an indexed component whose prefix has a packed
20953 -- array type, the prefix has been rewritten into a type conversion.
20954 -- Determine variable-ness from the converted expression.
20956 elsif Nkind
(P
) = N_Type_Conversion
20957 and then not Comes_From_Source
(P
)
20958 and then Is_Packed_Array
(Etype
(P
))
20960 return Is_Variable
(Expression
(P
));
20963 return Is_Variable
(P
);
20965 end Is_Variable_Prefix
;
20967 -- Start of processing for Is_Variable
20970 -- Special check, allow x'Deref(expr) as a variable
20972 if Nkind
(N
) = N_Attribute_Reference
20973 and then Attribute_Name
(N
) = Name_Deref
20978 -- Check if we perform the test on the original node since this may be a
20979 -- test of syntactic categories which must not be disturbed by whatever
20980 -- rewriting might have occurred. For example, an aggregate, which is
20981 -- certainly NOT a variable, could be turned into a variable by
20984 if Use_Original_Node
then
20985 Orig_Node
:= Original_Node
(N
);
20990 -- Definitely OK if Assignment_OK is set. Since this is something that
20991 -- only gets set for expanded nodes, the test is on N, not Orig_Node.
20993 if Nkind
(N
) in N_Subexpr
and then Assignment_OK
(N
) then
20996 -- Normally we go to the original node, but there is one exception where
20997 -- we use the rewritten node, namely when it is an explicit dereference.
20998 -- The generated code may rewrite a prefix which is an access type with
20999 -- an explicit dereference. The dereference is a variable, even though
21000 -- the original node may not be (since it could be a constant of the
21003 -- In Ada 2005 we have a further case to consider: the prefix may be a
21004 -- function call given in prefix notation. The original node appears to
21005 -- be a selected component, but we need to examine the call.
21007 elsif Nkind
(N
) = N_Explicit_Dereference
21008 and then Nkind
(Orig_Node
) /= N_Explicit_Dereference
21009 and then Present
(Etype
(Orig_Node
))
21010 and then Is_Access_Type
(Etype
(Orig_Node
))
21012 -- Note that if the prefix is an explicit dereference that does not
21013 -- come from source, we must check for a rewritten function call in
21014 -- prefixed notation before other forms of rewriting, to prevent a
21018 (Nkind
(Orig_Node
) = N_Function_Call
21019 and then not Is_Access_Constant
(Etype
(Prefix
(N
))))
21021 Is_Variable_Prefix
(Original_Node
(Prefix
(N
)));
21023 -- Generalized indexing operations are rewritten as explicit
21024 -- dereferences, and it is only during resolution that we can
21025 -- check whether the context requires an access_to_variable type.
21027 elsif Nkind
(N
) = N_Explicit_Dereference
21028 and then Present
(Etype
(Orig_Node
))
21029 and then Has_Implicit_Dereference
(Etype
(Orig_Node
))
21030 and then Ada_Version
>= Ada_2012
21032 return not Is_Access_Constant
(Etype
(Prefix
(N
)));
21034 -- A function call is never a variable
21036 elsif Nkind
(N
) = N_Function_Call
then
21039 -- All remaining checks use the original node
21041 elsif Is_Entity_Name
(Orig_Node
)
21042 and then Present
(Entity
(Orig_Node
))
21045 E
: constant Entity_Id
:= Entity
(Orig_Node
);
21046 K
: constant Entity_Kind
:= Ekind
(E
);
21049 if Is_Loop_Parameter
(E
) then
21053 return (K
= E_Variable
21054 and then Nkind
(Parent
(E
)) /= N_Exception_Handler
)
21055 or else (K
= E_Component
21056 and then not In_Protected_Function
(E
))
21057 or else (Present
(Etype
(E
))
21058 and then Is_Access_Variable
(Etype
(E
))
21059 and then Is_Dereferenced
(N
))
21060 or else K
= E_Out_Parameter
21061 or else K
= E_In_Out_Parameter
21062 or else K
= E_Generic_In_Out_Parameter
21064 -- Current instance of type. If this is a protected type, check
21065 -- we are not within the body of one of its protected functions.
21067 or else (Is_Type
(E
)
21068 and then In_Open_Scopes
(E
)
21069 and then not In_Protected_Function
(E
))
21071 or else (Is_Incomplete_Or_Private_Type
(E
)
21072 and then In_Open_Scopes
(Full_View
(E
)));
21076 case Nkind
(Orig_Node
) is
21077 when N_Indexed_Component
21080 return Is_Variable_Prefix
(Prefix
(Orig_Node
));
21082 when N_Selected_Component
=>
21083 return Is_Variable
(Selector_Name
(Orig_Node
))
21084 and then Is_Variable_Prefix
(Prefix
(Orig_Node
));
21086 -- For an explicit dereference, the type of the prefix cannot
21087 -- be an access to constant or an access to subprogram.
21089 when N_Explicit_Dereference
=>
21091 Typ
: constant Entity_Id
:= Etype
(Prefix
(Orig_Node
));
21093 return Is_Access_Type
(Typ
)
21094 and then not Is_Access_Constant
(Root_Type
(Typ
))
21095 and then Ekind
(Typ
) /= E_Access_Subprogram_Type
;
21098 -- The type conversion is the case where we do not deal with the
21099 -- context dependent special case of an actual parameter. Thus
21100 -- the type conversion is only considered a variable for the
21101 -- purposes of this routine if the target type is tagged. However,
21102 -- a type conversion is considered to be a variable if it does not
21103 -- come from source (this deals for example with the conversions
21104 -- of expressions to their actual subtypes).
21106 when N_Type_Conversion
=>
21107 return Is_Variable
(Expression
(Orig_Node
))
21109 (not Comes_From_Source
(Orig_Node
)
21111 (Is_Tagged_Type
(Etype
(Subtype_Mark
(Orig_Node
)))
21113 Is_Tagged_Type
(Etype
(Expression
(Orig_Node
)))));
21115 -- GNAT allows an unchecked type conversion as a variable. This
21116 -- only affects the generation of internal expanded code, since
21117 -- calls to instantiations of Unchecked_Conversion are never
21118 -- considered variables (since they are function calls).
21120 when N_Unchecked_Type_Conversion
=>
21121 return Is_Variable
(Expression
(Orig_Node
));
21129 ------------------------
21130 -- Is_View_Conversion --
21131 ------------------------
21133 function Is_View_Conversion
(N
: Node_Id
) return Boolean is
21135 if Nkind
(N
) = N_Type_Conversion
21136 and then Nkind
(Unqual_Conv
(N
)) in N_Has_Etype
21138 if Is_Tagged_Type
(Etype
(N
))
21139 and then Is_Tagged_Type
(Etype
(Unqual_Conv
(N
)))
21143 elsif Is_Actual_Parameter
(N
)
21144 and then (Is_Actual_Out_Parameter
(N
)
21145 or else Is_Actual_In_Out_Parameter
(N
))
21152 end Is_View_Conversion
;
21154 ---------------------------
21155 -- Is_Visibly_Controlled --
21156 ---------------------------
21158 function Is_Visibly_Controlled
(T
: Entity_Id
) return Boolean is
21159 Root
: constant Entity_Id
:= Root_Type
(T
);
21161 return Chars
(Scope
(Root
)) = Name_Finalization
21162 and then Chars
(Scope
(Scope
(Root
))) = Name_Ada
21163 and then Scope
(Scope
(Scope
(Root
))) = Standard_Standard
;
21164 end Is_Visibly_Controlled
;
21166 ----------------------------------------
21167 -- Is_Volatile_Full_Access_Object_Ref --
21168 ----------------------------------------
21170 function Is_Volatile_Full_Access_Object_Ref
(N
: Node_Id
) return Boolean is
21171 function Is_VFA_Object_Entity
(Id
: Entity_Id
) return Boolean;
21172 -- Determine whether arbitrary entity Id denotes an object that is
21173 -- Volatile_Full_Access.
21175 ----------------------------
21176 -- Is_VFA_Object_Entity --
21177 ----------------------------
21179 function Is_VFA_Object_Entity
(Id
: Entity_Id
) return Boolean is
21183 and then (Is_Volatile_Full_Access
(Id
)
21185 Is_Volatile_Full_Access
(Etype
(Id
)));
21186 end Is_VFA_Object_Entity
;
21188 -- Start of processing for Is_Volatile_Full_Access_Object_Ref
21191 if Is_Entity_Name
(N
) then
21192 return Is_VFA_Object_Entity
(Entity
(N
));
21194 elsif Is_Volatile_Full_Access
(Etype
(N
)) then
21197 elsif Nkind
(N
) = N_Selected_Component
then
21198 return Is_Volatile_Full_Access
(Entity
(Selector_Name
(N
)));
21203 end Is_Volatile_Full_Access_Object_Ref
;
21205 --------------------------
21206 -- Is_Volatile_Function --
21207 --------------------------
21209 function Is_Volatile_Function
(Func_Id
: Entity_Id
) return Boolean is
21211 pragma Assert
(Ekind
(Func_Id
) in E_Function | E_Generic_Function
);
21213 -- A protected function is volatile
21215 if Nkind
(Parent
(Unit_Declaration_Node
(Func_Id
))) =
21216 N_Protected_Definition
21220 -- An instance of Ada.Unchecked_Conversion is a volatile function if
21221 -- either the source or the target are effectively volatile.
21223 elsif Is_Unchecked_Conversion_Instance
(Func_Id
)
21224 and then Has_Effectively_Volatile_Profile
(Func_Id
)
21228 -- Otherwise the function is treated as volatile if it is subject to
21229 -- enabled pragma Volatile_Function.
21233 Is_Enabled_Pragma
(Get_Pragma
(Func_Id
, Pragma_Volatile_Function
));
21235 end Is_Volatile_Function
;
21237 ----------------------------
21238 -- Is_Volatile_Object_Ref --
21239 ----------------------------
21241 function Is_Volatile_Object_Ref
(N
: Node_Id
) return Boolean is
21242 function Is_Volatile_Object_Entity
(Id
: Entity_Id
) return Boolean;
21243 -- Determine whether arbitrary entity Id denotes an object that is
21246 function Prefix_Has_Volatile_Components
(P
: Node_Id
) return Boolean;
21247 -- Determine whether prefix P has volatile components. This requires
21248 -- the presence of a Volatile_Components aspect/pragma or that P be
21249 -- itself a volatile object as per RM C.6(8).
21251 ---------------------------------
21252 -- Is_Volatile_Object_Entity --
21253 ---------------------------------
21255 function Is_Volatile_Object_Entity
(Id
: Entity_Id
) return Boolean is
21259 and then (Is_Volatile
(Id
) or else Is_Volatile
(Etype
(Id
)));
21260 end Is_Volatile_Object_Entity
;
21262 ------------------------------------
21263 -- Prefix_Has_Volatile_Components --
21264 ------------------------------------
21266 function Prefix_Has_Volatile_Components
(P
: Node_Id
) return Boolean is
21267 Typ
: constant Entity_Id
:= Etype
(P
);
21270 if Is_Access_Type
(Typ
) then
21272 Dtyp
: constant Entity_Id
:= Designated_Type
(Typ
);
21275 return Has_Volatile_Components
(Dtyp
)
21276 or else Is_Volatile
(Dtyp
);
21279 elsif Has_Volatile_Components
(Typ
) then
21282 elsif Is_Entity_Name
(P
)
21283 and then Has_Volatile_Component
(Entity
(P
))
21287 elsif Is_Volatile_Object_Ref
(P
) then
21293 end Prefix_Has_Volatile_Components
;
21295 -- Start of processing for Is_Volatile_Object_Ref
21298 if Is_Entity_Name
(N
) then
21299 return Is_Volatile_Object_Entity
(Entity
(N
));
21301 elsif Is_Volatile
(Etype
(N
)) then
21304 elsif Nkind
(N
) = N_Indexed_Component
then
21305 return Prefix_Has_Volatile_Components
(Prefix
(N
));
21307 elsif Nkind
(N
) = N_Selected_Component
then
21308 return Prefix_Has_Volatile_Components
(Prefix
(N
))
21309 or else Is_Volatile
(Entity
(Selector_Name
(N
)));
21314 end Is_Volatile_Object_Ref
;
21316 -----------------------------
21317 -- Iterate_Call_Parameters --
21318 -----------------------------
21320 procedure Iterate_Call_Parameters
(Call
: Node_Id
) is
21321 Actual
: Node_Id
:= First_Actual
(Call
);
21322 Formal
: Entity_Id
:= First_Formal
(Get_Called_Entity
(Call
));
21325 while Present
(Formal
) and then Present
(Actual
) loop
21326 Handle_Parameter
(Formal
, Actual
);
21328 Next_Formal
(Formal
);
21329 Next_Actual
(Actual
);
21332 pragma Assert
(No
(Formal
));
21333 pragma Assert
(No
(Actual
));
21334 end Iterate_Call_Parameters
;
21336 --------------------------------
21337 -- Iterate_Interface_Ancestor --
21338 --------------------------------
21340 function Iterator_Interface_Ancestor
(Typ
: Entity_Id
) return Entity_Id
is
21342 if Has_Interfaces
(Typ
) then
21344 Iface_Elmt
: Elmt_Id
;
21346 Root_Iface
: Entity_Id
;
21349 Collect_Interfaces
(Typ
, Ifaces
);
21351 Iface_Elmt
:= First_Elmt
(Ifaces
);
21352 while Present
(Iface_Elmt
) loop
21353 Root_Iface
:= Root_Type
(Node
(Iface_Elmt
));
21355 if Chars
(Root_Iface
)
21356 in Name_Forward_Iterator | Name_Reversible_Iterator
21357 and then In_Predefined_Unit
(Root_Iface
)
21362 Next_Elmt
(Iface_Elmt
);
21368 end Iterator_Interface_Ancestor
;
21370 -------------------------
21371 -- Kill_Current_Values --
21372 -------------------------
21374 procedure Kill_Current_Values
21376 Last_Assignment_Only
: Boolean := False)
21379 if Is_Assignable
(Ent
) then
21380 Set_Last_Assignment
(Ent
, Empty
);
21383 if Is_Object
(Ent
) then
21384 if not Last_Assignment_Only
then
21386 Set_Current_Value
(Ent
, Empty
);
21388 -- Do not reset the Is_Known_[Non_]Null and Is_Known_Valid flags
21389 -- for a constant. Once the constant is elaborated, its value is
21390 -- not changed, therefore the associated flags that describe the
21391 -- value should not be modified either.
21393 if Ekind
(Ent
) = E_Constant
then
21396 -- Non-constant entities
21399 if not Can_Never_Be_Null
(Ent
) then
21400 Set_Is_Known_Non_Null
(Ent
, False);
21403 Set_Is_Known_Null
(Ent
, False);
21405 -- Reset the Is_Known_Valid flag unless the type is always
21406 -- valid. This does not apply to a loop parameter because its
21407 -- bounds are defined by the loop header and therefore always
21410 if not Is_Known_Valid
(Etype
(Ent
))
21411 and then Ekind
(Ent
) /= E_Loop_Parameter
21413 Set_Is_Known_Valid
(Ent
, False);
21418 end Kill_Current_Values
;
21420 procedure Kill_Current_Values
(Last_Assignment_Only
: Boolean := False) is
21424 -- Kill all saved checks, a special case of killing saved values
21426 if not Last_Assignment_Only
then
21430 -- Loop through relevant scopes, which includes the current scope and
21431 -- any parent scopes if the current scope is a block or a package.
21433 S
:= Current_Scope
;
21436 -- Clear current values of all entities in current scope
21441 Ent
:= First_Entity
(S
);
21442 while Present
(Ent
) loop
21443 Kill_Current_Values
(Ent
, Last_Assignment_Only
);
21448 -- If this is a not a subprogram, deal with parents
21450 if not Is_Subprogram
(S
) then
21452 exit Scope_Loop
when S
= Standard_Standard
;
21456 end loop Scope_Loop
;
21457 end Kill_Current_Values
;
21459 --------------------------
21460 -- Kill_Size_Check_Code --
21461 --------------------------
21463 procedure Kill_Size_Check_Code
(E
: Entity_Id
) is
21465 if (Ekind
(E
) = E_Constant
or else Ekind
(E
) = E_Variable
)
21466 and then Present
(Size_Check_Code
(E
))
21468 Remove
(Size_Check_Code
(E
));
21469 Set_Size_Check_Code
(E
, Empty
);
21471 end Kill_Size_Check_Code
;
21473 --------------------
21474 -- Known_Non_Null --
21475 --------------------
21477 function Known_Non_Null
(N
: Node_Id
) return Boolean is
21478 Status
: constant Null_Status_Kind
:= Null_Status
(N
);
21485 -- The expression yields a non-null value ignoring simple flow analysis
21487 if Status
= Is_Non_Null
then
21490 -- Otherwise check whether N is a reference to an entity that appears
21491 -- within a conditional construct.
21493 elsif Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
21495 -- First check if we are in decisive conditional
21497 Get_Current_Value_Condition
(N
, Op
, Val
);
21499 if Known_Null
(Val
) then
21500 if Op
= N_Op_Eq
then
21502 elsif Op
= N_Op_Ne
then
21507 -- If OK to do replacement, test Is_Known_Non_Null flag
21511 if OK_To_Do_Constant_Replacement
(Id
) then
21512 return Is_Known_Non_Null
(Id
);
21516 -- Otherwise it is not possible to determine whether N yields a non-null
21520 end Known_Non_Null
;
21526 function Known_Null
(N
: Node_Id
) return Boolean is
21527 Status
: constant Null_Status_Kind
:= Null_Status
(N
);
21534 -- The expression yields a null value ignoring simple flow analysis
21536 if Status
= Is_Null
then
21539 -- Otherwise check whether N is a reference to an entity that appears
21540 -- within a conditional construct.
21542 elsif Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
21544 -- First check if we are in decisive conditional
21546 Get_Current_Value_Condition
(N
, Op
, Val
);
21548 -- If Get_Current_Value_Condition were to return Val = N, then the
21549 -- recursion below could be infinite.
21552 raise Program_Error
;
21555 if Known_Null
(Val
) then
21556 if Op
= N_Op_Eq
then
21558 elsif Op
= N_Op_Ne
then
21563 -- If OK to do replacement, test Is_Known_Null flag
21567 if OK_To_Do_Constant_Replacement
(Id
) then
21568 return Is_Known_Null
(Id
);
21572 -- Otherwise it is not possible to determine whether N yields a null
21578 ---------------------------
21579 -- Last_Source_Statement --
21580 ---------------------------
21582 function Last_Source_Statement
(HSS
: Node_Id
) return Node_Id
is
21586 N
:= Last
(Statements
(HSS
));
21587 while Present
(N
) loop
21588 exit when Comes_From_Source
(N
);
21593 end Last_Source_Statement
;
21595 -----------------------
21596 -- Mark_Coextensions --
21597 -----------------------
21599 procedure Mark_Coextensions
(Context_Nod
: Node_Id
; Root_Nod
: Node_Id
) is
21600 Is_Dynamic
: Boolean;
21601 -- Indicates whether the context causes nested coextensions to be
21602 -- dynamic or static
21604 function Mark_Allocator
(N
: Node_Id
) return Traverse_Result
;
21605 -- Recognize an allocator node and label it as a dynamic coextension
21607 --------------------
21608 -- Mark_Allocator --
21609 --------------------
21611 function Mark_Allocator
(N
: Node_Id
) return Traverse_Result
is
21613 if Nkind
(N
) = N_Allocator
then
21615 Set_Is_Static_Coextension
(N
, False);
21616 Set_Is_Dynamic_Coextension
(N
);
21618 -- If the allocator expression is potentially dynamic, it may
21619 -- be expanded out of order and require dynamic allocation
21620 -- anyway, so we treat the coextension itself as dynamic.
21621 -- Potential optimization ???
21623 elsif Nkind
(Expression
(N
)) = N_Qualified_Expression
21624 and then Nkind
(Expression
(Expression
(N
))) = N_Op_Concat
21626 Set_Is_Static_Coextension
(N
, False);
21627 Set_Is_Dynamic_Coextension
(N
);
21629 Set_Is_Dynamic_Coextension
(N
, False);
21630 Set_Is_Static_Coextension
(N
);
21635 end Mark_Allocator
;
21637 procedure Mark_Allocators
is new Traverse_Proc
(Mark_Allocator
);
21639 -- Start of processing for Mark_Coextensions
21642 -- An allocator that appears on the right-hand side of an assignment is
21643 -- treated as a potentially dynamic coextension when the right-hand side
21644 -- is an allocator or a qualified expression.
21646 -- Obj := new ...'(new Coextension ...);
21648 if Nkind
(Context_Nod
) = N_Assignment_Statement
then
21649 Is_Dynamic
:= Nkind
(Expression
(Context_Nod
)) in
21650 N_Allocator | N_Qualified_Expression
;
21652 -- An allocator that appears within the expression of a simple return
21653 -- statement is treated as a potentially dynamic coextension when the
21654 -- expression is either aggregate, allocator, or qualified expression.
21656 -- return (new Coextension ...);
21657 -- return new ...'(new Coextension ...);
21659 elsif Nkind
(Context_Nod
) = N_Simple_Return_Statement
then
21660 Is_Dynamic
:= Nkind
(Expression
(Context_Nod
)) in
21661 N_Aggregate | N_Allocator | N_Qualified_Expression
;
21663 -- An alloctor that appears within the initialization expression of an
21664 -- object declaration is considered a potentially dynamic coextension
21665 -- when the initialization expression is an allocator or a qualified
21668 -- Obj : ... := new ...'(new Coextension ...);
21670 -- A similar case arises when the object declaration is part of an
21671 -- extended return statement.
21673 -- return Obj : ... := new ...'(new Coextension ...);
21674 -- return Obj : ... := (new Coextension ...);
21676 elsif Nkind
(Context_Nod
) = N_Object_Declaration
then
21677 Is_Dynamic
:= Nkind
(Root_Nod
) in N_Allocator | N_Qualified_Expression
21678 or else Nkind
(Parent
(Context_Nod
)) = N_Extended_Return_Statement
;
21680 -- This routine should not be called with constructs that cannot contain
21684 raise Program_Error
;
21687 Mark_Allocators
(Root_Nod
);
21688 end Mark_Coextensions
;
21690 ---------------------------------
21691 -- Mark_Elaboration_Attributes --
21692 ---------------------------------
21694 procedure Mark_Elaboration_Attributes
21695 (N_Id
: Node_Or_Entity_Id
;
21696 Checks
: Boolean := False;
21697 Level
: Boolean := False;
21698 Modes
: Boolean := False;
21699 Warnings
: Boolean := False)
21701 function Elaboration_Checks_OK
21702 (Target_Id
: Entity_Id
;
21703 Context_Id
: Entity_Id
) return Boolean;
21704 -- Determine whether elaboration checks are enabled for target Target_Id
21705 -- which resides within context Context_Id.
21707 procedure Mark_Elaboration_Attributes_Id
(Id
: Entity_Id
);
21708 -- Preserve relevant attributes of the context in arbitrary entity Id
21710 procedure Mark_Elaboration_Attributes_Node
(N
: Node_Id
);
21711 -- Preserve relevant attributes of the context in arbitrary node N
21713 ---------------------------
21714 -- Elaboration_Checks_OK --
21715 ---------------------------
21717 function Elaboration_Checks_OK
21718 (Target_Id
: Entity_Id
;
21719 Context_Id
: Entity_Id
) return Boolean
21721 Encl_Scop
: Entity_Id
;
21724 -- Elaboration checks are suppressed for the target
21726 if Elaboration_Checks_Suppressed
(Target_Id
) then
21730 -- Otherwise elaboration checks are OK for the target, but may be
21731 -- suppressed for the context where the target is declared.
21733 Encl_Scop
:= Context_Id
;
21734 while Present
(Encl_Scop
) and then Encl_Scop
/= Standard_Standard
loop
21735 if Elaboration_Checks_Suppressed
(Encl_Scop
) then
21739 Encl_Scop
:= Scope
(Encl_Scop
);
21742 -- Neither the target nor its declarative context have elaboration
21743 -- checks suppressed.
21746 end Elaboration_Checks_OK
;
21748 ------------------------------------
21749 -- Mark_Elaboration_Attributes_Id --
21750 ------------------------------------
21752 procedure Mark_Elaboration_Attributes_Id
(Id
: Entity_Id
) is
21754 -- Mark the status of elaboration checks in effect. Do not reset the
21755 -- status in case the entity is reanalyzed with checks suppressed.
21757 if Checks
and then not Is_Elaboration_Checks_OK_Id
(Id
) then
21758 Set_Is_Elaboration_Checks_OK_Id
(Id
,
21759 Elaboration_Checks_OK
21761 Context_Id
=> Scope
(Id
)));
21764 -- Mark the status of elaboration warnings in effect. Do not reset
21765 -- the status in case the entity is reanalyzed with warnings off.
21767 if Warnings
and then not Is_Elaboration_Warnings_OK_Id
(Id
) then
21768 Set_Is_Elaboration_Warnings_OK_Id
(Id
, Elab_Warnings
);
21770 end Mark_Elaboration_Attributes_Id
;
21772 --------------------------------------
21773 -- Mark_Elaboration_Attributes_Node --
21774 --------------------------------------
21776 procedure Mark_Elaboration_Attributes_Node
(N
: Node_Id
) is
21777 function Extract_Name
(N
: Node_Id
) return Node_Id
;
21778 -- Obtain the Name attribute of call or instantiation N
21784 function Extract_Name
(N
: Node_Id
) return Node_Id
is
21790 -- A call to an entry family appears in indexed form
21792 if Nkind
(Nam
) = N_Indexed_Component
then
21793 Nam
:= Prefix
(Nam
);
21796 -- The name may also appear in qualified form
21798 if Nkind
(Nam
) = N_Selected_Component
then
21799 Nam
:= Selector_Name
(Nam
);
21807 Context_Id
: Entity_Id
;
21810 -- Start of processing for Mark_Elaboration_Attributes_Node
21813 -- Mark the status of elaboration checks in effect. Do not reset the
21814 -- status in case the node is reanalyzed with checks suppressed.
21816 if Checks
and then not Is_Elaboration_Checks_OK_Node
(N
) then
21818 -- Assignments, attribute references, and variable references do
21819 -- not have a "declarative" context.
21821 Context_Id
:= Empty
;
21823 -- The status of elaboration checks for calls and instantiations
21824 -- depends on the most recent pragma Suppress/Unsuppress, as well
21825 -- as the suppression status of the context where the target is
21829 -- function Func ...;
21833 -- procedure Main is
21834 -- pragma Suppress (Elaboration_Checks, Pack);
21835 -- X : ... := Pack.Func;
21838 -- In the example above, the call to Func has elaboration checks
21839 -- enabled because there is no active general purpose suppression
21840 -- pragma, however the elaboration checks of Pack are explicitly
21841 -- suppressed. As a result the elaboration checks of the call must
21842 -- be disabled in order to preserve this dependency.
21844 if Nkind
(N
) in N_Entry_Call_Statement
21846 | N_Function_Instantiation
21847 | N_Package_Instantiation
21848 | N_Procedure_Call_Statement
21849 | N_Procedure_Instantiation
21851 Nam
:= Extract_Name
(N
);
21853 if Is_Entity_Name
(Nam
) and then Present
(Entity
(Nam
)) then
21854 Context_Id
:= Scope
(Entity
(Nam
));
21858 Set_Is_Elaboration_Checks_OK_Node
(N
,
21859 Elaboration_Checks_OK
21860 (Target_Id
=> Empty
,
21861 Context_Id
=> Context_Id
));
21864 -- Mark the enclosing level of the node. Do not reset the status in
21865 -- case the node is relocated and reanalyzed.
21867 if Level
and then not Is_Declaration_Level_Node
(N
) then
21868 Set_Is_Declaration_Level_Node
(N
,
21869 Find_Enclosing_Level
(N
) = Declaration_Level
);
21872 -- Mark the Ghost and SPARK mode in effect
21875 if Ghost_Mode
= Ignore
then
21876 Set_Is_Ignored_Ghost_Node
(N
);
21879 if SPARK_Mode
= On
then
21880 Set_Is_SPARK_Mode_On_Node
(N
);
21884 -- Mark the status of elaboration warnings in effect. Do not reset
21885 -- the status in case the node is reanalyzed with warnings off.
21887 if Warnings
and then not Is_Elaboration_Warnings_OK_Node
(N
) then
21888 Set_Is_Elaboration_Warnings_OK_Node
(N
, Elab_Warnings
);
21890 end Mark_Elaboration_Attributes_Node
;
21892 -- Start of processing for Mark_Elaboration_Attributes
21895 -- Do not capture any elaboration-related attributes when switch -gnatH
21896 -- (legacy elaboration checking mode enabled) is in effect because the
21897 -- attributes are useless to the legacy model.
21899 if Legacy_Elaboration_Checks
then
21903 if Nkind
(N_Id
) in N_Entity
then
21904 Mark_Elaboration_Attributes_Id
(N_Id
);
21906 Mark_Elaboration_Attributes_Node
(N_Id
);
21908 end Mark_Elaboration_Attributes
;
21910 ----------------------------------------
21911 -- Mark_Save_Invocation_Graph_Of_Body --
21912 ----------------------------------------
21914 procedure Mark_Save_Invocation_Graph_Of_Body
is
21915 Main
: constant Node_Id
:= Cunit
(Main_Unit
);
21916 Main_Unit
: constant Node_Id
:= Unit
(Main
);
21917 Aux_Id
: Entity_Id
;
21920 Set_Save_Invocation_Graph_Of_Body
(Main
);
21922 -- Assume that the main unit does not have a complimentary unit
21926 -- Obtain the complimentary unit of the main unit
21928 if Nkind
(Main_Unit
) in N_Generic_Package_Declaration
21929 | N_Generic_Subprogram_Declaration
21930 | N_Package_Declaration
21931 | N_Subprogram_Declaration
21933 Aux_Id
:= Corresponding_Body
(Main_Unit
);
21935 elsif Nkind
(Main_Unit
) in N_Package_Body
21936 | N_Subprogram_Body
21937 | N_Subprogram_Renaming_Declaration
21939 Aux_Id
:= Corresponding_Spec
(Main_Unit
);
21942 if Present
(Aux_Id
) then
21943 Set_Save_Invocation_Graph_Of_Body
21944 (Parent
(Unit_Declaration_Node
(Aux_Id
)));
21946 end Mark_Save_Invocation_Graph_Of_Body
;
21948 ----------------------------------
21949 -- Matching_Static_Array_Bounds --
21950 ----------------------------------
21952 function Matching_Static_Array_Bounds
21954 R_Typ
: Node_Id
) return Boolean
21956 L_Ndims
: constant Nat
:= Number_Dimensions
(L_Typ
);
21957 R_Ndims
: constant Nat
:= Number_Dimensions
(R_Typ
);
21959 L_Index
: Node_Id
:= Empty
; -- init to ...
21960 R_Index
: Node_Id
:= Empty
; -- ...avoid warnings
21969 if L_Ndims
/= R_Ndims
then
21973 -- Unconstrained types do not have static bounds
21975 if not Is_Constrained
(L_Typ
) or else not Is_Constrained
(R_Typ
) then
21979 -- First treat specially the first dimension, as the lower bound and
21980 -- length of string literals are not stored like those of arrays.
21982 if Ekind
(L_Typ
) = E_String_Literal_Subtype
then
21983 L_Low
:= String_Literal_Low_Bound
(L_Typ
);
21984 L_Len
:= String_Literal_Length
(L_Typ
);
21986 L_Index
:= First_Index
(L_Typ
);
21987 Get_Index_Bounds
(L_Index
, L_Low
, L_High
);
21989 if Is_OK_Static_Expression
(L_Low
)
21991 Is_OK_Static_Expression
(L_High
)
21993 if Expr_Value
(L_High
) < Expr_Value
(L_Low
) then
21996 L_Len
:= (Expr_Value
(L_High
) - Expr_Value
(L_Low
)) + 1;
22003 if Ekind
(R_Typ
) = E_String_Literal_Subtype
then
22004 R_Low
:= String_Literal_Low_Bound
(R_Typ
);
22005 R_Len
:= String_Literal_Length
(R_Typ
);
22007 R_Index
:= First_Index
(R_Typ
);
22008 Get_Index_Bounds
(R_Index
, R_Low
, R_High
);
22010 if Is_OK_Static_Expression
(R_Low
)
22012 Is_OK_Static_Expression
(R_High
)
22014 if Expr_Value
(R_High
) < Expr_Value
(R_Low
) then
22017 R_Len
:= (Expr_Value
(R_High
) - Expr_Value
(R_Low
)) + 1;
22024 if (Is_OK_Static_Expression
(L_Low
)
22026 Is_OK_Static_Expression
(R_Low
))
22027 and then Expr_Value
(L_Low
) = Expr_Value
(R_Low
)
22028 and then L_Len
= R_Len
22035 -- Then treat all other dimensions
22037 for Indx
in 2 .. L_Ndims
loop
22041 Get_Index_Bounds
(L_Index
, L_Low
, L_High
);
22042 Get_Index_Bounds
(R_Index
, R_Low
, R_High
);
22044 if (Is_OK_Static_Expression
(L_Low
) and then
22045 Is_OK_Static_Expression
(L_High
) and then
22046 Is_OK_Static_Expression
(R_Low
) and then
22047 Is_OK_Static_Expression
(R_High
))
22048 and then (Expr_Value
(L_Low
) = Expr_Value
(R_Low
)
22050 Expr_Value
(L_High
) = Expr_Value
(R_High
))
22058 -- If we fall through the loop, all indexes matched
22061 end Matching_Static_Array_Bounds
;
22067 function Might_Raise
(N
: Node_Id
) return Boolean is
22068 Result
: Boolean := False;
22070 function Process
(N
: Node_Id
) return Traverse_Result
;
22071 -- Set Result to True if we find something that could raise an exception
22077 function Process
(N
: Node_Id
) return Traverse_Result
is
22079 if Nkind
(N
) in N_Procedure_Call_Statement
22081 | N_Raise_Statement
22082 | N_Raise_xxx_Error
22083 | N_Raise_Expression
22092 procedure Set_Result
is new Traverse_Proc
(Process
);
22094 -- Start of processing for Might_Raise
22097 -- False if exceptions can't be propagated
22099 if No_Exception_Handlers_Set
then
22103 -- If the checks handled by the back end are not disabled, we cannot
22104 -- ensure that no exception will be raised.
22106 if not Access_Checks_Suppressed
(Empty
)
22107 or else not Discriminant_Checks_Suppressed
(Empty
)
22108 or else not Range_Checks_Suppressed
(Empty
)
22109 or else not Index_Checks_Suppressed
(Empty
)
22110 or else Opt
.Stack_Checking_Enabled
22119 ----------------------------------------
22120 -- Nearest_Class_Condition_Subprogram --
22121 ----------------------------------------
22123 function Nearest_Class_Condition_Subprogram
22124 (Kind
: Condition_Kind
;
22125 Spec_Id
: Entity_Id
) return Entity_Id
22127 Subp_Id
: constant Entity_Id
:= Ultimate_Alias
(Spec_Id
);
22130 -- Prevent cascaded errors
22132 if not Is_Dispatching_Operation
(Subp_Id
) then
22135 -- No need to search if this subprogram has class-wide postconditions
22137 elsif Present
(Class_Condition
(Kind
, Subp_Id
)) then
22141 -- Process the contracts of inherited subprograms, looking for
22142 -- class-wide pre/postconditions.
22145 Subps
: constant Subprogram_List
:= Inherited_Subprograms
(Subp_Id
);
22146 Subp_Id
: Entity_Id
;
22149 for Index
in Subps
'Range loop
22150 Subp_Id
:= Subps
(Index
);
22152 if Present
(Alias
(Subp_Id
)) then
22153 Subp_Id
:= Ultimate_Alias
(Subp_Id
);
22156 -- Wrappers of class-wide pre/postconditions reference the
22157 -- parent primitive that has the inherited contract.
22159 if Is_Wrapper
(Subp_Id
)
22160 and then Present
(LSP_Subprogram
(Subp_Id
))
22162 Subp_Id
:= LSP_Subprogram
(Subp_Id
);
22165 if Present
(Class_Condition
(Kind
, Subp_Id
)) then
22172 end Nearest_Class_Condition_Subprogram
;
22174 --------------------------------
22175 -- Nearest_Enclosing_Instance --
22176 --------------------------------
22178 function Nearest_Enclosing_Instance
(E
: Entity_Id
) return Entity_Id
is
22183 while Present
(Inst
) and then Inst
/= Standard_Standard
loop
22184 if Is_Generic_Instance
(Inst
) then
22188 Inst
:= Scope
(Inst
);
22192 end Nearest_Enclosing_Instance
;
22194 ------------------------
22195 -- Needs_Finalization --
22196 ------------------------
22198 function Needs_Finalization
(Typ
: Entity_Id
) return Boolean is
22199 function Has_Some_Controlled_Component
22200 (Input_Typ
: Entity_Id
) return Boolean;
22201 -- Determine whether type Input_Typ has at least one controlled
22204 -----------------------------------
22205 -- Has_Some_Controlled_Component --
22206 -----------------------------------
22208 function Has_Some_Controlled_Component
22209 (Input_Typ
: Entity_Id
) return Boolean
22214 -- When a type is already frozen and has at least one controlled
22215 -- component, or is manually decorated, it is sufficient to inspect
22216 -- flag Has_Controlled_Component.
22218 if Has_Controlled_Component
(Input_Typ
) then
22221 -- Otherwise inspect the internals of the type
22223 elsif not Is_Frozen
(Input_Typ
) then
22224 if Is_Array_Type
(Input_Typ
) then
22225 return Needs_Finalization
(Component_Type
(Input_Typ
));
22227 elsif Is_Record_Type
(Input_Typ
) then
22228 Comp
:= First_Component
(Input_Typ
);
22229 while Present
(Comp
) loop
22230 if Needs_Finalization
(Etype
(Comp
)) then
22234 Next_Component
(Comp
);
22240 end Has_Some_Controlled_Component
;
22242 -- Start of processing for Needs_Finalization
22245 -- Certain run-time configurations and targets do not provide support
22246 -- for controlled types.
22248 if Restriction_Active
(No_Finalization
) then
22251 -- C++ types are not considered controlled. It is assumed that the non-
22252 -- Ada side will handle their clean up.
22254 elsif Convention
(Typ
) = Convention_CPP
then
22257 -- Class-wide types are treated as controlled because derivations from
22258 -- the root type may introduce controlled components.
22260 elsif Is_Class_Wide_Type
(Typ
) then
22263 -- Concurrent types are controlled as long as their corresponding record
22266 elsif Is_Concurrent_Type
(Typ
)
22267 and then Present
(Corresponding_Record_Type
(Typ
))
22268 and then Needs_Finalization
(Corresponding_Record_Type
(Typ
))
22272 -- Otherwise the type is controlled when it is either derived from type
22273 -- [Limited_]Controlled and not subject to aspect Disable_Controlled, or
22274 -- contains at least one controlled component.
22278 Is_Controlled
(Typ
) or else Has_Some_Controlled_Component
(Typ
);
22280 end Needs_Finalization
;
22282 ----------------------
22283 -- Needs_One_Actual --
22284 ----------------------
22286 function Needs_One_Actual
(E
: Entity_Id
) return Boolean is
22287 Formal
: Entity_Id
;
22290 -- Ada 2005 or later, and formals present. The first formal must be
22291 -- of a type that supports prefix notation: a controlling argument,
22292 -- a class-wide type, or an access to such.
22294 if Ada_Version
>= Ada_2005
22295 and then Present
(First_Formal
(E
))
22296 and then No
(Default_Value
(First_Formal
(E
)))
22298 (Is_Controlling_Formal
(First_Formal
(E
))
22299 or else Is_Class_Wide_Type
(Etype
(First_Formal
(E
)))
22300 or else Is_Anonymous_Access_Type
(Etype
(First_Formal
(E
))))
22302 Formal
:= Next_Formal
(First_Formal
(E
));
22303 while Present
(Formal
) loop
22304 if No
(Default_Value
(Formal
)) then
22308 Next_Formal
(Formal
);
22313 -- Ada 83/95 or no formals
22318 end Needs_One_Actual
;
22320 ----------------------------
22321 -- Needs_Secondary_Stack --
22322 ----------------------------
22324 function Needs_Secondary_Stack
(Id
: Entity_Id
) return Boolean is
22325 pragma Assert
(if Present
(Id
) then Ekind
(Id
) in E_Void | Type_Kind
);
22327 function Caller_Known_Size_Record
(Typ
: Entity_Id
) return Boolean;
22328 -- Called for untagged record and protected types. Return True if the
22329 -- size of function results is known in the caller for Typ.
22331 function Large_Max_Size_Mutable
(Typ
: Entity_Id
) return Boolean;
22332 -- Returns True if Typ is a nonlimited record with defaulted
22333 -- discriminants whose max size makes it unsuitable for allocating on
22334 -- the primary stack.
22336 ------------------------------
22337 -- Caller_Known_Size_Record --
22338 ------------------------------
22340 function Caller_Known_Size_Record
(Typ
: Entity_Id
) return Boolean is
22341 pragma Assert
(if Present
(Typ
) then Typ
= Underlying_Type
(Typ
));
22343 function Depends_On_Discriminant
(Typ
: Entity_Id
) return Boolean;
22344 -- Called for untagged record and protected types. Return True if Typ
22345 -- depends on discriminants, either directly when it is unconstrained
22346 -- or indirectly when it is constrained by uplevel discriminants.
22348 -----------------------------
22349 -- Depends_On_Discriminant --
22350 -----------------------------
22352 function Depends_On_Discriminant
(Typ
: Entity_Id
) return Boolean is
22356 if Has_Discriminants
(Typ
) then
22357 if not Is_Constrained
(Typ
) then
22361 Cons
:= First_Elmt
(Discriminant_Constraint
(Typ
));
22362 while Present
(Cons
) loop
22363 if Nkind
(Node
(Cons
)) = N_Identifier
22364 and then Ekind
(Entity
(Node
(Cons
))) = E_Discriminant
22375 end Depends_On_Discriminant
;
22378 -- This is a protected type without Corresponding_Record_Type set,
22379 -- typically because expansion is disabled. The safe thing to do is
22380 -- to return True, so Needs_Secondary_Stack returns False.
22386 -- First see if we have a variant part and return False if it depends
22387 -- on discriminants.
22389 if Has_Variant_Part
(Typ
) and then Depends_On_Discriminant
(Typ
) then
22393 -- Then loop over components and return False if their subtype has a
22394 -- caller-unknown size, possibly recursively.
22396 -- ??? This is overly conservative, an array could be nested inside
22397 -- some other record that is constrained by nondiscriminants. That
22398 -- is, the recursive calls are too conservative.
22404 Comp
:= First_Component
(Typ
);
22405 while Present
(Comp
) loop
22407 Comp_Type
: constant Entity_Id
:=
22408 Underlying_Type
(Etype
(Comp
));
22411 if Is_Record_Type
(Comp_Type
) then
22412 if not Caller_Known_Size_Record
(Comp_Type
) then
22416 elsif Is_Protected_Type
(Comp_Type
) then
22417 if not Caller_Known_Size_Record
22418 (Corresponding_Record_Type
(Comp_Type
))
22423 elsif Is_Array_Type
(Comp_Type
) then
22424 if Size_Depends_On_Discriminant
(Comp_Type
) then
22430 Next_Component
(Comp
);
22435 end Caller_Known_Size_Record
;
22437 ------------------------------
22438 -- Large_Max_Size_Mutable --
22439 ------------------------------
22441 function Large_Max_Size_Mutable
(Typ
: Entity_Id
) return Boolean is
22442 pragma Assert
(Typ
= Underlying_Type
(Typ
));
22444 function Is_Large_Discrete_Type
(T
: Entity_Id
) return Boolean;
22445 -- Returns true if the discrete type T has a large range
22447 ----------------------------
22448 -- Is_Large_Discrete_Type --
22449 ----------------------------
22451 function Is_Large_Discrete_Type
(T
: Entity_Id
) return Boolean is
22452 Threshold
: constant Int
:= 16;
22453 -- Arbitrary threshold above which we consider it "large". We want
22454 -- a fairly large threshold, because these large types really
22455 -- shouldn't have default discriminants in the first place, in
22459 return UI_To_Int
(RM_Size
(T
)) > Threshold
;
22460 end Is_Large_Discrete_Type
;
22462 -- Start of processing for Large_Max_Size_Mutable
22465 if Is_Record_Type
(Typ
)
22466 and then not Is_Inherently_Limited_Type
(Typ
)
22467 and then Has_Defaulted_Discriminants
(Typ
)
22469 -- Loop through the components, looking for an array whose upper
22470 -- bound(s) depends on discriminants, where both the subtype of
22471 -- the discriminant and the index subtype are too large.
22477 Comp
:= First_Component
(Typ
);
22478 while Present
(Comp
) loop
22480 Comp_Type
: constant Entity_Id
:=
22481 Underlying_Type
(Etype
(Comp
));
22488 if Present
(Comp_Type
)
22489 and then Is_Array_Type
(Comp_Type
)
22491 Indx
:= First_Index
(Comp_Type
);
22493 while Present
(Indx
) loop
22494 Ityp
:= Etype
(Indx
);
22495 Hi
:= Type_High_Bound
(Ityp
);
22497 if Nkind
(Hi
) = N_Identifier
22498 and then Ekind
(Entity
(Hi
)) = E_Discriminant
22499 and then Is_Large_Discrete_Type
(Ityp
)
22500 and then Is_Large_Discrete_Type
22501 (Etype
(Entity
(Hi
)))
22511 Next_Component
(Comp
);
22517 end Large_Max_Size_Mutable
;
22519 -- Local declarations
22521 Typ
: constant Entity_Id
:= Underlying_Type
(Id
);
22523 -- Start of processing for Needs_Secondary_Stack
22526 -- This is a private type which is not completed yet. This can only
22527 -- happen in a default expression (of a formal parameter or of a
22528 -- record component). The safe thing to do is to return False.
22534 -- Do not expand transient scope for non-existent procedure return or
22535 -- string literal types.
22537 if Typ
= Standard_Void_Type
22538 or else Ekind
(Typ
) = E_String_Literal_Subtype
22542 -- If Typ is a generic formal incomplete type, then we want to look at
22543 -- the actual type.
22545 elsif Ekind
(Typ
) = E_Record_Subtype
22546 and then Present
(Cloned_Subtype
(Typ
))
22548 return Needs_Secondary_Stack
(Cloned_Subtype
(Typ
));
22550 -- Class-wide types obviously have an unknown size. For specific tagged
22551 -- types, if a call returning one of them is dispatching on result, and
22552 -- this type is not returned on the secondary stack, then the call goes
22553 -- through a thunk that only moves the result from the primary onto the
22554 -- secondary stack, because the computation of the size of the result is
22555 -- possible but complex from the outside.
22557 elsif Is_Class_Wide_Type
(Typ
) then
22560 -- If the return slot of the back end cannot be accessed, then there
22561 -- is no way to call Adjust at the right time for the return object if
22562 -- the type needs finalization, so the return object must be allocated
22563 -- on the secondary stack.
22565 elsif not Back_End_Return_Slot
and then Needs_Finalization
(Typ
) then
22568 -- Definite subtypes have a known size. This includes all elementary
22569 -- types. Tasks have a known size even if they have discriminants, so
22570 -- we return False here, with one exception:
22571 -- For a type like:
22572 -- type T (Last : Natural := 0) is
22573 -- X : String (1 .. Last);
22575 -- we return True. That's because for "P(F(...));", where F returns T,
22576 -- we don't know the size of the result at the call site, so if we
22577 -- allocated it on the primary stack, we would have to allocate the
22578 -- maximum size, which is way too big.
22580 elsif Is_Definite_Subtype
(Typ
) or else Is_Task_Type
(Typ
) then
22581 return Large_Max_Size_Mutable
(Typ
);
22583 -- Indefinite (discriminated) record type
22585 elsif Is_Record_Type
(Typ
) then
22586 return not Caller_Known_Size_Record
(Typ
);
22588 -- Indefinite (discriminated) protected type
22590 elsif Is_Protected_Type
(Typ
) then
22591 return not Caller_Known_Size_Record
(Corresponding_Record_Type
(Typ
));
22593 -- Unconstrained array type
22596 pragma Assert
(Is_Array_Type
(Typ
) and then not Is_Constrained
(Typ
));
22599 end Needs_Secondary_Stack
;
22601 ---------------------------------
22602 -- Needs_Simple_Initialization --
22603 ---------------------------------
22605 function Needs_Simple_Initialization
22607 Consider_IS
: Boolean := True) return Boolean
22609 Consider_IS_NS
: constant Boolean :=
22610 Normalize_Scalars
or (Initialize_Scalars
and Consider_IS
);
22613 -- Never need initialization if it is suppressed
22615 if Initialization_Suppressed
(Typ
) then
22619 -- Check for private type, in which case test applies to the underlying
22620 -- type of the private type.
22622 if Is_Private_Type
(Typ
) then
22624 RT
: constant Entity_Id
:= Underlying_Type
(Typ
);
22626 if Present
(RT
) then
22627 return Needs_Simple_Initialization
(RT
);
22633 -- Scalar type with Default_Value aspect requires initialization
22635 elsif Is_Scalar_Type
(Typ
) and then Has_Default_Aspect
(Typ
) then
22638 -- Cases needing simple initialization are access types, and, if pragma
22639 -- Normalize_Scalars or Initialize_Scalars is in effect, then all scalar
22642 elsif Is_Access_Type
(Typ
)
22643 or else (Consider_IS_NS
and then Is_Scalar_Type
(Typ
))
22647 -- If Initialize/Normalize_Scalars is in effect, string objects also
22648 -- need initialization, unless they are created in the course of
22649 -- expanding an aggregate (since in the latter case they will be
22650 -- filled with appropriate initializing values before they are used).
22652 elsif Consider_IS_NS
22653 and then Is_Standard_String_Type
(Typ
)
22655 (not Is_Itype
(Typ
)
22656 or else Nkind
(Associated_Node_For_Itype
(Typ
)) /= N_Aggregate
)
22663 end Needs_Simple_Initialization
;
22665 -------------------------------------
22666 -- Needs_Variable_Reference_Marker --
22667 -------------------------------------
22669 function Needs_Variable_Reference_Marker
22671 Calls_OK
: Boolean) return Boolean
22673 function Within_Suitable_Context
(Ref
: Node_Id
) return Boolean;
22674 -- Deteremine whether variable reference Ref appears within a suitable
22675 -- context that allows the creation of a marker.
22677 -----------------------------
22678 -- Within_Suitable_Context --
22679 -----------------------------
22681 function Within_Suitable_Context
(Ref
: Node_Id
) return Boolean is
22686 while Present
(Par
) loop
22688 -- The context is not suitable when the reference appears within
22689 -- the formal part of an instantiation which acts as compilation
22690 -- unit because there is no proper list for the insertion of the
22693 if Nkind
(Par
) = N_Generic_Association
22694 and then Nkind
(Parent
(Par
)) in N_Generic_Instantiation
22695 and then Nkind
(Parent
(Parent
(Par
))) = N_Compilation_Unit
22699 -- The context is not suitable when the reference appears within
22700 -- a pragma. If the pragma has run-time semantics, the reference
22701 -- will be reconsidered once the pragma is expanded.
22703 elsif Nkind
(Par
) = N_Pragma
then
22706 -- The context is not suitable when the reference appears within a
22707 -- subprogram call, and the caller requests this behavior.
22710 and then Nkind
(Par
) in N_Entry_Call_Statement
22712 | N_Procedure_Call_Statement
22716 -- Prevent the search from going too far
22718 elsif Is_Body_Or_Package_Declaration
(Par
) then
22722 Par
:= Parent
(Par
);
22726 end Within_Suitable_Context
;
22731 Var_Id
: Entity_Id
;
22733 -- Start of processing for Needs_Variable_Reference_Marker
22736 -- No marker needs to be created when switch -gnatH (legacy elaboration
22737 -- checking mode enabled) is in effect because the legacy ABE mechanism
22738 -- does not use markers.
22740 if Legacy_Elaboration_Checks
then
22743 -- No marker needs to be created when the reference is preanalyzed
22744 -- because the marker will be inserted in the wrong place.
22746 elsif Preanalysis_Active
then
22749 -- Only references warrant a marker
22751 elsif Nkind
(N
) not in N_Expanded_Name | N_Identifier
then
22754 -- Only source references warrant a marker
22756 elsif not Comes_From_Source
(N
) then
22759 -- No marker needs to be created when the reference is erroneous, left
22760 -- in a bad state, or does not denote a variable.
22762 elsif not (Present
(Entity
(N
))
22763 and then Ekind
(Entity
(N
)) = E_Variable
22764 and then Entity
(N
) /= Any_Id
)
22769 Var_Id
:= Entity
(N
);
22770 Prag
:= SPARK_Pragma
(Var_Id
);
22772 -- Both the variable and reference must appear in SPARK_Mode On regions
22773 -- because this elaboration scenario falls under the SPARK rules.
22775 if not (Comes_From_Source
(Var_Id
)
22776 and then Present
(Prag
)
22777 and then Get_SPARK_Mode_From_Annotation
(Prag
) = On
22778 and then Is_SPARK_Mode_On_Node
(N
))
22782 -- No marker needs to be created when the reference does not appear
22783 -- within a suitable context (see body for details).
22785 -- Performance note: parent traversal
22787 elsif not Within_Suitable_Context
(N
) then
22791 -- At this point it is known that the variable reference will play a
22792 -- role in ABE diagnostics and requires a marker.
22795 end Needs_Variable_Reference_Marker
;
22797 ------------------------
22798 -- New_Copy_List_Tree --
22799 ------------------------
22801 function New_Copy_List_Tree
(List
: List_Id
) return List_Id
is
22806 if List
= No_List
then
22813 while Present
(E
) loop
22814 Append
(New_Copy_Tree
(E
), NL
);
22820 end New_Copy_List_Tree
;
22822 -------------------
22823 -- New_Copy_Tree --
22824 -------------------
22826 -- The following tables play a key role in replicating entities and Itypes.
22827 -- They are intentionally declared at the library level rather than within
22828 -- New_Copy_Tree to avoid elaborating them on each call. This performance
22829 -- optimization saves up to 2% of the entire compilation time spent in the
22830 -- front end. Care should be taken to reset the tables on each new call to
22833 NCT_Table_Max
: constant := 511;
22835 subtype NCT_Table_Index
is Nat
range 0 .. NCT_Table_Max
- 1;
22837 function NCT_Table_Hash
(Key
: Node_Or_Entity_Id
) return NCT_Table_Index
;
22838 -- Obtain the hash value of node or entity Key
22840 --------------------
22841 -- NCT_Table_Hash --
22842 --------------------
22844 function NCT_Table_Hash
(Key
: Node_Or_Entity_Id
) return NCT_Table_Index
is
22846 return NCT_Table_Index
(Key
mod NCT_Table_Max
);
22847 end NCT_Table_Hash
;
22849 ----------------------
22850 -- NCT_New_Entities --
22851 ----------------------
22853 -- The following table maps old entities and Itypes to their corresponding
22854 -- new entities and Itypes.
22858 package NCT_New_Entities
is new Simple_HTable
(
22859 Header_Num
=> NCT_Table_Index
,
22860 Element
=> Entity_Id
,
22861 No_Element
=> Empty
,
22863 Hash
=> NCT_Table_Hash
,
22866 ------------------------
22867 -- NCT_Pending_Itypes --
22868 ------------------------
22870 -- The following table maps old Associated_Node_For_Itype nodes to a set of
22871 -- new itypes. Given a set of old Itypes Aaa, Bbb, and Ccc, where all three
22872 -- have the same Associated_Node_For_Itype Ppp, and their corresponding new
22873 -- Itypes Xxx, Yyy, Zzz, the table contains the following mapping:
22875 -- Ppp -> (Xxx, Yyy, Zzz)
22877 -- The set is expressed as an Elist
22879 package NCT_Pending_Itypes
is new Simple_HTable
(
22880 Header_Num
=> NCT_Table_Index
,
22881 Element
=> Elist_Id
,
22882 No_Element
=> No_Elist
,
22884 Hash
=> NCT_Table_Hash
,
22887 NCT_Tables_In_Use
: Boolean := False;
22888 -- This flag keeps track of whether the two tables NCT_New_Entities and
22889 -- NCT_Pending_Itypes are in use. The flag is part of an optimization
22890 -- where certain operations are not performed if the tables are not in
22891 -- use. This saves up to 8% of the entire compilation time spent in the
22894 -------------------
22895 -- New_Copy_Tree --
22896 -------------------
22898 function New_Copy_Tree
22900 Map
: Elist_Id
:= No_Elist
;
22901 New_Sloc
: Source_Ptr
:= No_Location
;
22902 New_Scope
: Entity_Id
:= Empty
) return Node_Id
22904 -- This routine performs low-level tree manipulations and needs access
22905 -- to the internals of the tree.
22907 EWA_Level
: Nat
:= 0;
22908 -- This counter keeps track of how many N_Expression_With_Actions nodes
22909 -- are encountered during a depth-first traversal of the subtree. These
22910 -- nodes may define new entities in their Actions lists and thus require
22911 -- special processing.
22913 EWA_Inner_Scope_Level
: Nat
:= 0;
22914 -- This counter keeps track of how many scoping constructs appear within
22915 -- an N_Expression_With_Actions node.
22917 procedure Add_New_Entity
(Old_Id
: Entity_Id
; New_Id
: Entity_Id
);
22918 pragma Inline
(Add_New_Entity
);
22919 -- Add an entry in the NCT_New_Entities table which maps key Old_Id to
22920 -- value New_Id. Old_Id is an entity which appears within the Actions
22921 -- list of an N_Expression_With_Actions node, or within an entity map.
22922 -- New_Id is the corresponding new entity generated during Phase 1.
22924 procedure Add_Pending_Itype
(Assoc_Nod
: Node_Id
; Itype
: Entity_Id
);
22925 pragma Inline
(Add_Pending_Itype
);
22926 -- Add an entry in the NCT_Pending_Itypes which maps key Assoc_Nod to
22927 -- value Itype. Assoc_Nod is the associated node of an itype. Itype is
22930 procedure Build_NCT_Tables
(Entity_Map
: Elist_Id
);
22931 pragma Inline
(Build_NCT_Tables
);
22932 -- Populate tables NCT_New_Entities and NCT_Pending_Itypes with the
22933 -- information supplied in entity map Entity_Map. The format of the
22934 -- entity map must be as follows:
22936 -- Old_Id1, New_Id1, Old_Id2, New_Id2, .., Old_IdN, New_IdN
22938 function Copy_Any_Node_With_Replacement
22939 (N
: Node_Or_Entity_Id
) return Node_Or_Entity_Id
;
22940 pragma Inline
(Copy_Any_Node_With_Replacement
);
22941 -- Replicate entity or node N by invoking one of the following routines:
22943 -- Copy_Node_With_Replacement
22944 -- Corresponding_Entity
22946 function Copy_Elist_With_Replacement
(List
: Elist_Id
) return Elist_Id
;
22947 -- Replicate the elements of entity list List
22949 function Copy_Field_With_Replacement
22951 Old_Par
: Node_Id
:= Empty
;
22952 New_Par
: Node_Id
:= Empty
;
22953 Semantic
: Boolean := False) return Union_Id
;
22954 -- Replicate field Field by invoking one of the following routines:
22956 -- Copy_Elist_With_Replacement
22957 -- Copy_List_With_Replacement
22958 -- Copy_Node_With_Replacement
22959 -- Corresponding_Entity
22961 -- If the field is not an entity list, entity, itype, syntactic list,
22962 -- or node, then the field is returned unchanged. The routine always
22963 -- replicates entities, itypes, and valid syntactic fields. Old_Par is
22964 -- the expected parent of a syntactic field. New_Par is the new parent
22965 -- associated with a replicated syntactic field. Flag Semantic should
22966 -- be set when the input is a semantic field.
22968 function Copy_List_With_Replacement
(List
: List_Id
) return List_Id
;
22969 -- Replicate the elements of syntactic list List
22971 function Copy_Node_With_Replacement
(N
: Node_Id
) return Node_Id
;
22972 -- Replicate node N
22974 function Corresponding_Entity
(Id
: Entity_Id
) return Entity_Id
;
22975 pragma Inline
(Corresponding_Entity
);
22976 -- Return the corresponding new entity of Id generated during Phase 1.
22977 -- If there is no such entity, return Id.
22979 function In_Entity_Map
22981 Entity_Map
: Elist_Id
) return Boolean;
22982 pragma Inline
(In_Entity_Map
);
22983 -- Determine whether entity Id is one of the old ids specified in entity
22984 -- map Entity_Map. The format of the entity map must be as follows:
22986 -- Old_Id1, New_Id1, Old_Id2, New_Id2, .., Old_IdN, New_IdN
22988 procedure Update_CFS_Sloc
(N
: Node_Or_Entity_Id
);
22989 pragma Inline
(Update_CFS_Sloc
);
22990 -- Update the Comes_From_Source and Sloc attributes of node or entity N
22992 procedure Update_Controlling_Argument
22993 (Old_Call
: Node_Id
;
22994 New_Call
: Node_Id
);
22995 pragma Inline
(Update_Controlling_Argument
);
22996 -- Update Controlling_Argument of New_Call base on Old_Call to make it
22997 -- points to the corresponding newly copied actual parameter.
22999 procedure Update_Named_Associations
23000 (Old_Call
: Node_Id
;
23001 New_Call
: Node_Id
);
23002 pragma Inline
(Update_Named_Associations
);
23003 -- Update semantic chain First/Next_Named_Association of call New_call
23004 -- based on call Old_Call.
23006 procedure Update_New_Entities
(Entity_Map
: Elist_Id
);
23007 pragma Inline
(Update_New_Entities
);
23008 -- Update the semantic attributes of all new entities generated during
23009 -- Phase 1 that do not appear in entity map Entity_Map. The format of
23010 -- the entity map must be as follows:
23012 -- Old_Id1, New_Id1, Old_Id2, New_Id2, .., Old_IdN, New_IdN
23014 procedure Update_Pending_Itypes
23015 (Old_Assoc
: Node_Id
;
23016 New_Assoc
: Node_Id
);
23017 pragma Inline
(Update_Pending_Itypes
);
23018 -- Update semantic attribute Associated_Node_For_Itype to refer to node
23019 -- New_Assoc for all itypes whose associated node is Old_Assoc.
23021 procedure Update_Semantic_Fields
(Id
: Entity_Id
);
23022 pragma Inline
(Update_Semantic_Fields
);
23023 -- Subsidiary to Update_New_Entities. Update semantic fields of entity
23026 procedure Visit_Any_Node
(N
: Node_Or_Entity_Id
);
23027 pragma Inline
(Visit_Any_Node
);
23028 -- Visit entity of node N by invoking one of the following routines:
23034 procedure Visit_Elist
(List
: Elist_Id
);
23035 -- Visit the elements of entity list List
23037 procedure Visit_Entity
(Id
: Entity_Id
);
23038 -- Visit entity Id. This action may create a new entity of Id and save
23039 -- it in table NCT_New_Entities.
23041 procedure Visit_Field
23043 Par_Nod
: Node_Id
:= Empty
;
23044 Semantic
: Boolean := False);
23045 -- Visit field Field by invoking one of the following routines:
23053 -- If the field is not an entity list, entity, itype, syntactic list,
23054 -- or node, then the field is not visited. The routine always visits
23055 -- valid syntactic fields. Par_Nod is the expected parent of the
23056 -- syntactic field. Flag Semantic should be set when the input is a
23059 procedure Visit_Itype
(Itype
: Entity_Id
);
23060 -- Visit itype Itype. This action may create a new entity for Itype and
23061 -- save it in table NCT_New_Entities. In addition, the routine may map
23062 -- the associated node of Itype to the new itype in NCT_Pending_Itypes.
23064 procedure Visit_List
(List
: List_Id
);
23065 -- Visit the elements of syntactic list List
23067 procedure Visit_Node
(N
: Node_Id
);
23070 procedure Visit_Semantic_Fields
(Id
: Entity_Id
);
23071 pragma Inline
(Visit_Semantic_Fields
);
23072 -- Subsidiary to Visit_Entity and Visit_Itype. Visit common semantic
23073 -- fields of entity or itype Id.
23075 --------------------
23076 -- Add_New_Entity --
23077 --------------------
23079 procedure Add_New_Entity
(Old_Id
: Entity_Id
; New_Id
: Entity_Id
) is
23081 pragma Assert
(Present
(Old_Id
));
23082 pragma Assert
(Present
(New_Id
));
23083 pragma Assert
(Nkind
(Old_Id
) in N_Entity
);
23084 pragma Assert
(Nkind
(New_Id
) in N_Entity
);
23086 NCT_Tables_In_Use
:= True;
23088 -- Sanity check the NCT_New_Entities table. No previous mapping with
23089 -- key Old_Id should exist.
23091 pragma Assert
(No
(NCT_New_Entities
.Get
(Old_Id
)));
23093 -- Establish the mapping
23095 -- Old_Id -> New_Id
23097 NCT_New_Entities
.Set
(Old_Id
, New_Id
);
23098 end Add_New_Entity
;
23100 -----------------------
23101 -- Add_Pending_Itype --
23102 -----------------------
23104 procedure Add_Pending_Itype
(Assoc_Nod
: Node_Id
; Itype
: Entity_Id
) is
23108 pragma Assert
(Present
(Assoc_Nod
));
23109 pragma Assert
(Present
(Itype
));
23110 pragma Assert
(Nkind
(Itype
) in N_Entity
);
23111 pragma Assert
(Is_Itype
(Itype
));
23113 NCT_Tables_In_Use
:= True;
23115 -- It is not possible to sanity check the NCT_Pendint_Itypes table
23116 -- directly because a single node may act as the associated node for
23117 -- multiple itypes.
23119 Itypes
:= NCT_Pending_Itypes
.Get
(Assoc_Nod
);
23121 if No
(Itypes
) then
23122 Itypes
:= New_Elmt_List
;
23123 NCT_Pending_Itypes
.Set
(Assoc_Nod
, Itypes
);
23126 -- Establish the mapping
23128 -- Assoc_Nod -> (Itype, ...)
23130 -- Avoid inserting the same itype multiple times. This involves a
23131 -- linear search, however the set of itypes with the same associated
23132 -- node is very small.
23134 Append_Unique_Elmt
(Itype
, Itypes
);
23135 end Add_Pending_Itype
;
23137 ----------------------
23138 -- Build_NCT_Tables --
23139 ----------------------
23141 procedure Build_NCT_Tables
(Entity_Map
: Elist_Id
) is
23143 Old_Id
: Entity_Id
;
23144 New_Id
: Entity_Id
;
23147 -- Nothing to do when there is no entity map
23149 if No
(Entity_Map
) then
23153 Elmt
:= First_Elmt
(Entity_Map
);
23154 while Present
(Elmt
) loop
23156 -- Extract the (Old_Id, New_Id) pair from the entity map
23158 Old_Id
:= Node
(Elmt
);
23161 New_Id
:= Node
(Elmt
);
23164 -- Establish the following mapping within table NCT_New_Entities
23166 -- Old_Id -> New_Id
23168 Add_New_Entity
(Old_Id
, New_Id
);
23170 -- Establish the following mapping within table NCT_Pending_Itypes
23171 -- when the new entity is an itype.
23173 -- Assoc_Nod -> (New_Id, ...)
23175 -- IMPORTANT: the associated node is that of the old itype because
23176 -- the node will be replicated in Phase 2.
23178 if Is_Itype
(Old_Id
) then
23180 (Assoc_Nod
=> Associated_Node_For_Itype
(Old_Id
),
23184 end Build_NCT_Tables
;
23186 ------------------------------------
23187 -- Copy_Any_Node_With_Replacement --
23188 ------------------------------------
23190 function Copy_Any_Node_With_Replacement
23191 (N
: Node_Or_Entity_Id
) return Node_Or_Entity_Id
23194 if Nkind
(N
) in N_Entity
then
23195 return Corresponding_Entity
(N
);
23197 return Copy_Node_With_Replacement
(N
);
23199 end Copy_Any_Node_With_Replacement
;
23201 ---------------------------------
23202 -- Copy_Elist_With_Replacement --
23203 ---------------------------------
23205 function Copy_Elist_With_Replacement
(List
: Elist_Id
) return Elist_Id
is
23210 -- Copy the contents of the old list. Note that the list itself may
23211 -- be empty, in which case the routine returns a new empty list. This
23212 -- avoids sharing lists between subtrees. The element of an entity
23213 -- list could be an entity or a node, hence the invocation of routine
23214 -- Copy_Any_Node_With_Replacement.
23216 if Present
(List
) then
23217 Result
:= New_Elmt_List
;
23219 Elmt
:= First_Elmt
(List
);
23220 while Present
(Elmt
) loop
23222 (Copy_Any_Node_With_Replacement
(Node
(Elmt
)), Result
);
23227 -- Otherwise the list does not exist
23230 Result
:= No_Elist
;
23234 end Copy_Elist_With_Replacement
;
23236 ---------------------------------
23237 -- Copy_Field_With_Replacement --
23238 ---------------------------------
23240 function Copy_Field_With_Replacement
23242 Old_Par
: Node_Id
:= Empty
;
23243 New_Par
: Node_Id
:= Empty
;
23244 Semantic
: Boolean := False) return Union_Id
23247 -- The field is empty
23249 if Field
= Union_Id
(Empty
) then
23252 -- The field is an entity/itype/node
23254 elsif Field
in Node_Range
then
23256 Old_N
: constant Node_Id
:= Node_Id
(Field
);
23257 Syntactic
: constant Boolean :=
23258 Is_Syntactic_Node
(Source
=> Old_Par
, Field
=> Old_N
);
23263 -- The field is an entity/itype
23265 if Nkind
(Old_N
) in N_Entity
then
23267 -- An entity/itype is always replicated
23269 New_N
:= Corresponding_Entity
(Old_N
);
23271 -- Update the parent pointer when the entity is a syntactic
23272 -- field. Note that itypes do not have parent pointers.
23274 if Syntactic
and then New_N
/= Old_N
then
23275 Set_Parent
(New_N
, New_Par
);
23278 -- The field is a node
23281 -- A node is replicated when it is either a syntactic field
23282 -- or when the caller treats it as a semantic attribute.
23284 if Syntactic
or else Semantic
then
23285 New_N
:= Copy_Node_With_Replacement
(Old_N
);
23287 -- Update the parent pointer when the node is a syntactic
23290 if Syntactic
and then New_N
/= Old_N
then
23291 Set_Parent
(New_N
, New_Par
);
23294 -- Otherwise the node is returned unchanged
23301 return Union_Id
(New_N
);
23304 -- The field is an entity list
23306 elsif Field
in Elist_Range
then
23307 return Union_Id
(Copy_Elist_With_Replacement
(Elist_Id
(Field
)));
23309 -- The field is a syntactic list
23311 elsif Field
in List_Range
then
23313 Old_List
: constant List_Id
:= List_Id
(Field
);
23314 Syntactic
: constant Boolean := Parent
(Old_List
) = Old_Par
;
23316 New_List
: List_Id
;
23319 -- A list is replicated when it is either a syntactic field or
23320 -- when the caller treats it as a semantic attribute.
23322 if Syntactic
or else Semantic
then
23323 New_List
:= Copy_List_With_Replacement
(Old_List
);
23325 -- Update the parent pointer when the list is a syntactic
23328 if Syntactic
and then New_List
/= Old_List
then
23329 Set_Parent
(New_List
, New_Par
);
23332 -- Otherwise the list is returned unchanged
23335 New_List
:= Old_List
;
23338 return Union_Id
(New_List
);
23341 -- Otherwise the field denotes an attribute that does not need to be
23342 -- replicated (Chars, literals, etc).
23347 end Copy_Field_With_Replacement
;
23349 --------------------------------
23350 -- Copy_List_With_Replacement --
23351 --------------------------------
23353 function Copy_List_With_Replacement
(List
: List_Id
) return List_Id
is
23358 -- Copy the contents of the old list. Note that the list itself may
23359 -- be empty, in which case the routine returns a new empty list. This
23360 -- avoids sharing lists between subtrees. The element of a syntactic
23361 -- list is always a node, never an entity or itype, hence the call to
23362 -- routine Copy_Node_With_Replacement.
23364 if Present
(List
) then
23365 Result
:= New_List
;
23367 Elmt
:= First
(List
);
23368 while Present
(Elmt
) loop
23369 Append
(Copy_Node_With_Replacement
(Elmt
), Result
);
23374 -- Otherwise the list does not exist
23381 end Copy_List_With_Replacement
;
23383 --------------------------------
23384 -- Copy_Node_With_Replacement --
23385 --------------------------------
23387 function Copy_Node_With_Replacement
(N
: Node_Id
) return Node_Id
is
23390 function Transform
(U
: Union_Id
) return Union_Id
;
23391 -- Copies one field, replacing N with Result
23397 function Transform
(U
: Union_Id
) return Union_Id
is
23399 return Copy_Field_With_Replacement
23402 New_Par
=> Result
);
23405 procedure Walk
is new Walk_Sinfo_Fields_Pairwise
(Transform
);
23407 -- Start of processing for Copy_Node_With_Replacement
23410 -- Assume that the node must be returned unchanged
23414 if N
> Empty_Or_Error
then
23415 pragma Assert
(Nkind
(N
) not in N_Entity
);
23417 Result
:= New_Copy
(N
);
23419 Walk
(Result
, Result
);
23421 -- Update the Comes_From_Source and Sloc attributes of the node
23422 -- in case the caller has supplied new values.
23424 Update_CFS_Sloc
(Result
);
23426 -- Update the Associated_Node_For_Itype attribute of all itypes
23427 -- created during Phase 1 whose associated node is N. As a result
23428 -- the Associated_Node_For_Itype refers to the replicated node.
23429 -- No action needs to be taken when the Associated_Node_For_Itype
23430 -- refers to an entity because this was already handled during
23431 -- Phase 1, in Visit_Itype.
23433 Update_Pending_Itypes
23435 New_Assoc
=> Result
);
23437 -- Update the First/Next_Named_Association chain and the
23438 -- Controlling_Argument for a replicated call.
23440 if Nkind
(N
) in N_Entry_Call_Statement
23441 | N_Subprogram_Call
23443 Update_Named_Associations
23445 New_Call
=> Result
);
23447 if Nkind
(N
) in N_Subprogram_Call
then
23448 Update_Controlling_Argument
23450 New_Call
=> Result
);
23453 -- Update the Renamed_Object attribute of a replicated object
23456 elsif Nkind
(N
) = N_Object_Renaming_Declaration
then
23457 Set_Renamed_Object_Of_Possibly_Void
23458 (Defining_Entity
(Result
), Name
(Result
));
23460 -- Update the Chars attribute of identifiers
23462 elsif Nkind
(N
) = N_Identifier
then
23464 -- The Entity field of identifiers that denote aspects is used
23465 -- to store arbitrary expressions (and hence we must check that
23466 -- they reference an actual entity before copying their Chars
23469 if Present
(Entity
(Result
))
23470 and then Nkind
(Entity
(Result
)) in N_Entity
23472 Set_Chars
(Result
, Chars
(Entity
(Result
)));
23478 end Copy_Node_With_Replacement
;
23480 --------------------------
23481 -- Corresponding_Entity --
23482 --------------------------
23484 function Corresponding_Entity
(Id
: Entity_Id
) return Entity_Id
is
23485 New_Id
: Entity_Id
;
23486 Result
: Entity_Id
;
23489 -- Assume that the entity must be returned unchanged
23493 if Id
> Empty_Or_Error
then
23494 pragma Assert
(Nkind
(Id
) in N_Entity
);
23496 -- Determine whether the entity has a corresponding new entity
23497 -- generated during Phase 1 and if it does, use it.
23499 if NCT_Tables_In_Use
then
23500 New_Id
:= NCT_New_Entities
.Get
(Id
);
23502 if Present
(New_Id
) then
23509 end Corresponding_Entity
;
23511 -------------------
23512 -- In_Entity_Map --
23513 -------------------
23515 function In_Entity_Map
23517 Entity_Map
: Elist_Id
) return Boolean
23520 Old_Id
: Entity_Id
;
23523 -- The entity map contains pairs (Old_Id, New_Id). The advancement
23524 -- step always skips the New_Id portion of the pair.
23526 if Present
(Entity_Map
) then
23527 Elmt
:= First_Elmt
(Entity_Map
);
23528 while Present
(Elmt
) loop
23529 Old_Id
:= Node
(Elmt
);
23531 if Old_Id
= Id
then
23543 ---------------------
23544 -- Update_CFS_Sloc --
23545 ---------------------
23547 procedure Update_CFS_Sloc
(N
: Node_Or_Entity_Id
) is
23549 -- A new source location defaults the Comes_From_Source attribute
23551 if New_Sloc
/= No_Location
then
23552 Set_Comes_From_Source
(N
, Get_Comes_From_Source_Default
);
23553 Set_Sloc
(N
, New_Sloc
);
23555 end Update_CFS_Sloc
;
23557 ---------------------------------
23558 -- Update_Controlling_Argument --
23559 ---------------------------------
23561 procedure Update_Controlling_Argument
23562 (Old_Call
: Node_Id
;
23563 New_Call
: Node_Id
)
23568 Old_Ctrl_Arg
: constant Node_Id
:= Controlling_Argument
(Old_Call
);
23569 -- Controlling argument of the old call node
23571 Replaced
: Boolean := False;
23572 -- Flag to make sure that replacement works as expected
23575 if No
(Old_Ctrl_Arg
) then
23579 -- Recreate the Controlling_Argument of a call by traversing both the
23580 -- old and new actual parameters in parallel.
23582 New_Act
:= First
(Parameter_Associations
(New_Call
));
23583 Old_Act
:= First
(Parameter_Associations
(Old_Call
));
23584 while Present
(Old_Act
) loop
23586 -- Actual parameter appears either in a named parameter
23587 -- association or directly.
23589 if Nkind
(Old_Act
) = N_Parameter_Association
then
23590 if Explicit_Actual_Parameter
(Old_Act
) = Old_Ctrl_Arg
then
23591 Set_Controlling_Argument
23592 (New_Call
, Explicit_Actual_Parameter
(New_Act
));
23597 elsif Old_Act
= Old_Ctrl_Arg
then
23598 Set_Controlling_Argument
(New_Call
, New_Act
);
23607 pragma Assert
(Replaced
);
23608 end Update_Controlling_Argument
;
23610 -------------------------------
23611 -- Update_Named_Associations --
23612 -------------------------------
23614 procedure Update_Named_Associations
23615 (Old_Call
: Node_Id
;
23616 New_Call
: Node_Id
)
23619 New_Next
: Node_Id
;
23621 Old_Next
: Node_Id
;
23624 if No
(First_Named_Actual
(Old_Call
)) then
23628 -- Recreate the First/Next_Named_Actual chain of a call by traversing
23629 -- the chains of both the old and new calls in parallel.
23631 New_Act
:= First
(Parameter_Associations
(New_Call
));
23632 Old_Act
:= First
(Parameter_Associations
(Old_Call
));
23633 while Present
(Old_Act
) loop
23634 if Nkind
(Old_Act
) = N_Parameter_Association
23635 and then Explicit_Actual_Parameter
(Old_Act
)
23636 = First_Named_Actual
(Old_Call
)
23638 Set_First_Named_Actual
(New_Call
,
23639 Explicit_Actual_Parameter
(New_Act
));
23642 if Nkind
(Old_Act
) = N_Parameter_Association
23643 and then Present
(Next_Named_Actual
(Old_Act
))
23645 -- Scan the actual parameter list to find the next suitable
23646 -- named actual. Note that the list may be out of order.
23648 New_Next
:= First
(Parameter_Associations
(New_Call
));
23649 Old_Next
:= First
(Parameter_Associations
(Old_Call
));
23650 while Nkind
(Old_Next
) /= N_Parameter_Association
23651 or else Explicit_Actual_Parameter
(Old_Next
) /=
23652 Next_Named_Actual
(Old_Act
)
23658 Set_Next_Named_Actual
(New_Act
,
23659 Explicit_Actual_Parameter
(New_Next
));
23665 end Update_Named_Associations
;
23667 -------------------------
23668 -- Update_New_Entities --
23669 -------------------------
23671 procedure Update_New_Entities
(Entity_Map
: Elist_Id
) is
23672 New_Id
: Entity_Id
:= Empty
;
23673 Old_Id
: Entity_Id
:= Empty
;
23676 if NCT_Tables_In_Use
then
23677 NCT_New_Entities
.Get_First
(Old_Id
, New_Id
);
23679 -- Update the semantic fields of all new entities created during
23680 -- Phase 1 which were not supplied via an entity map.
23681 -- ??? Is there a better way of distinguishing those?
23683 while Present
(Old_Id
) and then Present
(New_Id
) loop
23684 if not In_Entity_Map
(Old_Id
, Entity_Map
) then
23685 Update_Semantic_Fields
(New_Id
);
23688 NCT_New_Entities
.Get_Next
(Old_Id
, New_Id
);
23691 end Update_New_Entities
;
23693 ---------------------------
23694 -- Update_Pending_Itypes --
23695 ---------------------------
23697 procedure Update_Pending_Itypes
23698 (Old_Assoc
: Node_Id
;
23699 New_Assoc
: Node_Id
)
23705 if NCT_Tables_In_Use
then
23706 Itypes
:= NCT_Pending_Itypes
.Get
(Old_Assoc
);
23708 -- Update the Associated_Node_For_Itype attribute for all itypes
23709 -- which originally refer to Old_Assoc to designate New_Assoc.
23711 if Present
(Itypes
) then
23712 Item
:= First_Elmt
(Itypes
);
23713 while Present
(Item
) loop
23714 Set_Associated_Node_For_Itype
(Node
(Item
), New_Assoc
);
23720 end Update_Pending_Itypes
;
23722 ----------------------------
23723 -- Update_Semantic_Fields --
23724 ----------------------------
23726 procedure Update_Semantic_Fields
(Id
: Entity_Id
) is
23728 -- Discriminant_Constraint
23730 if Is_Type
(Id
) and then Has_Discriminants
(Base_Type
(Id
)) then
23731 Set_Discriminant_Constraint
(Id
, Elist_Id
(
23732 Copy_Field_With_Replacement
23733 (Field
=> Union_Id
(Discriminant_Constraint
(Id
)),
23734 Semantic
=> True)));
23739 Set_Etype
(Id
, Node_Id
(
23740 Copy_Field_With_Replacement
23741 (Field
=> Union_Id
(Etype
(Id
)),
23742 Semantic
=> True)));
23745 -- Packed_Array_Impl_Type
23747 if Is_Array_Type
(Id
) then
23748 if Present
(First_Index
(Id
)) then
23749 Set_First_Index
(Id
, First
(List_Id
(
23750 Copy_Field_With_Replacement
23751 (Field
=> Union_Id
(List_Containing
(First_Index
(Id
))),
23752 Semantic
=> True))));
23755 if Is_Packed
(Id
) then
23756 Set_Packed_Array_Impl_Type
(Id
, Node_Id
(
23757 Copy_Field_With_Replacement
23758 (Field
=> Union_Id
(Packed_Array_Impl_Type
(Id
)),
23759 Semantic
=> True)));
23765 Set_Prev_Entity
(Id
, Node_Id
(
23766 Copy_Field_With_Replacement
23767 (Field
=> Union_Id
(Prev_Entity
(Id
)),
23768 Semantic
=> True)));
23772 Set_Next_Entity
(Id
, Node_Id
(
23773 Copy_Field_With_Replacement
23774 (Field
=> Union_Id
(Next_Entity
(Id
)),
23775 Semantic
=> True)));
23779 if Is_Discrete_Type
(Id
) then
23780 Set_Scalar_Range
(Id
, Node_Id
(
23781 Copy_Field_With_Replacement
23782 (Field
=> Union_Id
(Scalar_Range
(Id
)),
23783 Semantic
=> True)));
23788 -- Update the scope when the caller specified an explicit one
23790 if Present
(New_Scope
) then
23791 Set_Scope
(Id
, New_Scope
);
23793 Set_Scope
(Id
, Node_Id
(
23794 Copy_Field_With_Replacement
23795 (Field
=> Union_Id
(Scope
(Id
)),
23796 Semantic
=> True)));
23798 end Update_Semantic_Fields
;
23800 --------------------
23801 -- Visit_Any_Node --
23802 --------------------
23804 procedure Visit_Any_Node
(N
: Node_Or_Entity_Id
) is
23806 if Nkind
(N
) in N_Entity
then
23807 if Is_Itype
(N
) then
23815 end Visit_Any_Node
;
23821 procedure Visit_Elist
(List
: Elist_Id
) is
23825 -- The element of an entity list could be an entity, itype, or a
23826 -- node, hence the call to Visit_Any_Node.
23828 if Present
(List
) then
23829 Elmt
:= First_Elmt
(List
);
23830 while Present
(Elmt
) loop
23831 Visit_Any_Node
(Node
(Elmt
));
23842 procedure Visit_Entity
(Id
: Entity_Id
) is
23843 New_Id
: Entity_Id
;
23846 pragma Assert
(Nkind
(Id
) in N_Entity
);
23847 pragma Assert
(not Is_Itype
(Id
));
23849 -- Nothing to do when the entity is not defined in the Actions list
23850 -- of an N_Expression_With_Actions node.
23852 if EWA_Level
= 0 then
23855 -- Nothing to do when the entity is defined in a scoping construct
23856 -- within an N_Expression_With_Actions node.
23858 elsif EWA_Inner_Scope_Level
> 0 then
23861 -- Nothing to do when the entity does not denote a construct that
23862 -- may appear within an N_Expression_With_Actions node. Relaxing
23863 -- this restriction leads to a performance penalty.
23865 -- ??? this list is flaky, and may hide dormant bugs
23866 -- Should functions be included???
23868 -- Quantified expressions contain an entity declaration that must
23869 -- always be replaced when the expander is active, even if it has
23870 -- not been analyzed yet like e.g. in predicates.
23872 elsif Ekind
(Id
) not in E_Block
23877 and then not Is_Entity_Of_Quantified_Expression
(Id
)
23878 and then not Is_Type
(Id
)
23882 -- Nothing to do when the entity was already visited
23884 elsif NCT_Tables_In_Use
23885 and then Present
(NCT_New_Entities
.Get
(Id
))
23889 -- Nothing to do when the declaration node of the entity is not in
23890 -- the subtree being replicated.
23892 elsif not In_Subtree
23893 (N
=> Declaration_Node
(Id
),
23899 -- Create a new entity by directly copying the old entity. This
23900 -- action causes all attributes of the old entity to be inherited.
23902 New_Id
:= New_Copy
(Id
);
23904 -- Create a new name for the new entity because the back end needs
23905 -- distinct names for debugging purposes, provided that the entity
23906 -- has already been analyzed.
23908 if Ekind
(Id
) /= E_Void
then
23909 Set_Chars
(New_Id
, New_Internal_Name
('T'));
23912 -- Update the Comes_From_Source and Sloc attributes of the entity in
23913 -- case the caller has supplied new values.
23915 Update_CFS_Sloc
(New_Id
);
23917 -- Establish the following mapping within table NCT_New_Entities:
23921 Add_New_Entity
(Id
, New_Id
);
23923 -- Deal with the semantic fields of entities. The fields are visited
23924 -- because they may mention entities which reside within the subtree
23927 Visit_Semantic_Fields
(Id
);
23934 procedure Visit_Field
23936 Par_Nod
: Node_Id
:= Empty
;
23937 Semantic
: Boolean := False)
23940 -- The field is empty
23942 if Field
= Union_Id
(Empty
) then
23945 -- The field is an entity/itype/node
23947 elsif Field
in Node_Range
then
23949 N
: constant Node_Id
:= Node_Id
(Field
);
23952 -- The field is an entity/itype
23954 if Nkind
(N
) in N_Entity
then
23956 -- Itypes are always visited
23958 if Is_Itype
(N
) then
23961 -- An entity is visited when it is either a syntactic field
23962 -- or when the caller treats it as a semantic attribute.
23964 elsif Parent
(N
) = Par_Nod
or else Semantic
then
23968 -- The field is a node
23971 -- A node is visited when it is either a syntactic field or
23972 -- when the caller treats it as a semantic attribute.
23974 if Parent
(N
) = Par_Nod
or else Semantic
then
23980 -- The field is an entity list
23982 elsif Field
in Elist_Range
then
23983 Visit_Elist
(Elist_Id
(Field
));
23985 -- The field is a syntax list
23987 elsif Field
in List_Range
then
23989 List
: constant List_Id
:= List_Id
(Field
);
23992 -- A syntax list is visited when it is either a syntactic field
23993 -- or when the caller treats it as a semantic attribute.
23995 if Parent
(List
) = Par_Nod
or else Semantic
then
24000 -- Otherwise the field denotes information which does not need to be
24001 -- visited (chars, literals, etc.).
24012 procedure Visit_Itype
(Itype
: Entity_Id
) is
24013 New_Assoc
: Node_Id
;
24014 New_Itype
: Entity_Id
;
24015 Old_Assoc
: Node_Id
;
24018 pragma Assert
(Nkind
(Itype
) in N_Entity
);
24019 pragma Assert
(Is_Itype
(Itype
));
24021 -- Itypes that describe the designated type of access to subprograms
24022 -- have the structure of subprogram declarations, with signatures,
24023 -- etc. Either we duplicate the signatures completely, or choose to
24024 -- share such itypes, which is fine because their elaboration will
24025 -- have no side effects.
24027 if Ekind
(Itype
) = E_Subprogram_Type
then
24030 -- Nothing to do if the itype was already visited
24032 elsif NCT_Tables_In_Use
24033 and then Present
(NCT_New_Entities
.Get
(Itype
))
24037 -- Nothing to do if the associated node of the itype is not within
24038 -- the subtree being replicated.
24040 elsif not In_Subtree
24041 (N
=> Associated_Node_For_Itype
(Itype
),
24047 -- Create a new itype by directly copying the old itype. This action
24048 -- causes all attributes of the old itype to be inherited.
24050 New_Itype
:= New_Copy
(Itype
);
24052 -- Create a new name for the new itype because the back end requires
24053 -- distinct names for debugging purposes.
24055 Set_Chars
(New_Itype
, New_Internal_Name
('T'));
24057 -- Update the Comes_From_Source and Sloc attributes of the itype in
24058 -- case the caller has supplied new values.
24060 Update_CFS_Sloc
(New_Itype
);
24062 -- Establish the following mapping within table NCT_New_Entities:
24064 -- Itype -> New_Itype
24066 Add_New_Entity
(Itype
, New_Itype
);
24068 -- The new itype must be unfrozen because the resulting subtree may
24069 -- be inserted anywhere and cause an earlier or later freezing.
24071 if Present
(Freeze_Node
(New_Itype
)) then
24072 Set_Freeze_Node
(New_Itype
, Empty
);
24073 Set_Is_Frozen
(New_Itype
, False);
24076 -- If a record subtype is simply copied, the entity list will be
24077 -- shared, so Cloned_Subtype must be set to indicate this.
24079 if Ekind
(Itype
) in E_Class_Wide_Subtype | E_Record_Subtype
then
24080 Set_Cloned_Subtype
(New_Itype
, Itype
);
24083 -- The associated node may denote an entity, in which case it may
24084 -- already have a new corresponding entity created during a prior
24085 -- call to Visit_Entity or Visit_Itype for the same subtree.
24088 -- Old_Assoc ---------> New_Assoc
24090 -- Created by Visit_Itype
24091 -- Itype -------------> New_Itype
24092 -- ANFI = Old_Assoc ANFI = Old_Assoc < must be updated
24094 -- In the example above, Old_Assoc is an arbitrary entity that was
24095 -- already visited for the same subtree and has a corresponding new
24096 -- entity New_Assoc. Old_Assoc was inherited by New_Itype by virtue
24097 -- of copying entities, however it must be updated to New_Assoc.
24099 Old_Assoc
:= Associated_Node_For_Itype
(Itype
);
24101 if Nkind
(Old_Assoc
) in N_Entity
then
24102 if NCT_Tables_In_Use
then
24103 New_Assoc
:= NCT_New_Entities
.Get
(Old_Assoc
);
24105 if Present
(New_Assoc
) then
24106 Set_Associated_Node_For_Itype
(New_Itype
, New_Assoc
);
24110 -- Otherwise the associated node denotes a node. Postpone the update
24111 -- until Phase 2 when the node is replicated. Establish the following
24112 -- mapping within table NCT_Pending_Itypes:
24114 -- Old_Assoc -> (New_Type, ...)
24117 Add_Pending_Itype
(Old_Assoc
, New_Itype
);
24120 -- Deal with the semantic fields of itypes. The fields are visited
24121 -- because they may mention entities that reside within the subtree
24124 Visit_Semantic_Fields
(Itype
);
24131 procedure Visit_List
(List
: List_Id
) is
24135 -- Note that the element of a syntactic list is always a node, never
24136 -- an entity or itype, hence the call to Visit_Node.
24138 Elmt
:= First
(List
);
24139 while Present
(Elmt
) loop
24150 procedure Visit_Node
(N
: Node_Id
) is
24152 pragma Assert
(Nkind
(N
) not in N_Entity
);
24154 -- If the node is a quantified expression and expander is active,
24155 -- it contains an implicit declaration that may require a new entity
24156 -- when the condition has already been (pre)analyzed.
24158 if Nkind
(N
) = N_Expression_With_Actions
24160 (Nkind
(N
) = N_Quantified_Expression
and then Expander_Active
)
24162 EWA_Level
:= EWA_Level
+ 1;
24164 elsif EWA_Level
> 0
24165 and then Nkind
(N
) in N_Block_Statement
24166 | N_Subprogram_Body
24167 | N_Subprogram_Declaration
24169 EWA_Inner_Scope_Level
:= EWA_Inner_Scope_Level
+ 1;
24172 -- If the node is a block, we need to process all declarations
24173 -- in the block and make new entities for each.
24175 if Nkind
(N
) = N_Block_Statement
then
24177 Decl
: Node_Id
:= First
(Declarations
(N
));
24180 while Present
(Decl
) loop
24181 if Nkind
(Decl
) = N_Object_Declaration
then
24182 Add_New_Entity
(Defining_Identifier
(Decl
),
24183 New_Copy
(Defining_Identifier
(Decl
)));
24192 procedure Action
(U
: Union_Id
);
24193 procedure Action
(U
: Union_Id
) is
24195 Visit_Field
(Field
=> U
, Par_Nod
=> N
);
24198 procedure Walk
is new Walk_Sinfo_Fields
(Action
);
24204 and then Nkind
(N
) in N_Block_Statement
24205 | N_Subprogram_Body
24206 | N_Subprogram_Declaration
24208 EWA_Inner_Scope_Level
:= EWA_Inner_Scope_Level
- 1;
24210 elsif Nkind
(N
) = N_Expression_With_Actions
24212 (Nkind
(N
) = N_Quantified_Expression
and then Expander_Active
)
24214 EWA_Level
:= EWA_Level
- 1;
24218 ---------------------------
24219 -- Visit_Semantic_Fields --
24220 ---------------------------
24222 procedure Visit_Semantic_Fields
(Id
: Entity_Id
) is
24224 pragma Assert
(Nkind
(Id
) in N_Entity
);
24226 -- Discriminant_Constraint
24228 if Is_Type
(Id
) and then Has_Discriminants
(Base_Type
(Id
)) then
24230 (Field
=> Union_Id
(Discriminant_Constraint
(Id
)),
24237 (Field
=> Union_Id
(Etype
(Id
)),
24241 -- Packed_Array_Impl_Type
24243 if Is_Array_Type
(Id
) then
24244 if Present
(First_Index
(Id
)) then
24246 (Field
=> Union_Id
(List_Containing
(First_Index
(Id
))),
24250 if Is_Packed
(Id
) then
24252 (Field
=> Union_Id
(Packed_Array_Impl_Type
(Id
)),
24259 if Is_Discrete_Type
(Id
) then
24261 (Field
=> Union_Id
(Scalar_Range
(Id
)),
24264 end Visit_Semantic_Fields
;
24266 -- Start of processing for New_Copy_Tree
24269 -- Routine New_Copy_Tree performs a deep copy of a subtree by creating
24270 -- shallow copies for each node within, and then updating the child and
24271 -- parent pointers accordingly. This process is straightforward, however
24272 -- the routine must deal with the following complications:
24274 -- * Entities defined within N_Expression_With_Actions nodes must be
24275 -- replicated rather than shared to avoid introducing two identical
24276 -- symbols within the same scope. Note that no other expression can
24277 -- currently define entities.
24280 -- Source_Low : ...;
24281 -- Source_High : ...;
24283 -- <reference to Source_Low>
24284 -- <reference to Source_High>
24287 -- New_Copy_Tree handles this case by first creating new entities
24288 -- and then updating all existing references to point to these new
24295 -- <reference to New_Low>
24296 -- <reference to New_High>
24299 -- * Itypes defined within the subtree must be replicated to avoid any
24300 -- dependencies on invalid or inaccessible data.
24302 -- subtype Source_Itype is ... range Source_Low .. Source_High;
24304 -- New_Copy_Tree handles this case by first creating a new itype in
24305 -- the same fashion as entities, and then updating various relevant
24308 -- subtype New_Itype is ... range New_Low .. New_High;
24310 -- * The Associated_Node_For_Itype field of itypes must be updated to
24311 -- reference the proper replicated entity or node.
24313 -- * Semantic fields of entities such as Etype and Scope must be
24314 -- updated to reference the proper replicated entities.
24316 -- * Some semantic fields of nodes must be updated to reference
24317 -- the proper replicated nodes.
24319 -- Finally, quantified expressions contain an implicit declaration for
24320 -- the bound variable. Given that quantified expressions appearing
24321 -- in contracts are copied to create pragmas and eventually checking
24322 -- procedures, a new bound variable must be created for each copy, to
24323 -- prevent multiple declarations of the same symbol.
24325 -- To meet all these demands, routine New_Copy_Tree is split into two
24328 -- Phase 1 traverses the tree in order to locate entities and itypes
24329 -- defined within the subtree. New entities are generated and saved in
24330 -- table NCT_New_Entities. The semantic fields of all new entities and
24331 -- itypes are then updated accordingly.
24333 -- Phase 2 traverses the tree in order to replicate each node. Various
24334 -- semantic fields of nodes and entities are updated accordingly.
24336 -- Preparatory phase. Clear the contents of tables NCT_New_Entities and
24337 -- NCT_Pending_Itypes in case a previous call to New_Copy_Tree left some
24340 if NCT_Tables_In_Use
then
24341 NCT_Tables_In_Use
:= False;
24343 NCT_New_Entities
.Reset
;
24344 NCT_Pending_Itypes
.Reset
;
24347 -- Populate tables NCT_New_Entities and NCT_Pending_Itypes with data
24348 -- supplied by a linear entity map. The tables offer faster access to
24351 Build_NCT_Tables
(Map
);
24353 -- Execute Phase 1. Traverse the subtree and generate new entities for
24354 -- the following cases:
24356 -- * An entity defined within an N_Expression_With_Actions node
24358 -- * An itype referenced within the subtree where the associated node
24359 -- is also in the subtree.
24361 -- All new entities are accessible via table NCT_New_Entities, which
24362 -- contains mappings of the form:
24364 -- Old_Entity -> New_Entity
24365 -- Old_Itype -> New_Itype
24367 -- In addition, the associated nodes of all new itypes are mapped in
24368 -- table NCT_Pending_Itypes:
24370 -- Assoc_Nod -> (New_Itype1, New_Itype2, .., New_ItypeN)
24372 Visit_Any_Node
(Source
);
24374 -- Update the semantic attributes of all new entities generated during
24375 -- Phase 1 before starting Phase 2. The updates could be performed in
24376 -- routine Corresponding_Entity, however this may cause the same entity
24377 -- to be updated multiple times, effectively generating useless nodes.
24378 -- Keeping the updates separates from Phase 2 ensures that only one set
24379 -- of attributes is generated for an entity at any one time.
24381 Update_New_Entities
(Map
);
24383 -- Execute Phase 2. Replicate the source subtree one node at a time.
24384 -- The following transformations take place:
24386 -- * References to entities and itypes are updated to refer to the
24387 -- new entities and itypes generated during Phase 1.
24389 -- * All Associated_Node_For_Itype attributes of itypes are updated
24390 -- to refer to the new replicated Associated_Node_For_Itype.
24392 return Copy_Node_With_Replacement
(Source
);
24395 -------------------------
24396 -- New_External_Entity --
24397 -------------------------
24399 function New_External_Entity
24400 (Kind
: Entity_Kind
;
24401 Scope_Id
: Entity_Id
;
24402 Sloc_Value
: Source_Ptr
;
24403 Related_Id
: Entity_Id
;
24404 Suffix
: Character;
24405 Suffix_Index
: Int
:= 0;
24406 Prefix
: Character := ' ') return Entity_Id
24408 N
: constant Entity_Id
:=
24409 Make_Defining_Identifier
(Sloc_Value
,
24411 (Chars
(Related_Id
), Suffix
, Suffix_Index
, Prefix
));
24414 Mutate_Ekind
(N
, Kind
);
24415 Set_Is_Internal
(N
, True);
24416 Append_Entity
(N
, Scope_Id
);
24417 Set_Public_Status
(N
);
24419 if Kind
in Type_Kind
then
24420 Reinit_Size_Align
(N
);
24424 end New_External_Entity
;
24426 -------------------------
24427 -- New_Internal_Entity --
24428 -------------------------
24430 function New_Internal_Entity
24431 (Kind
: Entity_Kind
;
24432 Scope_Id
: Entity_Id
;
24433 Sloc_Value
: Source_Ptr
;
24434 Id_Char
: Character) return Entity_Id
24436 N
: constant Entity_Id
:= Make_Temporary
(Sloc_Value
, Id_Char
);
24439 Mutate_Ekind
(N
, Kind
);
24440 Set_Is_Internal
(N
, True);
24441 Append_Entity
(N
, Scope_Id
);
24443 if Kind
in Type_Kind
then
24444 Reinit_Size_Align
(N
);
24448 end New_Internal_Entity
;
24454 function Next_Actual
(Actual_Id
: Node_Id
) return Node_Id
is
24455 Par
: constant Node_Id
:= Parent
(Actual_Id
);
24459 -- If we are pointing at a positional parameter, it is a member of a
24460 -- node list (the list of parameters), and the next parameter is the
24461 -- next node on the list, unless we hit a parameter association, then
24462 -- we shift to using the chain whose head is the First_Named_Actual in
24463 -- the parent, and then is threaded using the Next_Named_Actual of the
24464 -- Parameter_Association. All this fiddling is because the original node
24465 -- list is in the textual call order, and what we need is the
24466 -- declaration order.
24468 if Is_List_Member
(Actual_Id
) then
24469 N
:= Next
(Actual_Id
);
24471 if Nkind
(N
) = N_Parameter_Association
then
24473 -- In case of a build-in-place call, the call will no longer be a
24474 -- call; it will have been rewritten.
24476 if Nkind
(Par
) in N_Entry_Call_Statement
24478 | N_Procedure_Call_Statement
24480 return First_Named_Actual
(Par
);
24482 -- In case of a call rewritten in GNATprove mode while "inlining
24483 -- for proof" go to the original call.
24485 elsif Nkind
(Par
) = N_Null_Statement
then
24489 Nkind
(Original_Node
(Par
)) in N_Subprogram_Call
);
24491 return First_Named_Actual
(Original_Node
(Par
));
24500 return Next_Named_Actual
(Parent
(Actual_Id
));
24504 procedure Next_Actual
(Actual_Id
: in out Node_Id
) is
24506 Actual_Id
:= Next_Actual
(Actual_Id
);
24513 function Next_Global
(Node
: Node_Id
) return Node_Id
is
24515 -- The global item may either be in a list, or by itself, in which case
24516 -- there is no next global item with the same mode.
24518 if Is_List_Member
(Node
) then
24519 return Next
(Node
);
24525 procedure Next_Global
(Node
: in out Node_Id
) is
24527 Node
:= Next_Global
(Node
);
24530 ------------------------
24531 -- No_Caching_Enabled --
24532 ------------------------
24534 function No_Caching_Enabled
(Id
: Entity_Id
) return Boolean is
24535 Prag
: constant Node_Id
:= Get_Pragma
(Id
, Pragma_No_Caching
);
24539 if Present
(Prag
) then
24540 Arg1
:= First
(Pragma_Argument_Associations
(Prag
));
24542 -- The pragma has an optional Boolean expression, the related
24543 -- property is enabled only when the expression evaluates to True.
24545 if Present
(Arg1
) then
24546 return Is_True
(Expr_Value
(Get_Pragma_Arg
(Arg1
)));
24548 -- Otherwise the lack of expression enables the property by
24555 -- The property was never set in the first place
24560 end No_Caching_Enabled
;
24562 --------------------------
24563 -- No_Heap_Finalization --
24564 --------------------------
24566 function No_Heap_Finalization
(Typ
: Entity_Id
) return Boolean is
24568 if Ekind
(Typ
) in E_Access_Type | E_General_Access_Type
24569 and then Is_Library_Level_Entity
(Typ
)
24571 -- A global No_Heap_Finalization pragma applies to all library-level
24572 -- named access-to-object types.
24574 if Present
(No_Heap_Finalization_Pragma
) then
24577 -- The library-level named access-to-object type itself is subject to
24578 -- pragma No_Heap_Finalization.
24580 elsif Present
(Get_Pragma
(Typ
, Pragma_No_Heap_Finalization
)) then
24586 end No_Heap_Finalization
;
24588 -----------------------
24589 -- Normalize_Actuals --
24590 -----------------------
24592 -- Chain actuals according to formals of subprogram. If there are no named
24593 -- associations, the chain is simply the list of Parameter Associations,
24594 -- since the order is the same as the declaration order. If there are named
24595 -- associations, then the First_Named_Actual field in the N_Function_Call
24596 -- or N_Procedure_Call_Statement node points to the Parameter_Association
24597 -- node for the parameter that comes first in declaration order. The
24598 -- remaining named parameters are then chained in declaration order using
24599 -- Next_Named_Actual.
24601 -- This routine also verifies that the number of actuals is compatible with
24602 -- the number and default values of formals, but performs no type checking
24603 -- (type checking is done by the caller).
24605 -- If the matching succeeds, Success is set to True and the caller proceeds
24606 -- with type-checking. If the match is unsuccessful, then Success is set to
24607 -- False, and the caller attempts a different interpretation, if there is
24610 -- If the flag Report is on, the call is not overloaded, and a failure to
24611 -- match can be reported here, rather than in the caller.
24613 procedure Normalize_Actuals
24617 Success
: out Boolean)
24619 Actuals
: constant List_Id
:= Parameter_Associations
(N
);
24620 Actual
: Node_Id
:= Empty
;
24621 Formal
: Entity_Id
;
24622 Last
: Node_Id
:= Empty
;
24623 First_Named
: Node_Id
:= Empty
;
24626 Formals_To_Match
: Integer := 0;
24627 Actuals_To_Match
: Integer := 0;
24629 procedure Chain
(A
: Node_Id
);
24630 -- Add named actual at the proper place in the list, using the
24631 -- Next_Named_Actual link.
24633 function Reporting
return Boolean;
24634 -- Determines if an error is to be reported. To report an error, we
24635 -- need Report to be True, and also we do not report errors caused
24636 -- by calls to init procs that occur within other init procs. Such
24637 -- errors must always be cascaded errors, since if all the types are
24638 -- declared correctly, the compiler will certainly build decent calls.
24644 procedure Chain
(A
: Node_Id
) is
24648 -- Call node points to first actual in list
24650 Set_First_Named_Actual
(N
, Explicit_Actual_Parameter
(A
));
24653 Set_Next_Named_Actual
(Last
, Explicit_Actual_Parameter
(A
));
24657 Set_Next_Named_Actual
(Last
, Empty
);
24664 function Reporting
return Boolean is
24669 elsif not Within_Init_Proc
then
24672 elsif Is_Init_Proc
(Entity
(Name
(N
))) then
24680 -- Start of processing for Normalize_Actuals
24683 if Is_Access_Type
(S
) then
24685 -- The name in the call is a function call that returns an access
24686 -- to subprogram. The designated type has the list of formals.
24688 Formal
:= First_Formal
(Designated_Type
(S
));
24690 Formal
:= First_Formal
(S
);
24693 while Present
(Formal
) loop
24694 Formals_To_Match
:= Formals_To_Match
+ 1;
24695 Next_Formal
(Formal
);
24698 -- Find if there is a named association, and verify that no positional
24699 -- associations appear after named ones.
24701 if Present
(Actuals
) then
24702 Actual
:= First
(Actuals
);
24705 while Present
(Actual
)
24706 and then Nkind
(Actual
) /= N_Parameter_Association
24708 Actuals_To_Match
:= Actuals_To_Match
+ 1;
24712 if No
(Actual
) and Actuals_To_Match
= Formals_To_Match
then
24714 -- Most common case: positional notation, no defaults
24719 elsif Actuals_To_Match
> Formals_To_Match
then
24721 -- Too many actuals: will not work
24724 if Is_Entity_Name
(Name
(N
)) then
24725 Error_Msg_N
("too many arguments in call to&", Name
(N
));
24727 Error_Msg_N
("too many arguments in call", N
);
24735 First_Named
:= Actual
;
24737 while Present
(Actual
) loop
24738 if Nkind
(Actual
) /= N_Parameter_Association
then
24740 ("positional parameters not allowed after named ones", Actual
);
24745 Actuals_To_Match
:= Actuals_To_Match
+ 1;
24751 if Present
(Actuals
) then
24752 Actual
:= First
(Actuals
);
24755 Formal
:= First_Formal
(S
);
24756 while Present
(Formal
) loop
24758 -- Match the formals in order. If the corresponding actual is
24759 -- positional, nothing to do. Else scan the list of named actuals
24760 -- to find the one with the right name.
24762 if Present
(Actual
)
24763 and then Nkind
(Actual
) /= N_Parameter_Association
24766 Actuals_To_Match
:= Actuals_To_Match
- 1;
24767 Formals_To_Match
:= Formals_To_Match
- 1;
24770 -- For named parameters, search the list of actuals to find
24771 -- one that matches the next formal name.
24773 Actual
:= First_Named
;
24775 while Present
(Actual
) loop
24776 if Chars
(Selector_Name
(Actual
)) = Chars
(Formal
) then
24779 Actuals_To_Match
:= Actuals_To_Match
- 1;
24780 Formals_To_Match
:= Formals_To_Match
- 1;
24788 if Ekind
(Formal
) /= E_In_Parameter
24789 or else No
(Default_Value
(Formal
))
24792 if (Comes_From_Source
(S
)
24793 or else Sloc
(S
) = Standard_Location
)
24794 and then Is_Overloadable
(S
)
24798 Nkind
(Parent
(N
)) in N_Procedure_Call_Statement
24800 | N_Parameter_Association
24801 and then Ekind
(S
) /= E_Function
24803 Set_Etype
(N
, Etype
(S
));
24806 Error_Msg_Name_1
:= Chars
(S
);
24807 Error_Msg_Sloc
:= Sloc
(S
);
24809 ("missing argument for parameter & "
24810 & "in call to % declared #", N
, Formal
);
24813 elsif Is_Overloadable
(S
) then
24814 Error_Msg_Name_1
:= Chars
(S
);
24816 -- Point to type derivation that generated the
24819 Error_Msg_Sloc
:= Sloc
(Parent
(S
));
24822 ("missing argument for parameter & "
24823 & "in call to % (inherited) #", N
, Formal
);
24827 ("missing argument for parameter &", N
, Formal
);
24835 Formals_To_Match
:= Formals_To_Match
- 1;
24840 Next_Formal
(Formal
);
24843 if Formals_To_Match
= 0 and then Actuals_To_Match
= 0 then
24850 -- Find some superfluous named actual that did not get
24851 -- attached to the list of associations.
24853 Actual
:= First
(Actuals
);
24854 while Present
(Actual
) loop
24855 if Nkind
(Actual
) = N_Parameter_Association
24856 and then Actual
/= Last
24857 and then No
(Next_Named_Actual
(Actual
))
24859 -- A validity check may introduce a copy of a call that
24860 -- includes an extra actual (for example for an unrelated
24861 -- accessibility check). Check that the extra actual matches
24862 -- some extra formal, which must exist already because
24863 -- subprogram must be frozen at this point.
24865 if Present
(Extra_Formals
(S
))
24866 and then not Comes_From_Source
(Actual
)
24867 and then Nkind
(Actual
) = N_Parameter_Association
24868 and then Chars
(Extra_Formals
(S
)) =
24869 Chars
(Selector_Name
(Actual
))
24874 ("unmatched actual & in call", Selector_Name
(Actual
));
24886 end Normalize_Actuals
;
24888 --------------------------------
24889 -- Note_Possible_Modification --
24890 --------------------------------
24892 procedure Note_Possible_Modification
(N
: Node_Id
; Sure
: Boolean) is
24893 Modification_Comes_From_Source
: constant Boolean :=
24894 Comes_From_Source
(Parent
(N
));
24900 -- Loop to find referenced entity, if there is one
24906 if Is_Entity_Name
(Exp
) then
24907 Ent
:= Entity
(Exp
);
24909 -- If the entity is missing, it is an undeclared identifier,
24910 -- and there is nothing to annotate.
24916 elsif Nkind
(Exp
) = N_Explicit_Dereference
then
24918 P
: constant Node_Id
:= Prefix
(Exp
);
24921 -- In formal verification mode, keep track of all reads and
24922 -- writes through explicit dereferences.
24924 if GNATprove_Mode
then
24925 SPARK_Specific
.Generate_Dereference
(N
, 'm');
24928 if Nkind
(P
) = N_Selected_Component
24929 and then Present
(Entry_Formal
(Entity
(Selector_Name
(P
))))
24931 -- Case of a reference to an entry formal
24933 Ent
:= Entry_Formal
(Entity
(Selector_Name
(P
)));
24935 elsif Nkind
(P
) = N_Identifier
24936 and then Nkind
(Parent
(Entity
(P
))) = N_Object_Declaration
24937 and then Present
(Expression
(Parent
(Entity
(P
))))
24938 and then Nkind
(Expression
(Parent
(Entity
(P
)))) =
24941 -- Case of a reference to a value on which side effects have
24944 Exp
:= Prefix
(Expression
(Parent
(Entity
(P
))));
24952 elsif Nkind
(Exp
) in N_Type_Conversion | N_Unchecked_Type_Conversion
24954 Exp
:= Expression
(Exp
);
24957 elsif Nkind
(Exp
) in
24958 N_Slice | N_Indexed_Component | N_Selected_Component
24960 -- Special check, if the prefix is an access type, then return
24961 -- since we are modifying the thing pointed to, not the prefix.
24962 -- When we are expanding, most usually the prefix is replaced
24963 -- by an explicit dereference, and this test is not needed, but
24964 -- in some cases (notably -gnatc mode and generics) when we do
24965 -- not do full expansion, we need this special test.
24967 if Is_Access_Type
(Etype
(Prefix
(Exp
))) then
24970 -- Otherwise go to prefix and keep going
24973 Exp
:= Prefix
(Exp
);
24977 -- All other cases, not a modification
24983 -- Now look for entity being referenced
24985 if Present
(Ent
) then
24986 if Is_Object
(Ent
) then
24987 if Comes_From_Source
(Exp
)
24988 or else Modification_Comes_From_Source
24990 -- Give warning if pragma unmodified is given and we are
24991 -- sure this is a modification.
24993 if Has_Pragma_Unmodified
(Ent
) and then Sure
then
24995 -- Note that the entity may be present only as a result
24996 -- of pragma Unused.
24998 if Has_Pragma_Unused
(Ent
) then
25000 ("??aspect Unused specified for &!", N
, Ent
);
25003 ("??aspect Unmodified specified for &!", N
, Ent
);
25007 Set_Never_Set_In_Source
(Ent
, False);
25010 Set_Is_True_Constant
(Ent
, False);
25011 Set_Current_Value
(Ent
, Empty
);
25012 Set_Is_Known_Null
(Ent
, False);
25014 if not Can_Never_Be_Null
(Ent
) then
25015 Set_Is_Known_Non_Null
(Ent
, False);
25018 -- Follow renaming chain
25020 if Ekind
(Ent
) in E_Variable | E_Constant
25021 and then Present
(Renamed_Object
(Ent
))
25023 Exp
:= Renamed_Object
(Ent
);
25025 -- If the entity is the loop variable in an iteration over
25026 -- a container, retrieve container expression to indicate
25027 -- possible modification.
25029 if Present
(Related_Expression
(Ent
))
25030 and then Nkind
(Parent
(Related_Expression
(Ent
))) =
25031 N_Iterator_Specification
25033 Exp
:= Original_Node
(Related_Expression
(Ent
));
25038 -- The expression may be the renaming of a subcomponent of an
25039 -- array or container. The assignment to the subcomponent is
25040 -- a modification of the container.
25042 elsif Comes_From_Source
(Original_Node
(Exp
))
25043 and then Nkind
(Original_Node
(Exp
)) in
25044 N_Selected_Component | N_Indexed_Component
25046 Exp
:= Prefix
(Original_Node
(Exp
));
25050 -- Generate a reference only if the assignment comes from
25051 -- source. This excludes, for example, calls to a dispatching
25052 -- assignment operation when the left-hand side is tagged. In
25053 -- GNATprove mode, we need those references also on generated
25054 -- code, as these are used to compute the local effects of
25057 if Modification_Comes_From_Source
or GNATprove_Mode
then
25058 Generate_Reference
(Ent
, Exp
, 'm');
25060 -- If the target of the assignment is the bound variable
25061 -- in an iterator, indicate that the corresponding array
25062 -- or container is also modified.
25064 if Ada_Version
>= Ada_2012
25065 and then Nkind
(Parent
(Ent
)) = N_Iterator_Specification
25068 Domain
: constant Node_Id
:= Name
(Parent
(Ent
));
25071 -- ??? In the full version of the construct, the
25072 -- domain of iteration can be given by an expression.
25074 if Is_Entity_Name
(Domain
) then
25075 Generate_Reference
(Entity
(Domain
), Exp
, 'm');
25076 Set_Is_True_Constant
(Entity
(Domain
), False);
25077 Set_Never_Set_In_Source
(Entity
(Domain
), False);
25086 -- If we are sure this is a modification from source, and we know
25087 -- this modifies a constant, then give an appropriate warning.
25090 and then Modification_Comes_From_Source
25091 and then Overlays_Constant
(Ent
)
25092 and then Address_Clause_Overlay_Warnings
25095 Addr
: constant Node_Id
:= Address_Clause
(Ent
);
25100 Find_Overlaid_Entity
(Addr
, O_Ent
, Off
);
25102 Error_Msg_Sloc
:= Sloc
(Addr
);
25104 ("?o?constant& may be modified via address clause#",
25115 end Note_Possible_Modification
;
25121 function Null_Status
(N
: Node_Id
) return Null_Status_Kind
is
25122 function Is_Null_Excluding_Def
(Def
: Node_Id
) return Boolean;
25123 -- Determine whether definition Def carries a null exclusion
25125 function Null_Status_Of_Entity
(Id
: Entity_Id
) return Null_Status_Kind
;
25126 -- Determine the null status of arbitrary entity Id
25128 function Null_Status_Of_Type
(Typ
: Entity_Id
) return Null_Status_Kind
;
25129 -- Determine the null status of type Typ
25131 ---------------------------
25132 -- Is_Null_Excluding_Def --
25133 ---------------------------
25135 function Is_Null_Excluding_Def
(Def
: Node_Id
) return Boolean is
25137 return Nkind
(Def
) in N_Access_Definition
25138 | N_Access_Function_Definition
25139 | N_Access_Procedure_Definition
25140 | N_Access_To_Object_Definition
25141 | N_Component_Definition
25142 | N_Derived_Type_Definition
25143 and then Null_Exclusion_Present
(Def
);
25144 end Is_Null_Excluding_Def
;
25146 ---------------------------
25147 -- Null_Status_Of_Entity --
25148 ---------------------------
25150 function Null_Status_Of_Entity
25151 (Id
: Entity_Id
) return Null_Status_Kind
25153 Decl
: constant Node_Id
:= Declaration_Node
(Id
);
25157 -- The value of an imported or exported entity may be set externally
25158 -- regardless of a null exclusion. As a result, the value cannot be
25159 -- determined statically.
25161 if Is_Imported
(Id
) or else Is_Exported
(Id
) then
25164 elsif Nkind
(Decl
) in N_Component_Declaration
25165 | N_Discriminant_Specification
25166 | N_Formal_Object_Declaration
25167 | N_Object_Declaration
25168 | N_Object_Renaming_Declaration
25169 | N_Parameter_Specification
25171 -- A component declaration yields a non-null value when either
25172 -- its component definition or access definition carries a null
25175 if Nkind
(Decl
) = N_Component_Declaration
then
25176 Def
:= Component_Definition
(Decl
);
25178 if Is_Null_Excluding_Def
(Def
) then
25179 return Is_Non_Null
;
25182 Def
:= Access_Definition
(Def
);
25184 if Present
(Def
) and then Is_Null_Excluding_Def
(Def
) then
25185 return Is_Non_Null
;
25188 -- A formal object declaration yields a non-null value if its
25189 -- access definition carries a null exclusion. If the object is
25190 -- default initialized, then the value depends on the expression.
25192 elsif Nkind
(Decl
) = N_Formal_Object_Declaration
then
25193 Def
:= Access_Definition
(Decl
);
25195 if Present
(Def
) and then Is_Null_Excluding_Def
(Def
) then
25196 return Is_Non_Null
;
25199 -- A constant may yield a null or non-null value depending on its
25200 -- initialization expression.
25202 elsif Ekind
(Id
) = E_Constant
then
25203 return Null_Status
(Constant_Value
(Id
));
25205 -- The construct yields a non-null value when it has a null
25208 elsif Null_Exclusion_Present
(Decl
) then
25209 return Is_Non_Null
;
25211 -- An object renaming declaration yields a non-null value if its
25212 -- access definition carries a null exclusion. Otherwise the value
25213 -- depends on the renamed name.
25215 elsif Nkind
(Decl
) = N_Object_Renaming_Declaration
then
25216 Def
:= Access_Definition
(Decl
);
25218 if Present
(Def
) and then Is_Null_Excluding_Def
(Def
) then
25219 return Is_Non_Null
;
25222 return Null_Status
(Name
(Decl
));
25227 -- At this point the declaration of the entity does not carry a null
25228 -- exclusion and lacks an initialization expression. Check the status
25231 return Null_Status_Of_Type
(Etype
(Id
));
25232 end Null_Status_Of_Entity
;
25234 -------------------------
25235 -- Null_Status_Of_Type --
25236 -------------------------
25238 function Null_Status_Of_Type
(Typ
: Entity_Id
) return Null_Status_Kind
is
25243 -- Traverse the type chain looking for types with null exclusion
25246 while Present
(Curr
) and then Etype
(Curr
) /= Curr
loop
25247 Decl
:= Parent
(Curr
);
25249 -- Guard against itypes which do not always have declarations. A
25250 -- type yields a non-null value if it carries a null exclusion.
25252 if Present
(Decl
) then
25253 if Nkind
(Decl
) = N_Full_Type_Declaration
25254 and then Is_Null_Excluding_Def
(Type_Definition
(Decl
))
25256 return Is_Non_Null
;
25258 elsif Nkind
(Decl
) = N_Subtype_Declaration
25259 and then Null_Exclusion_Present
(Decl
)
25261 return Is_Non_Null
;
25265 Curr
:= Etype
(Curr
);
25268 -- The type chain does not contain any null excluding types
25271 end Null_Status_Of_Type
;
25273 -- Start of processing for Null_Status
25276 -- Prevent cascaded errors or infinite loops when trying to determine
25277 -- the null status of an erroneous construct.
25279 if Error_Posted
(N
) then
25282 -- An allocator always creates a non-null value
25284 elsif Nkind
(N
) = N_Allocator
then
25285 return Is_Non_Null
;
25287 -- Taking the 'Access of something yields a non-null value
25289 elsif Nkind
(N
) = N_Attribute_Reference
25290 and then Attribute_Name
(N
) in Name_Access
25291 | Name_Unchecked_Access
25292 | Name_Unrestricted_Access
25294 return Is_Non_Null
;
25296 -- "null" yields null
25298 elsif Nkind
(N
) = N_Null
then
25301 -- Check the status of the operand of a type conversion
25303 elsif Nkind
(N
) in N_Type_Conversion | N_Unchecked_Type_Conversion
then
25304 return Null_Status
(Expression
(N
));
25306 -- The input denotes a reference to an entity. Determine whether the
25307 -- entity or its type yields a null or non-null value.
25309 elsif Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
25310 return Null_Status_Of_Entity
(Entity
(N
));
25313 -- Otherwise it is not possible to determine the null status of the
25314 -- subexpression at compile time without resorting to simple flow
25320 --------------------------------------
25321 -- Null_To_Null_Address_Convert_OK --
25322 --------------------------------------
25324 function Null_To_Null_Address_Convert_OK
25326 Typ
: Entity_Id
:= Empty
) return Boolean
25329 if not Relaxed_RM_Semantics
then
25333 if Nkind
(N
) = N_Null
then
25334 return Present
(Typ
) and then Is_Descendant_Of_Address
(Typ
);
25336 elsif Nkind
(N
) in N_Op_Compare
then
25338 L
: constant Node_Id
:= Left_Opnd
(N
);
25339 R
: constant Node_Id
:= Right_Opnd
(N
);
25342 -- We check the Etype of the complementary operand since the
25343 -- N_Null node is not decorated at this stage.
25346 ((Nkind
(L
) = N_Null
25347 and then Is_Descendant_Of_Address
(Etype
(R
)))
25349 (Nkind
(R
) = N_Null
25350 and then Is_Descendant_Of_Address
(Etype
(L
))));
25355 end Null_To_Null_Address_Convert_OK
;
25357 ---------------------------------
25358 -- Number_Of_Elements_In_Array --
25359 ---------------------------------
25361 function Number_Of_Elements_In_Array
(T
: Entity_Id
) return Int
is
25369 pragma Assert
(Is_Array_Type
(T
));
25371 Indx
:= First_Index
(T
);
25372 while Present
(Indx
) loop
25373 Typ
:= Underlying_Type
(Etype
(Indx
));
25375 -- Never look at junk bounds of a generic type
25377 if Is_Generic_Type
(Typ
) then
25381 -- Check the array bounds are known at compile time and return zero
25382 -- if they are not.
25384 Low
:= Type_Low_Bound
(Typ
);
25385 High
:= Type_High_Bound
(Typ
);
25387 if not Compile_Time_Known_Value
(Low
) then
25389 elsif not Compile_Time_Known_Value
(High
) then
25393 Num
* UI_To_Int
((Expr_Value
(High
) - Expr_Value
(Low
) + 1));
25400 end Number_Of_Elements_In_Array
;
25402 ---------------------------------
25403 -- Original_Aspect_Pragma_Name --
25404 ---------------------------------
25406 function Original_Aspect_Pragma_Name
(N
: Node_Id
) return Name_Id
is
25408 Item_Nam
: Name_Id
;
25411 pragma Assert
(Nkind
(N
) in N_Aspect_Specification | N_Pragma
);
25415 -- The pragma was generated to emulate an aspect, use the original
25416 -- aspect specification.
25418 if Nkind
(Item
) = N_Pragma
and then From_Aspect_Specification
(Item
) then
25419 Item
:= Corresponding_Aspect
(Item
);
25422 -- Retrieve the name of the aspect/pragma. As assertion pragmas from
25423 -- a generic instantiation might have been rewritten into pragma Check,
25424 -- we look at the original node for Item. Note also that Pre, Pre_Class,
25425 -- Post and Post_Class rewrite their pragma identifier to preserve the
25426 -- original name, so we look at the original node for the identifier.
25427 -- ??? this is kludgey
25429 if Nkind
(Item
) = N_Pragma
then
25431 Chars
(Original_Node
(Pragma_Identifier
(Original_Node
(Item
))));
25433 if Item_Nam
= Name_Check
then
25434 -- Pragma "Check" preserves the original pragma name as its first
25437 Chars
(Expression
(First
(Pragma_Argument_Associations
25438 (Original_Node
(Item
)))));
25442 pragma Assert
(Nkind
(Item
) = N_Aspect_Specification
);
25443 Item_Nam
:= Chars
(Identifier
(Item
));
25446 -- Deal with 'Class by converting the name to its _XXX form
25448 if Class_Present
(Item
) then
25449 if Item_Nam
= Name_Invariant
then
25450 Item_Nam
:= Name_uInvariant
;
25452 elsif Item_Nam
= Name_Post
then
25453 Item_Nam
:= Name_uPost
;
25455 elsif Item_Nam
= Name_Pre
then
25456 Item_Nam
:= Name_uPre
;
25458 elsif Item_Nam
in Name_Type_Invariant | Name_Type_Invariant_Class
25460 Item_Nam
:= Name_uType_Invariant
;
25462 -- Nothing to do for other cases (e.g. a Check that derived from
25463 -- Pre_Class and has the flag set). Also we do nothing if the name
25464 -- is already in special _xxx form.
25470 end Original_Aspect_Pragma_Name
;
25472 --------------------------------------
25473 -- Original_Corresponding_Operation --
25474 --------------------------------------
25476 function Original_Corresponding_Operation
(S
: Entity_Id
) return Entity_Id
25478 Typ
: constant Entity_Id
:= Find_Dispatching_Type
(S
);
25481 -- If S is an inherited primitive S2 the original corresponding
25482 -- operation of S is the original corresponding operation of S2
25484 if Present
(Alias
(S
))
25485 and then Find_Dispatching_Type
(Alias
(S
)) /= Typ
25487 return Original_Corresponding_Operation
(Alias
(S
));
25489 -- If S overrides an inherited subprogram S2 the original corresponding
25490 -- operation of S is the original corresponding operation of S2
25492 elsif Present
(Overridden_Operation
(S
)) then
25493 return Original_Corresponding_Operation
(Overridden_Operation
(S
));
25495 -- otherwise it is S itself
25500 end Original_Corresponding_Operation
;
25502 -----------------------------------
25503 -- Original_View_In_Visible_Part --
25504 -----------------------------------
25506 function Original_View_In_Visible_Part
25507 (Typ
: Entity_Id
) return Boolean
25509 Scop
: constant Entity_Id
:= Scope
(Typ
);
25512 -- The scope must be a package
25514 if not Is_Package_Or_Generic_Package
(Scop
) then
25518 -- A type with a private declaration has a private view declared in
25519 -- the visible part.
25521 if Has_Private_Declaration
(Typ
) then
25525 return List_Containing
(Parent
(Typ
)) =
25526 Visible_Declarations
(Package_Specification
(Scop
));
25527 end Original_View_In_Visible_Part
;
25529 -------------------
25530 -- Output_Entity --
25531 -------------------
25533 procedure Output_Entity
(Id
: Entity_Id
) is
25537 Scop
:= Scope
(Id
);
25539 -- The entity may lack a scope when it is in the process of being
25540 -- analyzed. Use the current scope as an approximation.
25543 Scop
:= Current_Scope
;
25546 Output_Name
(Chars
(Id
), Scop
);
25553 procedure Output_Name
(Nam
: Name_Id
; Scop
: Entity_Id
:= Current_Scope
) is
25557 (Get_Qualified_Name
25568 -- This would be trivial, simply a test for an identifier that was a
25569 -- reference to a formal, if it were not for the fact that a previous call
25570 -- to Expand_Entry_Parameter will have modified the reference to the
25571 -- identifier. A formal of a protected entity is rewritten as
25573 -- typ!(recobj).rec.all'Constrained
25575 -- where rec is a selector whose Entry_Formal link points to the formal
25577 -- If the type of the entry parameter has a representation clause, then an
25578 -- extra temp is involved (see below).
25580 -- For a formal of a task entity, the formal is rewritten as a local
25583 -- In addition, a formal that is marked volatile because it is aliased
25584 -- through an address clause is rewritten as dereference as well.
25586 function Param_Entity
(N
: Node_Id
) return Entity_Id
is
25587 Renamed_Obj
: Node_Id
;
25590 -- Simple reference case
25592 if Nkind
(N
) in N_Identifier | N_Expanded_Name
then
25593 if Is_Formal
(Entity
(N
)) then
25596 -- Handle renamings of formal parameters and formals of tasks that
25597 -- are rewritten as renamings.
25599 elsif Nkind
(Parent
(Entity
(N
))) = N_Object_Renaming_Declaration
then
25600 Renamed_Obj
:= Get_Referenced_Object
(Renamed_Object
(Entity
(N
)));
25602 if Is_Entity_Name
(Renamed_Obj
)
25603 and then Is_Formal
(Entity
(Renamed_Obj
))
25605 return Entity
(Renamed_Obj
);
25608 Nkind
(Parent
(Parent
(Entity
(N
)))) = N_Accept_Statement
25615 if Nkind
(N
) = N_Explicit_Dereference
then
25617 P
: Node_Id
:= Prefix
(N
);
25623 -- If the type of an entry parameter has a representation
25624 -- clause, then the prefix is not a selected component, but
25625 -- instead a reference to a temp pointing at the selected
25626 -- component. In this case, set P to be the initial value of
25629 if Nkind
(P
) = N_Identifier
then
25632 if Ekind
(E
) = E_Constant
then
25633 Decl
:= Parent
(E
);
25635 if Nkind
(Decl
) = N_Object_Declaration
then
25636 P
:= Expression
(Decl
);
25641 if Nkind
(P
) = N_Selected_Component
then
25642 S
:= Selector_Name
(P
);
25644 if Present
(Entry_Formal
(Entity
(S
))) then
25645 return Entry_Formal
(Entity
(S
));
25648 elsif Nkind
(Original_Node
(N
)) = N_Identifier
then
25649 return Param_Entity
(Original_Node
(N
));
25658 ----------------------
25659 -- Policy_In_Effect --
25660 ----------------------
25662 function Policy_In_Effect
(Policy
: Name_Id
) return Name_Id
is
25663 function Policy_In_List
(List
: Node_Id
) return Name_Id
;
25664 -- Determine the mode of a policy in a N_Pragma list
25666 --------------------
25667 -- Policy_In_List --
25668 --------------------
25670 function Policy_In_List
(List
: Node_Id
) return Name_Id
is
25677 while Present
(Prag
) loop
25678 Arg1
:= First
(Pragma_Argument_Associations
(Prag
));
25679 Arg2
:= Next
(Arg1
);
25681 Arg1
:= Get_Pragma_Arg
(Arg1
);
25682 Arg2
:= Get_Pragma_Arg
(Arg2
);
25684 -- The current Check_Policy pragma matches the requested policy or
25685 -- appears in the single argument form (Assertion, policy_id).
25687 if Chars
(Arg1
) in Name_Assertion | Policy
then
25688 return Chars
(Arg2
);
25691 Prag
:= Next_Pragma
(Prag
);
25695 end Policy_In_List
;
25701 -- Start of processing for Policy_In_Effect
25704 if not Is_Valid_Assertion_Kind
(Policy
) then
25705 raise Program_Error
;
25708 -- Inspect all policy pragmas that appear within scopes (if any)
25710 Kind
:= Policy_In_List
(Check_Policy_List
);
25712 -- Inspect all configuration policy pragmas (if any)
25714 if Kind
= No_Name
then
25715 Kind
:= Policy_In_List
(Check_Policy_List_Config
);
25718 -- The context lacks policy pragmas, determine the mode based on whether
25719 -- assertions are enabled at the configuration level. This ensures that
25720 -- the policy is preserved when analyzing generics.
25722 if Kind
= No_Name
then
25723 if Assertions_Enabled_Config
then
25724 Kind
:= Name_Check
;
25726 Kind
:= Name_Ignore
;
25730 -- In CodePeer mode and GNATprove mode, we need to consider all
25731 -- assertions, unless they are disabled. Force Name_Check on
25732 -- ignored assertions.
25734 if Kind
in Name_Ignore | Name_Off
25735 and then (CodePeer_Mode
or GNATprove_Mode
)
25737 Kind
:= Name_Check
;
25741 end Policy_In_Effect
;
25743 -------------------------------
25744 -- Preanalyze_Without_Errors --
25745 -------------------------------
25747 procedure Preanalyze_Without_Errors
(N
: Node_Id
) is
25748 Status
: constant Boolean := Get_Ignore_Errors
;
25750 Set_Ignore_Errors
(True);
25752 Set_Ignore_Errors
(Status
);
25753 end Preanalyze_Without_Errors
;
25755 -----------------------
25756 -- Predicate_Enabled --
25757 -----------------------
25759 function Predicate_Enabled
(Typ
: Entity_Id
) return Boolean is
25761 return Present
(Predicate_Function
(Typ
))
25762 and then not Predicates_Ignored
(Typ
)
25763 and then not Predicate_Checks_Suppressed
(Empty
);
25764 end Predicate_Enabled
;
25766 ----------------------------------
25767 -- Predicate_Failure_Expression --
25768 ----------------------------------
25770 function Predicate_Failure_Expression
25771 (Typ
: Entity_Id
; Inherited_OK
: Boolean) return Node_Id
25773 PF_Aspect
: constant Node_Id
:=
25774 Find_Aspect
(Typ
, Aspect_Predicate_Failure
);
25776 -- Check for Predicate_Failure aspect specification via an
25777 -- aspect_specification (as opposed to via a pragma).
25779 if Present
(PF_Aspect
) then
25780 if Inherited_OK
or else Entity
(PF_Aspect
) = Typ
then
25781 return Expression
(PF_Aspect
);
25787 -- Check for Predicate_Failure aspect specification via a pragma.
25790 Rep_Item
: Node_Id
:= First_Rep_Item
(Typ
);
25792 while Present
(Rep_Item
) loop
25793 if Nkind
(Rep_Item
) = N_Pragma
25794 and then Get_Pragma_Id
(Rep_Item
) = Pragma_Predicate_Failure
25797 Arg1
: constant Node_Id
:=
25799 (First
(Pragma_Argument_Associations
(Rep_Item
)));
25800 Arg2
: constant Node_Id
:=
25802 (Next
(First
(Pragma_Argument_Associations
(Rep_Item
))));
25804 if Inherited_OK
or else
25805 (Nkind
(Arg1
) in N_Has_Entity
25806 and then Entity
(Arg1
) = Typ
)
25813 Next_Rep_Item
(Rep_Item
);
25817 -- If we are interested in an inherited Predicate_Failure aspect
25818 -- and we have an ancestor to inherit from, then recursively check
25821 if Inherited_OK
and then Present
(Nearest_Ancestor
(Typ
)) then
25822 return Predicate_Failure_Expression
(Nearest_Ancestor
(Typ
),
25823 Inherited_OK
=> True);
25827 end Predicate_Failure_Expression
;
25829 ----------------------------------
25830 -- Predicate_Tests_On_Arguments --
25831 ----------------------------------
25833 function Predicate_Tests_On_Arguments
(Subp
: Entity_Id
) return Boolean is
25835 -- Always test predicates on indirect call
25837 if Ekind
(Subp
) = E_Subprogram_Type
then
25840 -- Do not test predicates on call to generated default Finalize, since
25841 -- we are not interested in whether something we are finalizing (and
25842 -- typically destroying) satisfies its predicates.
25844 elsif Chars
(Subp
) = Name_Finalize
25845 and then not Comes_From_Source
(Subp
)
25849 -- Do not test predicates on any internally generated routines
25851 elsif Is_Internal_Name
(Chars
(Subp
)) then
25854 -- Do not test predicates on call to Init_Proc, since if needed the
25855 -- predicate test will occur at some other point.
25857 elsif Is_Init_Proc
(Subp
) then
25860 -- Do not test predicates on call to predicate function, since this
25861 -- would cause infinite recursion.
25863 elsif Ekind
(Subp
) = E_Function
25864 and then Is_Predicate_Function
(Subp
)
25868 -- For now, no other exceptions
25873 end Predicate_Tests_On_Arguments
;
25875 -----------------------
25876 -- Private_Component --
25877 -----------------------
25879 function Private_Component
(Type_Id
: Entity_Id
) return Entity_Id
is
25880 Ancestor
: constant Entity_Id
:= Base_Type
(Type_Id
);
25882 function Trace_Components
25884 Check
: Boolean) return Entity_Id
;
25885 -- Recursive function that does the work, and checks against circular
25886 -- definition for each subcomponent type.
25888 ----------------------
25889 -- Trace_Components --
25890 ----------------------
25892 function Trace_Components
25894 Check
: Boolean) return Entity_Id
25896 Btype
: constant Entity_Id
:= Base_Type
(T
);
25897 Component
: Entity_Id
;
25899 Candidate
: Entity_Id
:= Empty
;
25902 if Check
and then Btype
= Ancestor
then
25903 Error_Msg_N
("circular type definition", Type_Id
);
25907 if Is_Private_Type
(Btype
) and then not Is_Generic_Type
(Btype
) then
25908 if Present
(Full_View
(Btype
))
25909 and then Is_Record_Type
(Full_View
(Btype
))
25910 and then not Is_Frozen
(Btype
)
25912 -- To indicate that the ancestor depends on a private type, the
25913 -- current Btype is sufficient. However, to check for circular
25914 -- definition we must recurse on the full view.
25916 Candidate
:= Trace_Components
(Full_View
(Btype
), True);
25918 if Candidate
= Any_Type
then
25928 elsif Is_Array_Type
(Btype
) then
25929 return Trace_Components
(Component_Type
(Btype
), True);
25931 elsif Is_Record_Type
(Btype
) then
25932 Component
:= First_Entity
(Btype
);
25933 while Present
(Component
)
25934 and then Comes_From_Source
(Component
)
25936 -- Skip anonymous types generated by constrained components
25938 if not Is_Type
(Component
) then
25939 P
:= Trace_Components
(Etype
(Component
), True);
25941 if Present
(P
) then
25942 if P
= Any_Type
then
25950 Next_Entity
(Component
);
25958 end Trace_Components
;
25960 -- Start of processing for Private_Component
25963 return Trace_Components
(Type_Id
, False);
25964 end Private_Component
;
25966 ---------------------------
25967 -- Primitive_Names_Match --
25968 ---------------------------
25970 function Primitive_Names_Match
(E1
, E2
: Entity_Id
) return Boolean is
25971 function Non_Internal_Name
(E
: Entity_Id
) return Name_Id
;
25972 -- Given an internal name, returns the corresponding non-internal name
25974 ------------------------
25975 -- Non_Internal_Name --
25976 ------------------------
25978 function Non_Internal_Name
(E
: Entity_Id
) return Name_Id
is
25980 Get_Name_String
(Chars
(E
));
25981 Name_Len
:= Name_Len
- 1;
25983 end Non_Internal_Name
;
25985 -- Start of processing for Primitive_Names_Match
25988 pragma Assert
(Present
(E1
) and then Present
(E2
));
25990 return Chars
(E1
) = Chars
(E2
)
25992 (not Is_Internal_Name
(Chars
(E1
))
25993 and then Is_Internal_Name
(Chars
(E2
))
25994 and then Non_Internal_Name
(E2
) = Chars
(E1
))
25996 (not Is_Internal_Name
(Chars
(E2
))
25997 and then Is_Internal_Name
(Chars
(E1
))
25998 and then Non_Internal_Name
(E1
) = Chars
(E2
))
26000 (Is_Predefined_Dispatching_Operation
(E1
)
26001 and then Is_Predefined_Dispatching_Operation
(E2
)
26002 and then Same_TSS
(E1
, E2
))
26004 (Is_Init_Proc
(E1
) and then Is_Init_Proc
(E2
));
26005 end Primitive_Names_Match
;
26007 -----------------------
26008 -- Process_End_Label --
26009 -----------------------
26011 procedure Process_End_Label
26020 Label_Ref
: Boolean;
26021 -- Set True if reference to end label itself is required
26024 -- Gets set to the operator symbol or identifier that references the
26025 -- entity Ent. For the child unit case, this is the identifier from the
26026 -- designator. For other cases, this is simply Endl.
26028 procedure Generate_Parent_Ref
(N
: Node_Id
; E
: Entity_Id
);
26029 -- N is an identifier node that appears as a parent unit reference in
26030 -- the case where Ent is a child unit. This procedure generates an
26031 -- appropriate cross-reference entry. E is the corresponding entity.
26033 -------------------------
26034 -- Generate_Parent_Ref --
26035 -------------------------
26037 procedure Generate_Parent_Ref
(N
: Node_Id
; E
: Entity_Id
) is
26039 -- If names do not match, something weird, skip reference
26041 if Chars
(E
) = Chars
(N
) then
26043 -- Generate the reference. We do NOT consider this as a reference
26044 -- for unreferenced symbol purposes.
26046 Generate_Reference
(E
, N
, 'r', Set_Ref
=> False, Force
=> True);
26048 if Style_Check
then
26049 Style
.Check_Identifier
(N
, E
);
26052 end Generate_Parent_Ref
;
26054 -- Start of processing for Process_End_Label
26057 -- If no node, ignore. This happens in some error situations, and
26058 -- also for some internally generated structures where no end label
26059 -- references are required in any case.
26065 -- Nothing to do if no End_Label, happens for internally generated
26066 -- constructs where we don't want an end label reference anyway. Also
26067 -- nothing to do if Endl is a string literal, which means there was
26068 -- some prior error (bad operator symbol)
26070 Endl
:= End_Label
(N
);
26072 if No
(Endl
) or else Nkind
(Endl
) = N_String_Literal
then
26076 -- Reference node is not in extended main source unit
26078 if not In_Extended_Main_Source_Unit
(N
) then
26080 -- Generally we do not collect references except for the extended
26081 -- main source unit. The one exception is the 'e' entry for a
26082 -- package spec, where it is useful for a client to have the
26083 -- ending information to define scopes.
26089 Label_Ref
:= False;
26091 -- For this case, we can ignore any parent references, but we
26092 -- need the package name itself for the 'e' entry.
26094 if Nkind
(Endl
) = N_Designator
then
26095 Endl
:= Identifier
(Endl
);
26099 -- Reference is in extended main source unit
26104 -- For designator, generate references for the parent entries
26106 if Nkind
(Endl
) = N_Designator
then
26108 -- Generate references for the prefix if the END line comes from
26109 -- source (otherwise we do not need these references) We climb the
26110 -- scope stack to find the expected entities.
26112 if Comes_From_Source
(Endl
) then
26113 Nam
:= Name
(Endl
);
26114 Scop
:= Current_Scope
;
26115 while Nkind
(Nam
) = N_Selected_Component
loop
26116 Scop
:= Scope
(Scop
);
26117 exit when No
(Scop
);
26118 Generate_Parent_Ref
(Selector_Name
(Nam
), Scop
);
26119 Nam
:= Prefix
(Nam
);
26122 if Present
(Scop
) then
26123 Generate_Parent_Ref
(Nam
, Scope
(Scop
));
26127 Endl
:= Identifier
(Endl
);
26131 -- If the end label is not for the given entity, then either we have
26132 -- some previous error, or this is a generic instantiation for which
26133 -- we do not need to make a cross-reference in this case anyway. In
26134 -- either case we simply ignore the call.
26136 if Chars
(Ent
) /= Chars
(Endl
) then
26140 -- If label was really there, then generate a normal reference and then
26141 -- adjust the location in the end label to point past the name (which
26142 -- should almost always be the semicolon).
26144 Loc
:= Sloc
(Endl
);
26146 if Comes_From_Source
(Endl
) then
26148 -- If a label reference is required, then do the style check and
26149 -- generate an l-type cross-reference entry for the label
26152 if Style_Check
then
26153 Style
.Check_Identifier
(Endl
, Ent
);
26156 Generate_Reference
(Ent
, Endl
, 'l', Set_Ref
=> False);
26159 -- Set the location to point past the label (normally this will
26160 -- mean the semicolon immediately following the label). This is
26161 -- done for the sake of the 'e' or 't' entry generated below.
26163 Get_Decoded_Name_String
(Chars
(Endl
));
26164 Set_Sloc
(Endl
, Sloc
(Endl
) + Source_Ptr
(Name_Len
));
26167 -- Now generate the e/t reference
26169 Generate_Reference
(Ent
, Endl
, Typ
, Set_Ref
=> False, Force
=> True);
26171 -- Restore Sloc, in case modified above, since we have an identifier
26172 -- and the normal Sloc should be left set in the tree.
26174 Set_Sloc
(Endl
, Loc
);
26175 end Process_End_Label
;
26177 --------------------------------
26178 -- Propagate_Concurrent_Flags --
26179 --------------------------------
26181 procedure Propagate_Concurrent_Flags
26183 Comp_Typ
: Entity_Id
)
26186 if Has_Task
(Comp_Typ
) then
26187 Set_Has_Task
(Typ
);
26190 if Has_Protected
(Comp_Typ
) then
26191 Set_Has_Protected
(Typ
);
26194 if Has_Timing_Event
(Comp_Typ
) then
26195 Set_Has_Timing_Event
(Typ
);
26197 end Propagate_Concurrent_Flags
;
26199 ------------------------------
26200 -- Propagate_DIC_Attributes --
26201 ------------------------------
26203 procedure Propagate_DIC_Attributes
26205 From_Typ
: Entity_Id
)
26207 DIC_Proc
: Entity_Id
;
26208 Partial_DIC_Proc
: Entity_Id
;
26211 if Present
(Typ
) and then Present
(From_Typ
) then
26212 pragma Assert
(Is_Type
(Typ
) and then Is_Type
(From_Typ
));
26214 -- Nothing to do if both the source and the destination denote the
26217 if From_Typ
= Typ
then
26220 -- Nothing to do when the destination denotes an incomplete type
26221 -- because the DIC is associated with the current instance of a
26222 -- private type, thus it can never apply to an incomplete type.
26224 elsif Is_Incomplete_Type
(Typ
) then
26228 DIC_Proc
:= DIC_Procedure
(From_Typ
);
26229 Partial_DIC_Proc
:= Partial_DIC_Procedure
(From_Typ
);
26231 -- The setting of the attributes is intentionally conservative. This
26232 -- prevents accidental clobbering of enabled attributes. We need to
26233 -- call Base_Type twice, because it is sometimes not set to an actual
26236 if Has_Inherited_DIC
(From_Typ
) then
26237 Set_Has_Inherited_DIC
(Base_Type
(Base_Type
(Typ
)));
26240 if Has_Own_DIC
(From_Typ
) then
26241 Set_Has_Own_DIC
(Base_Type
(Base_Type
(Typ
)));
26244 if Present
(DIC_Proc
) and then No
(DIC_Procedure
(Typ
)) then
26245 Set_DIC_Procedure
(Typ
, DIC_Proc
);
26248 if Present
(Partial_DIC_Proc
)
26249 and then No
(Partial_DIC_Procedure
(Typ
))
26251 Set_Partial_DIC_Procedure
(Typ
, Partial_DIC_Proc
);
26254 end Propagate_DIC_Attributes
;
26256 ------------------------------------
26257 -- Propagate_Invariant_Attributes --
26258 ------------------------------------
26260 procedure Propagate_Invariant_Attributes
26262 From_Typ
: Entity_Id
)
26264 Full_IP
: Entity_Id
;
26265 Part_IP
: Entity_Id
;
26268 if Present
(Typ
) and then Present
(From_Typ
) then
26269 pragma Assert
(Is_Type
(Typ
) and then Is_Type
(From_Typ
));
26271 -- Nothing to do if both the source and the destination denote the
26274 if From_Typ
= Typ
then
26278 Full_IP
:= Invariant_Procedure
(From_Typ
);
26279 Part_IP
:= Partial_Invariant_Procedure
(From_Typ
);
26281 -- The setting of the attributes is intentionally conservative. This
26282 -- prevents accidental clobbering of enabled attributes. We need to
26283 -- call Base_Type twice, because it is sometimes not set to an actual
26286 if Has_Inheritable_Invariants
(From_Typ
) then
26287 Set_Has_Inheritable_Invariants
(Base_Type
(Base_Type
(Typ
)));
26290 if Has_Inherited_Invariants
(From_Typ
) then
26291 Set_Has_Inherited_Invariants
(Base_Type
(Base_Type
(Typ
)));
26294 if Has_Own_Invariants
(From_Typ
) then
26295 Set_Has_Own_Invariants
(Base_Type
(Base_Type
(Typ
)));
26298 if Present
(Full_IP
) and then No
(Invariant_Procedure
(Typ
)) then
26299 Set_Invariant_Procedure
(Typ
, Full_IP
);
26302 if Present
(Part_IP
) and then No
(Partial_Invariant_Procedure
(Typ
))
26304 Set_Partial_Invariant_Procedure
(Typ
, Part_IP
);
26307 end Propagate_Invariant_Attributes
;
26309 ------------------------------------
26310 -- Propagate_Predicate_Attributes --
26311 ------------------------------------
26313 procedure Propagate_Predicate_Attributes
26315 From_Typ
: Entity_Id
)
26317 Pred_Func
: Entity_Id
;
26319 if Present
(Typ
) and then Present
(From_Typ
) then
26320 pragma Assert
(Is_Type
(Typ
) and then Is_Type
(From_Typ
));
26322 -- Nothing to do if both the source and the destination denote the
26325 if From_Typ
= Typ
then
26329 Pred_Func
:= Predicate_Function
(From_Typ
);
26331 -- The setting of the attributes is intentionally conservative. This
26332 -- prevents accidental clobbering of enabled attributes.
26334 if Has_Predicates
(From_Typ
) then
26335 Set_Has_Predicates
(Typ
);
26338 if Present
(Pred_Func
) and then No
(Predicate_Function
(Typ
)) then
26339 Set_Predicate_Function
(Typ
, Pred_Func
);
26342 end Propagate_Predicate_Attributes
;
26344 ---------------------------------------
26345 -- Record_Possible_Part_Of_Reference --
26346 ---------------------------------------
26348 procedure Record_Possible_Part_Of_Reference
26349 (Var_Id
: Entity_Id
;
26352 Encap
: constant Entity_Id
:= Encapsulating_State
(Var_Id
);
26356 -- The variable is a constituent of a single protected/task type. Such
26357 -- a variable acts as a component of the type and must appear within a
26358 -- specific region (SPARK RM 9(3)). Instead of recording the reference,
26359 -- verify its legality now.
26361 if Present
(Encap
) and then Is_Single_Concurrent_Object
(Encap
) then
26362 Check_Part_Of_Reference
(Var_Id
, Ref
);
26364 -- The variable is subject to pragma Part_Of and may eventually become a
26365 -- constituent of a single protected/task type. Record the reference to
26366 -- verify its placement when the contract of the variable is analyzed.
26368 elsif Present
(Get_Pragma
(Var_Id
, Pragma_Part_Of
)) then
26369 Refs
:= Part_Of_References
(Var_Id
);
26372 Refs
:= New_Elmt_List
;
26373 Set_Part_Of_References
(Var_Id
, Refs
);
26376 Append_Elmt
(Ref
, Refs
);
26378 end Record_Possible_Part_Of_Reference
;
26384 function Referenced
(Id
: Entity_Id
; Expr
: Node_Id
) return Boolean is
26385 Seen
: Boolean := False;
26387 function Is_Reference
(N
: Node_Id
) return Traverse_Result
;
26388 -- Determine whether node N denotes a reference to Id. If this is the
26389 -- case, set global flag Seen to True and stop the traversal.
26395 function Is_Reference
(N
: Node_Id
) return Traverse_Result
is
26397 if Is_Entity_Name
(N
)
26398 and then Present
(Entity
(N
))
26399 and then Entity
(N
) = Id
26408 procedure Inspect_Expression
is new Traverse_Proc
(Is_Reference
);
26410 -- Start of processing for Referenced
26413 Inspect_Expression
(Expr
);
26417 ------------------------------------
26418 -- References_Generic_Formal_Type --
26419 ------------------------------------
26421 function References_Generic_Formal_Type
(N
: Node_Id
) return Boolean is
26423 function Process
(N
: Node_Id
) return Traverse_Result
;
26424 -- Process one node in search for generic formal type
26430 function Process
(N
: Node_Id
) return Traverse_Result
is
26432 if Nkind
(N
) in N_Has_Entity
then
26434 E
: constant Entity_Id
:= Entity
(N
);
26436 if Present
(E
) then
26437 if Is_Generic_Type
(E
) then
26439 elsif Present
(Etype
(E
))
26440 and then Is_Generic_Type
(Etype
(E
))
26451 function Traverse
is new Traverse_Func
(Process
);
26452 -- Traverse tree to look for generic type
26455 if Inside_A_Generic
then
26456 return Traverse
(N
) = Abandon
;
26460 end References_Generic_Formal_Type
;
26462 -------------------------------
26463 -- Remove_Entity_And_Homonym --
26464 -------------------------------
26466 procedure Remove_Entity_And_Homonym
(Id
: Entity_Id
) is
26468 Remove_Entity
(Id
);
26469 Remove_Homonym
(Id
);
26470 end Remove_Entity_And_Homonym
;
26472 --------------------
26473 -- Remove_Homonym --
26474 --------------------
26476 procedure Remove_Homonym
(Id
: Entity_Id
) is
26478 Prev
: Entity_Id
:= Empty
;
26481 if Id
= Current_Entity
(Id
) then
26482 if Present
(Homonym
(Id
)) then
26483 Set_Current_Entity
(Homonym
(Id
));
26485 Set_Name_Entity_Id
(Chars
(Id
), Empty
);
26489 Hom
:= Current_Entity
(Id
);
26490 while Present
(Hom
) and then Hom
/= Id
loop
26492 Hom
:= Homonym
(Hom
);
26495 -- If Id is not on the homonym chain, nothing to do
26497 if Present
(Hom
) then
26498 Set_Homonym
(Prev
, Homonym
(Id
));
26501 end Remove_Homonym
;
26503 ------------------------------
26504 -- Remove_Overloaded_Entity --
26505 ------------------------------
26507 procedure Remove_Overloaded_Entity
(Id
: Entity_Id
) is
26508 procedure Remove_Primitive_Of
(Typ
: Entity_Id
);
26509 -- Remove primitive subprogram Id from the list of primitives that
26510 -- belong to type Typ.
26512 -------------------------
26513 -- Remove_Primitive_Of --
26514 -------------------------
26516 procedure Remove_Primitive_Of
(Typ
: Entity_Id
) is
26520 if Is_Tagged_Type
(Typ
) then
26521 Prims
:= Direct_Primitive_Operations
(Typ
);
26523 if Present
(Prims
) then
26524 Remove
(Prims
, Id
);
26527 end Remove_Primitive_Of
;
26531 Formal
: Entity_Id
;
26533 -- Start of processing for Remove_Overloaded_Entity
26536 Remove_Entity_And_Homonym
(Id
);
26538 -- The entity denotes a primitive subprogram. Remove it from the list of
26539 -- primitives of the associated controlling type.
26541 if Ekind
(Id
) in E_Function | E_Procedure
and then Is_Primitive
(Id
) then
26542 Formal
:= First_Formal
(Id
);
26543 while Present
(Formal
) loop
26544 if Is_Controlling_Formal
(Formal
) then
26545 Remove_Primitive_Of
(Etype
(Formal
));
26549 Next_Formal
(Formal
);
26552 if Ekind
(Id
) = E_Function
and then Has_Controlling_Result
(Id
) then
26553 Remove_Primitive_Of
(Etype
(Id
));
26556 end Remove_Overloaded_Entity
;
26558 ---------------------
26559 -- Rep_To_Pos_Flag --
26560 ---------------------
26562 function Rep_To_Pos_Flag
(E
: Entity_Id
; Loc
: Source_Ptr
) return Node_Id
is
26564 return New_Occurrence_Of
26565 (Boolean_Literals
(not Range_Checks_Suppressed
(E
)), Loc
);
26566 end Rep_To_Pos_Flag
;
26568 --------------------
26569 -- Require_Entity --
26570 --------------------
26572 procedure Require_Entity
(N
: Node_Id
) is
26574 if Is_Entity_Name
(N
) and then No
(Entity
(N
)) then
26575 if Total_Errors_Detected
/= 0 then
26576 Set_Entity
(N
, Any_Id
);
26578 raise Program_Error
;
26581 end Require_Entity
;
26583 ------------------------------
26584 -- Requires_Transient_Scope --
26585 ------------------------------
26587 function Requires_Transient_Scope
(Typ
: Entity_Id
) return Boolean is
26589 return Needs_Secondary_Stack
(Typ
) or else Needs_Finalization
(Typ
);
26590 end Requires_Transient_Scope
;
26592 --------------------------
26593 -- Reset_Analyzed_Flags --
26594 --------------------------
26596 procedure Reset_Analyzed_Flags
(N
: Node_Id
) is
26597 function Clear_Analyzed
(N
: Node_Id
) return Traverse_Result
;
26598 -- Function used to reset Analyzed flags in tree. Note that we do
26599 -- not reset Analyzed flags in entities, since there is no need to
26600 -- reanalyze entities, and indeed, it is wrong to do so, since it
26601 -- can result in generating auxiliary stuff more than once.
26603 --------------------
26604 -- Clear_Analyzed --
26605 --------------------
26607 function Clear_Analyzed
(N
: Node_Id
) return Traverse_Result
is
26609 if Nkind
(N
) not in N_Entity
then
26610 Set_Analyzed
(N
, False);
26614 end Clear_Analyzed
;
26616 procedure Reset_Analyzed
is new Traverse_Proc
(Clear_Analyzed
);
26618 -- Start of processing for Reset_Analyzed_Flags
26621 Reset_Analyzed
(N
);
26622 end Reset_Analyzed_Flags
;
26624 ------------------------
26625 -- Restore_SPARK_Mode --
26626 ------------------------
26628 procedure Restore_SPARK_Mode
26629 (Mode
: SPARK_Mode_Type
;
26633 SPARK_Mode
:= Mode
;
26634 SPARK_Mode_Pragma
:= Prag
;
26635 end Restore_SPARK_Mode
;
26637 --------------------------------
26638 -- Returns_Unconstrained_Type --
26639 --------------------------------
26641 function Returns_Unconstrained_Type
(Subp
: Entity_Id
) return Boolean is
26643 return Ekind
(Subp
) = E_Function
26644 and then not Is_Scalar_Type
(Etype
(Subp
))
26645 and then not Is_Access_Type
(Etype
(Subp
))
26646 and then not Is_Constrained
(Etype
(Subp
));
26647 end Returns_Unconstrained_Type
;
26649 ----------------------------
26650 -- Root_Type_Of_Full_View --
26651 ----------------------------
26653 function Root_Type_Of_Full_View
(T
: Entity_Id
) return Entity_Id
is
26654 Rtyp
: constant Entity_Id
:= Root_Type
(T
);
26657 -- The root type of the full view may itself be a private type. Keep
26658 -- looking for the ultimate derivation parent.
26660 if Is_Private_Type
(Rtyp
) and then Present
(Full_View
(Rtyp
)) then
26661 return Root_Type_Of_Full_View
(Full_View
(Rtyp
));
26665 end Root_Type_Of_Full_View
;
26667 ---------------------------
26668 -- Safe_To_Capture_Value --
26669 ---------------------------
26671 function Safe_To_Capture_Value
26674 Cond
: Boolean := False) return Boolean
26677 -- The only entities for which we track constant values are variables
26678 -- that are not renamings, constants and formal parameters, so check
26679 -- if we have this case.
26681 -- Note: it may seem odd to track constant values for constants, but in
26682 -- fact this routine is used for other purposes than simply capturing
26683 -- the value. In particular, the setting of Known[_Non]_Null and
26686 if (Ekind
(Ent
) = E_Variable
and then No
(Renamed_Object
(Ent
)))
26688 Ekind
(Ent
) = E_Constant
26694 -- For conditionals, we also allow loop parameters
26696 elsif Cond
and then Ekind
(Ent
) = E_Loop_Parameter
then
26699 -- For all other cases, not just unsafe, but impossible to capture
26700 -- Current_Value, since the above are the only entities which have
26701 -- Current_Value fields.
26707 -- Skip if volatile or aliased, since funny things might be going on in
26708 -- these cases which we cannot necessarily track. Also skip any variable
26709 -- for which an address clause is given, or whose address is taken. Also
26710 -- never capture value of library level variables (an attempt to do so
26711 -- can occur in the case of package elaboration code).
26713 if Treat_As_Volatile
(Ent
)
26714 or else Is_Aliased
(Ent
)
26715 or else Present
(Address_Clause
(Ent
))
26716 or else Address_Taken
(Ent
)
26717 or else (Is_Library_Level_Entity
(Ent
)
26718 and then Ekind
(Ent
) = E_Variable
)
26723 -- OK, all above conditions are met. We also require that the scope of
26724 -- the reference be the same as the scope of the entity, not counting
26725 -- packages and blocks and loops.
26728 E_Scope
: constant Entity_Id
:= Scope
(Ent
);
26729 R_Scope
: Entity_Id
;
26732 R_Scope
:= Current_Scope
;
26733 while R_Scope
/= Standard_Standard
loop
26734 exit when R_Scope
= E_Scope
;
26736 if Ekind
(R_Scope
) not in E_Package | E_Block | E_Loop
then
26739 R_Scope
:= Scope
(R_Scope
);
26744 -- We also require that the reference does not appear in a context
26745 -- where it is not sure to be executed (i.e. a conditional context
26746 -- or an exception handler). We skip this if Cond is True, since the
26747 -- capturing of values from conditional tests handles this ok.
26749 if Cond
or else No
(N
) then
26760 -- Seems dubious that case expressions are not handled here ???
26763 while Present
(P
) loop
26764 if Is_Body
(P
) then
26767 elsif Nkind
(P
) = N_If_Statement
26768 or else Nkind
(P
) = N_Case_Statement
26769 or else (Nkind
(P
) in N_Short_Circuit
26770 and then Desc
= Right_Opnd
(P
))
26771 or else (Nkind
(P
) = N_If_Expression
26772 and then Desc
/= First
(Expressions
(P
)))
26773 or else Nkind
(P
) = N_Exception_Handler
26774 or else Nkind
(P
) = N_Selective_Accept
26775 or else Nkind
(P
) = N_Conditional_Entry_Call
26776 or else Nkind
(P
) = N_Timed_Entry_Call
26777 or else Nkind
(P
) = N_Asynchronous_Select
26785 -- A special Ada 2012 case: the original node may be part
26786 -- of the else_actions of a conditional expression, in which
26787 -- case it might not have been expanded yet, and appears in
26788 -- a non-syntactic list of actions. In that case it is clearly
26789 -- not safe to save a value.
26792 and then Is_List_Member
(Desc
)
26793 and then No
(Parent
(List_Containing
(Desc
)))
26801 -- OK, looks safe to set value
26804 end Safe_To_Capture_Value
;
26810 function Same_Name
(N1
, N2
: Node_Id
) return Boolean is
26811 K1
: constant Node_Kind
:= Nkind
(N1
);
26812 K2
: constant Node_Kind
:= Nkind
(N2
);
26815 if (K1
= N_Identifier
or else K1
= N_Defining_Identifier
)
26816 and then (K2
= N_Identifier
or else K2
= N_Defining_Identifier
)
26818 return Chars
(N1
) = Chars
(N2
);
26820 elsif (K1
= N_Selected_Component
or else K1
= N_Expanded_Name
)
26821 and then (K2
= N_Selected_Component
or else K2
= N_Expanded_Name
)
26823 return Same_Name
(Selector_Name
(N1
), Selector_Name
(N2
))
26824 and then Same_Name
(Prefix
(N1
), Prefix
(N2
));
26835 function Same_Object
(Node1
, Node2
: Node_Id
) return Boolean is
26836 N1
: constant Node_Id
:= Original_Node
(Node1
);
26837 N2
: constant Node_Id
:= Original_Node
(Node2
);
26838 -- We do the tests on original nodes, since we are most interested
26839 -- in the original source, not any expansion that got in the way.
26841 K1
: constant Node_Kind
:= Nkind
(N1
);
26842 K2
: constant Node_Kind
:= Nkind
(N2
);
26845 -- First case, both are entities with same entity
26847 if K1
in N_Has_Entity
and then K2
in N_Has_Entity
then
26849 EN1
: constant Entity_Id
:= Entity
(N1
);
26850 EN2
: constant Entity_Id
:= Entity
(N2
);
26852 if Present
(EN1
) and then Present
(EN2
)
26853 and then (Ekind
(EN1
) in E_Variable | E_Constant
26854 or else Is_Formal
(EN1
))
26862 -- Second case, selected component with same selector, same record
26864 if K1
= N_Selected_Component
26865 and then K2
= N_Selected_Component
26866 and then Chars
(Selector_Name
(N1
)) = Chars
(Selector_Name
(N2
))
26868 return Same_Object
(Prefix
(N1
), Prefix
(N2
));
26870 -- Third case, indexed component with same subscripts, same array
26872 elsif K1
= N_Indexed_Component
26873 and then K2
= N_Indexed_Component
26874 and then Same_Object
(Prefix
(N1
), Prefix
(N2
))
26879 E1
:= First
(Expressions
(N1
));
26880 E2
:= First
(Expressions
(N2
));
26881 while Present
(E1
) loop
26882 if not Same_Value
(E1
, E2
) then
26893 -- Fourth case, slice of same array with same bounds
26896 and then K2
= N_Slice
26897 and then Nkind
(Discrete_Range
(N1
)) = N_Range
26898 and then Nkind
(Discrete_Range
(N2
)) = N_Range
26899 and then Same_Value
(Low_Bound
(Discrete_Range
(N1
)),
26900 Low_Bound
(Discrete_Range
(N2
)))
26901 and then Same_Value
(High_Bound
(Discrete_Range
(N1
)),
26902 High_Bound
(Discrete_Range
(N2
)))
26904 return Same_Name
(Prefix
(N1
), Prefix
(N2
));
26906 -- All other cases, not clearly the same object
26913 ---------------------------------
26914 -- Same_Or_Aliased_Subprograms --
26915 ---------------------------------
26917 function Same_Or_Aliased_Subprograms
26919 E
: Entity_Id
) return Boolean
26921 Subp_Alias
: constant Entity_Id
:= Alias
(S
);
26922 Subp
: Entity_Id
:= E
;
26924 -- During expansion of subprograms with postconditions the original
26925 -- subprogram's declarations and statements get wrapped into a local
26926 -- _Wrapped_Statements subprogram.
26928 if Chars
(Subp
) = Name_uWrapped_Statements
then
26929 Subp
:= Enclosing_Subprogram
(Subp
);
26933 or else (Present
(Subp_Alias
) and then Subp_Alias
= Subp
);
26934 end Same_Or_Aliased_Subprograms
;
26940 function Same_Type
(T1
, T2
: Entity_Id
) return Boolean is
26945 elsif not Is_Constrained
(T1
)
26946 and then not Is_Constrained
(T2
)
26947 and then Base_Type
(T1
) = Base_Type
(T2
)
26951 -- For now don't bother with case of identical constraints, to be
26952 -- fiddled with later on perhaps (this is only used for optimization
26953 -- purposes, so it is not critical to do a best possible job)
26964 function Same_Value
(Node1
, Node2
: Node_Id
) return Boolean is
26966 if Compile_Time_Known_Value
(Node1
)
26967 and then Compile_Time_Known_Value
(Node2
)
26969 -- Handle properly compile-time expressions that are not
26972 if Is_String_Type
(Etype
(Node1
)) then
26973 return Expr_Value_S
(Node1
) = Expr_Value_S
(Node2
);
26976 return Expr_Value
(Node1
) = Expr_Value
(Node2
);
26979 elsif Same_Object
(Node1
, Node2
) then
26986 --------------------
26987 -- Set_SPARK_Mode --
26988 --------------------
26990 procedure Set_SPARK_Mode
(Context
: Entity_Id
) is
26992 -- Do not consider illegal or partially decorated constructs
26994 if Ekind
(Context
) = E_Void
or else Error_Posted
(Context
) then
26997 elsif Present
(SPARK_Pragma
(Context
)) then
26999 (Mode
=> Get_SPARK_Mode_From_Annotation
(SPARK_Pragma
(Context
)),
27000 Prag
=> SPARK_Pragma
(Context
));
27002 end Set_SPARK_Mode
;
27004 -------------------------
27005 -- Scalar_Part_Present --
27006 -------------------------
27008 function Scalar_Part_Present
(Typ
: Entity_Id
) return Boolean is
27009 Val_Typ
: constant Entity_Id
:= Validated_View
(Typ
);
27013 if Is_Scalar_Type
(Val_Typ
) then
27016 elsif Is_Array_Type
(Val_Typ
) then
27017 return Scalar_Part_Present
(Component_Type
(Val_Typ
));
27019 elsif Is_Record_Type
(Val_Typ
) then
27020 Field
:= First_Component_Or_Discriminant
(Val_Typ
);
27021 while Present
(Field
) loop
27022 if Scalar_Part_Present
(Etype
(Field
)) then
27026 Next_Component_Or_Discriminant
(Field
);
27031 end Scalar_Part_Present
;
27033 ------------------------
27034 -- Scope_Is_Transient --
27035 ------------------------
27037 function Scope_Is_Transient
return Boolean is
27039 return Scope_Stack
.Table
(Scope_Stack
.Last
).Is_Transient
;
27040 end Scope_Is_Transient
;
27046 function Scope_Within
27047 (Inner
: Entity_Id
;
27048 Outer
: Entity_Id
) return Boolean
27054 while Present
(Curr
) and then Curr
/= Standard_Standard
loop
27055 Curr
:= Scope
(Curr
);
27057 if Curr
= Outer
then
27060 -- A selective accept body appears within a task type, but the
27061 -- enclosing subprogram is the procedure of the task body.
27063 elsif Ekind
(Implementation_Base_Type
(Curr
)) = E_Task_Type
27065 Outer
= Task_Body_Procedure
(Implementation_Base_Type
(Curr
))
27069 -- Ditto for the body of a protected operation
27071 elsif Is_Subprogram
(Curr
)
27072 and then Outer
= Protected_Body_Subprogram
(Curr
)
27076 -- The body of a protected operation is within the protected type
27078 elsif Is_Subprogram
(Curr
)
27079 and then Present
(Protected_Subprogram
(Curr
))
27080 and then Is_Protected_Type
(Outer
)
27081 and then Scope
(Protected_Subprogram
(Curr
)) = Outer
27085 -- Outside of its scope, a synchronized type may just be private
27087 elsif Is_Private_Type
(Curr
)
27088 and then Present
(Full_View
(Curr
))
27089 and then Is_Concurrent_Type
(Full_View
(Curr
))
27091 return Scope_Within
(Full_View
(Curr
), Outer
);
27098 --------------------------
27099 -- Scope_Within_Or_Same --
27100 --------------------------
27102 function Scope_Within_Or_Same
27103 (Inner
: Entity_Id
;
27104 Outer
: Entity_Id
) return Boolean
27106 Curr
: Entity_Id
:= Inner
;
27109 -- Similar to the above, but check for scope identity first
27111 while Present
(Curr
) and then Curr
/= Standard_Standard
loop
27112 if Curr
= Outer
then
27115 elsif Ekind
(Implementation_Base_Type
(Curr
)) = E_Task_Type
27117 Outer
= Task_Body_Procedure
(Implementation_Base_Type
(Curr
))
27121 elsif Is_Subprogram
(Curr
)
27122 and then Outer
= Protected_Body_Subprogram
(Curr
)
27126 elsif Is_Subprogram
(Curr
)
27127 and then Present
(Protected_Subprogram
(Curr
))
27128 and then Is_Protected_Type
(Outer
)
27129 and then Scope
(Protected_Subprogram
(Curr
)) = Outer
27133 elsif Is_Private_Type
(Curr
)
27134 and then Present
(Full_View
(Curr
))
27136 if Full_View
(Curr
) = Outer
then
27139 return Scope_Within
(Full_View
(Curr
), Outer
);
27143 Curr
:= Scope
(Curr
);
27147 end Scope_Within_Or_Same
;
27149 ------------------------
27150 -- Set_Current_Entity --
27151 ------------------------
27153 -- The given entity is to be set as the currently visible definition of its
27154 -- associated name (i.e. the Node_Id associated with its name). All we have
27155 -- to do is to get the name from the identifier, and then set the
27156 -- associated Node_Id to point to the given entity.
27158 procedure Set_Current_Entity
(E
: Entity_Id
) is
27160 Set_Name_Entity_Id
(Chars
(E
), E
);
27161 end Set_Current_Entity
;
27163 ---------------------------
27164 -- Set_Debug_Info_Needed --
27165 ---------------------------
27167 procedure Set_Debug_Info_Needed
(T
: Entity_Id
) is
27169 procedure Set_Debug_Info_Needed_If_Not_Set
(E
: Entity_Id
);
27170 pragma Inline
(Set_Debug_Info_Needed_If_Not_Set
);
27171 -- Used to set debug info in a related node if not set already
27173 --------------------------------------
27174 -- Set_Debug_Info_Needed_If_Not_Set --
27175 --------------------------------------
27177 procedure Set_Debug_Info_Needed_If_Not_Set
(E
: Entity_Id
) is
27179 if Present
(E
) and then not Needs_Debug_Info
(E
) then
27180 Set_Debug_Info_Needed
(E
);
27182 -- For a private type, indicate that the full view also needs
27183 -- debug information.
27186 and then Is_Private_Type
(E
)
27187 and then Present
(Full_View
(E
))
27189 Set_Debug_Info_Needed
(Full_View
(E
));
27192 end Set_Debug_Info_Needed_If_Not_Set
;
27194 -- Start of processing for Set_Debug_Info_Needed
27197 -- Nothing to do if there is no available entity
27202 -- Nothing to do for an entity with suppressed debug information
27204 elsif Debug_Info_Off
(T
) then
27207 -- Nothing to do for an ignored Ghost entity because the entity will be
27208 -- eliminated from the tree.
27210 elsif Is_Ignored_Ghost_Entity
(T
) then
27213 -- Nothing to do if entity comes from a predefined file. Library files
27214 -- are compiled without debug information, but inlined bodies of these
27215 -- routines may appear in user code, and debug information on them ends
27216 -- up complicating debugging the user code.
27218 elsif In_Inlined_Body
and then In_Predefined_Unit
(T
) then
27219 Set_Needs_Debug_Info
(T
, False);
27222 -- Set flag in entity itself. Note that we will go through the following
27223 -- circuitry even if the flag is already set on T. That's intentional,
27224 -- it makes sure that the flag will be set in subsidiary entities.
27226 Set_Needs_Debug_Info
(T
);
27228 -- Set flag on subsidiary entities if not set already
27230 if Is_Object
(T
) then
27231 Set_Debug_Info_Needed_If_Not_Set
(Etype
(T
));
27233 elsif Is_Type
(T
) then
27234 Set_Debug_Info_Needed_If_Not_Set
(Etype
(T
));
27236 if Is_Record_Type
(T
) then
27238 Ent
: Entity_Id
:= First_Entity
(T
);
27240 while Present
(Ent
) loop
27241 Set_Debug_Info_Needed_If_Not_Set
(Ent
);
27246 -- For a class wide subtype, we also need debug information
27247 -- for the equivalent type.
27249 if Ekind
(T
) = E_Class_Wide_Subtype
then
27250 Set_Debug_Info_Needed_If_Not_Set
(Equivalent_Type
(T
));
27253 elsif Is_Array_Type
(T
) then
27254 Set_Debug_Info_Needed_If_Not_Set
(Component_Type
(T
));
27257 Indx
: Node_Id
:= First_Index
(T
);
27259 while Present
(Indx
) loop
27260 Set_Debug_Info_Needed_If_Not_Set
(Etype
(Indx
));
27265 -- For a packed array type, we also need debug information for
27266 -- the type used to represent the packed array. Conversely, we
27267 -- also need it for the former if we need it for the latter.
27269 if Is_Packed
(T
) then
27270 Set_Debug_Info_Needed_If_Not_Set
(Packed_Array_Impl_Type
(T
));
27273 if Is_Packed_Array_Impl_Type
(T
) then
27274 Set_Debug_Info_Needed_If_Not_Set
(Original_Array_Type
(T
));
27277 elsif Is_Access_Type
(T
) then
27278 Set_Debug_Info_Needed_If_Not_Set
(Directly_Designated_Type
(T
));
27280 elsif Is_Private_Type
(T
) then
27282 FV
: constant Entity_Id
:= Full_View
(T
);
27285 Set_Debug_Info_Needed_If_Not_Set
(FV
);
27287 -- If the full view is itself a derived private type, we need
27288 -- debug information on its underlying type.
27291 and then Is_Private_Type
(FV
)
27292 and then Present
(Underlying_Full_View
(FV
))
27294 Set_Needs_Debug_Info
(Underlying_Full_View
(FV
));
27298 elsif Is_Protected_Type
(T
) then
27299 Set_Debug_Info_Needed_If_Not_Set
(Corresponding_Record_Type
(T
));
27301 elsif Is_Scalar_Type
(T
) then
27303 -- If the subrange bounds are materialized by dedicated constant
27304 -- objects, also include them in the debug info to make sure the
27305 -- debugger can properly use them.
27307 if Present
(Scalar_Range
(T
))
27308 and then Nkind
(Scalar_Range
(T
)) = N_Range
27311 Low_Bnd
: constant Node_Id
:= Type_Low_Bound
(T
);
27312 High_Bnd
: constant Node_Id
:= Type_High_Bound
(T
);
27315 if Is_Entity_Name
(Low_Bnd
) then
27316 Set_Debug_Info_Needed_If_Not_Set
(Entity
(Low_Bnd
));
27319 if Is_Entity_Name
(High_Bnd
) then
27320 Set_Debug_Info_Needed_If_Not_Set
(Entity
(High_Bnd
));
27326 end Set_Debug_Info_Needed
;
27328 --------------------------------
27329 -- Set_Debug_Info_Defining_Id --
27330 --------------------------------
27332 procedure Set_Debug_Info_Defining_Id
(N
: Node_Id
) is
27334 if Comes_From_Source
(Defining_Identifier
(N
))
27335 or else Debug_Generated_Code
27337 Set_Debug_Info_Needed
(Defining_Identifier
(N
));
27339 end Set_Debug_Info_Defining_Id
;
27341 ----------------------------
27342 -- Set_Entity_With_Checks --
27343 ----------------------------
27345 procedure Set_Entity_With_Checks
(N
: Node_Id
; Val
: Entity_Id
) is
27346 Val_Actual
: Entity_Id
;
27348 Post_Node
: Node_Id
;
27351 -- Unconditionally set the entity
27353 Set_Entity
(N
, Val
);
27355 -- The node to post on is the selector in the case of an expanded name,
27356 -- and otherwise the node itself.
27358 if Nkind
(N
) = N_Expanded_Name
then
27359 Post_Node
:= Selector_Name
(N
);
27364 -- Check for violation of No_Fixed_IO
27366 if Restriction_Check_Required
(No_Fixed_IO
)
27368 ((RTU_Loaded
(Ada_Text_IO
)
27369 and then (Is_RTE
(Val
, RE_Decimal_IO
)
27371 Is_RTE
(Val
, RE_Fixed_IO
)))
27374 (RTU_Loaded
(Ada_Wide_Text_IO
)
27375 and then (Is_RTE
(Val
, RO_WT_Decimal_IO
)
27377 Is_RTE
(Val
, RO_WT_Fixed_IO
)))
27380 (RTU_Loaded
(Ada_Wide_Wide_Text_IO
)
27381 and then (Is_RTE
(Val
, RO_WW_Decimal_IO
)
27383 Is_RTE
(Val
, RO_WW_Fixed_IO
))))
27385 -- A special extra check, don't complain about a reference from within
27386 -- the Ada.Interrupts package itself!
27388 and then not In_Same_Extended_Unit
(N
, Val
)
27390 Check_Restriction
(No_Fixed_IO
, Post_Node
);
27393 -- Remaining checks are only done on source nodes. Note that we test
27394 -- for violation of No_Fixed_IO even on non-source nodes, because the
27395 -- cases for checking violations of this restriction are instantiations
27396 -- where the reference in the instance has Comes_From_Source False.
27398 if not Comes_From_Source
(N
) then
27402 -- Check for violation of No_Abort_Statements, which is triggered by
27403 -- call to Ada.Task_Identification.Abort_Task.
27405 if Restriction_Check_Required
(No_Abort_Statements
)
27406 and then Is_RTE
(Val
, RE_Abort_Task
)
27408 -- A special extra check, don't complain about a reference from within
27409 -- the Ada.Task_Identification package itself!
27411 and then not In_Same_Extended_Unit
(N
, Val
)
27413 Check_Restriction
(No_Abort_Statements
, Post_Node
);
27416 if Val
= Standard_Long_Long_Integer
then
27417 Check_Restriction
(No_Long_Long_Integers
, Post_Node
);
27420 -- Check for violation of No_Dynamic_Attachment
27422 if Restriction_Check_Required
(No_Dynamic_Attachment
)
27423 and then RTU_Loaded
(Ada_Interrupts
)
27424 and then (Is_RTE
(Val
, RE_Is_Reserved
) or else
27425 Is_RTE
(Val
, RE_Is_Attached
) or else
27426 Is_RTE
(Val
, RE_Current_Handler
) or else
27427 Is_RTE
(Val
, RE_Attach_Handler
) or else
27428 Is_RTE
(Val
, RE_Exchange_Handler
) or else
27429 Is_RTE
(Val
, RE_Detach_Handler
) or else
27430 Is_RTE
(Val
, RE_Reference
))
27432 -- A special extra check, don't complain about a reference from within
27433 -- the Ada.Interrupts package itself!
27435 and then not In_Same_Extended_Unit
(N
, Val
)
27437 Check_Restriction
(No_Dynamic_Attachment
, Post_Node
);
27440 -- Check for No_Implementation_Identifiers
27442 if Restriction_Check_Required
(No_Implementation_Identifiers
) then
27444 -- We have an implementation defined entity if it is marked as
27445 -- implementation defined, or is defined in a package marked as
27446 -- implementation defined. However, library packages themselves
27447 -- are excluded (we don't want to flag Interfaces itself, just
27448 -- the entities within it).
27450 if (Is_Implementation_Defined
(Val
)
27452 (Present
(Scope
(Val
))
27453 and then Is_Implementation_Defined
(Scope
(Val
))))
27454 and then not (Is_Package_Or_Generic_Package
(Val
)
27455 and then Is_Library_Level_Entity
(Val
))
27457 Check_Restriction
(No_Implementation_Identifiers
, Post_Node
);
27461 -- Do the style check
27464 and then not Suppress_Style_Checks
(Val
)
27465 and then not In_Instance
27467 if Nkind
(N
) = N_Identifier
then
27469 elsif Nkind
(N
) = N_Expanded_Name
then
27470 Nod
:= Selector_Name
(N
);
27475 -- A special situation arises for derived operations, where we want
27476 -- to do the check against the parent (since the Sloc of the derived
27477 -- operation points to the derived type declaration itself).
27480 while not Comes_From_Source
(Val_Actual
)
27481 and then Nkind
(Val_Actual
) in N_Entity
27482 and then (Ekind
(Val_Actual
) = E_Enumeration_Literal
27483 or else Is_Subprogram_Or_Generic_Subprogram
(Val_Actual
))
27484 and then Present
(Alias
(Val_Actual
))
27486 Val_Actual
:= Alias
(Val_Actual
);
27489 -- Renaming declarations for generic actuals do not come from source,
27490 -- and have a different name from that of the entity they rename, so
27491 -- there is no style check to perform here.
27493 if Chars
(Nod
) = Chars
(Val_Actual
) then
27494 Style
.Check_Identifier
(Nod
, Val_Actual
);
27497 end Set_Entity_With_Checks
;
27499 ------------------------------
27500 -- Set_Invalid_Scalar_Value --
27501 ------------------------------
27503 procedure Set_Invalid_Scalar_Value
27504 (Scal_Typ
: Float_Scalar_Id
;
27507 Slot
: Ureal
renames Invalid_Floats
(Scal_Typ
);
27510 -- Detect an attempt to set a different value for the same scalar type
27512 pragma Assert
(Slot
= No_Ureal
);
27514 end Set_Invalid_Scalar_Value
;
27516 ------------------------------
27517 -- Set_Invalid_Scalar_Value --
27518 ------------------------------
27520 procedure Set_Invalid_Scalar_Value
27521 (Scal_Typ
: Integer_Scalar_Id
;
27524 Slot
: Uint
renames Invalid_Integers
(Scal_Typ
);
27527 -- Detect an attempt to set a different value for the same scalar type
27529 pragma Assert
(No
(Slot
));
27531 end Set_Invalid_Scalar_Value
;
27533 ------------------------
27534 -- Set_Name_Entity_Id --
27535 ------------------------
27537 procedure Set_Name_Entity_Id
(Id
: Name_Id
; Val
: Entity_Id
) is
27539 Set_Name_Table_Int
(Id
, Int
(Val
));
27540 end Set_Name_Entity_Id
;
27542 ---------------------
27543 -- Set_Next_Actual --
27544 ---------------------
27546 procedure Set_Next_Actual
(Ass1_Id
: Node_Id
; Ass2_Id
: Node_Id
) is
27548 if Nkind
(Parent
(Ass1_Id
)) = N_Parameter_Association
then
27549 Set_First_Named_Actual
(Parent
(Ass1_Id
), Ass2_Id
);
27551 end Set_Next_Actual
;
27553 ----------------------------------
27554 -- Set_Optimize_Alignment_Flags --
27555 ----------------------------------
27557 procedure Set_Optimize_Alignment_Flags
(E
: Entity_Id
) is
27559 if Optimize_Alignment
= 'S' then
27560 Set_Optimize_Alignment_Space
(E
);
27561 elsif Optimize_Alignment
= 'T' then
27562 Set_Optimize_Alignment_Time
(E
);
27564 end Set_Optimize_Alignment_Flags
;
27566 -----------------------
27567 -- Set_Public_Status --
27568 -----------------------
27570 procedure Set_Public_Status
(Id
: Entity_Id
) is
27571 S
: constant Entity_Id
:= Current_Scope
;
27573 function Within_HSS_Or_If
(E
: Entity_Id
) return Boolean;
27574 -- Determines if E is defined within handled statement sequence or
27575 -- an if statement, returns True if so, False otherwise.
27577 ----------------------
27578 -- Within_HSS_Or_If --
27579 ----------------------
27581 function Within_HSS_Or_If
(E
: Entity_Id
) return Boolean is
27584 N
:= Declaration_Node
(E
);
27592 N_Handled_Sequence_Of_Statements | N_If_Statement
27597 end Within_HSS_Or_If
;
27599 -- Start of processing for Set_Public_Status
27602 -- Everything in the scope of Standard is public
27604 if S
= Standard_Standard
then
27605 Set_Is_Public
(Id
);
27607 -- Entity is definitely not public if enclosing scope is not public
27609 elsif not Is_Public
(S
) then
27612 -- An object or function declaration that occurs in a handled sequence
27613 -- of statements or within an if statement is the declaration for a
27614 -- temporary object or local subprogram generated by the expander. It
27615 -- never needs to be made public and furthermore, making it public can
27616 -- cause back end problems.
27618 elsif Nkind
(Parent
(Id
)) in
27619 N_Object_Declaration | N_Function_Specification
27620 and then Within_HSS_Or_If
(Id
)
27624 -- Entities in public packages or records are public
27626 elsif Ekind
(S
) = E_Package
or Is_Record_Type
(S
) then
27627 Set_Is_Public
(Id
);
27629 -- The bounds of an entry family declaration can generate object
27630 -- declarations that are visible to the back-end, e.g. in the
27631 -- the declaration of a composite type that contains tasks.
27633 elsif Is_Concurrent_Type
(S
)
27634 and then not Has_Completion
(S
)
27635 and then Nkind
(Parent
(Id
)) = N_Object_Declaration
27637 Set_Is_Public
(Id
);
27639 end Set_Public_Status
;
27641 -----------------------------
27642 -- Set_Referenced_Modified --
27643 -----------------------------
27645 procedure Set_Referenced_Modified
(N
: Node_Id
; Out_Param
: Boolean) is
27649 -- Deal with indexed or selected component where prefix is modified
27651 if Nkind
(N
) in N_Indexed_Component | N_Selected_Component
then
27652 Pref
:= Prefix
(N
);
27654 -- If prefix is access type, then it is the designated object that is
27655 -- being modified, which means we have no entity to set the flag on.
27657 if No
(Etype
(Pref
)) or else Is_Access_Type
(Etype
(Pref
)) then
27660 -- Otherwise chase the prefix
27663 Set_Referenced_Modified
(Pref
, Out_Param
);
27666 -- Otherwise see if we have an entity name (only other case to process)
27668 elsif Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
27669 Set_Referenced_As_LHS
(Entity
(N
), not Out_Param
);
27670 Set_Referenced_As_Out_Parameter
(Entity
(N
), Out_Param
);
27672 end Set_Referenced_Modified
;
27678 procedure Set_Rep_Info
(T1
: Entity_Id
; T2
: Entity_Id
) is
27680 Set_Is_Atomic
(T1
, Is_Atomic
(T2
));
27681 Set_Is_Independent
(T1
, Is_Independent
(T2
));
27682 Set_Is_Volatile_Full_Access
(T1
, Is_Volatile_Full_Access
(T2
));
27684 if Is_Base_Type
(T1
) then
27685 Set_Is_Volatile
(T1
, Is_Volatile
(T2
));
27689 -------------------
27690 -- Set_Size_Info --
27691 -------------------
27693 procedure Set_Size_Info
(T1
, T2
: Entity_Id
) is
27695 -- We copy Esize, but not RM_Size, since in general RM_Size is
27696 -- subtype specific and does not get inherited by all subtypes.
27698 Copy_Esize
(To
=> T1
, From
=> T2
);
27699 Set_Has_Biased_Representation
(T1
, Has_Biased_Representation
(T2
));
27701 if Is_Discrete_Or_Fixed_Point_Type
(T1
)
27703 Is_Discrete_Or_Fixed_Point_Type
(T2
)
27705 Set_Is_Unsigned_Type
(T1
, Is_Unsigned_Type
(T2
));
27708 Copy_Alignment
(To
=> T1
, From
=> T2
);
27711 ------------------------------
27712 -- Should_Ignore_Pragma_Par --
27713 ------------------------------
27715 function Should_Ignore_Pragma_Par
(Prag_Name
: Name_Id
) return Boolean is
27716 pragma Assert
(Compiler_State
= Parsing
);
27717 -- This one can't work during semantic analysis, because we don't have a
27718 -- correct Current_Source_File.
27720 Result
: constant Boolean :=
27721 Get_Name_Table_Boolean3
(Prag_Name
)
27722 and then not Is_Internal_File_Name
27723 (File_Name
(Current_Source_File
));
27726 end Should_Ignore_Pragma_Par
;
27728 ------------------------------
27729 -- Should_Ignore_Pragma_Sem --
27730 ------------------------------
27732 function Should_Ignore_Pragma_Sem
(N
: Node_Id
) return Boolean is
27733 pragma Assert
(Compiler_State
= Analyzing
);
27734 Prag_Name
: constant Name_Id
:= Pragma_Name
(N
);
27735 Result
: constant Boolean :=
27736 Get_Name_Table_Boolean3
(Prag_Name
)
27737 and then not In_Internal_Unit
(N
);
27741 end Should_Ignore_Pragma_Sem
;
27743 --------------------
27744 -- Static_Boolean --
27745 --------------------
27747 function Static_Boolean
(N
: Node_Id
) return Opt_Ubool
is
27749 Analyze_And_Resolve
(N
, Standard_Boolean
);
27752 or else Error_Posted
(N
)
27753 or else Etype
(N
) = Any_Type
27758 if Is_OK_Static_Expression
(N
) then
27759 if not Raises_Constraint_Error
(N
) then
27760 return Expr_Value
(N
);
27765 elsif Etype
(N
) = Any_Type
then
27769 Flag_Non_Static_Expr
27770 ("static boolean expression required here", N
);
27773 end Static_Boolean
;
27775 --------------------
27776 -- Static_Integer --
27777 --------------------
27779 function Static_Integer
(N
: Node_Id
) return Uint
is
27781 Analyze_And_Resolve
(N
, Any_Integer
);
27784 or else Error_Posted
(N
)
27785 or else Etype
(N
) = Any_Type
27790 if Is_OK_Static_Expression
(N
) then
27791 if not Raises_Constraint_Error
(N
) then
27792 return Expr_Value
(N
);
27797 elsif Etype
(N
) = Any_Type
then
27801 Flag_Non_Static_Expr
27802 ("static integer expression required here", N
);
27805 end Static_Integer
;
27807 -------------------------------
27808 -- Statically_Denotes_Entity --
27809 -------------------------------
27811 function Statically_Denotes_Entity
(N
: Node_Id
) return Boolean is
27814 if not Is_Entity_Name
(N
) then
27821 Nkind
(Parent
(E
)) /= N_Object_Renaming_Declaration
27822 or else Is_Prival
(E
)
27823 or else Statically_Denotes_Entity
(Renamed_Object
(E
));
27824 end Statically_Denotes_Entity
;
27826 -------------------------------
27827 -- Statically_Denotes_Object --
27828 -------------------------------
27830 function Statically_Denotes_Object
(N
: Node_Id
) return Boolean is
27832 return Statically_Denotes_Entity
(N
)
27833 and then Is_Object_Reference
(N
);
27834 end Statically_Denotes_Object
;
27836 --------------------------
27837 -- Statically_Different --
27838 --------------------------
27840 function Statically_Different
(E1
, E2
: Node_Id
) return Boolean is
27841 R1
: constant Node_Id
:= Get_Referenced_Object
(E1
);
27842 R2
: constant Node_Id
:= Get_Referenced_Object
(E2
);
27844 return Is_Entity_Name
(R1
)
27845 and then Is_Entity_Name
(R2
)
27846 and then Entity
(R1
) /= Entity
(R2
)
27847 and then not Is_Formal
(Entity
(R1
))
27848 and then not Is_Formal
(Entity
(R2
));
27849 end Statically_Different
;
27851 -----------------------------
27852 -- Statically_Names_Object --
27853 -----------------------------
27855 function Statically_Names_Object
(N
: Node_Id
) return Boolean is
27857 if Statically_Denotes_Object
(N
) then
27859 elsif Is_Entity_Name
(N
) then
27861 E
: constant Entity_Id
:= Entity
(N
);
27863 return Nkind
(Parent
(E
)) = N_Object_Renaming_Declaration
27864 and then Statically_Names_Object
(Renamed_Object
(E
));
27869 when N_Indexed_Component
=>
27870 if Is_Access_Type
(Etype
(Prefix
(N
))) then
27871 -- treat implicit dereference same as explicit
27875 if not Is_Constrained
(Etype
(Prefix
(N
))) then
27880 Indx
: Node_Id
:= First_Index
(Etype
(Prefix
(N
)));
27881 Expr
: Node_Id
:= First
(Expressions
(N
));
27882 Index_Subtype
: Node_Id
;
27885 Index_Subtype
:= Etype
(Indx
);
27887 if not Is_Static_Subtype
(Index_Subtype
) then
27890 if not Is_OK_Static_Expression
(Expr
) then
27895 Index_Value
: constant Uint
:= Expr_Value
(Expr
);
27896 Low_Value
: constant Uint
:=
27897 Expr_Value
(Type_Low_Bound
(Index_Subtype
));
27898 High_Value
: constant Uint
:=
27899 Expr_Value
(Type_High_Bound
(Index_Subtype
));
27901 if Index_Value
< Low_Value
27902 or Index_Value
> High_Value
27909 Expr
:= Next
(Expr
);
27910 pragma Assert
(Present
(Indx
) = Present
(Expr
)
27911 or else Serious_Errors_Detected
> 0);
27912 exit when not (Present
(Indx
) and Present
(Expr
));
27916 when N_Selected_Component
=>
27917 if Is_Access_Type
(Etype
(Prefix
(N
))) then
27918 -- treat implicit dereference same as explicit
27922 if Ekind
(Entity
(Selector_Name
(N
))) not in
27923 E_Component | E_Discriminant
27929 Comp
: constant Entity_Id
:=
27930 Original_Record_Component
(Entity
(Selector_Name
(N
)));
27932 -- AI12-0373 confirms that we should not call
27933 -- Has_Discriminant_Dependent_Constraint here which would be
27936 if Is_Declared_Within_Variant
(Comp
) then
27941 when others => -- includes N_Slice, N_Explicit_Dereference
27945 pragma Assert
(Present
(Prefix
(N
)));
27947 return Statically_Names_Object
(Prefix
(N
));
27948 end Statically_Names_Object
;
27950 ---------------------------------
27951 -- String_From_Numeric_Literal --
27952 ---------------------------------
27954 function String_From_Numeric_Literal
(N
: Node_Id
) return String_Id
is
27955 Loc
: constant Source_Ptr
:= Sloc
(N
);
27956 Sbuffer
: constant Source_Buffer_Ptr
:=
27957 Source_Text
(Get_Source_File_Index
(Loc
));
27958 Src_Ptr
: Source_Ptr
:= Loc
;
27960 C
: Character := Sbuffer
(Src_Ptr
);
27961 -- Current source program character
27963 function Belongs_To_Numeric_Literal
(C
: Character) return Boolean;
27964 -- Return True if C belongs to the numeric literal
27966 --------------------------------
27967 -- Belongs_To_Numeric_Literal --
27968 --------------------------------
27970 function Belongs_To_Numeric_Literal
(C
: Character) return Boolean is
27973 when '0' .. '9' |
'_' |
'.' |
'e' |
'#' |
'A' .. 'F' =>
27976 -- Make sure '+' or '-' is part of an exponent
27980 Prev_C
: constant Character := Sbuffer
(Src_Ptr
- 1);
27982 return Prev_C
in 'e' |
'E';
27985 -- Other characters cannot belong to a numeric literal
27990 end Belongs_To_Numeric_Literal
;
27992 -- Start of processing for String_From_Numeric_Literal
27996 while Belongs_To_Numeric_Literal
(C
) loop
27997 Store_String_Char
(C
);
27998 Src_Ptr
:= Src_Ptr
+ 1;
27999 C
:= Sbuffer
(Src_Ptr
);
28003 end String_From_Numeric_Literal
;
28005 --------------------------------------
28006 -- Subject_To_Loop_Entry_Attributes --
28007 --------------------------------------
28009 function Subject_To_Loop_Entry_Attributes
(N
: Node_Id
) return Boolean is
28015 -- The expansion mechanism transform a loop subject to at least one
28016 -- 'Loop_Entry attribute into a conditional block. Infinite loops lack
28017 -- the conditional part.
28019 if Nkind
(Stmt
) in N_Block_Statement | N_If_Statement
28020 and then Nkind
(Original_Node
(N
)) = N_Loop_Statement
28022 Stmt
:= Original_Node
(N
);
28026 Nkind
(Stmt
) = N_Loop_Statement
28027 and then Present
(Identifier
(Stmt
))
28028 and then Present
(Entity
(Identifier
(Stmt
)))
28029 and then Has_Loop_Entry_Attributes
(Entity
(Identifier
(Stmt
)));
28030 end Subject_To_Loop_Entry_Attributes
;
28032 ---------------------
28033 -- Subprogram_Name --
28034 ---------------------
28036 function Subprogram_Name
(N
: Node_Id
) return String is
28037 Buf
: Bounded_String
;
28038 Ent
: Node_Id
:= N
;
28042 while Present
(Ent
) loop
28043 case Nkind
(Ent
) is
28044 when N_Subprogram_Body
=>
28045 Ent
:= Defining_Unit_Name
(Specification
(Ent
));
28048 when N_Subprogram_Declaration
=>
28049 Nod
:= Corresponding_Body
(Ent
);
28051 if Present
(Nod
) then
28054 Ent
:= Defining_Unit_Name
(Specification
(Ent
));
28059 when N_Subprogram_Instantiation
28061 | N_Package_Specification
28063 Ent
:= Defining_Unit_Name
(Ent
);
28066 when N_Protected_Type_Declaration
=>
28067 Ent
:= Corresponding_Body
(Ent
);
28070 when N_Protected_Body
28073 Ent
:= Defining_Identifier
(Ent
);
28083 Ent
:= Parent
(Ent
);
28087 return "unknown subprogram:unknown file:0:0";
28090 -- If the subprogram is a child unit, use its simple name to start the
28091 -- construction of the fully qualified name.
28093 if Nkind
(Ent
) = N_Defining_Program_Unit_Name
then
28094 Ent
:= Defining_Identifier
(Ent
);
28097 Append_Entity_Name
(Buf
, Ent
);
28099 -- Append homonym number if needed
28101 if Nkind
(N
) in N_Entity
and then Has_Homonym
(N
) then
28103 H
: Entity_Id
:= Homonym
(N
);
28107 while Present
(H
) loop
28108 if Scope
(H
) = Scope
(N
) then
28122 -- Append source location of Ent to Buf so that the string will
28123 -- look like "subp:file:line:col".
28126 Loc
: constant Source_Ptr
:= Sloc
(Ent
);
28129 Append
(Buf
, Reference_Name
(Get_Source_File_Index
(Loc
)));
28131 Append
(Buf
, Nat
(Get_Logical_Line_Number
(Loc
)));
28133 Append
(Buf
, Nat
(Get_Column_Number
(Loc
)));
28137 end Subprogram_Name
;
28139 -------------------------------
28140 -- Support_Atomic_Primitives --
28141 -------------------------------
28143 function Support_Atomic_Primitives
(Typ
: Entity_Id
) return Boolean is
28147 -- Verify the alignment of Typ is known
28149 if not Known_Alignment
(Typ
) then
28153 if Known_Static_Esize
(Typ
) then
28154 Size
:= UI_To_Int
(Esize
(Typ
));
28156 -- If the Esize (Object_Size) is unknown at compile time, look at the
28157 -- RM_Size (Value_Size) which may have been set by an explicit rep item.
28159 elsif Known_Static_RM_Size
(Typ
) then
28160 Size
:= UI_To_Int
(RM_Size
(Typ
));
28162 -- Otherwise, the size is considered to be unknown.
28168 -- Check that the size of the component is 8, 16, 32, or 64 bits and
28169 -- that Typ is properly aligned.
28172 when 8 |
16 |
32 |
64 =>
28173 return Size
= UI_To_Int
(Alignment
(Typ
)) * 8;
28178 end Support_Atomic_Primitives
;
28184 procedure Trace_Scope
(N
: Node_Id
; E
: Entity_Id
; Msg
: String) is
28186 if Debug_Flag_W
then
28187 for J
in 0 .. Scope_Stack
.Last
loop
28192 Write_Name
(Chars
(E
));
28193 Write_Str
(" from ");
28194 Write_Location
(Sloc
(N
));
28199 -----------------------
28200 -- Transfer_Entities --
28201 -----------------------
28203 procedure Transfer_Entities
(From
: Entity_Id
; To
: Entity_Id
) is
28204 procedure Set_Public_Status_Of
(Id
: Entity_Id
);
28205 -- Set the Is_Public attribute of arbitrary entity Id by calling routine
28206 -- Set_Public_Status. If successful and Id denotes a record type, set
28207 -- the Is_Public attribute of its fields.
28209 --------------------------
28210 -- Set_Public_Status_Of --
28211 --------------------------
28213 procedure Set_Public_Status_Of
(Id
: Entity_Id
) is
28217 if not Is_Public
(Id
) then
28218 Set_Public_Status
(Id
);
28220 -- When the input entity is a public record type, ensure that all
28221 -- its internal fields are also exposed to the linker. The fields
28222 -- of a class-wide type are never made public.
28225 and then Is_Record_Type
(Id
)
28226 and then not Is_Class_Wide_Type
(Id
)
28228 Field
:= First_Entity
(Id
);
28229 while Present
(Field
) loop
28230 Set_Is_Public
(Field
);
28231 Next_Entity
(Field
);
28235 end Set_Public_Status_Of
;
28239 Full_Id
: Entity_Id
;
28242 -- Start of processing for Transfer_Entities
28245 Id
:= First_Entity
(From
);
28247 if Present
(Id
) then
28249 -- Merge the entity chain of the source scope with that of the
28250 -- destination scope.
28252 if Present
(Last_Entity
(To
)) then
28253 Link_Entities
(Last_Entity
(To
), Id
);
28255 Set_First_Entity
(To
, Id
);
28258 Set_Last_Entity
(To
, Last_Entity
(From
));
28260 -- Inspect the entities of the source scope and update their Scope
28263 while Present
(Id
) loop
28264 Set_Scope
(Id
, To
);
28265 Set_Public_Status_Of
(Id
);
28267 -- Handle an internally generated full view for a private type
28269 if Is_Private_Type
(Id
)
28270 and then Present
(Full_View
(Id
))
28271 and then Is_Itype
(Full_View
(Id
))
28273 Full_Id
:= Full_View
(Id
);
28275 Set_Scope
(Full_Id
, To
);
28276 Set_Public_Status_Of
(Full_Id
);
28282 Set_First_Entity
(From
, Empty
);
28283 Set_Last_Entity
(From
, Empty
);
28285 end Transfer_Entities
;
28287 ------------------------
28288 -- Traverse_More_Func --
28289 ------------------------
28291 function Traverse_More_Func
(Node
: Node_Id
) return Traverse_Final_Result
is
28293 Processing_Itype
: Boolean := False;
28294 -- Set to True while traversing the nodes under an Itype, to prevent
28295 -- looping on Itype handling during that traversal.
28297 function Process_More
(N
: Node_Id
) return Traverse_Result
;
28298 -- Wrapper over the Process callback to handle parts of the AST that
28299 -- are not normally traversed as syntactic children.
28301 function Traverse_Rec
(N
: Node_Id
) return Traverse_Final_Result
;
28302 -- Main recursive traversal implemented as an instantiation of
28303 -- Traverse_Func over a modified Process callback.
28309 function Process_More
(N
: Node_Id
) return Traverse_Result
is
28311 procedure Traverse_More
(N
: Node_Id
;
28312 Res
: in out Traverse_Result
);
28313 procedure Traverse_More
(L
: List_Id
;
28314 Res
: in out Traverse_Result
);
28315 -- Traverse a node or list and update the traversal result to value
28316 -- Abandon when needed.
28318 -------------------
28319 -- Traverse_More --
28320 -------------------
28322 procedure Traverse_More
(N
: Node_Id
;
28323 Res
: in out Traverse_Result
)
28326 -- Do not process any more nodes if Abandon was reached
28328 if Res
= Abandon
then
28332 if Traverse_Rec
(N
) = Abandon
then
28337 procedure Traverse_More
(L
: List_Id
;
28338 Res
: in out Traverse_Result
)
28340 N
: Node_Id
:= First
(L
);
28343 -- Do not process any more nodes if Abandon was reached
28345 if Res
= Abandon
then
28349 while Present
(N
) loop
28350 Traverse_More
(N
, Res
);
28358 Result
: Traverse_Result
;
28360 -- Start of processing for Process_More
28363 -- Initial callback to Process. Return immediately on Skip/Abandon.
28364 -- Otherwise update the value of Node for further processing of
28365 -- non-syntactic children.
28367 Result
:= Process
(N
);
28370 when OK
=> Node
:= N
;
28371 when OK_Orig
=> Node
:= Original_Node
(N
);
28372 when Skip
=> return Skip
;
28373 when Abandon
=> return Abandon
;
28376 -- Process the relevant semantic children which are a logical part of
28377 -- the AST under this node before returning for the processing of
28378 -- syntactic children.
28380 -- Start with all non-syntactic lists of action nodes
28382 case Nkind
(Node
) is
28383 when N_Component_Association
=>
28384 Traverse_More
(Loop_Actions
(Node
), Result
);
28386 when N_Elsif_Part
=>
28387 Traverse_More
(Condition_Actions
(Node
), Result
);
28389 when N_Short_Circuit
=>
28390 Traverse_More
(Actions
(Node
), Result
);
28392 when N_Case_Expression_Alternative
=>
28393 Traverse_More
(Actions
(Node
), Result
);
28395 when N_Iterated_Component_Association
=>
28396 Traverse_More
(Loop_Actions
(Node
), Result
);
28398 when N_Iterated_Element_Association
=>
28399 Traverse_More
(Loop_Actions
(Node
), Result
);
28401 when N_Iteration_Scheme
=>
28402 Traverse_More
(Condition_Actions
(Node
), Result
);
28404 when N_If_Expression
=>
28405 Traverse_More
(Then_Actions
(Node
), Result
);
28406 Traverse_More
(Else_Actions
(Node
), Result
);
28408 -- Various nodes have a field Actions as a syntactic node,
28409 -- so it will be traversed in the regular syntactic traversal.
28411 when N_Compilation_Unit_Aux
28412 | N_Compound_Statement
28413 | N_Expression_With_Actions
28422 -- If Process_Itypes is True, process unattached nodes which come
28423 -- from Itypes. This only concerns currently ranges of scalar
28424 -- (possibly as index) types. This traversal is protected against
28425 -- looping with Processing_Itype.
28428 and then not Processing_Itype
28429 and then Nkind
(Node
) in N_Has_Etype
28430 and then Present
(Etype
(Node
))
28431 and then Is_Itype
(Etype
(Node
))
28434 Typ
: constant Entity_Id
:= Etype
(Node
);
28436 Processing_Itype
:= True;
28438 case Ekind
(Typ
) is
28439 when Scalar_Kind
=>
28440 Traverse_More
(Scalar_Range
(Typ
), Result
);
28444 Index
: Node_Id
:= First_Index
(Typ
);
28447 while Present
(Index
) loop
28448 if Nkind
(Index
) in N_Has_Entity
then
28449 Rng
:= Scalar_Range
(Entity
(Index
));
28454 Traverse_More
(Rng
, Result
);
28455 Next_Index
(Index
);
28462 Processing_Itype
:= False;
28469 -- Define Traverse_Rec as a renaming of the instantiation, as an
28470 -- instantiation cannot complete a previous spec.
28472 function Traverse_Recursive
is new Traverse_Func
(Process_More
);
28473 function Traverse_Rec
(N
: Node_Id
) return Traverse_Final_Result
28474 renames Traverse_Recursive
;
28476 -- Start of processing for Traverse_More_Func
28479 return Traverse_Rec
(Node
);
28480 end Traverse_More_Func
;
28482 ------------------------
28483 -- Traverse_More_Proc --
28484 ------------------------
28486 procedure Traverse_More_Proc
(Node
: Node_Id
) is
28487 function Traverse
is new Traverse_More_Func
(Process
, Process_Itypes
);
28488 Discard
: Traverse_Final_Result
;
28489 pragma Warnings
(Off
, Discard
);
28491 Discard
:= Traverse
(Node
);
28492 end Traverse_More_Proc
;
28494 ------------------------------------
28495 -- Type_Without_Stream_Operation --
28496 ------------------------------------
28498 function Type_Without_Stream_Operation
28500 Op
: TSS_Name_Type
:= TSS_Null
) return Entity_Id
28502 BT
: constant Entity_Id
:= Base_Type
(T
);
28503 Op_Missing
: Boolean;
28506 if not Restriction_Active
(No_Default_Stream_Attributes
) then
28510 if Is_Elementary_Type
(T
) then
28511 if Op
= TSS_Null
then
28513 No
(TSS
(BT
, TSS_Stream_Read
))
28514 or else No
(TSS
(BT
, TSS_Stream_Write
));
28517 Op_Missing
:= No
(TSS
(BT
, Op
));
28526 elsif Is_Array_Type
(T
) then
28527 return Type_Without_Stream_Operation
(Component_Type
(T
), Op
);
28529 elsif Is_Record_Type
(T
) then
28535 Comp
:= First_Component
(T
);
28536 while Present
(Comp
) loop
28537 C_Typ
:= Type_Without_Stream_Operation
(Etype
(Comp
), Op
);
28539 if Present
(C_Typ
) then
28543 Next_Component
(Comp
);
28549 elsif Is_Private_Type
(T
) and then Present
(Full_View
(T
)) then
28550 return Type_Without_Stream_Operation
(Full_View
(T
), Op
);
28554 end Type_Without_Stream_Operation
;
28556 ------------------------------
28557 -- Ultimate_Overlaid_Entity --
28558 ------------------------------
28560 function Ultimate_Overlaid_Entity
(E
: Entity_Id
) return Entity_Id
is
28562 Alias
: Entity_Id
:= E
;
28566 -- Currently this routine is only called for stand-alone objects that
28567 -- have been analysed, since the analysis of the Address aspect is often
28570 pragma Assert
(Ekind
(E
) in E_Constant | E_Variable
);
28573 Address
:= Address_Clause
(Alias
);
28574 if Present
(Address
) then
28575 Find_Overlaid_Entity
(Address
, Alias
, Offset
);
28576 if Present
(Alias
) then
28581 elsif Alias
= E
then
28587 end Ultimate_Overlaid_Entity
;
28589 ---------------------
28590 -- Ultimate_Prefix --
28591 ---------------------
28593 function Ultimate_Prefix
(N
: Node_Id
) return Node_Id
is
28598 while Nkind
(Pref
) in N_Explicit_Dereference
28599 | N_Indexed_Component
28600 | N_Selected_Component
28603 Pref
:= Prefix
(Pref
);
28607 end Ultimate_Prefix
;
28609 ----------------------------
28610 -- Unique_Defining_Entity --
28611 ----------------------------
28613 function Unique_Defining_Entity
(N
: Node_Id
) return Entity_Id
is
28615 return Unique_Entity
(Defining_Entity
(N
));
28616 end Unique_Defining_Entity
;
28618 -------------------
28619 -- Unique_Entity --
28620 -------------------
28622 function Unique_Entity
(E
: Entity_Id
) return Entity_Id
is
28623 U
: Entity_Id
:= E
;
28629 if Present
(Full_View
(E
)) then
28630 U
:= Full_View
(E
);
28634 if Nkind
(Parent
(E
)) = N_Entry_Body
then
28636 Prot_Item
: Entity_Id
;
28637 Prot_Type
: Entity_Id
;
28640 if Ekind
(E
) = E_Entry
then
28641 Prot_Type
:= Scope
(E
);
28643 -- Bodies of entry families are nested within an extra scope
28644 -- that contains an entry index declaration.
28647 Prot_Type
:= Scope
(Scope
(E
));
28650 -- A protected type may be declared as a private type, in
28651 -- which case we need to get its full view.
28653 if Is_Private_Type
(Prot_Type
) then
28654 Prot_Type
:= Full_View
(Prot_Type
);
28657 -- Full view may not be present on error, in which case
28658 -- return E by default.
28660 if Present
(Prot_Type
) then
28661 pragma Assert
(Ekind
(Prot_Type
) = E_Protected_Type
);
28663 -- Traverse the entity list of the protected type and
28664 -- locate an entry declaration which matches the entry
28667 Prot_Item
:= First_Entity
(Prot_Type
);
28668 while Present
(Prot_Item
) loop
28669 if Ekind
(Prot_Item
) in Entry_Kind
28670 and then Corresponding_Body
(Parent
(Prot_Item
)) = E
28676 Next_Entity
(Prot_Item
);
28682 when Formal_Kind
=>
28683 if Present
(Spec_Entity
(E
)) then
28684 U
:= Spec_Entity
(E
);
28687 when E_Package_Body
=>
28690 if Nkind
(P
) = N_Defining_Program_Unit_Name
then
28694 if Nkind
(P
) = N_Package_Body
28695 and then Present
(Corresponding_Spec
(P
))
28697 U
:= Corresponding_Spec
(P
);
28699 elsif Nkind
(P
) = N_Package_Body_Stub
28700 and then Present
(Corresponding_Spec_Of_Stub
(P
))
28702 U
:= Corresponding_Spec_Of_Stub
(P
);
28705 when E_Protected_Body
=>
28708 if Nkind
(P
) = N_Protected_Body
28709 and then Present
(Corresponding_Spec
(P
))
28711 U
:= Corresponding_Spec
(P
);
28713 elsif Nkind
(P
) = N_Protected_Body_Stub
28714 and then Present
(Corresponding_Spec_Of_Stub
(P
))
28716 U
:= Corresponding_Spec_Of_Stub
(P
);
28718 if Is_Single_Protected_Object
(U
) then
28723 if Is_Private_Type
(U
) then
28724 U
:= Full_View
(U
);
28727 when E_Subprogram_Body
=>
28730 if Nkind
(P
) = N_Defining_Program_Unit_Name
then
28736 if Nkind
(P
) = N_Subprogram_Body
28737 and then Present
(Corresponding_Spec
(P
))
28739 U
:= Corresponding_Spec
(P
);
28741 elsif Nkind
(P
) = N_Subprogram_Body_Stub
28742 and then Present
(Corresponding_Spec_Of_Stub
(P
))
28744 U
:= Corresponding_Spec_Of_Stub
(P
);
28746 elsif Nkind
(P
) = N_Subprogram_Renaming_Declaration
then
28747 U
:= Corresponding_Spec
(P
);
28750 when E_Task_Body
=>
28753 if Nkind
(P
) = N_Task_Body
28754 and then Present
(Corresponding_Spec
(P
))
28756 U
:= Corresponding_Spec
(P
);
28758 elsif Nkind
(P
) = N_Task_Body_Stub
28759 and then Present
(Corresponding_Spec_Of_Stub
(P
))
28761 U
:= Corresponding_Spec_Of_Stub
(P
);
28763 if Is_Single_Task_Object
(U
) then
28768 if Is_Private_Type
(U
) then
28769 U
:= Full_View
(U
);
28773 if Present
(Full_View
(E
)) then
28774 U
:= Full_View
(E
);
28788 function Unique_Name
(E
: Entity_Id
) return String is
28790 -- Local subprograms
28792 function Add_Homonym_Suffix
(E
: Entity_Id
) return String;
28794 function This_Name
return String;
28796 ------------------------
28797 -- Add_Homonym_Suffix --
28798 ------------------------
28800 function Add_Homonym_Suffix
(E
: Entity_Id
) return String is
28802 -- Names in E_Subprogram_Body or E_Package_Body entities are not
28803 -- reliable, as they may not include the overloading suffix.
28804 -- Instead, when looking for the name of E or one of its enclosing
28805 -- scope, we get the name of the corresponding Unique_Entity.
28807 U
: constant Entity_Id
:= Unique_Entity
(E
);
28808 Nam
: constant String := Get_Name_String
(Chars
(U
));
28811 -- If E has homonyms but is not fully qualified, as done in
28812 -- GNATprove mode, append the homonym number on the fly. Strip the
28813 -- leading space character in the image of natural numbers. Also do
28814 -- not print the homonym value of 1.
28816 if Has_Homonym
(U
) then
28818 N
: constant Pos
:= Homonym_Number
(U
);
28819 S
: constant String := N
'Img;
28822 return Nam
& "__" & S
(2 .. S
'Last);
28828 end Add_Homonym_Suffix
;
28834 function This_Name
return String is
28836 return Add_Homonym_Suffix
(E
);
28841 U
: constant Entity_Id
:= Unique_Entity
(E
);
28843 -- Start of processing for Unique_Name
28846 if E
= Standard_Standard
28847 or else Has_Fully_Qualified_Name
(E
)
28851 elsif Ekind
(E
) = E_Enumeration_Literal
then
28852 return Unique_Name
(Etype
(E
)) & "__" & This_Name
;
28856 S
: constant Entity_Id
:= Scope
(U
);
28857 pragma Assert
(Present
(S
));
28860 -- Prefix names of predefined types with standard__, but leave
28861 -- names of user-defined packages and subprograms without prefix
28862 -- (even if technically they are nested in the Standard package).
28864 if S
= Standard_Standard
then
28865 if Ekind
(U
) = E_Package
or else Is_Subprogram
(U
) then
28868 return Unique_Name
(S
) & "__" & This_Name
;
28871 -- For intances of generic subprograms use the name of the related
28872 -- instance and skip the scope of its wrapper package.
28874 elsif Is_Wrapper_Package
(S
) then
28875 pragma Assert
(Scope
(S
) = Scope
(Related_Instance
(S
)));
28876 -- Wrapper package and the instantiation are in the same scope
28879 Related_Name
: constant String :=
28880 Add_Homonym_Suffix
(Related_Instance
(S
));
28881 Enclosing_Name
: constant String :=
28882 Unique_Name
(Scope
(S
)) & "__" & Related_Name
;
28885 if Is_Subprogram
(U
)
28886 and then not Is_Generic_Actual_Subprogram
(U
)
28888 return Enclosing_Name
;
28890 return Enclosing_Name
& "__" & This_Name
;
28894 elsif Is_Child_Unit
(U
) then
28895 return Child_Prefix
& Unique_Name
(S
) & "__" & This_Name
;
28897 return Unique_Name
(S
) & "__" & This_Name
;
28903 ---------------------
28904 -- Unit_Is_Visible --
28905 ---------------------
28907 function Unit_Is_Visible
(U
: Entity_Id
) return Boolean is
28908 Curr
: constant Node_Id
:= Cunit
(Current_Sem_Unit
);
28909 Curr_Entity
: constant Entity_Id
:= Cunit_Entity
(Current_Sem_Unit
);
28911 function Unit_In_Parent_Context
(Par_Unit
: Node_Id
) return Boolean;
28912 -- For a child unit, check whether unit appears in a with_clause
28915 function Unit_In_Context
(Comp_Unit
: Node_Id
) return Boolean;
28916 -- Scan the context clause of one compilation unit looking for a
28917 -- with_clause for the unit in question.
28919 ----------------------------
28920 -- Unit_In_Parent_Context --
28921 ----------------------------
28923 function Unit_In_Parent_Context
(Par_Unit
: Node_Id
) return Boolean is
28925 if Unit_In_Context
(Par_Unit
) then
28928 elsif Is_Child_Unit
(Defining_Entity
(Unit
(Par_Unit
))) then
28929 return Unit_In_Parent_Context
(Parent_Spec
(Unit
(Par_Unit
)));
28934 end Unit_In_Parent_Context
;
28936 ---------------------
28937 -- Unit_In_Context --
28938 ---------------------
28940 function Unit_In_Context
(Comp_Unit
: Node_Id
) return Boolean is
28944 Clause
:= First
(Context_Items
(Comp_Unit
));
28945 while Present
(Clause
) loop
28946 if Nkind
(Clause
) = N_With_Clause
then
28947 if Library_Unit
(Clause
) = U
then
28950 -- The with_clause may denote a renaming of the unit we are
28951 -- looking for, eg. Text_IO which renames Ada.Text_IO.
28954 Renamed_Entity
(Entity
(Name
(Clause
))) =
28955 Defining_Entity
(Unit
(U
))
28965 end Unit_In_Context
;
28967 -- Start of processing for Unit_Is_Visible
28970 -- The currrent unit is directly visible
28975 elsif Unit_In_Context
(Curr
) then
28978 -- If the current unit is a body, check the context of the spec
28980 elsif Nkind
(Unit
(Curr
)) = N_Package_Body
28982 (Nkind
(Unit
(Curr
)) = N_Subprogram_Body
28983 and then not Acts_As_Spec
(Unit
(Curr
)))
28985 if Unit_In_Context
(Library_Unit
(Curr
)) then
28990 -- If the spec is a child unit, examine the parents
28992 if Is_Child_Unit
(Curr_Entity
) then
28993 if Nkind
(Unit
(Curr
)) in N_Unit_Body
then
28995 Unit_In_Parent_Context
28996 (Parent_Spec
(Unit
(Library_Unit
(Curr
))));
28998 return Unit_In_Parent_Context
(Parent_Spec
(Unit
(Curr
)));
29004 end Unit_Is_Visible
;
29006 ------------------------------
29007 -- Universal_Interpretation --
29008 ------------------------------
29010 function Universal_Interpretation
(Opnd
: Node_Id
) return Entity_Id
is
29011 Index
: Interp_Index
;
29015 -- The argument may be a formal parameter of an operator or subprogram
29016 -- with multiple interpretations, or else an expression for an actual.
29018 if Nkind
(Opnd
) = N_Defining_Identifier
29019 or else not Is_Overloaded
(Opnd
)
29021 if Is_Universal_Numeric_Type
(Etype
(Opnd
)) then
29022 return Etype
(Opnd
);
29028 Get_First_Interp
(Opnd
, Index
, It
);
29029 while Present
(It
.Typ
) loop
29030 if Is_Universal_Numeric_Type
(It
.Typ
) then
29034 Get_Next_Interp
(Index
, It
);
29039 end Universal_Interpretation
;
29045 function Unqualify
(Expr
: Node_Id
) return Node_Id
is
29047 -- Recurse to handle unlikely case of multiple levels of qualification
29049 if Nkind
(Expr
) = N_Qualified_Expression
then
29050 return Unqualify
(Expression
(Expr
));
29052 -- Normal case, not a qualified expression
29063 function Unqual_Conv
(Expr
: Node_Id
) return Node_Id
is
29065 -- Recurse to handle unlikely case of multiple levels of qualification
29066 -- and/or conversion.
29068 if Nkind
(Expr
) in N_Qualified_Expression
29069 | N_Type_Conversion
29070 | N_Unchecked_Type_Conversion
29072 return Unqual_Conv
(Expression
(Expr
));
29074 -- Normal case, not a qualified expression
29081 --------------------
29082 -- Validated_View --
29083 --------------------
29085 function Validated_View
(Typ
: Entity_Id
) return Entity_Id
is
29087 -- Scalar types can be always validated. In fast, switiching to the base
29088 -- type would drop the range constraints and force validation to use a
29089 -- larger type than necessary.
29091 if Is_Scalar_Type
(Typ
) then
29094 -- Array types can be validated even when they are derived, because
29095 -- validation only requires their bounds and component types to be
29096 -- accessible. In fact, switching to the parent type would pollute
29097 -- expansion of attribute Valid_Scalars with unnecessary conversion
29098 -- that might not be eliminated by the frontend.
29100 elsif Is_Array_Type
(Typ
) then
29103 -- For other types, in particular for record subtypes, we switch to the
29106 elsif not Is_Base_Type
(Typ
) then
29107 return Validated_View
(Base_Type
(Typ
));
29109 -- Obtain the full view of the input type by stripping away concurrency,
29110 -- derivations, and privacy.
29112 elsif Is_Concurrent_Type
(Typ
) then
29113 if Present
(Corresponding_Record_Type
(Typ
)) then
29114 return Corresponding_Record_Type
(Typ
);
29119 elsif Is_Derived_Type
(Typ
) then
29120 return Validated_View
(Etype
(Typ
));
29122 elsif Is_Private_Type
(Typ
) then
29123 if Present
(Underlying_Full_View
(Typ
)) then
29124 return Validated_View
(Underlying_Full_View
(Typ
));
29126 elsif Present
(Full_View
(Typ
)) then
29127 return Validated_View
(Full_View
(Typ
));
29132 elsif From_Limited_With
(Typ
) then
29133 if Has_Non_Limited_View
(Typ
) then
29134 return Validated_View
(Non_Limited_View
(Typ
));
29142 end Validated_View
;
29144 -----------------------
29145 -- Visible_Ancestors --
29146 -----------------------
29148 function Visible_Ancestors
(Typ
: Entity_Id
) return Elist_Id
is
29154 pragma Assert
(Is_Record_Type
(Typ
) and then Is_Tagged_Type
(Typ
));
29156 -- Collect all the parents and progenitors of Typ. If the full-view of
29157 -- private parents and progenitors is available then it is used to
29158 -- generate the list of visible ancestors; otherwise their partial
29159 -- view is added to the resulting list.
29164 Use_Full_View
=> True);
29168 Ifaces_List
=> List_2
,
29169 Exclude_Parents
=> True,
29170 Use_Full_View
=> True);
29172 -- Join the two lists. Avoid duplications because an interface may
29173 -- simultaneously be parent and progenitor of a type.
29175 Elmt
:= First_Elmt
(List_2
);
29176 while Present
(Elmt
) loop
29177 Append_Unique_Elmt
(Node
(Elmt
), List_1
);
29182 end Visible_Ancestors
;
29184 ---------------------------
29185 -- Warn_On_Hiding_Entity --
29186 ---------------------------
29188 procedure Warn_On_Hiding_Entity
29190 Hidden
, Visible
: Entity_Id
;
29191 On_Use_Clause
: Boolean)
29194 -- Don't warn for record components since they always have a well
29195 -- defined scope which does not confuse other uses. Note that in
29196 -- some cases, Ekind has not been set yet.
29198 if Ekind
(Hidden
) /= E_Component
29199 and then Ekind
(Hidden
) /= E_Discriminant
29200 and then Nkind
(Parent
(Hidden
)) /= N_Component_Declaration
29201 and then Ekind
(Visible
) /= E_Component
29202 and then Ekind
(Visible
) /= E_Discriminant
29203 and then Nkind
(Parent
(Visible
)) /= N_Component_Declaration
29205 -- Don't warn for one character variables. It is too common to use
29206 -- such variables as locals and will just cause too many false hits.
29208 and then Length_Of_Name
(Chars
(Hidden
)) /= 1
29210 -- Don't warn for non-source entities
29212 and then Comes_From_Source
(Hidden
)
29213 and then Comes_From_Source
(Visible
)
29215 -- Don't warn within a generic instantiation
29217 and then not In_Instance
29219 -- Don't warn unless entity in question is in extended main source
29221 and then In_Extended_Main_Source_Unit
(Visible
)
29223 -- Finally, in the case of a declaration, the hidden entity must
29224 -- be either immediately visible or use visible (i.e. from a used
29225 -- package). In the case of a use clause, the visible entity must
29226 -- be immediately visible.
29229 (if On_Use_Clause
then
29230 Is_Immediately_Visible
(Visible
)
29232 (Is_Immediately_Visible
(Hidden
)
29234 Is_Potentially_Use_Visible
(Hidden
)))
29236 if On_Use_Clause
then
29237 Error_Msg_Sloc
:= Sloc
(Visible
);
29238 Error_Msg_NE
("visible declaration of&# hides homonym "
29239 & "from use clause?h?", N
, Hidden
);
29241 Error_Msg_Sloc
:= Sloc
(Hidden
);
29242 Error_Msg_NE
("declaration hides &#?h?", N
, Visible
);
29245 end Warn_On_Hiding_Entity
;
29247 ----------------------
29248 -- Within_Init_Proc --
29249 ----------------------
29251 function Within_Init_Proc
return Boolean is
29255 S
:= Current_Scope
;
29256 while not Is_Overloadable
(S
) loop
29257 if S
= Standard_Standard
then
29264 return Is_Init_Proc
(S
);
29265 end Within_Init_Proc
;
29267 ---------------------------
29268 -- Within_Protected_Type --
29269 ---------------------------
29271 function Within_Protected_Type
(E
: Entity_Id
) return Boolean is
29272 Scop
: Entity_Id
:= Scope
(E
);
29275 while Present
(Scop
) loop
29276 if Ekind
(Scop
) = E_Protected_Type
then
29280 Scop
:= Scope
(Scop
);
29284 end Within_Protected_Type
;
29290 function Within_Scope
(E
: Entity_Id
; S
: Entity_Id
) return Boolean is
29292 return Scope_Within_Or_Same
(Scope
(E
), S
);
29299 procedure Wrong_Type
29301 Expected_Type
: Entity_Id
;
29302 Multiple
: Boolean := False)
29304 Found_Type
: constant Entity_Id
:= First_Subtype
(Etype
(Expr
));
29305 Expec_Type
: constant Entity_Id
:= First_Subtype
(Expected_Type
);
29307 Err_Msg_Exp_Typ
: Entity_Id
:= Expected_Type
;
29308 -- Type entity used when printing errors concerning the expected type
29310 Matching_Field
: Entity_Id
;
29311 -- Entity to give a more precise suggestion on how to write a one-
29312 -- element positional aggregate.
29314 function Has_One_Matching_Field
return Boolean;
29315 -- Determines if Expec_Type is a record type with a single component or
29316 -- discriminant whose type matches the found type or is one dimensional
29317 -- array whose component type matches the found type. In the case of
29318 -- one discriminant, we ignore the variant parts. That's not accurate,
29319 -- but good enough for the warning.
29321 ----------------------------
29322 -- Has_One_Matching_Field --
29323 ----------------------------
29325 function Has_One_Matching_Field
return Boolean is
29329 Matching_Field
:= Empty
;
29331 if Is_Array_Type
(Expec_Type
)
29332 and then Number_Dimensions
(Expec_Type
) = 1
29333 and then Covers
(Etype
(Component_Type
(Expec_Type
)), Found_Type
)
29335 -- Use type name if available. This excludes multidimensional
29336 -- arrays and anonymous arrays.
29338 if Comes_From_Source
(Expec_Type
) then
29339 Matching_Field
:= Expec_Type
;
29341 -- For an assignment, use name of target
29343 elsif Nkind
(Parent
(Expr
)) = N_Assignment_Statement
29344 and then Is_Entity_Name
(Name
(Parent
(Expr
)))
29346 Matching_Field
:= Entity
(Name
(Parent
(Expr
)));
29351 elsif not Is_Record_Type
(Expec_Type
) then
29355 E
:= First_Entity
(Expec_Type
);
29360 elsif Ekind
(E
) not in E_Discriminant | E_Component
29361 or else Chars
(E
) in Name_uTag | Name_uParent
29370 if not Covers
(Etype
(E
), Found_Type
) then
29373 elsif Present
(Next_Entity
(E
))
29374 and then (Ekind
(E
) = E_Component
29375 or else Ekind
(Next_Entity
(E
)) = E_Discriminant
)
29380 Matching_Field
:= E
;
29384 end Has_One_Matching_Field
;
29386 -- Start of processing for Wrong_Type
29389 -- Don't output message if either type is Any_Type, or if a message
29390 -- has already been posted for this node and we do not want multiple
29391 -- error messages. We need to do the latter check explicitly (it is
29392 -- ordinarily done in Errout) because we are using '!' to force the
29393 -- output of the error messages.
29395 if Expec_Type
= Any_Type
29396 or else Found_Type
= Any_Type
29397 or else (Error_Posted
(Expr
) and then not Multiple
)
29401 -- If one of the types is a Taft-Amendment type and the other it its
29402 -- completion, it must be an illegal use of a TAT in the spec, for
29403 -- which an error was already emitted. Avoid cascaded errors.
29405 elsif Is_Incomplete_Type
(Expec_Type
)
29406 and then Has_Completion_In_Body
(Expec_Type
)
29407 and then Full_View
(Expec_Type
) = Etype
(Expr
)
29411 elsif Is_Incomplete_Type
(Etype
(Expr
))
29412 and then Has_Completion_In_Body
(Etype
(Expr
))
29413 and then Full_View
(Etype
(Expr
)) = Expec_Type
29418 -- Avoid printing internally generated subtypes in error messages and
29419 -- instead use the corresponding first subtype in such cases.
29421 if not Comes_From_Source
(Err_Msg_Exp_Typ
)
29422 or else not Comes_From_Source
(Declaration_Node
(Err_Msg_Exp_Typ
))
29424 Err_Msg_Exp_Typ
:= First_Subtype
(Err_Msg_Exp_Typ
);
29427 -- An interesting special check. If the expression is parenthesized
29428 -- and its type corresponds to the type of the sole component of the
29429 -- expected record type, or to the component type of the expected one
29430 -- dimensional array type, then assume we have a bad aggregate attempt.
29432 if Nkind
(Expr
) in N_Subexpr
29433 and then Paren_Count
(Expr
) /= 0
29434 and then Has_One_Matching_Field
29436 Error_Msg_N
("positional aggregate cannot have one component", Expr
);
29438 if Present
(Matching_Field
) then
29439 if Is_Array_Type
(Expec_Type
) then
29441 ("\write instead `&''First ='> ...`", Expr
, Matching_Field
);
29444 ("\write instead `& ='> ...`", Expr
, Matching_Field
);
29448 -- Another special check, if we are looking for a pool-specific access
29449 -- type and we found an E_Access_Attribute_Type, then we have the case
29450 -- of an Access attribute being used in a context which needs a pool-
29451 -- specific type, which is never allowed. The one extra check we make
29452 -- is that the expected designated type covers the Found_Type.
29454 elsif Is_Access_Type
(Expec_Type
)
29455 and then Ekind
(Found_Type
) = E_Access_Attribute_Type
29456 and then Ekind
(Base_Type
(Expec_Type
)) /= E_General_Access_Type
29457 and then Ekind
(Base_Type
(Expec_Type
)) /= E_Anonymous_Access_Type
29459 (Designated_Type
(Expec_Type
), Designated_Type
(Found_Type
))
29462 ("result must be general access type!", Expr
);
29463 Error_Msg_NE
-- CODEFIX
29464 ("\add ALL to }!", Expr
, Err_Msg_Exp_Typ
);
29466 -- Another special check, if the expected type is an integer type,
29467 -- but the expression is of type System.Address, and the parent is
29468 -- an addition or subtraction operation whose left operand is the
29469 -- expression in question and whose right operand is of an integral
29470 -- type, then this is an attempt at address arithmetic, so give
29471 -- appropriate message.
29473 elsif Is_Integer_Type
(Expec_Type
)
29474 and then Is_RTE
(Found_Type
, RE_Address
)
29475 and then Nkind
(Parent
(Expr
)) in N_Op_Add | N_Op_Subtract
29476 and then Expr
= Left_Opnd
(Parent
(Expr
))
29477 and then Is_Integer_Type
(Etype
(Right_Opnd
(Parent
(Expr
))))
29480 ("address arithmetic not predefined in package System",
29483 ("\possible missing with/use of System.Storage_Elements",
29487 -- If the expected type is an anonymous access type, as for access
29488 -- parameters and discriminants, the error is on the designated types.
29490 elsif Ekind
(Expec_Type
) = E_Anonymous_Access_Type
then
29491 if Comes_From_Source
(Expec_Type
) then
29492 Error_Msg_NE
("expected}!", Expr
, Expec_Type
);
29495 ("expected an access type with designated}",
29496 Expr
, Designated_Type
(Expec_Type
));
29499 if Is_Access_Type
(Found_Type
)
29500 and then not Comes_From_Source
(Found_Type
)
29503 ("\\found an access type with designated}!",
29504 Expr
, Designated_Type
(Found_Type
));
29506 if From_Limited_With
(Found_Type
) then
29507 Error_Msg_NE
("\\found incomplete}!", Expr
, Found_Type
);
29508 Error_Msg_Qual_Level
:= 99;
29509 Error_Msg_NE
-- CODEFIX
29510 ("\\missing `WITH &;", Expr
, Scope
(Found_Type
));
29511 Error_Msg_Qual_Level
:= 0;
29513 Error_Msg_NE
("found}!", Expr
, Found_Type
);
29517 -- Normal case of one type found, some other type expected
29520 -- If the names of the two types are the same, see if some number
29521 -- of levels of qualification will help. Don't try more than three
29522 -- levels, and if we get to standard, it's no use (and probably
29523 -- represents an error in the compiler) Also do not bother with
29524 -- internal scope names.
29527 Expec_Scope
: Entity_Id
;
29528 Found_Scope
: Entity_Id
;
29531 Expec_Scope
:= Expec_Type
;
29532 Found_Scope
:= Found_Type
;
29534 for Levels
in Nat
range 0 .. 3 loop
29535 if Chars
(Expec_Scope
) /= Chars
(Found_Scope
) then
29536 Error_Msg_Qual_Level
:= Levels
;
29540 Expec_Scope
:= Scope
(Expec_Scope
);
29541 Found_Scope
:= Scope
(Found_Scope
);
29543 exit when Expec_Scope
= Standard_Standard
29544 or else Found_Scope
= Standard_Standard
29545 or else not Comes_From_Source
(Expec_Scope
)
29546 or else not Comes_From_Source
(Found_Scope
);
29550 if Is_Record_Type
(Expec_Type
)
29551 and then Present
(Corresponding_Remote_Type
(Expec_Type
))
29553 Error_Msg_NE
("expected}!", Expr
,
29554 Corresponding_Remote_Type
(Expec_Type
));
29556 Error_Msg_NE
("expected}!", Expr
, Err_Msg_Exp_Typ
);
29559 if Is_Entity_Name
(Expr
)
29560 and then Is_Package_Or_Generic_Package
(Entity
(Expr
))
29562 Error_Msg_N
("\\found package name!", Expr
);
29564 elsif Is_Entity_Name
(Expr
)
29565 and then Ekind
(Entity
(Expr
)) in E_Procedure | E_Generic_Procedure
29567 if Ekind
(Expec_Type
) = E_Access_Subprogram_Type
then
29569 ("found procedure name, possibly missing Access attribute!",
29573 ("\\found procedure name instead of function!", Expr
);
29576 elsif Nkind
(Expr
) = N_Function_Call
29577 and then Ekind
(Expec_Type
) = E_Access_Subprogram_Type
29578 and then Etype
(Designated_Type
(Expec_Type
)) = Etype
(Expr
)
29579 and then No
(Parameter_Associations
(Expr
))
29582 ("found function name, possibly missing Access attribute!",
29585 -- Catch common error: a prefix or infix operator which is not
29586 -- directly visible because the type isn't.
29588 elsif Nkind
(Expr
) in N_Op
29589 and then Is_Overloaded
(Expr
)
29590 and then not Is_Immediately_Visible
(Expec_Type
)
29591 and then not Is_Potentially_Use_Visible
(Expec_Type
)
29592 and then not In_Use
(Expec_Type
)
29593 and then Has_Compatible_Type
(Right_Opnd
(Expr
), Expec_Type
)
29596 ("operator of the type is not directly visible!", Expr
);
29598 elsif Ekind
(Found_Type
) = E_Void
29599 and then Present
(Parent
(Found_Type
))
29600 and then Nkind
(Parent
(Found_Type
)) = N_Full_Type_Declaration
29602 Error_Msg_NE
("\\found premature usage of}!", Expr
, Found_Type
);
29605 Error_Msg_NE
("\\found}!", Expr
, Found_Type
);
29608 -- A special check for cases like M1 and M2 = 0 where M1 and M2 are
29609 -- of the same modular type, and (M1 and M2) = 0 was intended.
29611 if Expec_Type
= Standard_Boolean
29612 and then Is_Modular_Integer_Type
(Found_Type
)
29613 and then Nkind
(Parent
(Expr
)) in N_Op_And | N_Op_Or | N_Op_Xor
29614 and then Nkind
(Right_Opnd
(Parent
(Expr
))) in N_Op_Compare
29617 Op
: constant Node_Id
:= Right_Opnd
(Parent
(Expr
));
29618 L
: constant Node_Id
:= Left_Opnd
(Op
);
29619 R
: constant Node_Id
:= Right_Opnd
(Op
);
29622 -- The case for the message is when the left operand of the
29623 -- comparison is the same modular type, or when it is an
29624 -- integer literal (or other universal integer expression),
29625 -- which would have been typed as the modular type if the
29626 -- parens had been there.
29628 if (Etype
(L
) = Found_Type
29630 Etype
(L
) = Universal_Integer
)
29631 and then Is_Integer_Type
(Etype
(R
))
29634 ("\\possible missing parens for modular operation", Expr
);
29639 -- Reset error message qualification indication
29641 Error_Msg_Qual_Level
:= 0;
29645 --------------------------------
29646 -- Yields_Synchronized_Object --
29647 --------------------------------
29649 function Yields_Synchronized_Object
(Typ
: Entity_Id
) return Boolean is
29650 Has_Sync_Comp
: Boolean := False;
29654 -- An array type yields a synchronized object if its component type
29655 -- yields a synchronized object.
29657 if Is_Array_Type
(Typ
) then
29658 return Yields_Synchronized_Object
(Component_Type
(Typ
));
29660 -- A descendant of type Ada.Synchronous_Task_Control.Suspension_Object
29661 -- yields a synchronized object by default.
29663 elsif Is_Descendant_Of_Suspension_Object
(Typ
) then
29666 -- A protected type yields a synchronized object by default
29668 elsif Is_Protected_Type
(Typ
) then
29671 -- A record type or type extension yields a synchronized object when its
29672 -- discriminants (if any) lack default values and all components are of
29673 -- a type that yields a synchronized object.
29675 elsif Is_Record_Type
(Typ
) then
29677 -- Inspect all entities defined in the scope of the type, looking for
29678 -- components of a type that does not yield a synchronized object or
29679 -- for discriminants with default values.
29681 Id
:= First_Entity
(Typ
);
29682 while Present
(Id
) loop
29683 if Comes_From_Source
(Id
) then
29684 if Ekind
(Id
) = E_Component
then
29685 if Yields_Synchronized_Object
(Etype
(Id
)) then
29686 Has_Sync_Comp
:= True;
29688 -- The component does not yield a synchronized object
29694 elsif Ekind
(Id
) = E_Discriminant
29695 and then Present
(Expression
(Parent
(Id
)))
29704 -- Ensure that the parent type of a type extension yields a
29705 -- synchronized object.
29707 if Etype
(Typ
) /= Typ
29708 and then not Is_Private_Type
(Etype
(Typ
))
29709 and then not Yields_Synchronized_Object
(Etype
(Typ
))
29714 -- If we get here, then all discriminants lack default values and all
29715 -- components are of a type that yields a synchronized object.
29717 return Has_Sync_Comp
;
29719 -- A synchronized interface type yields a synchronized object by default
29721 elsif Is_Synchronized_Interface
(Typ
) then
29724 -- A task type yields a synchronized object by default
29726 elsif Is_Task_Type
(Typ
) then
29729 -- A private type yields a synchronized object if its underlying type
29732 elsif Is_Private_Type
(Typ
)
29733 and then Present
(Underlying_Type
(Typ
))
29735 return Yields_Synchronized_Object
(Underlying_Type
(Typ
));
29737 -- Otherwise the type does not yield a synchronized object
29742 end Yields_Synchronized_Object
;
29744 ---------------------------
29745 -- Yields_Universal_Type --
29746 ---------------------------
29748 function Yields_Universal_Type
(N
: Node_Id
) return Boolean is
29750 -- Integer and real literals are of a universal type
29752 if Nkind
(N
) in N_Integer_Literal | N_Real_Literal
then
29755 -- The values of certain attributes are of a universal type
29757 elsif Nkind
(N
) = N_Attribute_Reference
then
29759 Universal_Type_Attribute
(Get_Attribute_Id
(Attribute_Name
(N
)));
29761 -- ??? There are possibly other cases to consider
29766 end Yields_Universal_Type
;
29768 package body Interval_Lists
is
29770 procedure Check_Consistency
(Intervals
: Discrete_Interval_List
);
29771 -- Check that list is sorted, lacks null intervals, and has gaps
29772 -- between intervals.
29774 function Chosen_Interval
(Choice
: Node_Id
) return Discrete_Interval
;
29775 -- Given an element of a Discrete_Choices list, a
29776 -- Static_Discrete_Predicate list, or an Others_Discrete_Choices
29777 -- list (but not an N_Others_Choice node) return the corresponding
29778 -- interval. If an element that does not represent a single
29779 -- contiguous interval due to a static predicate (or which
29780 -- represents a single contiguous interval whose bounds depend on
29781 -- a static predicate) is encountered, then that is an error on the
29782 -- part of whoever built the list in question.
29784 function In_Interval
29785 (Value
: Uint
; Interval
: Discrete_Interval
) return Boolean;
29786 -- Does the given value lie within the given interval?
29788 procedure Normalize_Interval_List
29789 (List
: in out Discrete_Interval_List
; Last
: out Nat
);
29790 -- Perform sorting and merging as required by Check_Consistency
29792 -------------------------
29793 -- Aggregate_Intervals --
29794 -------------------------
29796 function Aggregate_Intervals
(N
: Node_Id
) return Discrete_Interval_List
29798 pragma Assert
(Nkind
(N
) = N_Aggregate
29799 and then Is_Array_Type
(Etype
(N
)));
29801 function Unmerged_Intervals_Count
return Nat
;
29802 -- Count the number of intervals given in the aggregate N; the others
29803 -- choice (if present) is not taken into account.
29805 ------------------------------
29806 -- Unmerged_Intervals_Count --
29807 ------------------------------
29809 function Unmerged_Intervals_Count
return Nat
is
29814 Comp
:= First
(Component_Associations
(N
));
29815 while Present
(Comp
) loop
29816 Choice
:= First
(Choices
(Comp
));
29818 while Present
(Choice
) loop
29819 if Nkind
(Choice
) /= N_Others_Choice
then
29820 Count
:= Count
+ 1;
29830 end Unmerged_Intervals_Count
;
29835 Max_I
: constant Nat
:= Unmerged_Intervals_Count
;
29836 Intervals
: Discrete_Interval_List
(1 .. Max_I
);
29839 -- Start of processing for Aggregate_Intervals
29842 -- No action needed if there are no intervals
29848 -- Internally store all the unsorted intervals
29850 Comp
:= First
(Component_Associations
(N
));
29851 while Present
(Comp
) loop
29853 Choice_Intervals
: constant Discrete_Interval_List
29854 := Choice_List_Intervals
(Choices
(Comp
));
29856 for J
in Choice_Intervals
'Range loop
29857 Num_I
:= Num_I
+ 1;
29858 Intervals
(Num_I
) := Choice_Intervals
(J
);
29865 -- Normalize the lists sorting and merging the intervals
29868 Aggr_Intervals
: Discrete_Interval_List
(1 .. Num_I
)
29869 := Intervals
(1 .. Num_I
);
29871 Normalize_Interval_List
(Aggr_Intervals
, Num_I
);
29872 Check_Consistency
(Aggr_Intervals
(1 .. Num_I
));
29873 return Aggr_Intervals
(1 .. Num_I
);
29875 end Aggregate_Intervals
;
29877 ------------------------
29878 -- Check_Consistency --
29879 ------------------------
29881 procedure Check_Consistency
(Intervals
: Discrete_Interval_List
) is
29883 if Serious_Errors_Detected
> 0 then
29887 -- low bound is 1 and high bound equals length
29888 pragma Assert
(Intervals
'First = 1 and Intervals
'Last >= 0);
29889 for Idx
in Intervals
'Range loop
29890 -- each interval is non-null
29891 pragma Assert
(Intervals
(Idx
).Low
<= Intervals
(Idx
).High
);
29892 if Idx
/= Intervals
'First then
29893 -- intervals are sorted with non-empty gaps between them
29895 (Intervals
(Idx
- 1).High
< (Intervals
(Idx
).Low
- 1));
29899 end Check_Consistency
;
29901 ---------------------------
29902 -- Choice_List_Intervals --
29903 ---------------------------
29905 function Choice_List_Intervals
29906 (Discrete_Choices
: List_Id
) return Discrete_Interval_List
29908 function Unmerged_Choice_Count
return Nat
;
29909 -- The number of intervals before adjacent intervals are merged
29911 ---------------------------
29912 -- Unmerged_Choice_Count --
29913 ---------------------------
29915 function Unmerged_Choice_Count
return Nat
is
29916 Choice
: Node_Id
:= First
(Discrete_Choices
);
29919 while Present
(Choice
) loop
29920 -- Non-contiguous choices involving static predicates
29921 -- have already been normalized away.
29923 if Nkind
(Choice
) = N_Others_Choice
then
29925 Count
+ List_Length
(Others_Discrete_Choices
(Choice
));
29927 Count
:= Count
+ 1; -- an ordinary expression or range
29933 end Unmerged_Choice_Count
;
29937 Choice
: Node_Id
:= First
(Discrete_Choices
);
29938 Result
: Discrete_Interval_List
(1 .. Unmerged_Choice_Count
);
29941 -- Start of processing for Choice_List_Intervals
29944 while Present
(Choice
) loop
29945 if Nkind
(Choice
) = N_Others_Choice
then
29947 Others_Choice
: Node_Id
29948 := First
(Others_Discrete_Choices
(Choice
));
29950 while Present
(Others_Choice
) loop
29951 Count
:= Count
+ 1;
29952 Result
(Count
) := Chosen_Interval
(Others_Choice
);
29953 Next
(Others_Choice
);
29957 Count
:= Count
+ 1;
29958 Result
(Count
) := Chosen_Interval
(Choice
);
29964 pragma Assert
(Count
= Result
'Last);
29965 Normalize_Interval_List
(Result
, Count
);
29966 Check_Consistency
(Result
(1 .. Count
));
29967 return Result
(1 .. Count
);
29968 end Choice_List_Intervals
;
29970 ---------------------
29971 -- Chosen_Interval --
29972 ---------------------
29974 function Chosen_Interval
(Choice
: Node_Id
) return Discrete_Interval
is
29976 case Nkind
(Choice
) is
29978 return (Low
=> Expr_Value
(Low_Bound
(Choice
)),
29979 High
=> Expr_Value
(High_Bound
(Choice
)));
29981 when N_Subtype_Indication
=>
29983 Range_Exp
: constant Node_Id
29984 := Range_Expression
(Constraint
(Choice
));
29986 return (Low
=> Expr_Value
(Low_Bound
(Range_Exp
)),
29987 High
=> Expr_Value
(High_Bound
(Range_Exp
)));
29990 when N_Others_Choice
=>
29991 raise Program_Error
;
29994 if Is_Entity_Name
(Choice
) and then Is_Type
(Entity
(Choice
))
29997 (Low
=> Expr_Value
(Type_Low_Bound
(Entity
(Choice
))),
29998 High
=> Expr_Value
(Type_High_Bound
(Entity
(Choice
))));
30001 return (Low | High
=> Expr_Value
(Choice
));
30004 end Chosen_Interval
;
30010 function In_Interval
30011 (Value
: Uint
; Interval
: Discrete_Interval
) return Boolean is
30013 return Value
>= Interval
.Low
and then Value
<= Interval
.High
;
30021 (Subset
, Of_Set
: Discrete_Interval_List
) return Boolean
30023 -- Returns True iff for each interval of Subset we can find
30024 -- a single interval of Of_Set which contains the Subset interval.
30026 if Of_Set
'Length = 0 then
30027 return Subset
'Length = 0;
30031 Set_Index
: Pos
range Of_Set
'Range := Of_Set
'First;
30034 for Ss_Idx
in Subset
'Range loop
30035 while not In_Interval
30036 (Value
=> Subset
(Ss_Idx
).Low
,
30037 Interval
=> Of_Set
(Set_Index
))
30039 if Set_Index
= Of_Set
'Last then
30043 Set_Index
:= Set_Index
+ 1;
30047 (Value
=> Subset
(Ss_Idx
).High
,
30048 Interval
=> Of_Set
(Set_Index
))
30058 -----------------------------
30059 -- Normalize_Interval_List --
30060 -----------------------------
30062 procedure Normalize_Interval_List
30063 (List
: in out Discrete_Interval_List
; Last
: out Nat
)
30065 Temp_0
: Discrete_Interval
:= (others => Uint_0
);
30066 -- Cope with Heap_Sort_G idiosyncrasies.
30068 function Is_Null
(Idx
: Pos
) return Boolean;
30069 -- True iff List (Idx) defines a null range
30071 function Lt_Interval
(Idx1
, Idx2
: Natural) return Boolean;
30072 -- Compare two list elements
30074 procedure Merge_Intervals
(Null_Interval_Count
: out Nat
);
30075 -- Merge contiguous ranges by replacing one with merged range and
30076 -- the other with a null value. Return a count of the null intervals,
30077 -- both preexisting and those introduced by merging.
30079 procedure Move_Interval
(From
, To
: Natural);
30080 -- Copy interval from one location to another
30082 function Read_Interval
(From
: Natural) return Discrete_Interval
;
30083 -- Normal array indexing unless From = 0
30085 ----------------------
30086 -- Interval_Sorting --
30087 ----------------------
30089 package Interval_Sorting
is
30090 new Gnat
.Heap_Sort_G
(Move_Interval
, Lt_Interval
);
30096 function Is_Null
(Idx
: Pos
) return Boolean is
30098 return List
(Idx
).Low
> List
(Idx
).High
;
30105 function Lt_Interval
(Idx1
, Idx2
: Natural) return Boolean is
30106 Elem1
: constant Discrete_Interval
:= Read_Interval
(Idx1
);
30107 Elem2
: constant Discrete_Interval
:= Read_Interval
(Idx2
);
30108 Null_1
: constant Boolean := Elem1
.Low
> Elem1
.High
;
30109 Null_2
: constant Boolean := Elem2
.Low
> Elem2
.High
;
30111 if Null_1
/= Null_2
then
30112 -- So that sorting moves null intervals to high end
30115 elsif Elem1
.Low
/= Elem2
.Low
then
30116 return Elem1
.Low
< Elem2
.Low
;
30119 return Elem1
.High
< Elem2
.High
;
30123 ---------------------
30124 -- Merge_Intervals --
30125 ---------------------
30127 procedure Merge_Intervals
(Null_Interval_Count
: out Nat
) is
30128 Not_Null
: Pos
range List
'Range;
30129 -- Index of the most recently examined non-null interval
30131 Null_Interval
: constant Discrete_Interval
30132 := (Low
=> Uint_1
, High
=> Uint_0
); -- any null range ok here
30134 if List
'Length = 0 or else Is_Null
(List
'First) then
30135 Null_Interval_Count
:= List
'Length;
30136 -- no non-null elements, so no merge candidates
30140 Null_Interval_Count
:= 0;
30141 Not_Null
:= List
'First;
30143 for Idx
in List
'First + 1 .. List
'Last loop
30144 if Is_Null
(Idx
) then
30146 -- all remaining elements are null
30148 Null_Interval_Count
:=
30149 Null_Interval_Count
+ List
(Idx
.. List
'Last)'Length;
30152 elsif List
(Idx
).Low
= List
(Not_Null
).High
+ 1 then
30154 -- Merge the two intervals into one; discard the other
30156 List
(Not_Null
).High
:= List
(Idx
).High
;
30157 List
(Idx
) := Null_Interval
;
30158 Null_Interval_Count
:= Null_Interval_Count
+ 1;
30161 if List
(Idx
).Low
<= List
(Not_Null
).High
then
30162 raise Intervals_Error
;
30165 pragma Assert
(List
(Idx
).Low
> List
(Not_Null
).High
);
30169 end Merge_Intervals
;
30171 -------------------
30172 -- Move_Interval --
30173 -------------------
30175 procedure Move_Interval
(From
, To
: Natural) is
30176 Rhs
: constant Discrete_Interval
:= Read_Interval
(From
);
30181 List
(Pos
(To
)) := Rhs
;
30185 -------------------
30186 -- Read_Interval --
30187 -------------------
30189 function Read_Interval
(From
: Natural) return Discrete_Interval
is
30194 return List
(Pos
(From
));
30198 -- Start of processing for Normalize_Interval_Lists
30201 Interval_Sorting
.Sort
(Natural (List
'Last));
30204 Null_Interval_Count
: Nat
;
30207 Merge_Intervals
(Null_Interval_Count
);
30208 Last
:= List
'Last - Null_Interval_Count
;
30210 if Null_Interval_Count
/= 0 then
30211 -- Move null intervals introduced during merging to high end
30212 Interval_Sorting
.Sort
(Natural (List
'Last));
30215 end Normalize_Interval_List
;
30217 --------------------
30218 -- Type_Intervals --
30219 --------------------
30221 function Type_Intervals
(Typ
: Entity_Id
) return Discrete_Interval_List
30224 if Has_Static_Predicate
(Typ
) then
30226 -- No sorting or merging needed
30227 SDP_List
: constant List_Id
:= Static_Discrete_Predicate
(Typ
);
30228 Range_Or_Expr
: Node_Id
:= First
(SDP_List
);
30229 Result
: Discrete_Interval_List
(1 .. List_Length
(SDP_List
));
30232 for Idx
in Result
'Range loop
30233 Result
(Idx
) := Chosen_Interval
(Range_Or_Expr
);
30234 Next
(Range_Or_Expr
);
30237 pragma Assert
(No
(Range_Or_Expr
));
30238 Check_Consistency
(Result
);
30243 Low
: constant Uint
:= Expr_Value
(Type_Low_Bound
(Typ
));
30244 High
: constant Uint
:= Expr_Value
(Type_High_Bound
(Typ
));
30248 Null_Array
: Discrete_Interval_List
(1 .. 0);
30253 return (1 => (Low
=> Low
, High
=> High
));
30257 end Type_Intervals
;
30259 end Interval_Lists
;
30261 package body Old_Attr_Util
is
30262 package body Conditional_Evaluation
is
30263 type Determining_Expr_Context
is
30264 (No_Context
, If_Expr
, Case_Expr
, Short_Circuit_Op
, Membership_Test
);
30266 -- Determining_Expr_Context enumeration elements (except for
30267 -- No_Context) correspond to the list items in RM 6.1.1 definition
30268 -- of "determining expression".
30270 type Determining_Expr
30271 (Context
: Determining_Expr_Context
:= No_Context
)
30273 Expr
: Node_Id
:= Empty
;
30275 when Short_Circuit_Op
=>
30276 Is_And_Then
: Boolean;
30278 Is_Then_Part
: Boolean;
30280 Alternatives
: Node_Id
;
30281 when Membership_Test
=>
30282 -- Given a subexpression of <exp4> in a membership test
30283 -- <exp1> in <exp2> | <exp3> | <exp4> | <exp5>
30284 -- the corresponding determining expression value would
30285 -- have First_Non_Preceding = <exp4> (See RM 6.1.1).
30286 First_Non_Preceding
: Node_Id
;
30292 type Determining_Expression_List
is
30293 array (Positive range <>) of Determining_Expr
;
30295 function Determining_Condition
(Det
: Determining_Expr
)
30297 -- Given a determining expression, build a Boolean-valued
30298 -- condition that incorporates that expression into condition
30299 -- suitable for deciding whether to initialize a 'Old constant.
30300 -- Polarity is "True => initialize the constant".
30302 function Determining_Expressions
30303 (Expr
: Node_Id
; Expr_Trailer
: Node_Id
:= Empty
)
30304 return Determining_Expression_List
;
30305 -- Given a conditionally evaluated expression, return its
30306 -- determining expressions.
30307 -- See RM 6.1.1 for definition of term "determining expressions".
30308 -- Tests should be performed in the order they occur in the
30309 -- array, with short circuiting.
30310 -- A determining expression need not be of a boolean type (e.g.,
30311 -- it might be the determining expression of a case expression).
30312 -- The Expr_Trailer parameter should be defaulted for nonrecursive
30315 function Is_Conditionally_Evaluated
(Expr
: Node_Id
) return Boolean;
30316 -- See RM 6.1.1 for definition of term "conditionally evaluated".
30318 function Is_Known_On_Entry
(Expr
: Node_Id
) return Boolean;
30319 -- See RM 6.1.1 for definition of term "known on entry".
30321 --------------------------------------
30322 -- Conditional_Evaluation_Condition --
30323 --------------------------------------
30325 function Conditional_Evaluation_Condition
30326 (Expr
: Node_Id
) return Node_Id
30328 Determiners
: constant Determining_Expression_List
:=
30329 Determining_Expressions
(Expr
);
30330 Loc
: constant Source_Ptr
:= Sloc
(Expr
);
30331 Result
: Node_Id
:=
30332 New_Occurrence_Of
(Standard_True
, Loc
);
30334 pragma Assert
(Determiners
'Length > 0 or else
30335 Is_Anonymous_Access_Type
(Etype
(Expr
)));
30337 for I
in Determiners
'Range loop
30338 Result
:= Make_And_Then
30340 Left_Opnd
=> Result
,
30342 Determining_Condition
(Determiners
(I
)));
30345 end Conditional_Evaluation_Condition
;
30347 ---------------------------
30348 -- Determining_Condition --
30349 ---------------------------
30351 function Determining_Condition
(Det
: Determining_Expr
) return Node_Id
30353 Loc
: constant Source_Ptr
:= Sloc
(Det
.Expr
);
30355 case Det
.Context
is
30356 when Short_Circuit_Op
=>
30357 if Det
.Is_And_Then
then
30358 return New_Copy_Tree
(Det
.Expr
);
30360 return Make_Op_Not
(Loc
, New_Copy_Tree
(Det
.Expr
));
30364 if Det
.Is_Then_Part
then
30365 return New_Copy_Tree
(Det
.Expr
);
30367 return Make_Op_Not
(Loc
, New_Copy_Tree
(Det
.Expr
));
30372 Alts
: List_Id
:= Discrete_Choices
(Det
.Alternatives
);
30374 if Nkind
(First
(Alts
)) = N_Others_Choice
then
30375 Alts
:= Others_Discrete_Choices
(First
(Alts
));
30378 return Make_In
(Loc
,
30379 Left_Opnd
=> New_Copy_Tree
(Det
.Expr
),
30380 Right_Opnd
=> Empty
,
30381 Alternatives
=> New_Copy_List
(Alts
));
30384 when Membership_Test
=>
30386 function Copy_Prefix
30387 (List
: List_Id
; Suffix_Start
: Node_Id
)
30389 -- Given a list and a member of that list, returns
30390 -- a copy (similar to Nlists.New_Copy_List) of the
30391 -- prefix of the list up to but not including
30398 function Copy_Prefix
30399 (List
: List_Id
; Suffix_Start
: Node_Id
)
30402 Result
: constant List_Id
:= New_List
;
30403 Elem
: Node_Id
:= First
(List
);
30405 while Elem
/= Suffix_Start
loop
30406 Append
(New_Copy
(Elem
), Result
);
30408 pragma Assert
(Present
(Elem
));
30414 return Make_In
(Loc
,
30415 Left_Opnd
=> New_Copy_Tree
(Left_Opnd
(Det
.Expr
)),
30416 Right_Opnd
=> Empty
,
30417 Alternatives
=> Copy_Prefix
30418 (Alternatives
(Det
.Expr
),
30419 Det
.First_Non_Preceding
));
30423 raise Program_Error
;
30425 end Determining_Condition
;
30427 -----------------------------
30428 -- Determining_Expressions --
30429 -----------------------------
30431 function Determining_Expressions
30432 (Expr
: Node_Id
; Expr_Trailer
: Node_Id
:= Empty
)
30433 return Determining_Expression_List
30435 Par
: Node_Id
:= Expr
;
30436 Trailer
: Node_Id
:= Expr_Trailer
;
30437 Next_Element
: Determining_Expr
;
30439 -- We want to stop climbing up the tree when we reach the
30440 -- postcondition expression. An aspect_specification is
30441 -- transformed into a pragma, so reaching a pragma is our
30442 -- termination condition. This relies on the fact that
30443 -- pragmas are not allowed in declare expressions (or any
30444 -- other kind of expression).
30447 Next_Element
.Expr
:= Empty
;
30449 case Nkind
(Par
) is
30450 when N_Short_Circuit
=>
30451 if Trailer
= Right_Opnd
(Par
) then
30453 (Expr
=> Left_Opnd
(Par
),
30454 Context
=> Short_Circuit_Op
,
30455 Is_And_Then
=> Nkind
(Par
) = N_And_Then
);
30458 when N_If_Expression
=>
30459 -- For an expression like
30460 -- (if C1 then ... elsif C2 then ... else Foo'Old)
30461 -- the RM says are two determining expressions,
30462 -- C1 and C2. Our treatment here (where we only add
30463 -- one determining expression to the list) is ok because
30464 -- we will see two if-expressions, one within the other.
30466 if Trailer
/= First
(Expressions
(Par
)) then
30468 (Expr
=> First
(Expressions
(Par
)),
30469 Context
=> If_Expr
,
30471 Trailer
= Next
(First
(Expressions
(Par
))));
30474 when N_Case_Expression_Alternative
=>
30475 pragma Assert
(Nkind
(Parent
(Par
)) = N_Case_Expression
);
30478 (Expr
=> Expression
(Parent
(Par
)),
30479 Context
=> Case_Expr
,
30480 Alternatives
=> Par
);
30482 when N_Membership_Test
=>
30483 if Trailer
/= Left_Opnd
(Par
)
30484 and then Is_Non_Empty_List
(Alternatives
(Par
))
30485 and then Trailer
/= First
(Alternatives
(Par
))
30487 pragma Assert
(No
(Right_Opnd
(Par
)));
30489 (Is_List_Member
(Trailer
)
30490 and then List_Containing
(Trailer
)
30491 = Alternatives
(Par
));
30493 -- This one is different than the others
30494 -- because one element in the array result
30495 -- may represent multiple determining
30496 -- expressions (i.e. every member of the list
30497 -- Alternatives (Par)
30498 -- up to but not including Trailer).
30502 Context
=> Membership_Test
,
30503 First_Non_Preceding
=> Trailer
);
30508 Previous
: constant Node_Id
:= Prev
(Par
);
30509 Prev_Expr
: Node_Id
;
30511 if Nkind
(Previous
) = N_Pragma
and then
30512 Split_PPC
(Previous
)
30514 -- A source-level postcondition of
30515 -- A and then B and then C
30517 -- pragma Postcondition (A);
30518 -- pragma Postcondition (B);
30519 -- pragma Postcondition (C);
30520 -- with Split_PPC set to True on all but the
30521 -- last pragma. We account for that here.
30525 (Pragma_Argument_Associations
(Previous
)));
30527 -- This Analyze call is needed in the case when
30528 -- Sem_Attr.Analyze_Attribute calls
30529 -- Eligible_For_Conditional_Evaluation. Without
30530 -- it, we end up passing an unanalyzed expression
30531 -- to Is_Known_On_Entry and that doesn't work.
30533 Analyze
(Prev_Expr
);
30536 (Expr
=> Prev_Expr
,
30537 Context
=> Short_Circuit_Op
,
30538 Is_And_Then
=> True);
30540 return Determining_Expressions
(Prev_Expr
)
30544 (Get_Pragma_Id
(Pragma_Name
(Par
)) in
30546 | Pragma_Contract_Cases
30547 | Pragma_Exceptional_Cases
30549 | Pragma_Postcondition
30550 | Pragma_Post_Class
30551 | Pragma_Refined_Post
);
30553 return (1 .. 0 => <>); -- recursion terminates here
30558 -- This case should be impossible, but if it does
30559 -- happen somehow then we don't want an infinite loop.
30560 raise Program_Error
;
30567 Par
:= Parent
(Par
);
30569 if Present
(Next_Element
.Expr
) then
30570 return Determining_Expressions
30571 (Expr
=> Par
, Expr_Trailer
=> Trailer
)
30575 end Determining_Expressions
;
30577 -----------------------------------------
30578 -- Eligible_For_Conditional_Evaluation --
30579 -----------------------------------------
30581 function Eligible_For_Conditional_Evaluation
30582 (Expr
: Node_Id
) return Boolean
30585 if Is_Anonymous_Access_Type
(Etype
(Expr
)) then
30586 -- The code in exp_attr.adb that also builds declarations
30587 -- for 'Old constants doesn't handle the anonymous access
30588 -- type case correctly, so we avoid that problem by
30589 -- returning True here.
30592 elsif Ada_Version
< Ada_2022
then
30595 elsif Inside_Class_Condition_Preanalysis
then
30596 -- No need to evaluate it during preanalysis of a class-wide
30597 -- pre/postcondition since the expression is not installed yet
30598 -- on its definite context.
30601 elsif not Is_Conditionally_Evaluated
(Expr
) then
30605 Determiners
: constant Determining_Expression_List
:=
30606 Determining_Expressions
(Expr
);
30608 pragma Assert
(Determiners
'Length > 0);
30610 for Idx
in Determiners
'Range loop
30611 if not Is_Known_On_Entry
(Determiners
(Idx
).Expr
) then
30618 end Eligible_For_Conditional_Evaluation
;
30620 --------------------------------
30621 -- Is_Conditionally_Evaluated --
30622 --------------------------------
30624 function Is_Conditionally_Evaluated
(Expr
: Node_Id
) return Boolean
30626 -- There are three possibilities - the expression is
30627 -- unconditionally evaluated, repeatedly evaluated, or
30628 -- conditionally evaluated (see RM 6.1.1). So we implement
30629 -- this test by testing for the other two.
30631 function Is_Repeatedly_Evaluated
(Expr
: Node_Id
) return Boolean;
30632 -- See RM 6.1.1 for definition of "repeatedly evaluated".
30634 -----------------------------
30635 -- Is_Repeatedly_Evaluated --
30636 -----------------------------
30638 function Is_Repeatedly_Evaluated
(Expr
: Node_Id
) return Boolean is
30639 Par
: Node_Id
:= Expr
;
30640 Trailer
: Node_Id
:= Empty
;
30642 -- There are three ways that an expression can be repeatedly
30645 -- An aspect_specification is transformed into a pragma, so
30646 -- reaching a pragma is our termination condition. We want to
30647 -- stop when we reach the postcondition expression.
30649 while Nkind
(Par
) /= N_Pragma
loop
30650 pragma Assert
(Present
(Par
));
30652 -- test for case 1:
30653 -- A subexpression of a predicate of a
30654 -- quantified_expression.
30656 if Nkind
(Par
) = N_Quantified_Expression
30657 and then Trailer
= Condition
(Par
)
30660 elsif Nkind
(Par
) = N_Expression_With_Actions
30662 Nkind
(Original_Node
(Par
)) = N_Quantified_Expression
30667 -- test for cases 2 and 3:
30668 -- A subexpression of the expression of an
30669 -- array_component_association or of
30670 -- a container_element_associatiation.
30672 if Nkind
(Par
) in N_Component_Association
30673 | N_Iterated_Component_Association
30674 and then Trailer
= Expression
(Par
)
30676 -- determine whether Par is part of an array aggregate
30677 -- or a container aggregate
30679 Rover
: Node_Id
:= Par
;
30681 while Nkind
(Rover
) not in N_Has_Etype
loop
30682 pragma Assert
(Present
(Rover
));
30683 Rover
:= Parent
(Rover
);
30685 if Present
(Etype
(Rover
)) then
30686 if Is_Array_Type
(Etype
(Rover
))
30687 or else Is_Container_Aggregate
(Rover
)
30696 Par
:= Parent
(Par
);
30700 end Is_Repeatedly_Evaluated
;
30703 if not Is_Potentially_Unevaluated
(Expr
) then
30704 -- the expression is unconditionally evaluated
30706 elsif Is_Repeatedly_Evaluated
(Expr
) then
30711 end Is_Conditionally_Evaluated
;
30713 -----------------------
30714 -- Is_Known_On_Entry --
30715 -----------------------
30717 function Is_Known_On_Entry
(Expr
: Node_Id
) return Boolean is
30718 -- ??? This implementation is incomplete. See RM 6.1.1
30719 -- for details. In particular, this function *should* return
30720 -- True for a function call (or a user-defined literal, which
30721 -- is equivalent to a function call) if all actual parameters
30722 -- (including defaulted params) are known on entry and the
30723 -- function has "Globals => null" specified; the current
30724 -- implementation will incorrectly return False in this case.
30726 function All_Exps_Known_On_Entry
30727 (Expr_List
: List_Id
) return Boolean;
30728 -- Given a list of expressions, returns False iff
30729 -- Is_Known_On_Entry is False for at least one list element.
30731 -----------------------------
30732 -- All_Exps_Known_On_Entry --
30733 -----------------------------
30735 function All_Exps_Known_On_Entry
30736 (Expr_List
: List_Id
) return Boolean
30738 Expr
: Node_Id
:= First
(Expr_List
);
30740 while Present
(Expr
) loop
30741 if not Is_Known_On_Entry
(Expr
) then
30747 end All_Exps_Known_On_Entry
;
30750 if Is_Static_Expression
(Expr
) then
30754 if Is_Attribute_Old
(Expr
) then
30759 Pref
: Node_Id
:= Expr
;
30762 case Nkind
(Pref
) is
30763 when N_Selected_Component
=>
30766 when N_Indexed_Component
=>
30767 if not All_Exps_Known_On_Entry
(Expressions
(Pref
))
30773 return False; -- just to be clear about this case
30779 Pref
:= Prefix
(Pref
);
30782 if Is_Entity_Name
(Pref
)
30783 and then Is_Constant_Object
(Entity
(Pref
))
30786 Obj
: constant Entity_Id
:= Entity
(Pref
);
30787 Obj_Typ
: constant Entity_Id
:= Etype
(Obj
);
30789 case Ekind
(Obj
) is
30790 when E_In_Parameter
=>
30791 if not Is_Elementary_Type
(Obj_Typ
) then
30793 elsif Is_Aliased
(Obj
) then
30798 -- return False for a deferred constant
30799 if Present
(Full_View
(Obj
)) then
30803 -- return False if not "all views are constant".
30804 if Is_Immutably_Limited_Type
(Obj_Typ
)
30805 or Needs_Finalization
(Obj_Typ
)
30818 -- ??? Cope with a malformed tree. Code to cope with a
30819 -- nonstatic use of an enumeration literal should not be
30821 if Is_Entity_Name
(Pref
)
30822 and then Ekind
(Entity
(Pref
)) = E_Enumeration_Literal
30828 case Nkind
(Expr
) is
30830 return Is_Known_On_Entry
(Right_Opnd
(Expr
));
30832 when N_Binary_Op
=>
30833 return Is_Known_On_Entry
(Left_Opnd
(Expr
))
30834 and then Is_Known_On_Entry
(Right_Opnd
(Expr
));
30836 when N_Type_Conversion | N_Qualified_Expression
=>
30837 return Is_Known_On_Entry
(Expression
(Expr
));
30839 when N_If_Expression
=>
30840 if not All_Exps_Known_On_Entry
(Expressions
(Expr
)) then
30844 when N_Case_Expression
=>
30845 if not Is_Known_On_Entry
(Expression
(Expr
)) then
30850 Alt
: Node_Id
:= First
(Alternatives
(Expr
));
30852 while Present
(Alt
) loop
30853 if not Is_Known_On_Entry
(Expression
(Alt
)) then
30867 end Is_Known_On_Entry
;
30869 end Conditional_Evaluation
;
30871 package body Indirect_Temps
is
30873 Indirect_Temp_Access_Type_Char
: constant Character := 'K';
30874 -- The character passed to Make_Temporary when declaring
30875 -- the access type that is used in the implementation of an
30876 -- indirect temporary.
30878 --------------------------
30879 -- Indirect_Temp_Needed --
30880 --------------------------
30882 function Indirect_Temp_Needed
(Typ
: Entity_Id
) return Boolean is
30884 -- There should be no correctness issues if the only cases where
30885 -- this function returns False are cases where Typ is an
30886 -- anonymous access type and we need to generate a saooaaat (a
30887 -- stand-alone object of an anonymous access type) in order get
30888 -- accessibility right. In other cases where this function
30889 -- returns False, there would be no correctness problems with
30890 -- returning True instead; however, returning False when we can
30891 -- generally results in simpler code.
30895 -- If Typ is not definite, then we cannot generate
30898 or else not Is_Definite_Subtype
(Typ
)
30900 -- If Typ is tagged, then generating
30902 -- might generate an object with the wrong tag. If we had
30903 -- a predicate that indicated whether the nominal tag is
30904 -- trustworthy, we could use that predicate here.
30906 or else Is_Tagged_Type
(Typ
)
30908 -- If Typ needs finalization, then generating an implicit
30910 -- declaration could have user-visible side effects.
30912 or else Needs_Finalization
(Typ
)
30914 -- In the anonymous access type case, we need to
30915 -- generate a saooaaat. We don't want the code in
30916 -- in exp_attr.adb that deals with the case where this
30917 -- function returns False to have to deal with that case
30918 -- (just to avoid code duplication). So we cheat a little
30919 -- bit and return True here for an anonymous access type.
30921 or else Is_Anonymous_Access_Type
(Typ
);
30923 -- ??? Unimplemented - spec description says:
30924 -- For an unconstrained-but-definite discriminated subtype,
30925 -- returns True if the potential difference in size between an
30926 -- unconstrained object and a constrained object is large.
30929 -- type Typ (Len : Natural := 0) is
30930 -- record F : String (1 .. Len); end record;
30932 -- See Large_Max_Size_Mutable function elsewhere in this file,
30933 -- currently declared inside of Needs_Secondary_Stack, so it
30934 -- would have to be moved if we want it to be callable from here.
30936 end Indirect_Temp_Needed
;
30938 ---------------------------
30939 -- Declare_Indirect_Temp --
30940 ---------------------------
30942 procedure Declare_Indirect_Temp
30943 (Attr_Prefix
: Node_Id
; Indirect_Temp
: out Entity_Id
)
30945 Loc
: constant Source_Ptr
:= Sloc
(Attr_Prefix
);
30946 Prefix_Type
: constant Entity_Id
:= Etype
(Attr_Prefix
);
30947 Temp_Id
: constant Entity_Id
:=
30948 Make_Temporary
(Loc
, 'P', Attr_Prefix
);
30950 procedure Declare_Indirect_Temp_Via_Allocation
;
30951 -- Handle the usual case.
30953 -------------------------------------------
30954 -- Declare_Indirect_Temp_Via_Allocation --
30955 -------------------------------------------
30957 procedure Declare_Indirect_Temp_Via_Allocation
is
30958 Access_Type_Id
: constant Entity_Id
30960 (Loc
, Indirect_Temp_Access_Type_Char
, Attr_Prefix
);
30962 Temp_Decl
: constant Node_Id
:=
30963 Make_Object_Declaration
(Loc
,
30964 Defining_Identifier
=> Temp_Id
,
30965 Object_Definition
=>
30966 New_Occurrence_Of
(Access_Type_Id
, Loc
));
30968 Allocate_Class_Wide
: constant Boolean :=
30969 Is_Specific_Tagged_Type
(Prefix_Type
);
30970 -- If True then access type designates the class-wide type in
30971 -- order to preserve (at run time) the value of the underlying
30973 -- ??? We could do better here (in the case where Prefix_Type
30974 -- is tagged and specific) if we had a predicate which takes an
30975 -- expression and returns True iff the expression is of
30976 -- a specific tagged type and the underlying tag (at run time)
30977 -- is statically known to match that of the specific type.
30978 -- In that case, Allocate_Class_Wide could safely be False.
30980 function Designated_Subtype_Mark
return Node_Id
;
30981 -- Usually, a subtype mark indicating the subtype of the
30982 -- attribute prefix. If that subtype is a specific tagged
30983 -- type, then returns the corresponding class-wide type.
30984 -- If the prefix is of an anonymous access type, then returns
30985 -- the designated type of that type.
30987 -----------------------------
30988 -- Designated_Subtype_Mark --
30989 -----------------------------
30991 function Designated_Subtype_Mark
return Node_Id
is
30992 Typ
: Entity_Id
:= Prefix_Type
;
30994 if Allocate_Class_Wide
then
30995 if Is_Private_Type
(Typ
)
30996 and then Present
(Full_View
(Typ
))
30998 Typ
:= Full_View
(Typ
);
31000 Typ
:= Class_Wide_Type
(Typ
);
31003 return New_Occurrence_Of
(Typ
, Loc
);
31004 end Designated_Subtype_Mark
;
31006 Access_Type_Def
: constant Node_Id
31007 := Make_Access_To_Object_Definition
31008 (Loc
, Subtype_Indication
=> Designated_Subtype_Mark
);
31010 Access_Type_Decl
: constant Node_Id
31011 := Make_Full_Type_Declaration
31012 (Loc
, Access_Type_Id
,
31013 Type_Definition
=> Access_Type_Def
);
31015 Mutate_Ekind
(Temp_Id
, E_Variable
);
31016 Set_Etype
(Temp_Id
, Access_Type_Id
);
31017 Mutate_Ekind
(Access_Type_Id
, E_Access_Type
);
31019 if Append_Decls_In_Reverse_Order
then
31020 Append_Item
(Temp_Decl
, Is_Eval_Stmt
=> False);
31021 Append_Item
(Access_Type_Decl
, Is_Eval_Stmt
=> False);
31023 Append_Item
(Access_Type_Decl
, Is_Eval_Stmt
=> False);
31024 Append_Item
(Temp_Decl
, Is_Eval_Stmt
=> False);
31027 -- When a type associated with an indirect temporary gets
31028 -- created for a 'Old attribute reference we need to mark
31029 -- the type as such. This allows, for example, finalization
31030 -- masters associated with them to be finalized in the correct
31031 -- order after postcondition checks.
31033 if Attribute_Name
(Parent
(Attr_Prefix
)) = Name_Old
then
31034 Set_Stores_Attribute_Old_Prefix
(Access_Type_Id
);
31037 Analyze
(Access_Type_Decl
);
31038 Analyze
(Temp_Decl
);
31041 (Is_Access_Type_For_Indirect_Temp
(Access_Type_Id
));
31044 Expression
: Node_Id
:= Attr_Prefix
;
31045 Allocator
: Node_Id
;
31047 if Allocate_Class_Wide
then
31048 -- generate T'Class'(T'Class (<prefix>))
31050 Make_Type_Conversion
(Loc
,
31051 Subtype_Mark
=> Designated_Subtype_Mark
,
31052 Expression
=> Expression
);
31056 Make_Allocator
(Loc
,
31057 Make_Qualified_Expression
31059 Subtype_Mark
=> Designated_Subtype_Mark
,
31060 Expression
=> Expression
));
31062 -- Allocate saved prefix value on the secondary stack
31063 -- in order to avoid introducing a storage leak. This
31064 -- allocated object is never explicitly reclaimed.
31066 -- ??? Emit storage leak warning if RE_SS_Pool
31069 if RTE_Available
(RE_SS_Pool
) then
31070 Set_Storage_Pool
(Allocator
, RTE
(RE_SS_Pool
));
31071 Set_Procedure_To_Call
31072 (Allocator
, RTE
(RE_SS_Allocate
));
31073 Set_Uses_Sec_Stack
(Current_Scope
);
31077 (Make_Assignment_Statement
(Loc
,
31078 Name
=> New_Occurrence_Of
(Temp_Id
, Loc
),
31079 Expression
=> Allocator
),
31080 Is_Eval_Stmt
=> True);
31082 end Declare_Indirect_Temp_Via_Allocation
;
31085 Indirect_Temp
:= Temp_Id
;
31087 if Is_Anonymous_Access_Type
(Prefix_Type
) then
31088 -- In the anonymous access type case, we do not want a level
31089 -- indirection (which would result in declaring an
31090 -- access-to-access type); that would result in correctness
31091 -- problems - the accessibility level of the type of the
31092 -- 'Old constant would be wrong (See 6.1.1.). So in that case,
31093 -- we do not generate an allocator. Instead we generate
31094 -- Temp : access Designated := null;
31095 -- which is unconditionally elaborated and then
31096 -- Temp := <attribute prefix>;
31097 -- which is conditionally executed.
31100 Temp_Decl
: constant Node_Id
:=
31101 Make_Object_Declaration
(Loc
,
31102 Defining_Identifier
=> Temp_Id
,
31103 Object_Definition
=>
31104 Make_Access_Definition
31106 Constant_Present
=>
31107 Is_Access_Constant
(Prefix_Type
),
31110 (Designated_Type
(Prefix_Type
), Loc
)));
31112 Append_Item
(Temp_Decl
, Is_Eval_Stmt
=> False);
31113 Analyze
(Temp_Decl
);
31115 (Make_Assignment_Statement
(Loc
,
31116 Name
=> New_Occurrence_Of
(Temp_Id
, Loc
),
31117 Expression
=> Attr_Prefix
),
31118 Is_Eval_Stmt
=> True);
31122 Declare_Indirect_Temp_Via_Allocation
;
31124 end Declare_Indirect_Temp
;
31126 -------------------------
31127 -- Indirect_Temp_Value --
31128 -------------------------
31130 function Indirect_Temp_Value
31133 Loc
: Source_Ptr
) return Node_Id
31137 if Is_Anonymous_Access_Type
(Typ
) then
31138 -- No indirection in this case; just evaluate the temp.
31139 Result
:= New_Occurrence_Of
(Temp
, Loc
);
31140 Set_Etype
(Result
, Etype
(Temp
));
31143 Result
:= Make_Explicit_Dereference
(Loc
,
31144 New_Occurrence_Of
(Temp
, Loc
));
31146 Set_Etype
(Result
, Designated_Type
(Etype
(Temp
)));
31148 if Is_Specific_Tagged_Type
(Typ
) then
31149 -- The designated type of the access type is class-wide, so
31150 -- convert to the specific type.
31153 Make_Type_Conversion
(Loc
,
31154 Subtype_Mark
=> New_Occurrence_Of
(Typ
, Loc
),
31155 Expression
=> Result
);
31157 Set_Etype
(Result
, Typ
);
31162 end Indirect_Temp_Value
;
31164 function Is_Access_Type_For_Indirect_Temp
31165 (T
: Entity_Id
) return Boolean is
31167 if Is_Access_Type
(T
)
31168 and then not Comes_From_Source
(T
)
31169 and then Is_Internal_Name
(Chars
(T
))
31170 and then Nkind
(Scope
(T
)) in N_Entity
31171 and then Ekind
(Scope
(T
))
31172 in E_Entry | E_Entry_Family | E_Function | E_Procedure
31174 (Present
(Wrapped_Statements
(Scope
(T
)))
31175 or else Present
(Contract
(Scope
(T
))))
31177 -- ??? Should define a flag for this. We could incorrectly
31178 -- return True if other clients of Make_Temporary happen to
31179 -- pass in the same character.
31181 Name
: constant String := Get_Name_String
(Chars
(T
));
31183 if Name
(Name
'First) = Indirect_Temp_Access_Type_Char
then
31190 end Is_Access_Type_For_Indirect_Temp
;
31192 end Indirect_Temps
;
31195 package body Storage_Model_Support
is
31197 -----------------------------------------
31198 -- Has_Designated_Storage_Model_Aspect --
31199 -----------------------------------------
31201 function Has_Designated_Storage_Model_Aspect
31202 (Typ
: Entity_Id
) return Boolean
31205 return Has_Aspect
(Typ
, Aspect_Designated_Storage_Model
);
31206 end Has_Designated_Storage_Model_Aspect
;
31208 -----------------------------------
31209 -- Has_Storage_Model_Type_Aspect --
31210 -----------------------------------
31212 function Has_Storage_Model_Type_Aspect
(Typ
: Entity_Id
) return Boolean
31215 return Has_Aspect
(Typ
, Aspect_Storage_Model_Type
);
31216 end Has_Storage_Model_Type_Aspect
;
31218 --------------------------
31219 -- Storage_Model_Object --
31220 --------------------------
31222 function Storage_Model_Object
(Typ
: Entity_Id
) return Entity_Id
is
31224 pragma Assert
(Has_Designated_Storage_Model_Aspect
(Typ
));
31228 (Find_Value_Of_Aspect
(Typ
, Aspect_Designated_Storage_Model
));
31229 end Storage_Model_Object
;
31231 ------------------------
31232 -- Storage_Model_Type --
31233 ------------------------
31235 function Storage_Model_Type
(Obj
: Entity_Id
) return Entity_Id
is
31237 pragma Assert
(Has_Storage_Model_Type_Aspect
(Etype
(Obj
)));
31239 return Etype
(Obj
);
31240 end Storage_Model_Type
;
31242 -----------------------------------
31243 -- Get_Storage_Model_Type_Entity --
31244 -----------------------------------
31246 function Get_Storage_Model_Type_Entity
31247 (SM_Obj_Or_Type
: Entity_Id
;
31248 Nam
: Name_Id
) return Entity_Id
31250 Typ
: constant Entity_Id
:= (if Is_Object
(SM_Obj_Or_Type
) then
31251 Storage_Model_Type
(SM_Obj_Or_Type
)
31257 Nam
in Name_Address_Type
31258 | Name_Null_Address
31263 | Name_Storage_Size
);
31266 SMT_Aspect_Value
: constant Node_Id
:=
31267 Find_Value_Of_Aspect
(Typ
, Aspect_Storage_Model_Type
);
31270 -- When the aspect has an aggregate expression, search through it
31271 -- to locate a match for the name of the given "subaspect" and return
31272 -- the entity of the aggregate association's expression.
31274 if Present
(SMT_Aspect_Value
) then
31275 Assoc
:= First
(Component_Associations
(SMT_Aspect_Value
));
31276 while Present
(Assoc
) loop
31277 if Chars
(First
(Choices
(Assoc
))) = Nam
then
31278 return Entity
(Expression
(Assoc
));
31285 -- The aggregate argument of Storage_Model_Type is optional, and when
31286 -- not present the aspect defaults to the native storage model, where
31287 -- the address type is System.Address. In that case, we return
31288 -- System.Address for Name_Address_Type and System.Null_Address for
31289 -- Name_Null_Address, but return Empty for other cases, and leave it
31290 -- to the back end to map those to the appropriate native operations.
31292 if Nam
= Name_Address_Type
then
31293 return RTE
(RE_Address
);
31295 elsif Nam
= Name_Null_Address
then
31296 return RTE
(RE_Null_Address
);
31301 end Get_Storage_Model_Type_Entity
;
31303 --------------------------------
31304 -- Storage_Model_Address_Type --
31305 --------------------------------
31307 function Storage_Model_Address_Type
31308 (SM_Obj_Or_Type
: Entity_Id
) return Entity_Id
31312 Get_Storage_Model_Type_Entity
(SM_Obj_Or_Type
, Name_Address_Type
);
31313 end Storage_Model_Address_Type
;
31315 --------------------------------
31316 -- Storage_Model_Null_Address --
31317 --------------------------------
31319 function Storage_Model_Null_Address
31320 (SM_Obj_Or_Type
: Entity_Id
) return Entity_Id
31324 Get_Storage_Model_Type_Entity
(SM_Obj_Or_Type
, Name_Null_Address
);
31325 end Storage_Model_Null_Address
;
31327 ----------------------------
31328 -- Storage_Model_Allocate --
31329 ----------------------------
31331 function Storage_Model_Allocate
31332 (SM_Obj_Or_Type
: Entity_Id
) return Entity_Id
31335 return Get_Storage_Model_Type_Entity
(SM_Obj_Or_Type
, Name_Allocate
);
31336 end Storage_Model_Allocate
;
31338 ------------------------------
31339 -- Storage_Model_Deallocate --
31340 ------------------------------
31342 function Storage_Model_Deallocate
31343 (SM_Obj_Or_Type
: Entity_Id
) return Entity_Id
31347 Get_Storage_Model_Type_Entity
(SM_Obj_Or_Type
, Name_Deallocate
);
31348 end Storage_Model_Deallocate
;
31350 -----------------------------
31351 -- Storage_Model_Copy_From --
31352 -----------------------------
31354 function Storage_Model_Copy_From
31355 (SM_Obj_Or_Type
: Entity_Id
) return Entity_Id
31358 return Get_Storage_Model_Type_Entity
(SM_Obj_Or_Type
, Name_Copy_From
);
31359 end Storage_Model_Copy_From
;
31361 ---------------------------
31362 -- Storage_Model_Copy_To --
31363 ---------------------------
31365 function Storage_Model_Copy_To
31366 (SM_Obj_Or_Type
: Entity_Id
) return Entity_Id
31369 return Get_Storage_Model_Type_Entity
(SM_Obj_Or_Type
, Name_Copy_To
);
31370 end Storage_Model_Copy_To
;
31372 --------------------------------
31373 -- Storage_Model_Storage_Size --
31374 --------------------------------
31376 function Storage_Model_Storage_Size
31377 (SM_Obj_Or_Type
: Entity_Id
) return Entity_Id
31381 Get_Storage_Model_Type_Entity
(SM_Obj_Or_Type
, Name_Storage_Size
);
31382 end Storage_Model_Storage_Size
;
31384 end Storage_Model_Support
;
31387 Erroutc
.Subprogram_Name_Ptr
:= Subprogram_Name
'Access;