1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2022, 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 Casing
; use Casing
;
27 with Checks
; use Checks
;
28 with Debug
; use Debug
;
29 with Einfo
.Utils
; use Einfo
.Utils
;
30 with Elists
; use Elists
;
31 with Errout
; use Errout
;
32 with Erroutc
; use Erroutc
;
33 with Exp_Ch3
; use Exp_Ch3
;
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
;
75 with GNAT
.Heap_Sort_G
;
76 with GNAT
.HTable
; use GNAT
.HTable
;
78 package body Sem_Util
is
80 ---------------------------
81 -- Local Data Structures --
82 ---------------------------
84 Invalid_Binder_Values
: array (Scalar_Id
) of Entity_Id
:= (others => Empty
);
85 -- A collection to hold the entities of the variables declared in package
86 -- System.Scalar_Values which describe the invalid values of scalar types.
88 Invalid_Binder_Values_Set
: Boolean := False;
89 -- This flag prevents multiple attempts to initialize Invalid_Binder_Values
91 Invalid_Floats
: array (Float_Scalar_Id
) of Ureal
:= (others => No_Ureal
);
92 -- A collection to hold the invalid values of float types as specified by
93 -- pragma Initialize_Scalars.
95 Invalid_Integers
: array (Integer_Scalar_Id
) of Uint
:= (others => No_Uint
);
96 -- A collection to hold the invalid values of integer types as specified
97 -- by pragma Initialize_Scalars.
99 -----------------------
100 -- Local Subprograms --
101 -----------------------
103 function Build_Component_Subtype
106 T
: Entity_Id
) return Node_Id
;
107 -- This function builds the subtype for Build_Actual_Subtype_Of_Component
108 -- and Build_Discriminal_Subtype_Of_Component. C is a list of constraints,
109 -- Loc is the source location, T is the original subtype.
111 procedure Examine_Array_Bounds
113 All_Static
: out Boolean;
114 Has_Empty
: out Boolean);
115 -- Inspect the index constraints of array type Typ. Flag All_Static is set
116 -- when all ranges are static. Flag Has_Empty is set only when All_Static
117 -- is set and indicates that at least one range is empty.
119 function Has_Enabled_Property
120 (Item_Id
: Entity_Id
;
121 Property
: Name_Id
) return Boolean;
122 -- Subsidiary to routines Async_xxx_Enabled and Effective_xxx_Enabled.
123 -- Determine whether the state abstraction, object, or type denoted by
124 -- entity Item_Id has enabled property Property.
126 function Has_Null_Extension
(T
: Entity_Id
) return Boolean;
127 -- T is a derived tagged type. Check whether the type extension is null.
128 -- If the parent type is fully initialized, T can be treated as such.
130 function Is_Atomic_Object_Entity
(Id
: Entity_Id
) return Boolean;
131 -- Determine whether arbitrary entity Id denotes an atomic object as per
134 function Is_Container_Aggregate
(Exp
: Node_Id
) return Boolean;
135 -- Is the given expression a container aggregate?
138 with function Is_Effectively_Volatile_Entity
139 (Id
: Entity_Id
) return Boolean;
140 -- Function to use on object and type entities
141 function Is_Effectively_Volatile_Object_Shared
142 (N
: Node_Id
) return Boolean;
143 -- Shared function used to detect effectively volatile objects and
144 -- effectively volatile objects for reading.
146 function Is_Fully_Initialized_Variant
(Typ
: Entity_Id
) return Boolean;
147 -- Subsidiary to Is_Fully_Initialized_Type. For an unconstrained type
148 -- with discriminants whose default values are static, examine only the
149 -- components in the selected variant to determine whether all of them
152 function Is_Preelaborable_Function
(Id
: Entity_Id
) return Boolean;
153 -- Ada 2022: Determine whether the specified function is suitable as the
154 -- name of a call in a preelaborable construct (RM 10.2.1(7/5)).
156 type Null_Status_Kind
is
158 -- This value indicates that a subexpression is known to have a null
159 -- value at compile time.
162 -- This value indicates that a subexpression is known to have a non-null
163 -- value at compile time.
166 -- This value indicates that it cannot be determined at compile time
167 -- whether a subexpression yields a null or non-null value.
169 function Null_Status
(N
: Node_Id
) return Null_Status_Kind
;
170 -- Determine whether subexpression N of an access type yields a null value,
171 -- a non-null value, or the value cannot be determined at compile time. The
172 -- routine does not take simple flow diagnostics into account, it relies on
173 -- static facts such as the presence of null exclusions.
175 function Subprogram_Name
(N
: Node_Id
) return String;
176 -- Return the fully qualified name of the enclosing subprogram for the
177 -- given node N, with file:line:col information appended, e.g.
178 -- "subp:file:line:col", corresponding to the source location of the
179 -- body of the subprogram.
181 -----------------------------
182 -- Abstract_Interface_List --
183 -----------------------------
185 function Abstract_Interface_List
(Typ
: Entity_Id
) return List_Id
is
189 if Is_Concurrent_Type
(Typ
) then
191 -- If we are dealing with a synchronized subtype, go to the base
192 -- type, whose declaration has the interface list.
194 Nod
:= Declaration_Node
(Base_Type
(Typ
));
196 if Nkind
(Nod
) in N_Full_Type_Declaration | N_Private_Type_Declaration
201 elsif Ekind
(Typ
) = E_Record_Type_With_Private
then
202 if Nkind
(Parent
(Typ
)) = N_Full_Type_Declaration
then
203 Nod
:= Type_Definition
(Parent
(Typ
));
205 elsif Nkind
(Parent
(Typ
)) = N_Private_Type_Declaration
then
206 if Present
(Full_View
(Typ
))
208 Nkind
(Parent
(Full_View
(Typ
))) = N_Full_Type_Declaration
210 Nod
:= Type_Definition
(Parent
(Full_View
(Typ
)));
212 -- If the full-view is not available we cannot do anything else
213 -- here (the source has errors).
219 -- Support for generic formals with interfaces is still missing ???
221 elsif Nkind
(Parent
(Typ
)) = N_Formal_Type_Declaration
then
226 (Nkind
(Parent
(Typ
)) = N_Private_Extension_Declaration
);
230 elsif Ekind
(Typ
) = E_Record_Subtype
then
231 Nod
:= Type_Definition
(Parent
(Etype
(Typ
)));
233 elsif Ekind
(Typ
) = E_Record_Subtype_With_Private
then
235 -- Recurse, because parent may still be a private extension. Also
236 -- note that the full view of the subtype or the full view of its
237 -- base type may (both) be unavailable.
239 return Abstract_Interface_List
(Etype
(Typ
));
241 elsif Ekind
(Typ
) = E_Record_Type
then
242 if Nkind
(Parent
(Typ
)) = N_Formal_Type_Declaration
then
243 Nod
:= Formal_Type_Definition
(Parent
(Typ
));
245 Nod
:= Type_Definition
(Parent
(Typ
));
248 -- Otherwise the type is of a kind which does not implement interfaces
254 return Interface_List
(Nod
);
255 end Abstract_Interface_List
;
257 -------------------------
258 -- Accessibility_Level --
259 -------------------------
261 function Accessibility_Level
263 Level
: Accessibility_Level_Kind
;
264 In_Return_Context
: Boolean := False;
265 Allow_Alt_Model
: Boolean := True) return Node_Id
267 Loc
: constant Source_Ptr
:= Sloc
(Expr
);
269 function Accessibility_Level
(Expr
: Node_Id
) return Node_Id
270 is (Accessibility_Level
(Expr
, Level
, In_Return_Context
));
271 -- Renaming of the enclosing function to facilitate recursive calls
273 function Make_Level_Literal
(Level
: Uint
) return Node_Id
;
274 -- Construct an integer literal representing an accessibility level
275 -- with its type set to Natural.
277 function Innermost_Master_Scope_Depth
(N
: Node_Id
) return Uint
;
278 -- Returns the scope depth of the given node's innermost
279 -- enclosing dynamic scope (effectively the accessibility
280 -- level of the innermost enclosing master).
282 function Function_Call_Or_Allocator_Level
(N
: Node_Id
) return Node_Id
;
283 -- Centralized processing of subprogram calls which may appear in
286 function Typ_Access_Level
(Typ
: Entity_Id
) return Uint
287 is (Type_Access_Level
(Typ
, Allow_Alt_Model
));
288 -- Renaming of Type_Access_Level with Allow_Alt_Model specified to avoid
289 -- passing the parameter specifically in every call.
291 ----------------------------------
292 -- Innermost_Master_Scope_Depth --
293 ----------------------------------
295 function Innermost_Master_Scope_Depth
(N
: Node_Id
) return Uint
is
296 Encl_Scop
: Entity_Id
;
298 Node_Par
: Node_Id
:= Parent
(N
);
299 Master_Lvl_Modifier
: Int
:= 0;
302 -- Locate the nearest enclosing node (by traversing Parents)
303 -- that Defining_Entity can be applied to, and return the
304 -- depth of that entity's nearest enclosing dynamic scope.
306 -- The rules that define what a master are defined in
307 -- RM 7.6.1 (3), and include statements and conditions for loops
308 -- among other things. These cases are detected properly ???
310 while Present
(Node_Par
) loop
311 Ent
:= Defining_Entity_Or_Empty
(Node_Par
);
313 if Present
(Ent
) then
314 Encl_Scop
:= Nearest_Dynamic_Scope
(Ent
);
316 -- Ignore transient scopes made during expansion
318 if Comes_From_Source
(Node_Par
) then
320 Scope_Depth_Default_0
(Encl_Scop
) + Master_Lvl_Modifier
;
323 -- For a return statement within a function, return
324 -- the depth of the function itself. This is not just
325 -- a small optimization, but matters when analyzing
326 -- the expression in an expression function before
327 -- the body is created.
329 elsif Nkind
(Node_Par
) in N_Extended_Return_Statement
330 | N_Simple_Return_Statement
332 return Scope_Depth
(Enclosing_Subprogram
(Node_Par
));
334 -- Statements are counted as masters
336 elsif Is_Master
(Node_Par
) then
337 Master_Lvl_Modifier
:= Master_Lvl_Modifier
+ 1;
341 Node_Par
:= Parent
(Node_Par
);
344 -- Should never reach the following return
346 pragma Assert
(False);
348 return Scope_Depth
(Current_Scope
) + 1;
349 end Innermost_Master_Scope_Depth
;
351 ------------------------
352 -- Make_Level_Literal --
353 ------------------------
355 function Make_Level_Literal
(Level
: Uint
) return Node_Id
is
356 Result
: constant Node_Id
:= Make_Integer_Literal
(Loc
, Level
);
359 Set_Etype
(Result
, Standard_Natural
);
361 end Make_Level_Literal
;
363 --------------------------------------
364 -- Function_Call_Or_Allocator_Level --
365 --------------------------------------
367 function Function_Call_Or_Allocator_Level
(N
: Node_Id
) return Node_Id
is
371 -- Results of functions are objects, so we either get the
372 -- accessibility of the function or, in case of a call which is
373 -- indirect, the level of the access-to-subprogram type.
375 -- This code looks wrong ???
377 if Nkind
(N
) = N_Function_Call
378 and then Ada_Version
< Ada_2005
380 if Is_Entity_Name
(Name
(N
)) then
381 return Make_Level_Literal
382 (Subprogram_Access_Level
(Entity
(Name
(N
))));
384 return Make_Level_Literal
385 (Typ_Access_Level
(Etype
(Prefix
(Name
(N
)))));
388 -- We ignore coextensions as they cannot be implemented under the
389 -- "small-integer" model.
391 elsif Nkind
(N
) = N_Allocator
392 and then (Is_Static_Coextension
(N
)
393 or else Is_Dynamic_Coextension
(N
))
395 return Make_Level_Literal
(Scope_Depth
(Standard_Standard
));
398 -- Named access types have a designated level
400 if Is_Named_Access_Type
(Etype
(N
)) then
401 return Make_Level_Literal
(Typ_Access_Level
(Etype
(N
)));
403 -- Otherwise, the level is dictated by RM 3.10.2 (10.7/3)
406 -- Check No_Dynamic_Accessibility_Checks restriction override for
407 -- alternative accessibility model.
410 and then No_Dynamic_Accessibility_Checks_Enabled
(N
)
411 and then Is_Anonymous_Access_Type
(Etype
(N
))
413 -- In the alternative model the level is that of the
416 if Debug_Flag_Underscore_B
then
417 return Make_Level_Literal
(Typ_Access_Level
(Etype
(N
)));
419 -- For function calls the level is that of the innermost
420 -- master, otherwise (for allocators etc.) we get the level
421 -- of the corresponding anonymous access type, which is
422 -- calculated through the normal path of execution.
424 elsif Nkind
(N
) = N_Function_Call
then
425 return Make_Level_Literal
426 (Innermost_Master_Scope_Depth
(Expr
));
430 if Nkind
(N
) = N_Function_Call
then
431 -- Dynamic checks are generated when we are within a return
432 -- value or we are in a function call within an anonymous
433 -- access discriminant constraint of a return object (signified
434 -- by In_Return_Context) on the side of the callee.
436 -- So, in this case, return accessibility level of the
437 -- enclosing subprogram.
439 if In_Return_Value
(N
)
440 or else In_Return_Context
442 return Make_Level_Literal
443 (Subprogram_Access_Level
(Current_Subprogram
));
447 -- When the call is being dereferenced the level is that of the
448 -- enclosing master of the dereferenced call.
450 if Nkind
(Parent
(N
)) in N_Explicit_Dereference
451 | N_Indexed_Component
452 | N_Selected_Component
454 return Make_Level_Literal
455 (Innermost_Master_Scope_Depth
(Expr
));
458 -- Find any relevant enclosing parent nodes that designate an
459 -- object being initialized.
461 -- Note: The above is only relevant if the result is used "in its
462 -- entirety" as RM 3.10.2 (10.2/3) states. However, this is
463 -- accounted for in the case statement in the main body of
464 -- Accessibility_Level for N_Selected_Component.
466 Par
:= Parent
(Expr
);
468 while Present
(Par
) loop
469 -- Detect an expanded implicit conversion, typically this
470 -- occurs on implicitly converted actuals in calls.
472 -- Does this catch all implicit conversions ???
474 if Nkind
(Par
) = N_Type_Conversion
475 and then Is_Named_Access_Type
(Etype
(Par
))
477 return Make_Level_Literal
478 (Typ_Access_Level
(Etype
(Par
)));
481 -- Jump out when we hit an object declaration or the right-hand
482 -- side of an assignment, or a construct such as an aggregate
483 -- subtype indication which would be the result is not used
484 -- "in its entirety."
486 exit when Nkind
(Par
) in N_Object_Declaration
487 or else (Nkind
(Par
) = N_Assignment_Statement
488 and then Name
(Par
) /= Prev_Par
);
494 -- Assignment statements are handled in a similar way in
495 -- accordance to the left-hand part. However, strictly speaking,
496 -- this is illegal according to the RM, but this change is needed
497 -- to pass an ACATS C-test and is useful in general ???
500 when N_Object_Declaration
=>
501 return Make_Level_Literal
503 (Scope
(Defining_Identifier
(Par
))));
505 when N_Assignment_Statement
=>
506 -- Return the accessibility level of the left-hand part
508 return Accessibility_Level
510 Level
=> Object_Decl_Level
,
511 In_Return_Context
=> In_Return_Context
);
514 return Make_Level_Literal
515 (Innermost_Master_Scope_Depth
(Expr
));
518 end Function_Call_Or_Allocator_Level
;
522 E
: Entity_Id
:= Original_Node
(Expr
);
525 -- Start of processing for Accessibility_Level
528 -- We could be looking at a reference to a formal due to the expansion
529 -- of entries and other cases, so obtain the renaming if necessary.
531 if Present
(Param_Entity
(Expr
)) then
532 E
:= Param_Entity
(Expr
);
535 -- Extract the entity
537 if Nkind
(E
) in N_Has_Entity
and then Present
(Entity
(E
)) then
540 -- Deal with a possible renaming of a private protected component
542 if Ekind
(E
) in E_Constant | E_Variable
and then Is_Prival
(E
) then
543 E
:= Prival_Link
(E
);
547 -- Perform the processing on the expression
550 -- The level of an aggregate is that of the innermost master that
551 -- evaluates it as defined in RM 3.10.2 (10/4).
554 return Make_Level_Literal
(Innermost_Master_Scope_Depth
(Expr
));
556 -- The accessibility level is that of the access type, except for an
557 -- anonymous allocators which have special rules defined in RM 3.10.2
561 return Function_Call_Or_Allocator_Level
(E
);
563 -- We could reach this point for two reasons. Either the expression
564 -- applies to a special attribute ('Loop_Entry, 'Result, or 'Old), or
565 -- we are looking at the access attributes directly ('Access,
566 -- 'Address, or 'Unchecked_Access).
568 when N_Attribute_Reference
=>
569 Pre
:= Original_Node
(Prefix
(E
));
571 -- Regular 'Access attribute presence means we have to look at the
574 if Attribute_Name
(E
) = Name_Access
then
575 return Accessibility_Level
(Prefix
(E
));
577 -- Unchecked or unrestricted attributes have unlimited depth
579 elsif Attribute_Name
(E
) in Name_Address
580 | Name_Unchecked_Access
581 | Name_Unrestricted_Access
583 return Make_Level_Literal
(Scope_Depth
(Standard_Standard
));
585 -- 'Access can be taken further against other special attributes,
586 -- so handle these cases explicitly.
588 elsif Attribute_Name
(E
)
589 in Name_Old | Name_Loop_Entry | Name_Result
591 -- Named access types
593 if Is_Named_Access_Type
(Etype
(Pre
)) then
594 return Make_Level_Literal
595 (Typ_Access_Level
(Etype
(Pre
)));
597 -- Anonymous access types
599 elsif Nkind
(Pre
) in N_Has_Entity
600 and then Present
(Get_Dynamic_Accessibility
(Entity
(Pre
)))
601 and then Level
= Dynamic_Level
603 return New_Occurrence_Of
604 (Get_Dynamic_Accessibility
(Entity
(Pre
)), Loc
);
606 -- Otherwise the level is treated in a similar way as
607 -- aggregates according to RM 6.1.1 (35.1/4) which concerns
608 -- an implicit constant declaration - in turn defining the
609 -- accessibility level to be that of the implicit constant
613 return Make_Level_Literal
614 (Innermost_Master_Scope_Depth
(Expr
));
621 -- This is the "base case" for accessibility level calculations which
622 -- means we are near the end of our recursive traversal.
624 when N_Defining_Identifier
=>
625 -- A dynamic check is performed on the side of the callee when we
626 -- are within a return statement, so return a library-level
627 -- accessibility level to null out checks on the side of the
630 if Is_Explicitly_Aliased
(E
)
631 and then (In_Return_Context
632 or else (Level
/= Dynamic_Level
633 and then In_Return_Value
(Expr
)))
635 return Make_Level_Literal
(Scope_Depth
(Standard_Standard
));
637 -- Something went wrong and an extra accessibility formal has not
638 -- been generated when one should have ???
641 and then not Present
(Get_Dynamic_Accessibility
(E
))
642 and then Ekind
(Etype
(E
)) = E_Anonymous_Access_Type
644 return Make_Level_Literal
(Scope_Depth
(Standard_Standard
));
646 -- Stand-alone object of an anonymous access type "SAOAAT"
649 or else Ekind
(E
) in E_Variable
651 and then Present
(Get_Dynamic_Accessibility
(E
))
652 and then (Level
= Dynamic_Level
653 or else Level
= Zero_On_Dynamic_Level
)
655 if Level
= Zero_On_Dynamic_Level
then
656 return Make_Level_Literal
657 (Scope_Depth
(Standard_Standard
));
660 -- No_Dynamic_Accessibility_Checks restriction override for
661 -- alternative accessibility model.
664 and then No_Dynamic_Accessibility_Checks_Enabled
(E
)
666 -- In the alternative model the level is that of the
667 -- designated type entity's context.
669 if Debug_Flag_Underscore_B
then
670 return Make_Level_Literal
(Typ_Access_Level
(Etype
(E
)));
672 -- Otherwise the level depends on the entity's context
674 elsif Is_Formal
(E
) then
675 return Make_Level_Literal
676 (Subprogram_Access_Level
677 (Enclosing_Subprogram
(E
)));
679 return Make_Level_Literal
680 (Scope_Depth
(Enclosing_Dynamic_Scope
(E
)));
684 -- Return the dynamic level in the normal case
686 return New_Occurrence_Of
687 (Get_Dynamic_Accessibility
(E
), Loc
);
689 -- Initialization procedures have a special extra accessibility
690 -- parameter associated with the level at which the object
691 -- being initialized exists
693 elsif Ekind
(E
) = E_Record_Type
694 and then Is_Limited_Record
(E
)
695 and then Current_Scope
= Init_Proc
(E
)
696 and then Present
(Init_Proc_Level_Formal
(Current_Scope
))
698 return New_Occurrence_Of
699 (Init_Proc_Level_Formal
(Current_Scope
), Loc
);
701 -- Current instance of the type is deeper than that of the type
702 -- according to RM 3.10.2 (21).
704 elsif Is_Type
(E
) then
705 -- When restriction No_Dynamic_Accessibility_Checks is active
706 -- along with -gnatd_b.
709 and then No_Dynamic_Accessibility_Checks_Enabled
(E
)
710 and then Debug_Flag_Underscore_B
712 return Make_Level_Literal
(Typ_Access_Level
(E
));
717 return Make_Level_Literal
(Typ_Access_Level
(E
) + 1);
719 -- Move up the renamed entity or object if it came from source
720 -- since expansion may have created a dummy renaming under
721 -- certain circumstances.
723 -- Note: We check if the original node of the renaming comes
724 -- from source because the node may have been rewritten.
726 elsif Present
(Renamed_Entity_Or_Object
(E
))
727 and then Comes_From_Source
728 (Original_Node
(Renamed_Entity_Or_Object
(E
)))
730 return Accessibility_Level
(Renamed_Entity_Or_Object
(E
));
732 -- Named access types get their level from their associated type
734 elsif Is_Named_Access_Type
(Etype
(E
)) then
735 return Make_Level_Literal
736 (Typ_Access_Level
(Etype
(E
)));
738 -- Check if E is an expansion-generated renaming of an iterator
739 -- by examining Related_Expression. If so, determine the
740 -- accessibility level based on the original expression.
742 elsif Ekind
(E
) in E_Constant | E_Variable
743 and then Present
(Related_Expression
(E
))
745 return Accessibility_Level
(Related_Expression
(E
));
747 elsif Level
= Dynamic_Level
748 and then Ekind
(E
) in E_In_Parameter | E_In_Out_Parameter
749 and then Present
(Init_Proc_Level_Formal
(Scope
(E
)))
751 return New_Occurrence_Of
752 (Init_Proc_Level_Formal
(Scope
(E
)), Loc
);
754 -- Normal object - get the level of the enclosing scope
757 return Make_Level_Literal
758 (Scope_Depth
(Enclosing_Dynamic_Scope
(E
)));
761 -- Handle indexed and selected components including the special cases
762 -- whereby there is an implicit dereference, a component of a
763 -- composite type, or a function call in prefix notation.
765 -- We don't handle function calls in prefix notation correctly ???
767 when N_Indexed_Component | N_Selected_Component
=>
768 Pre
:= Original_Node
(Prefix
(E
));
770 -- When E is an indexed component or selected component and
771 -- the current Expr is a function call, we know that we are
772 -- looking at an expanded call in prefix notation.
774 if Nkind
(Expr
) = N_Function_Call
then
775 return Function_Call_Or_Allocator_Level
(Expr
);
777 -- If the prefix is a named access type, then we are dealing
778 -- with an implicit deferences. In that case the level is that
779 -- of the named access type in the prefix.
781 elsif Is_Named_Access_Type
(Etype
(Pre
)) then
782 return Make_Level_Literal
783 (Typ_Access_Level
(Etype
(Pre
)));
785 -- The current expression is a named access type, so there is no
786 -- reason to look at the prefix. Instead obtain the level of E's
787 -- named access type.
789 elsif Is_Named_Access_Type
(Etype
(E
)) then
790 return Make_Level_Literal
791 (Typ_Access_Level
(Etype
(E
)));
793 -- A nondiscriminant selected component where the component
794 -- is an anonymous access type means that its associated
795 -- level is that of the containing type - see RM 3.10.2 (16).
797 -- Note that when restriction No_Dynamic_Accessibility_Checks is
798 -- in effect we treat discriminant components as regular
801 elsif Nkind
(E
) = N_Selected_Component
802 and then Ekind
(Etype
(E
)) = E_Anonymous_Access_Type
803 and then Ekind
(Etype
(Pre
)) /= E_Anonymous_Access_Type
804 and then (not (Nkind
(Selector_Name
(E
)) in N_Has_Entity
805 and then Ekind
(Entity
(Selector_Name
(E
)))
808 -- The alternative accessibility models both treat
809 -- discriminants as regular components.
811 or else (No_Dynamic_Accessibility_Checks_Enabled
(E
)
812 and then Allow_Alt_Model
))
814 -- When restriction No_Dynamic_Accessibility_Checks is active
815 -- and -gnatd_b set, the level is that of the designated type.
818 and then No_Dynamic_Accessibility_Checks_Enabled
(E
)
819 and then Debug_Flag_Underscore_B
821 return Make_Level_Literal
822 (Typ_Access_Level
(Etype
(E
)));
825 -- Otherwise proceed normally
827 return Make_Level_Literal
828 (Typ_Access_Level
(Etype
(Prefix
(E
))));
830 -- Similar to the previous case - arrays featuring components of
831 -- anonymous access components get their corresponding level from
832 -- their containing type's declaration.
834 elsif Nkind
(E
) = N_Indexed_Component
835 and then Ekind
(Etype
(E
)) = E_Anonymous_Access_Type
836 and then Ekind
(Etype
(Pre
)) in Array_Kind
837 and then Ekind
(Component_Type
(Base_Type
(Etype
(Pre
))))
838 = E_Anonymous_Access_Type
840 -- When restriction No_Dynamic_Accessibility_Checks is active
841 -- and -gnatd_b set, the level is that of the designated type.
844 and then No_Dynamic_Accessibility_Checks_Enabled
(E
)
845 and then Debug_Flag_Underscore_B
847 return Make_Level_Literal
848 (Typ_Access_Level
(Etype
(E
)));
851 -- Otherwise proceed normally
853 return Make_Level_Literal
854 (Typ_Access_Level
(Etype
(Prefix
(E
))));
856 -- The accessibility calculation routine that handles function
857 -- calls (Function_Call_Level) assumes, in the case the
858 -- result is of an anonymous access type, that the result will be
859 -- used "in its entirety" when the call is present within an
860 -- assignment or object declaration.
862 -- To properly handle cases where the result is not used in its
863 -- entirety, we test if the prefix of the component in question is
864 -- a function call, which tells us that one of its components has
865 -- been identified and is being accessed. Therefore we can
866 -- conclude that the result is not used "in its entirety"
867 -- according to RM 3.10.2 (10.2/3).
869 elsif Nkind
(Pre
) = N_Function_Call
870 and then not Is_Named_Access_Type
(Etype
(Pre
))
872 -- Dynamic checks are generated when we are within a return
873 -- value or we are in a function call within an anonymous
874 -- access discriminant constraint of a return object (signified
875 -- by In_Return_Context) on the side of the callee.
877 -- So, in this case, return a library accessibility level to
878 -- null out the check on the side of the caller.
880 if (In_Return_Value
(E
)
881 or else In_Return_Context
)
882 and then Level
/= Dynamic_Level
884 return Make_Level_Literal
885 (Scope_Depth
(Standard_Standard
));
888 return Make_Level_Literal
889 (Innermost_Master_Scope_Depth
(Expr
));
891 -- Otherwise, continue recursing over the expression prefixes
894 return Accessibility_Level
(Prefix
(E
));
897 -- Qualified expressions
899 when N_Qualified_Expression
=>
900 if Is_Named_Access_Type
(Etype
(E
)) then
901 return Make_Level_Literal
902 (Typ_Access_Level
(Etype
(E
)));
904 return Accessibility_Level
(Expression
(E
));
907 -- Handle function calls
909 when N_Function_Call
=>
910 return Function_Call_Or_Allocator_Level
(E
);
912 -- Explicit dereference accessibility level calculation
914 when N_Explicit_Dereference
=>
915 Pre
:= Original_Node
(Prefix
(E
));
917 -- The prefix is a named access type so the level is taken from
920 if Is_Named_Access_Type
(Etype
(Pre
)) then
921 return Make_Level_Literal
(Typ_Access_Level
(Etype
(Pre
)));
923 -- Otherwise, recurse deeper
926 return Accessibility_Level
(Prefix
(E
));
931 when N_Type_Conversion | N_Unchecked_Type_Conversion
=>
932 -- View conversions are special in that they require use to
933 -- inspect the expression of the type conversion.
935 -- Allocators of anonymous access types are internally generated,
936 -- so recurse deeper in that case as well.
938 if Is_View_Conversion
(E
)
939 or else Ekind
(Etype
(E
)) = E_Anonymous_Access_Type
941 return Accessibility_Level
(Expression
(E
));
943 -- We don't care about the master if we are looking at a named
946 elsif Is_Named_Access_Type
(Etype
(E
)) then
947 return Make_Level_Literal
948 (Typ_Access_Level
(Etype
(E
)));
950 -- In section RM 3.10.2 (10/4) the accessibility rules for
951 -- aggregates and value conversions are outlined. Are these
952 -- followed in the case of initialization of an object ???
954 -- Should use Innermost_Master_Scope_Depth ???
957 return Accessibility_Level
(Current_Scope
);
960 -- Default to the type accessibility level for the type of the
961 -- expression's entity.
964 return Make_Level_Literal
(Typ_Access_Level
(Etype
(E
)));
966 end Accessibility_Level
;
968 --------------------------------
969 -- Static_Accessibility_Level --
970 --------------------------------
972 function Static_Accessibility_Level
974 Level
: Static_Accessibility_Level_Kind
;
975 In_Return_Context
: Boolean := False) return Uint
979 (Accessibility_Level
(Expr
, Level
, In_Return_Context
));
980 end Static_Accessibility_Level
;
982 ----------------------------------
983 -- Acquire_Warning_Match_String --
984 ----------------------------------
986 function Acquire_Warning_Match_String
(Str_Lit
: Node_Id
) return String is
987 S
: constant String := To_String
(Strval
(Str_Lit
));
992 -- Put "*" before or after or both, if it's not already there
995 F
: constant Boolean := S
(S
'First) = '*';
996 L
: constant Boolean := S
(S
'Last) = '*';
1008 return "*" & S
& "*";
1013 end Acquire_Warning_Match_String
;
1015 --------------------------------
1016 -- Add_Access_Type_To_Process --
1017 --------------------------------
1019 procedure Add_Access_Type_To_Process
(E
: Entity_Id
; A
: Entity_Id
) is
1023 Ensure_Freeze_Node
(E
);
1024 L
:= Access_Types_To_Process
(Freeze_Node
(E
));
1028 Set_Access_Types_To_Process
(Freeze_Node
(E
), L
);
1032 end Add_Access_Type_To_Process
;
1034 --------------------------
1035 -- Add_Block_Identifier --
1036 --------------------------
1038 procedure Add_Block_Identifier
(N
: Node_Id
; Id
: out Entity_Id
) is
1039 Loc
: constant Source_Ptr
:= Sloc
(N
);
1041 pragma Assert
(Nkind
(N
) = N_Block_Statement
);
1043 -- The block already has a label, return its entity
1045 if Present
(Identifier
(N
)) then
1046 Id
:= Entity
(Identifier
(N
));
1048 -- Create a new block label and set its attributes
1051 Id
:= New_Internal_Entity
(E_Block
, Current_Scope
, Loc
, 'B');
1052 Set_Etype
(Id
, Standard_Void_Type
);
1055 Set_Identifier
(N
, New_Occurrence_Of
(Id
, Loc
));
1056 Set_Block_Node
(Id
, Identifier
(N
));
1058 end Add_Block_Identifier
;
1060 ----------------------------
1061 -- Add_Global_Declaration --
1062 ----------------------------
1064 procedure Add_Global_Declaration
(N
: Node_Id
) is
1065 Aux_Node
: constant Node_Id
:= Aux_Decls_Node
(Cunit
(Current_Sem_Unit
));
1068 if No
(Declarations
(Aux_Node
)) then
1069 Set_Declarations
(Aux_Node
, New_List
);
1072 Append_To
(Declarations
(Aux_Node
), N
);
1074 end Add_Global_Declaration
;
1076 --------------------------------
1077 -- Address_Integer_Convert_OK --
1078 --------------------------------
1080 function Address_Integer_Convert_OK
(T1
, T2
: Entity_Id
) return Boolean is
1082 if Allow_Integer_Address
1083 and then ((Is_Descendant_Of_Address
(T1
)
1084 and then Is_Private_Type
(T1
)
1085 and then Is_Integer_Type
(T2
))
1087 (Is_Descendant_Of_Address
(T2
)
1088 and then Is_Private_Type
(T2
)
1089 and then Is_Integer_Type
(T1
)))
1095 end Address_Integer_Convert_OK
;
1101 function Address_Value
(N
: Node_Id
) return Node_Id
is
1102 Expr
: Node_Id
:= N
;
1106 -- For constant, get constant expression
1108 if Is_Entity_Name
(Expr
)
1109 and then Ekind
(Entity
(Expr
)) = E_Constant
1111 Expr
:= Constant_Value
(Entity
(Expr
));
1113 -- For unchecked conversion, get result to convert
1115 elsif Nkind
(Expr
) = N_Unchecked_Type_Conversion
then
1116 Expr
:= Expression
(Expr
);
1118 -- For (common case) of To_Address call, get argument
1120 elsif Nkind
(Expr
) = N_Function_Call
1121 and then Is_Entity_Name
(Name
(Expr
))
1122 and then Is_RTE
(Entity
(Name
(Expr
)), RE_To_Address
)
1124 Expr
:= First_Actual
(Expr
);
1126 -- We finally have the real expression
1140 function Addressable
(V
: Uint
) return Boolean is
1146 return V
= Uint_8
or else
1150 (V
= Uint_128
and then System_Max_Integer_Size
= 128);
1153 function Addressable
(V
: Int
) return Boolean is
1155 return V
= 8 or else
1159 V
= System_Max_Integer_Size
;
1162 ---------------------------------
1163 -- Aggregate_Constraint_Checks --
1164 ---------------------------------
1166 procedure Aggregate_Constraint_Checks
1168 Check_Typ
: Entity_Id
)
1170 Exp_Typ
: constant Entity_Id
:= Etype
(Exp
);
1173 if Raises_Constraint_Error
(Exp
) then
1177 -- Ada 2005 (AI-230): Generate a conversion to an anonymous access
1178 -- component's type to force the appropriate accessibility checks.
1180 -- Ada 2005 (AI-231): Generate conversion to the null-excluding type to
1181 -- force the corresponding run-time check
1183 if Is_Access_Type
(Check_Typ
)
1184 and then Is_Local_Anonymous_Access
(Check_Typ
)
1186 Rewrite
(Exp
, Convert_To
(Check_Typ
, Relocate_Node
(Exp
)));
1187 Analyze_And_Resolve
(Exp
, Check_Typ
);
1188 Check_Unset_Reference
(Exp
);
1191 -- What follows is really expansion activity, so check that expansion
1192 -- is on and is allowed. In GNATprove mode, we also want check flags to
1193 -- be added in the tree, so that the formal verification can rely on
1194 -- those to be present. In GNATprove mode for formal verification, some
1195 -- treatment typically only done during expansion needs to be performed
1196 -- on the tree, but it should not be applied inside generics. Otherwise,
1197 -- this breaks the name resolution mechanism for generic instances.
1199 if not Expander_Active
1200 and (Inside_A_Generic
or not Full_Analysis
or not GNATprove_Mode
)
1205 if Is_Access_Type
(Check_Typ
)
1206 and then Can_Never_Be_Null
(Check_Typ
)
1207 and then not Can_Never_Be_Null
(Exp_Typ
)
1209 Install_Null_Excluding_Check
(Exp
);
1212 -- First check if we have to insert discriminant checks
1214 if Has_Discriminants
(Exp_Typ
) then
1215 Apply_Discriminant_Check
(Exp
, Check_Typ
);
1217 -- Next emit length checks for array aggregates
1219 elsif Is_Array_Type
(Exp_Typ
) then
1220 Apply_Length_Check
(Exp
, Check_Typ
);
1222 -- Finally emit scalar and string checks. If we are dealing with a
1223 -- scalar literal we need to check by hand because the Etype of
1224 -- literals is not necessarily correct.
1226 elsif Is_Scalar_Type
(Exp_Typ
)
1227 and then Compile_Time_Known_Value
(Exp
)
1229 if Is_Out_Of_Range
(Exp
, Base_Type
(Check_Typ
)) then
1230 Apply_Compile_Time_Constraint_Error
1231 (Exp
, "value not in range of}??", CE_Range_Check_Failed
,
1232 Ent
=> Base_Type
(Check_Typ
),
1233 Typ
=> Base_Type
(Check_Typ
));
1235 elsif Is_Out_Of_Range
(Exp
, Check_Typ
) then
1236 Apply_Compile_Time_Constraint_Error
1237 (Exp
, "value not in range of}??", CE_Range_Check_Failed
,
1241 elsif not Range_Checks_Suppressed
(Check_Typ
) then
1242 Apply_Scalar_Range_Check
(Exp
, Check_Typ
);
1245 -- Verify that target type is also scalar, to prevent view anomalies
1246 -- in instantiations.
1248 elsif (Is_Scalar_Type
(Exp_Typ
)
1249 or else Nkind
(Exp
) = N_String_Literal
)
1250 and then Is_Scalar_Type
(Check_Typ
)
1251 and then Exp_Typ
/= Check_Typ
1253 if Is_Entity_Name
(Exp
)
1254 and then Ekind
(Entity
(Exp
)) = E_Constant
1256 -- If expression is a constant, it is worthwhile checking whether
1257 -- it is a bound of the type.
1259 if (Is_Entity_Name
(Type_Low_Bound
(Check_Typ
))
1260 and then Entity
(Exp
) = Entity
(Type_Low_Bound
(Check_Typ
)))
1262 (Is_Entity_Name
(Type_High_Bound
(Check_Typ
))
1263 and then Entity
(Exp
) = Entity
(Type_High_Bound
(Check_Typ
)))
1268 Rewrite
(Exp
, Convert_To
(Check_Typ
, Relocate_Node
(Exp
)));
1269 Analyze_And_Resolve
(Exp
, Check_Typ
);
1270 Check_Unset_Reference
(Exp
);
1273 -- Could use a comment on this case ???
1276 Rewrite
(Exp
, Convert_To
(Check_Typ
, Relocate_Node
(Exp
)));
1277 Analyze_And_Resolve
(Exp
, Check_Typ
);
1278 Check_Unset_Reference
(Exp
);
1282 end Aggregate_Constraint_Checks
;
1284 -----------------------
1285 -- Alignment_In_Bits --
1286 -----------------------
1288 function Alignment_In_Bits
(E
: Entity_Id
) return Uint
is
1290 return Alignment
(E
) * System_Storage_Unit
;
1291 end Alignment_In_Bits
;
1293 --------------------------------------
1294 -- All_Composite_Constraints_Static --
1295 --------------------------------------
1297 function All_Composite_Constraints_Static
1298 (Constr
: Node_Id
) return Boolean
1301 if No
(Constr
) or else Error_Posted
(Constr
) then
1305 case Nkind
(Constr
) is
1307 if Nkind
(Constr
) in N_Has_Entity
1308 and then Present
(Entity
(Constr
))
1310 if Is_Type
(Entity
(Constr
)) then
1312 not Is_Discrete_Type
(Entity
(Constr
))
1313 or else Is_OK_Static_Subtype
(Entity
(Constr
));
1316 elsif Nkind
(Constr
) = N_Range
then
1318 Is_OK_Static_Expression
(Low_Bound
(Constr
))
1320 Is_OK_Static_Expression
(High_Bound
(Constr
));
1322 elsif Nkind
(Constr
) = N_Attribute_Reference
1323 and then Attribute_Name
(Constr
) = Name_Range
1326 Is_OK_Static_Expression
1327 (Type_Low_Bound
(Etype
(Prefix
(Constr
))))
1329 Is_OK_Static_Expression
1330 (Type_High_Bound
(Etype
(Prefix
(Constr
))));
1334 not Present
(Etype
(Constr
)) -- previous error
1335 or else not Is_Discrete_Type
(Etype
(Constr
))
1336 or else Is_OK_Static_Expression
(Constr
);
1338 when N_Discriminant_Association
=>
1339 return All_Composite_Constraints_Static
(Expression
(Constr
));
1341 when N_Range_Constraint
=>
1343 All_Composite_Constraints_Static
(Range_Expression
(Constr
));
1345 when N_Index_Or_Discriminant_Constraint
=>
1347 One_Cstr
: Entity_Id
;
1349 One_Cstr
:= First
(Constraints
(Constr
));
1350 while Present
(One_Cstr
) loop
1351 if not All_Composite_Constraints_Static
(One_Cstr
) then
1361 when N_Subtype_Indication
=>
1363 All_Composite_Constraints_Static
(Subtype_Mark
(Constr
))
1365 All_Composite_Constraints_Static
(Constraint
(Constr
));
1368 raise Program_Error
;
1370 end All_Composite_Constraints_Static
;
1372 ------------------------
1373 -- Append_Entity_Name --
1374 ------------------------
1376 procedure Append_Entity_Name
(Buf
: in out Bounded_String
; E
: Entity_Id
) is
1377 Temp
: Bounded_String
;
1379 procedure Inner
(E
: Entity_Id
);
1380 -- Inner recursive routine, keep outer routine nonrecursive to ease
1381 -- debugging when we get strange results from this routine.
1387 procedure Inner
(E
: Entity_Id
) is
1391 -- If entity has an internal name, skip by it, and print its scope.
1392 -- Note that we strip a final R from the name before the test; this
1393 -- is needed for some cases of instantiations.
1396 E_Name
: Bounded_String
;
1399 Append
(E_Name
, Chars
(E
));
1401 if E_Name
.Chars
(E_Name
.Length
) = 'R' then
1402 E_Name
.Length
:= E_Name
.Length
- 1;
1405 if Is_Internal_Name
(E_Name
) then
1413 -- Just print entity name if its scope is at the outer level
1415 if Scop
= Standard_Standard
then
1418 -- If scope comes from source, write scope and entity
1420 elsif Comes_From_Source
(Scop
) then
1421 Append_Entity_Name
(Temp
, Scop
);
1424 -- If in wrapper package skip past it
1426 elsif Present
(Scop
) and then Is_Wrapper_Package
(Scop
) then
1427 Append_Entity_Name
(Temp
, Scope
(Scop
));
1430 -- Otherwise nothing to output (happens in unnamed block statements)
1439 E_Name
: Bounded_String
;
1442 Append_Unqualified_Decoded
(E_Name
, Chars
(E
));
1444 -- Remove trailing upper-case letters from the name (useful for
1445 -- dealing with some cases of internal names generated in the case
1446 -- of references from within a generic).
1448 while E_Name
.Length
> 1
1449 and then E_Name
.Chars
(E_Name
.Length
) in 'A' .. 'Z'
1451 E_Name
.Length
:= E_Name
.Length
- 1;
1454 -- Adjust casing appropriately (gets name from source if possible)
1456 Adjust_Name_Case
(E_Name
, Sloc
(E
));
1457 Append
(Temp
, E_Name
);
1461 -- Start of processing for Append_Entity_Name
1466 end Append_Entity_Name
;
1468 ---------------------------------
1469 -- Append_Inherited_Subprogram --
1470 ---------------------------------
1472 procedure Append_Inherited_Subprogram
(S
: Entity_Id
) is
1473 Par
: constant Entity_Id
:= Alias
(S
);
1474 -- The parent subprogram
1476 Scop
: constant Entity_Id
:= Scope
(Par
);
1477 -- The scope of definition of the parent subprogram
1479 Typ
: constant Entity_Id
:= Defining_Entity
(Parent
(S
));
1480 -- The derived type of which S is a primitive operation
1486 if Ekind
(Current_Scope
) = E_Package
1487 and then In_Private_Part
(Current_Scope
)
1488 and then Has_Private_Declaration
(Typ
)
1489 and then Is_Tagged_Type
(Typ
)
1490 and then Scop
= Current_Scope
1492 -- The inherited operation is available at the earliest place after
1493 -- the derived type declaration (RM 7.3.1 (6/1)). This is only
1494 -- relevant for type extensions. If the parent operation appears
1495 -- after the type extension, the operation is not visible.
1498 (Visible_Declarations
1499 (Package_Specification
(Current_Scope
)));
1500 while Present
(Decl
) loop
1501 if Nkind
(Decl
) = N_Private_Extension_Declaration
1502 and then Defining_Entity
(Decl
) = Typ
1504 if Sloc
(Decl
) > Sloc
(Par
) then
1505 Next_E
:= Next_Entity
(Par
);
1506 Link_Entities
(Par
, S
);
1507 Link_Entities
(S
, Next_E
);
1519 -- If partial view is not a type extension, or it appears before the
1520 -- subprogram declaration, insert normally at end of entity list.
1522 Append_Entity
(S
, Current_Scope
);
1523 end Append_Inherited_Subprogram
;
1525 -----------------------------------------
1526 -- Apply_Compile_Time_Constraint_Error --
1527 -----------------------------------------
1529 procedure Apply_Compile_Time_Constraint_Error
1532 Reason
: RT_Exception_Code
;
1533 Ent
: Entity_Id
:= Empty
;
1534 Typ
: Entity_Id
:= Empty
;
1535 Loc
: Source_Ptr
:= No_Location
;
1536 Warn
: Boolean := False;
1537 Emit_Message
: Boolean := True)
1539 Stat
: constant Boolean := Is_Static_Expression
(N
);
1540 R_Stat
: constant Node_Id
:=
1541 Make_Raise_Constraint_Error
(Sloc
(N
), Reason
=> Reason
);
1551 if Emit_Message
then
1553 (Compile_Time_Constraint_Error
(N
, Msg
, Ent
, Loc
, Warn
=> Warn
));
1556 -- Now we replace the node by an N_Raise_Constraint_Error node
1557 -- This does not need reanalyzing, so set it as analyzed now.
1559 Rewrite
(N
, R_Stat
);
1560 Set_Analyzed
(N
, True);
1562 Set_Etype
(N
, Rtyp
);
1563 Set_Raises_Constraint_Error
(N
);
1565 -- Now deal with possible local raise handling
1567 Possible_Local_Raise
(N
, Standard_Constraint_Error
);
1569 -- If the original expression was marked as static, the result is
1570 -- still marked as static, but the Raises_Constraint_Error flag is
1571 -- always set so that further static evaluation is not attempted.
1574 Set_Is_Static_Expression
(N
);
1576 end Apply_Compile_Time_Constraint_Error
;
1578 ---------------------------
1579 -- Async_Readers_Enabled --
1580 ---------------------------
1582 function Async_Readers_Enabled
(Id
: Entity_Id
) return Boolean is
1584 return Has_Enabled_Property
(Id
, Name_Async_Readers
);
1585 end Async_Readers_Enabled
;
1587 ---------------------------
1588 -- Async_Writers_Enabled --
1589 ---------------------------
1591 function Async_Writers_Enabled
(Id
: Entity_Id
) return Boolean is
1593 return Has_Enabled_Property
(Id
, Name_Async_Writers
);
1594 end Async_Writers_Enabled
;
1596 --------------------------------------
1597 -- Available_Full_View_Of_Component --
1598 --------------------------------------
1600 function Available_Full_View_Of_Component
(T
: Entity_Id
) return Boolean is
1601 ST
: constant Entity_Id
:= Scope
(T
);
1602 SCT
: constant Entity_Id
:= Scope
(Component_Type
(T
));
1604 return In_Open_Scopes
(ST
)
1605 and then In_Open_Scopes
(SCT
)
1606 and then Scope_Depth
(ST
) >= Scope_Depth
(SCT
);
1607 end Available_Full_View_Of_Component
;
1613 procedure Bad_Aspect
1616 Warn
: Boolean := False)
1619 Error_Msg_Warn
:= Warn
;
1620 Error_Msg_N
("<<& is not a valid aspect identifier", N
);
1622 -- Check bad spelling
1623 Error_Msg_Name_1
:= Aspect_Spell_Check
(Nam
);
1624 if Error_Msg_Name_1
/= No_Name
then
1625 Error_Msg_N
-- CODEFIX
1626 ("\<<possible misspelling of %", N
);
1634 procedure Bad_Attribute
1637 Warn
: Boolean := False)
1640 Error_Msg_Warn
:= Warn
;
1641 Error_Msg_N
("<<unrecognized attribute&", N
);
1643 -- Check for possible misspelling
1645 Error_Msg_Name_1
:= Attribute_Spell_Check
(Nam
);
1646 if Error_Msg_Name_1
/= No_Name
then
1647 Error_Msg_N
-- CODEFIX
1648 ("\<<possible misspelling of %", N
);
1652 --------------------------------
1653 -- Bad_Predicated_Subtype_Use --
1654 --------------------------------
1656 procedure Bad_Predicated_Subtype_Use
1660 Suggest_Static
: Boolean := False)
1665 -- Avoid cascaded errors
1667 if Error_Posted
(N
) then
1671 if Inside_A_Generic
then
1672 Gen
:= Current_Scope
;
1673 while Present
(Gen
) and then Ekind
(Gen
) /= E_Generic_Package
loop
1681 if Is_Generic_Formal
(Typ
) and then Is_Discrete_Type
(Typ
) then
1682 Set_No_Predicate_On_Actual
(Typ
);
1685 elsif Has_Predicates
(Typ
) then
1686 if Is_Generic_Actual_Type
(Typ
) then
1688 -- The restriction on loop parameters is only that the type
1689 -- should have no dynamic predicates.
1691 if Nkind
(Parent
(N
)) = N_Loop_Parameter_Specification
1692 and then not Has_Dynamic_Predicate_Aspect
(Typ
)
1693 and then Is_OK_Static_Subtype
(Typ
)
1698 Gen
:= Current_Scope
;
1699 while not Is_Generic_Instance
(Gen
) loop
1703 pragma Assert
(Present
(Gen
));
1705 if Ekind
(Gen
) = E_Package
and then In_Package_Body
(Gen
) then
1706 Error_Msg_Warn
:= SPARK_Mode
/= On
;
1707 Error_Msg_FE
(Msg
& "<<", N
, Typ
);
1708 Error_Msg_F
("\Program_Error [<<", N
);
1711 Make_Raise_Program_Error
(Sloc
(N
),
1712 Reason
=> PE_Bad_Predicated_Generic_Type
));
1715 Error_Msg_FE
(Msg
, N
, Typ
);
1719 Error_Msg_FE
(Msg
, N
, Typ
);
1722 -- Suggest to use First_Valid/Last_Valid instead of First/Last/Range
1723 -- if the predicate is static.
1725 if not Has_Dynamic_Predicate_Aspect
(Typ
)
1726 and then Has_Static_Predicate
(Typ
)
1727 and then Nkind
(N
) = N_Attribute_Reference
1730 Aname
: constant Name_Id
:= Attribute_Name
(N
);
1731 Attr_Id
: constant Attribute_Id
:= Get_Attribute_Id
(Aname
);
1734 when Attribute_First
=>
1735 Error_Msg_F
("\use attribute First_Valid instead", N
);
1736 when Attribute_Last
=>
1737 Error_Msg_F
("\use attribute Last_Valid instead", N
);
1738 when Attribute_Range
=>
1739 Error_Msg_F
("\use attributes First_Valid and "
1740 & "Last_Valid instead", N
);
1747 -- Emit an optional suggestion on how to remedy the error if the
1748 -- context warrants it.
1750 if Suggest_Static
and then Has_Static_Predicate
(Typ
) then
1751 Error_Msg_FE
("\predicate of & should be marked static", N
, Typ
);
1754 end Bad_Predicated_Subtype_Use
;
1756 -----------------------------------------
1757 -- Bad_Unordered_Enumeration_Reference --
1758 -----------------------------------------
1760 function Bad_Unordered_Enumeration_Reference
1762 T
: Entity_Id
) return Boolean
1765 return Is_Enumeration_Type
(T
)
1766 and then Warn_On_Unordered_Enumeration_Type
1767 and then not Is_Generic_Type
(T
)
1768 and then Comes_From_Source
(N
)
1769 and then not Has_Pragma_Ordered
(T
)
1770 and then not In_Same_Extended_Unit
(N
, T
);
1771 end Bad_Unordered_Enumeration_Reference
;
1773 ----------------------------
1774 -- Begin_Keyword_Location --
1775 ----------------------------
1777 function Begin_Keyword_Location
(N
: Node_Id
) return Source_Ptr
is
1789 HSS
:= Handled_Statement_Sequence
(N
);
1791 -- When the handled sequence of statements comes from source, the
1792 -- location of the "begin" keyword is that of the sequence itself.
1793 -- Note that an internal construct may inherit a source sequence.
1795 if Comes_From_Source
(HSS
) then
1798 -- The parser generates an internal handled sequence of statements to
1799 -- capture the location of the "begin" keyword if present in the source.
1800 -- Since there are no source statements, the location of the "begin"
1801 -- keyword is effectively that of the "end" keyword.
1803 elsif Comes_From_Source
(N
) then
1806 -- Otherwise the construct is internal and should carry the location of
1807 -- the original construct which prompted its creation.
1812 end Begin_Keyword_Location
;
1814 --------------------------
1815 -- Build_Actual_Subtype --
1816 --------------------------
1818 function Build_Actual_Subtype
1820 N
: Node_Or_Entity_Id
) return Node_Id
1823 -- Normally Sloc (N), but may point to corresponding body in some cases
1825 Constraints
: List_Id
;
1831 Disc_Type
: Entity_Id
;
1838 if Nkind
(N
) = N_Defining_Identifier
then
1839 Obj
:= New_Occurrence_Of
(N
, Loc
);
1841 -- If this is a formal parameter of a subprogram declaration, and
1842 -- we are compiling the body, we want the declaration for the
1843 -- actual subtype to carry the source position of the body, to
1844 -- prevent anomalies in gdb when stepping through the code.
1846 if Is_Formal
(N
) then
1848 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Scope
(N
));
1850 if Nkind
(Decl
) = N_Subprogram_Declaration
1851 and then Present
(Corresponding_Body
(Decl
))
1853 Loc
:= Sloc
(Corresponding_Body
(Decl
));
1862 if Is_Array_Type
(T
) then
1863 Constraints
:= New_List
;
1864 Index
:= First_Index
(T
);
1866 for J
in 1 .. Number_Dimensions
(T
) loop
1868 -- Build an array subtype declaration with the nominal subtype and
1869 -- the bounds of the actual. Add the declaration in front of the
1870 -- local declarations for the subprogram, for analysis before any
1871 -- reference to the formal in the body.
1873 -- If this is for an index with a fixed lower bound, then use
1874 -- the fixed lower bound as the lower bound of the actual
1875 -- subtype's corresponding index.
1877 if not Is_Constrained
(T
)
1878 and then Is_Fixed_Lower_Bound_Index_Subtype
(Etype
(Index
))
1880 Lo
:= New_Copy_Tree
(Type_Low_Bound
(Etype
(Index
)));
1884 Make_Attribute_Reference
(Loc
,
1886 Duplicate_Subexpr_No_Checks
(Obj
, Name_Req
=> True),
1887 Attribute_Name
=> Name_First
,
1888 Expressions
=> New_List
(
1889 Make_Integer_Literal
(Loc
, J
)));
1893 Make_Attribute_Reference
(Loc
,
1895 Duplicate_Subexpr_No_Checks
(Obj
, Name_Req
=> True),
1896 Attribute_Name
=> Name_Last
,
1897 Expressions
=> New_List
(
1898 Make_Integer_Literal
(Loc
, J
)));
1900 Append
(Make_Range
(Loc
, Lo
, Hi
), Constraints
);
1905 -- If the type has unknown discriminants there is no constrained
1906 -- subtype to build. This is never called for a formal or for a
1907 -- lhs, so returning the type is ok ???
1909 elsif Has_Unknown_Discriminants
(T
) then
1913 Constraints
:= New_List
;
1915 -- Type T is a generic derived type, inherit the discriminants from
1918 if Is_Private_Type
(T
)
1919 and then No
(Full_View
(T
))
1921 -- T was flagged as an error if it was declared as a formal
1922 -- derived type with known discriminants. In this case there
1923 -- is no need to look at the parent type since T already carries
1924 -- its own discriminants.
1926 and then not Error_Posted
(T
)
1928 Disc_Type
:= Etype
(Base_Type
(T
));
1933 Discr
:= First_Discriminant
(Disc_Type
);
1934 while Present
(Discr
) loop
1935 Append_To
(Constraints
,
1936 Make_Selected_Component
(Loc
,
1938 Duplicate_Subexpr_No_Checks
(Obj
),
1939 Selector_Name
=> New_Occurrence_Of
(Discr
, Loc
)));
1940 Next_Discriminant
(Discr
);
1944 Subt
:= Make_Temporary
(Loc
, 'S', Related_Node
=> N
);
1945 Set_Is_Internal
(Subt
);
1948 Make_Subtype_Declaration
(Loc
,
1949 Defining_Identifier
=> Subt
,
1950 Subtype_Indication
=>
1951 Make_Subtype_Indication
(Loc
,
1952 Subtype_Mark
=> New_Occurrence_Of
(T
, Loc
),
1954 Make_Index_Or_Discriminant_Constraint
(Loc
,
1955 Constraints
=> Constraints
)));
1957 Mark_Rewrite_Insertion
(Decl
);
1959 end Build_Actual_Subtype
;
1961 ---------------------------------------
1962 -- Build_Actual_Subtype_Of_Component --
1963 ---------------------------------------
1965 function Build_Actual_Subtype_Of_Component
1967 N
: Node_Id
) return Node_Id
1969 Loc
: constant Source_Ptr
:= Sloc
(N
);
1970 P
: constant Node_Id
:= Prefix
(N
);
1974 Index_Typ
: Entity_Id
;
1975 Sel
: Entity_Id
:= Empty
;
1977 Desig_Typ
: Entity_Id
;
1978 -- This is either a copy of T, or if T is an access type, then it is
1979 -- the directly designated type of this access type.
1981 function Build_Access_Record_Constraint
(C
: List_Id
) return List_Id
;
1982 -- If the record component is a constrained access to the current
1983 -- record, the subtype has not been constructed during analysis of
1984 -- the enclosing record type (see Analyze_Access). In that case, build
1985 -- a constrained access subtype after replacing references to the
1986 -- enclosing discriminants with the corresponding discriminant values
1989 function Build_Actual_Array_Constraint
return List_Id
;
1990 -- If one or more of the bounds of the component depends on
1991 -- discriminants, build actual constraint using the discriminants
1992 -- of the prefix, as above.
1994 function Build_Actual_Record_Constraint
return List_Id
;
1995 -- Similar to previous one, for discriminated components constrained
1996 -- by the discriminant of the enclosing object.
1998 function Build_Discriminant_Reference
1999 (Discrim_Name
: Node_Id
; Obj
: Node_Id
:= P
) return Node_Id
;
2000 -- Build a reference to the discriminant denoted by Discrim_Name.
2001 -- The prefix of the result is usually Obj, but it could be
2002 -- a prefix of Obj in some corner cases.
2004 function Copy_And_Maybe_Dereference
(N
: Node_Id
) return Node_Id
;
2005 -- Copy the subtree rooted at N and insert an explicit dereference if it
2006 -- is of an access type.
2008 -----------------------------------
2009 -- Build_Actual_Array_Constraint --
2010 -----------------------------------
2012 function Build_Actual_Array_Constraint
return List_Id
is
2013 Constraints
: constant List_Id
:= New_List
;
2021 Indx
:= First_Index
(Desig_Typ
);
2022 while Present
(Indx
) loop
2023 Old_Lo
:= Type_Low_Bound
(Etype
(Indx
));
2024 Old_Hi
:= Type_High_Bound
(Etype
(Indx
));
2026 if Denotes_Discriminant
(Old_Lo
) then
2027 Lo
:= Build_Discriminant_Reference
(Old_Lo
);
2029 Lo
:= New_Copy_Tree
(Old_Lo
);
2031 -- The new bound will be reanalyzed in the enclosing
2032 -- declaration. For literal bounds that come from a type
2033 -- declaration, the type of the context must be imposed, so
2034 -- insure that analysis will take place. For non-universal
2035 -- types this is not strictly necessary.
2037 Set_Analyzed
(Lo
, False);
2040 if Denotes_Discriminant
(Old_Hi
) then
2041 Hi
:= Build_Discriminant_Reference
(Old_Hi
);
2043 Hi
:= New_Copy_Tree
(Old_Hi
);
2044 Set_Analyzed
(Hi
, False);
2047 Append
(Make_Range
(Loc
, Lo
, Hi
), Constraints
);
2052 end Build_Actual_Array_Constraint
;
2054 ------------------------------------
2055 -- Build_Actual_Record_Constraint --
2056 ------------------------------------
2058 function Build_Actual_Record_Constraint
return List_Id
is
2059 Constraints
: constant List_Id
:= New_List
;
2064 D
:= First_Elmt
(Discriminant_Constraint
(Desig_Typ
));
2065 while Present
(D
) loop
2066 if Denotes_Discriminant
(Node
(D
)) then
2067 D_Val
:= Build_Discriminant_Reference
(Node
(D
));
2069 D_Val
:= New_Copy_Tree
(Node
(D
));
2072 Append
(D_Val
, Constraints
);
2077 end Build_Actual_Record_Constraint
;
2079 ----------------------------------
2080 -- Build_Discriminant_Reference --
2081 ----------------------------------
2083 function Build_Discriminant_Reference
2084 (Discrim_Name
: Node_Id
; Obj
: Node_Id
:= P
) return Node_Id
2086 Discrim
: constant Entity_Id
:= Entity
(Discrim_Name
);
2088 function Obj_Is_Good_Prefix
return Boolean;
2089 -- Returns True if Obj.Discrim makes sense; that is, if
2090 -- Obj has Discrim as one of its discriminants (or is an
2091 -- access value that designates such an object).
2093 ------------------------
2094 -- Obj_Is_Good_Prefix --
2095 ------------------------
2097 function Obj_Is_Good_Prefix
return Boolean is
2098 Obj_Type
: Entity_Id
:=
2099 Implementation_Base_Type
(Etype
(Obj
));
2101 Discriminated_Type
: constant Entity_Id
:=
2102 Implementation_Base_Type
2103 (Scope
(Original_Record_Component
(Discrim
)));
2105 -- The order of the following two tests matters in the
2106 -- access-to-class-wide case.
2108 if Is_Access_Type
(Obj_Type
) then
2109 Obj_Type
:= Implementation_Base_Type
2110 (Designated_Type
(Obj_Type
));
2113 if Is_Class_Wide_Type
(Obj_Type
) then
2114 Obj_Type
:= Implementation_Base_Type
2115 (Find_Specific_Type
(Obj_Type
));
2118 -- If a type T1 defines a discriminant D1, then Obj.D1 is ok (for
2119 -- our purposes here) if T1 is an ancestor of the type of Obj.
2120 -- So that's what we would like to test for here.
2121 -- The bad news: Is_Ancestor is only defined in the tagged case.
2122 -- The good news: in the untagged case, Implementation_Base_Type
2123 -- looks through derived types so we can use a simpler test.
2125 if Is_Tagged_Type
(Discriminated_Type
) then
2126 return Is_Ancestor
(Discriminated_Type
, Obj_Type
);
2128 return Discriminated_Type
= Obj_Type
;
2130 end Obj_Is_Good_Prefix
;
2132 -- Start of processing for Build_Discriminant_Reference
2135 if not Obj_Is_Good_Prefix
then
2136 -- If the given discriminant is not a component of the given
2137 -- object, then try the enclosing object.
2139 if Nkind
(Obj
) = N_Selected_Component
then
2140 return Build_Discriminant_Reference
2141 (Discrim_Name
=> Discrim_Name
,
2142 Obj
=> Prefix
(Obj
));
2143 elsif Nkind
(Obj
) in N_Has_Entity
2144 and then Nkind
(Parent
(Entity
(Obj
))) =
2145 N_Object_Renaming_Declaration
2147 -- Look through a renaming (a corner case of a corner case).
2148 return Build_Discriminant_Reference
2149 (Discrim_Name
=> Discrim_Name
,
2150 Obj
=> Name
(Parent
(Entity
(Obj
))));
2152 -- We are in some unexpected case here, so revert to the
2153 -- old behavior (by falling through to it).
2158 return Make_Selected_Component
(Loc
,
2159 Prefix
=> Copy_And_Maybe_Dereference
(Obj
),
2160 Selector_Name
=> New_Occurrence_Of
(Discrim
, Loc
));
2161 end Build_Discriminant_Reference
;
2163 ------------------------------------
2164 -- Build_Access_Record_Constraint --
2165 ------------------------------------
2167 function Build_Access_Record_Constraint
(C
: List_Id
) return List_Id
is
2168 Constraints
: constant List_Id
:= New_List
;
2173 -- Retrieve the constraint from the component declaration, because
2174 -- the component subtype has not been constructed and the component
2175 -- type is an unconstrained access.
2178 while Present
(D
) loop
2179 if Nkind
(D
) = N_Discriminant_Association
2180 and then Denotes_Discriminant
(Expression
(D
))
2182 D_Val
:= New_Copy_Tree
(D
);
2183 Set_Expression
(D_Val
,
2184 Make_Selected_Component
(Loc
,
2185 Prefix
=> Copy_And_Maybe_Dereference
(P
),
2187 New_Occurrence_Of
(Entity
(Expression
(D
)), Loc
)));
2189 elsif Denotes_Discriminant
(D
) then
2190 D_Val
:= Make_Selected_Component
(Loc
,
2191 Prefix
=> Copy_And_Maybe_Dereference
(P
),
2192 Selector_Name
=> New_Occurrence_Of
(Entity
(D
), Loc
));
2195 D_Val
:= New_Copy_Tree
(D
);
2198 Append
(D_Val
, Constraints
);
2203 end Build_Access_Record_Constraint
;
2205 --------------------------------
2206 -- Copy_And_Maybe_Dereference --
2207 --------------------------------
2209 function Copy_And_Maybe_Dereference
(N
: Node_Id
) return Node_Id
is
2210 New_N
: constant Node_Id
:= New_Copy_Tree
(N
);
2213 if Is_Access_Type
(Etype
(N
)) then
2214 return Make_Explicit_Dereference
(Sloc
(Parent
(N
)), New_N
);
2219 end Copy_And_Maybe_Dereference
;
2221 -- Start of processing for Build_Actual_Subtype_Of_Component
2224 -- The subtype does not need to be created for a selected component
2225 -- in a Spec_Expression.
2227 if In_Spec_Expression
then
2230 -- More comments for the rest of this body would be good ???
2232 elsif Nkind
(N
) = N_Explicit_Dereference
then
2233 if Is_Composite_Type
(T
)
2234 and then not Is_Constrained
(T
)
2235 and then not (Is_Class_Wide_Type
(T
)
2236 and then Is_Constrained
(Root_Type
(T
)))
2237 and then not Has_Unknown_Discriminants
(T
)
2239 -- If the type of the dereference is already constrained, it is an
2242 if Is_Array_Type
(Etype
(N
))
2243 and then Is_Constrained
(Etype
(N
))
2247 Remove_Side_Effects
(P
);
2248 return Build_Actual_Subtype
(T
, N
);
2255 elsif Nkind
(N
) = N_Selected_Component
then
2256 -- The entity of the selected component allows us to retrieve
2257 -- the original constraint from its component declaration.
2259 Sel
:= Entity
(Selector_Name
(N
));
2260 if Parent_Kind
(Sel
) /= N_Component_Declaration
then
2265 if Is_Access_Type
(T
) then
2266 Desig_Typ
:= Designated_Type
(T
);
2272 if Ekind
(Desig_Typ
) = E_Array_Subtype
then
2273 Id
:= First_Index
(Desig_Typ
);
2275 -- Check whether an index bound is constrained by a discriminant
2277 while Present
(Id
) loop
2278 Index_Typ
:= Underlying_Type
(Etype
(Id
));
2280 if Denotes_Discriminant
(Type_Low_Bound
(Index_Typ
))
2282 Denotes_Discriminant
(Type_High_Bound
(Index_Typ
))
2284 Remove_Side_Effects
(P
);
2286 Build_Component_Subtype
2287 (Build_Actual_Array_Constraint
, Loc
, Base_Type
(T
));
2293 elsif Is_Composite_Type
(Desig_Typ
)
2294 and then Has_Discriminants
(Desig_Typ
)
2295 and then not Is_Empty_Elmt_List
(Discriminant_Constraint
(Desig_Typ
))
2296 and then not Has_Unknown_Discriminants
(Desig_Typ
)
2298 if Is_Private_Type
(Desig_Typ
)
2299 and then No
(Discriminant_Constraint
(Desig_Typ
))
2301 Desig_Typ
:= Full_View
(Desig_Typ
);
2304 D
:= First_Elmt
(Discriminant_Constraint
(Desig_Typ
));
2305 while Present
(D
) loop
2306 if Denotes_Discriminant
(Node
(D
)) then
2307 Remove_Side_Effects
(P
);
2309 Build_Component_Subtype
(
2310 Build_Actual_Record_Constraint
, Loc
, Base_Type
(T
));
2316 -- Special processing for an access record component that is
2317 -- the target of an assignment. If the designated type is an
2318 -- unconstrained discriminated record we create its actual
2321 elsif Ekind
(T
) = E_Access_Type
2322 and then Present
(Sel
)
2323 and then Has_Per_Object_Constraint
(Sel
)
2324 and then Nkind
(Parent
(N
)) = N_Assignment_Statement
2325 and then N
= Name
(Parent
(N
))
2326 -- and then not Inside_Init_Proc
2327 -- and then Has_Discriminants (Desig_Typ)
2328 -- and then not Is_Constrained (Desig_Typ)
2331 S_Indic
: constant Node_Id
:=
2333 (Component_Definition
(Parent
(Sel
))));
2336 if Nkind
(S_Indic
) = N_Subtype_Indication
then
2337 Discs
:= Constraints
(Constraint
(S_Indic
));
2339 Remove_Side_Effects
(P
);
2340 return Build_Component_Subtype
2341 (Build_Access_Record_Constraint
(Discs
), Loc
, T
);
2348 -- If none of the above, the actual and nominal subtypes are the same
2351 end Build_Actual_Subtype_Of_Component
;
2353 -----------------------------
2354 -- Build_Component_Subtype --
2355 -----------------------------
2357 function Build_Component_Subtype
2360 T
: Entity_Id
) return Node_Id
2366 -- Unchecked_Union components do not require component subtypes
2368 if Is_Unchecked_Union
(T
) then
2372 Subt
:= Make_Temporary
(Loc
, 'S');
2373 Set_Is_Internal
(Subt
);
2376 Make_Subtype_Declaration
(Loc
,
2377 Defining_Identifier
=> Subt
,
2378 Subtype_Indication
=>
2379 Make_Subtype_Indication
(Loc
,
2380 Subtype_Mark
=> New_Occurrence_Of
(Base_Type
(T
), Loc
),
2382 Make_Index_Or_Discriminant_Constraint
(Loc
,
2383 Constraints
=> C
)));
2385 Mark_Rewrite_Insertion
(Decl
);
2387 end Build_Component_Subtype
;
2389 -----------------------------
2390 -- Build_Constrained_Itype --
2391 -----------------------------
2393 procedure Build_Constrained_Itype
2396 New_Assoc_List
: List_Id
)
2398 Constrs
: constant List_Id
:= New_List
;
2399 Loc
: constant Source_Ptr
:= Sloc
(N
);
2402 New_Assoc
: Node_Id
;
2403 Subtyp_Decl
: Node_Id
;
2406 New_Assoc
:= First
(New_Assoc_List
);
2407 while Present
(New_Assoc
) loop
2409 -- There is exactly one choice in the component association (and
2410 -- it is either a discriminant, a component or the others clause).
2411 pragma Assert
(List_Length
(Choices
(New_Assoc
)) = 1);
2413 -- Duplicate expression for the discriminant and put it on the
2414 -- list of constraints for the itype declaration.
2416 if Is_Entity_Name
(First
(Choices
(New_Assoc
)))
2418 Ekind
(Entity
(First
(Choices
(New_Assoc
)))) = E_Discriminant
2420 Append_To
(Constrs
, Duplicate_Subexpr
(Expression
(New_Assoc
)));
2426 if Has_Unknown_Discriminants
(Typ
)
2427 and then Present
(Underlying_Record_View
(Typ
))
2430 Make_Subtype_Indication
(Loc
,
2432 New_Occurrence_Of
(Underlying_Record_View
(Typ
), Loc
),
2434 Make_Index_Or_Discriminant_Constraint
(Loc
,
2435 Constraints
=> Constrs
));
2438 Make_Subtype_Indication
(Loc
,
2440 New_Occurrence_Of
(Base_Type
(Typ
), Loc
),
2442 Make_Index_Or_Discriminant_Constraint
(Loc
,
2443 Constraints
=> Constrs
));
2446 Def_Id
:= Create_Itype
(Ekind
(Typ
), N
);
2449 Make_Subtype_Declaration
(Loc
,
2450 Defining_Identifier
=> Def_Id
,
2451 Subtype_Indication
=> Indic
);
2452 Set_Parent
(Subtyp_Decl
, Parent
(N
));
2454 -- Itypes must be analyzed with checks off (see itypes.ads)
2456 Analyze
(Subtyp_Decl
, Suppress
=> All_Checks
);
2458 Set_Etype
(N
, Def_Id
);
2459 end Build_Constrained_Itype
;
2461 ---------------------------
2462 -- Build_Default_Subtype --
2463 ---------------------------
2465 function Build_Default_Subtype
2467 N
: Node_Id
) return Entity_Id
2469 Loc
: constant Source_Ptr
:= Sloc
(N
);
2473 -- The base type that is to be constrained by the defaults
2476 if not Has_Discriminants
(T
) or else Is_Constrained
(T
) then
2480 Bas
:= Base_Type
(T
);
2482 -- If T is non-private but its base type is private, this is the
2483 -- completion of a subtype declaration whose parent type is private
2484 -- (see Complete_Private_Subtype in Sem_Ch3). The proper discriminants
2485 -- are to be found in the full view of the base. Check that the private
2486 -- status of T and its base differ.
2488 if Is_Private_Type
(Bas
)
2489 and then not Is_Private_Type
(T
)
2490 and then Present
(Full_View
(Bas
))
2492 Bas
:= Full_View
(Bas
);
2495 Disc
:= First_Discriminant
(T
);
2497 if No
(Discriminant_Default_Value
(Disc
)) then
2502 Act
: constant Entity_Id
:= Make_Temporary
(Loc
, 'S');
2503 Constraints
: constant List_Id
:= New_List
;
2507 while Present
(Disc
) loop
2508 Append_To
(Constraints
,
2509 New_Copy_Tree
(Discriminant_Default_Value
(Disc
)));
2510 Next_Discriminant
(Disc
);
2514 Make_Subtype_Declaration
(Loc
,
2515 Defining_Identifier
=> Act
,
2516 Subtype_Indication
=>
2517 Make_Subtype_Indication
(Loc
,
2518 Subtype_Mark
=> New_Occurrence_Of
(Bas
, Loc
),
2520 Make_Index_Or_Discriminant_Constraint
(Loc
,
2521 Constraints
=> Constraints
)));
2523 Insert_Action
(N
, Decl
);
2525 -- If the context is a component declaration the subtype declaration
2526 -- will be analyzed when the enclosing type is frozen, otherwise do
2529 if Ekind
(Current_Scope
) /= E_Record_Type
then
2535 end Build_Default_Subtype
;
2537 ------------------------------
2538 -- Build_Default_Subtype_OK --
2539 ------------------------------
2541 function Build_Default_Subtype_OK
(T
: Entity_Id
) return Boolean is
2543 function Default_Discriminant_Values_Known_At_Compile_Time
2544 (T
: Entity_Id
) return Boolean;
2545 -- For an unconstrained type T, return False if the given type has a
2546 -- discriminant with default value not known at compile time. Return
2549 ---------------------------------------------------------
2550 -- Default_Discriminant_Values_Known_At_Compile_Time --
2551 ---------------------------------------------------------
2553 function Default_Discriminant_Values_Known_At_Compile_Time
2554 (T
: Entity_Id
) return Boolean
2561 -- If the type has no discriminant, we know them all at compile time
2563 if not Has_Discriminants
(T
) then
2567 -- The type has discriminants, check that none of them has a default
2568 -- value not known at compile time.
2570 Discr
:= First_Discriminant
(T
);
2572 while Present
(Discr
) loop
2573 DDV
:= Discriminant_Default_Value
(Discr
);
2575 if Present
(DDV
) and then not Compile_Time_Known_Value
(DDV
) then
2579 Next_Discriminant
(Discr
);
2583 end Default_Discriminant_Values_Known_At_Compile_Time
;
2585 -- Start of processing for Build_Default_Subtype_OK
2589 if Is_Constrained
(T
) then
2591 -- We won't build a new subtype if T is constrained
2596 if not Default_Discriminant_Values_Known_At_Compile_Time
(T
) then
2598 -- This is a special case of definite subtypes. To allocate a
2599 -- specific size to the subtype, we need to know the value at compile
2600 -- time. This might not be the case if the default value is the
2601 -- result of a function. In that case, the object might be definite
2602 -- and limited but the needed size might not be statically known or
2603 -- too tricky to obtain. In that case, we will not build the subtype.
2608 return Is_Definite_Subtype
(T
) and then Is_Limited_View
(T
);
2609 end Build_Default_Subtype_OK
;
2611 --------------------------------------------
2612 -- Build_Discriminal_Subtype_Of_Component --
2613 --------------------------------------------
2615 function Build_Discriminal_Subtype_Of_Component
2616 (T
: Entity_Id
) return Node_Id
2618 Loc
: constant Source_Ptr
:= Sloc
(T
);
2622 function Build_Discriminal_Array_Constraint
return List_Id
;
2623 -- If one or more of the bounds of the component depends on
2624 -- discriminants, build actual constraint using the discriminants
2627 function Build_Discriminal_Record_Constraint
return List_Id
;
2628 -- Similar to previous one, for discriminated components constrained by
2629 -- the discriminant of the enclosing object.
2631 ----------------------------------------
2632 -- Build_Discriminal_Array_Constraint --
2633 ----------------------------------------
2635 function Build_Discriminal_Array_Constraint
return List_Id
is
2636 Constraints
: constant List_Id
:= New_List
;
2644 Indx
:= First_Index
(T
);
2645 while Present
(Indx
) loop
2646 Old_Lo
:= Type_Low_Bound
(Etype
(Indx
));
2647 Old_Hi
:= Type_High_Bound
(Etype
(Indx
));
2649 if Denotes_Discriminant
(Old_Lo
) then
2650 Lo
:= New_Occurrence_Of
(Discriminal
(Entity
(Old_Lo
)), Loc
);
2653 Lo
:= New_Copy_Tree
(Old_Lo
);
2656 if Denotes_Discriminant
(Old_Hi
) then
2657 Hi
:= New_Occurrence_Of
(Discriminal
(Entity
(Old_Hi
)), Loc
);
2660 Hi
:= New_Copy_Tree
(Old_Hi
);
2663 Append
(Make_Range
(Loc
, Lo
, Hi
), Constraints
);
2668 end Build_Discriminal_Array_Constraint
;
2670 -----------------------------------------
2671 -- Build_Discriminal_Record_Constraint --
2672 -----------------------------------------
2674 function Build_Discriminal_Record_Constraint
return List_Id
is
2675 Constraints
: constant List_Id
:= New_List
;
2680 D
:= First_Elmt
(Discriminant_Constraint
(T
));
2681 while Present
(D
) loop
2682 if Denotes_Discriminant
(Node
(D
)) then
2684 New_Occurrence_Of
(Discriminal
(Entity
(Node
(D
))), Loc
);
2686 D_Val
:= New_Copy_Tree
(Node
(D
));
2689 Append
(D_Val
, Constraints
);
2694 end Build_Discriminal_Record_Constraint
;
2696 -- Start of processing for Build_Discriminal_Subtype_Of_Component
2699 if Ekind
(T
) = E_Array_Subtype
then
2700 Id
:= First_Index
(T
);
2701 while Present
(Id
) loop
2702 if Denotes_Discriminant
(Type_Low_Bound
(Etype
(Id
)))
2704 Denotes_Discriminant
(Type_High_Bound
(Etype
(Id
)))
2706 return Build_Component_Subtype
2707 (Build_Discriminal_Array_Constraint
, Loc
, T
);
2713 elsif Ekind
(T
) = E_Record_Subtype
2714 and then Has_Discriminants
(T
)
2715 and then not Has_Unknown_Discriminants
(T
)
2717 D
:= First_Elmt
(Discriminant_Constraint
(T
));
2718 while Present
(D
) loop
2719 if Denotes_Discriminant
(Node
(D
)) then
2720 return Build_Component_Subtype
2721 (Build_Discriminal_Record_Constraint
, Loc
, T
);
2728 -- If none of the above, the actual and nominal subtypes are the same
2731 end Build_Discriminal_Subtype_Of_Component
;
2733 ------------------------------
2734 -- Build_Elaboration_Entity --
2735 ------------------------------
2737 procedure Build_Elaboration_Entity
(N
: Node_Id
; Spec_Id
: Entity_Id
) is
2738 Loc
: constant Source_Ptr
:= Sloc
(N
);
2740 Elab_Ent
: Entity_Id
;
2742 procedure Set_Package_Name
(Ent
: Entity_Id
);
2743 -- Given an entity, sets the fully qualified name of the entity in
2744 -- Name_Buffer, with components separated by double underscores. This
2745 -- is a recursive routine that climbs the scope chain to Standard.
2747 ----------------------
2748 -- Set_Package_Name --
2749 ----------------------
2751 procedure Set_Package_Name
(Ent
: Entity_Id
) is
2753 if Scope
(Ent
) /= Standard_Standard
then
2754 Set_Package_Name
(Scope
(Ent
));
2757 Nam
: constant String := Get_Name_String
(Chars
(Ent
));
2759 Name_Buffer
(Name_Len
+ 1) := '_';
2760 Name_Buffer
(Name_Len
+ 2) := '_';
2761 Name_Buffer
(Name_Len
+ 3 .. Name_Len
+ Nam
'Length + 2) := Nam
;
2762 Name_Len
:= Name_Len
+ Nam
'Length + 2;
2766 Get_Name_String
(Chars
(Ent
));
2768 end Set_Package_Name
;
2770 -- Start of processing for Build_Elaboration_Entity
2773 -- Ignore call if already constructed
2775 if Present
(Elaboration_Entity
(Spec_Id
)) then
2778 -- Do not generate an elaboration entity in GNATprove move because the
2779 -- elaboration counter is a form of expansion.
2781 elsif GNATprove_Mode
then
2784 -- See if we need elaboration entity
2786 -- We always need an elaboration entity when preserving control flow, as
2787 -- we want to remain explicit about the unit's elaboration order.
2789 elsif Opt
.Suppress_Control_Flow_Optimizations
then
2792 -- We always need an elaboration entity for the dynamic elaboration
2793 -- model, since it is needed to properly generate the PE exception for
2794 -- access before elaboration.
2796 elsif Dynamic_Elaboration_Checks
then
2799 -- For the static model, we don't need the elaboration counter if this
2800 -- unit is sure to have no elaboration code, since that means there
2801 -- is no elaboration unit to be called. Note that we can't just decide
2802 -- after the fact by looking to see whether there was elaboration code,
2803 -- because that's too late to make this decision.
2805 elsif Restriction_Active
(No_Elaboration_Code
) then
2808 -- Similarly, for the static model, we can skip the elaboration counter
2809 -- if we have the No_Multiple_Elaboration restriction, since for the
2810 -- static model, that's the only purpose of the counter (to avoid
2811 -- multiple elaboration).
2813 elsif Restriction_Active
(No_Multiple_Elaboration
) then
2817 -- Here we need the elaboration entity
2819 -- Construct name of elaboration entity as xxx_E, where xxx is the unit
2820 -- name with dots replaced by double underscore. We have to manually
2821 -- construct this name, since it will be elaborated in the outer scope,
2822 -- and thus will not have the unit name automatically prepended.
2824 Set_Package_Name
(Spec_Id
);
2825 Add_Str_To_Name_Buffer
("_E");
2827 -- Create elaboration counter
2829 Elab_Ent
:= Make_Defining_Identifier
(Loc
, Chars
=> Name_Find
);
2830 Set_Elaboration_Entity
(Spec_Id
, Elab_Ent
);
2833 Make_Object_Declaration
(Loc
,
2834 Defining_Identifier
=> Elab_Ent
,
2835 Object_Definition
=>
2836 New_Occurrence_Of
(Standard_Short_Integer
, Loc
),
2837 Expression
=> Make_Integer_Literal
(Loc
, Uint_0
));
2839 Push_Scope
(Standard_Standard
);
2840 Add_Global_Declaration
(Decl
);
2843 -- Reset True_Constant indication, since we will indeed assign a value
2844 -- to the variable in the binder main. We also kill the Current_Value
2845 -- and Last_Assignment fields for the same reason.
2847 Set_Is_True_Constant
(Elab_Ent
, False);
2848 Set_Current_Value
(Elab_Ent
, Empty
);
2849 Set_Last_Assignment
(Elab_Ent
, Empty
);
2851 -- We do not want any further qualification of the name (if we did not
2852 -- do this, we would pick up the name of the generic package in the case
2853 -- of a library level generic instantiation).
2855 Set_Has_Qualified_Name
(Elab_Ent
);
2856 Set_Has_Fully_Qualified_Name
(Elab_Ent
);
2857 end Build_Elaboration_Entity
;
2859 --------------------------------
2860 -- Build_Explicit_Dereference --
2861 --------------------------------
2863 procedure Build_Explicit_Dereference
2867 Loc
: constant Source_Ptr
:= Sloc
(Expr
);
2872 -- An entity of a type with a reference aspect is overloaded with
2873 -- both interpretations: with and without the dereference. Now that
2874 -- the dereference is made explicit, set the type of the node properly,
2875 -- to prevent anomalies in the backend. Same if the expression is an
2876 -- overloaded function call whose return type has a reference aspect.
2878 if Is_Entity_Name
(Expr
) then
2879 Set_Etype
(Expr
, Etype
(Entity
(Expr
)));
2881 -- The designated entity will not be examined again when resolving
2882 -- the dereference, so generate a reference to it now.
2884 Generate_Reference
(Entity
(Expr
), Expr
);
2886 elsif Nkind
(Expr
) = N_Function_Call
then
2888 -- If the name of the indexing function is overloaded, locate the one
2889 -- whose return type has an implicit dereference on the desired
2890 -- discriminant, and set entity and type of function call.
2892 if Is_Overloaded
(Name
(Expr
)) then
2893 Get_First_Interp
(Name
(Expr
), I
, It
);
2895 while Present
(It
.Nam
) loop
2896 if Ekind
((It
.Typ
)) = E_Record_Type
2897 and then First_Entity
((It
.Typ
)) = Disc
2899 Set_Entity
(Name
(Expr
), It
.Nam
);
2900 Set_Etype
(Name
(Expr
), Etype
(It
.Nam
));
2904 Get_Next_Interp
(I
, It
);
2908 -- Set type of call from resolved function name.
2910 Set_Etype
(Expr
, Etype
(Name
(Expr
)));
2913 Set_Is_Overloaded
(Expr
, False);
2915 -- The expression will often be a generalized indexing that yields a
2916 -- container element that is then dereferenced, in which case the
2917 -- generalized indexing call is also non-overloaded.
2919 if Nkind
(Expr
) = N_Indexed_Component
2920 and then Present
(Generalized_Indexing
(Expr
))
2922 Set_Is_Overloaded
(Generalized_Indexing
(Expr
), False);
2926 Make_Explicit_Dereference
(Loc
,
2928 Make_Selected_Component
(Loc
,
2929 Prefix
=> Relocate_Node
(Expr
),
2930 Selector_Name
=> New_Occurrence_Of
(Disc
, Loc
))));
2931 Set_Etype
(Prefix
(Expr
), Etype
(Disc
));
2932 Set_Etype
(Expr
, Designated_Type
(Etype
(Disc
)));
2933 end Build_Explicit_Dereference
;
2935 ---------------------------
2936 -- Build_Overriding_Spec --
2937 ---------------------------
2939 function Build_Overriding_Spec
2941 Typ
: Entity_Id
) return Node_Id
2943 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
2944 Par_Typ
: constant Entity_Id
:= Find_Dispatching_Type
(Op
);
2945 Spec
: constant Node_Id
:= Specification
(Unit_Declaration_Node
(Op
));
2947 Formal_Spec
: Node_Id
;
2948 Formal_Type
: Node_Id
;
2952 New_Spec
:= Copy_Subprogram_Spec
(Spec
);
2954 Formal_Spec
:= First
(Parameter_Specifications
(New_Spec
));
2955 while Present
(Formal_Spec
) loop
2956 Formal_Type
:= Parameter_Type
(Formal_Spec
);
2958 if Is_Entity_Name
(Formal_Type
)
2959 and then Entity
(Formal_Type
) = Par_Typ
2961 Rewrite
(Formal_Type
, New_Occurrence_Of
(Typ
, Loc
));
2964 -- Nothing needs to be done for access parameters
2970 end Build_Overriding_Spec
;
2976 function Build_Subtype
2977 (Related_Node
: Node_Id
;
2980 Constraints
: List_Id
)
2984 Subtyp_Decl
: Node_Id
;
2986 Btyp
: Entity_Id
:= Base_Type
(Typ
);
2989 -- The Related_Node better be here or else we won't be able to
2990 -- attach new itypes to a node in the tree.
2992 pragma Assert
(Present
(Related_Node
));
2994 -- If the view of the component's type is incomplete or private
2995 -- with unknown discriminants, then the constraint must be applied
2996 -- to the full type.
2998 if Has_Unknown_Discriminants
(Btyp
)
2999 and then Present
(Underlying_Type
(Btyp
))
3001 Btyp
:= Underlying_Type
(Btyp
);
3005 Make_Subtype_Indication
(Loc
,
3006 Subtype_Mark
=> New_Occurrence_Of
(Btyp
, Loc
),
3008 Make_Index_Or_Discriminant_Constraint
(Loc
, Constraints
));
3010 Def_Id
:= Create_Itype
(Ekind
(Typ
), Related_Node
);
3013 Make_Subtype_Declaration
(Loc
,
3014 Defining_Identifier
=> Def_Id
,
3015 Subtype_Indication
=> Indic
);
3017 Set_Parent
(Subtyp_Decl
, Parent
(Related_Node
));
3019 -- Itypes must be analyzed with checks off (see package Itypes)
3021 Analyze
(Subtyp_Decl
, Suppress
=> All_Checks
);
3023 if Is_Itype
(Def_Id
) and then Has_Predicates
(Typ
) then
3024 Inherit_Predicate_Flags
(Def_Id
, Typ
);
3026 -- Indicate where the predicate function may be found
3028 if Is_Itype
(Typ
) then
3029 if Present
(Predicate_Function
(Def_Id
)) then
3032 elsif Present
(Predicate_Function
(Typ
)) then
3033 Set_Predicate_Function
(Def_Id
, Predicate_Function
(Typ
));
3036 Set_Predicated_Parent
(Def_Id
, Predicated_Parent
(Typ
));
3039 elsif No
(Predicate_Function
(Def_Id
)) then
3040 Set_Predicated_Parent
(Def_Id
, Typ
);
3047 -----------------------------------
3048 -- Cannot_Raise_Constraint_Error --
3049 -----------------------------------
3051 function Cannot_Raise_Constraint_Error
(Expr
: Node_Id
) return Boolean is
3053 function List_Cannot_Raise_CE
(L
: List_Id
) return Boolean;
3054 -- Returns True if none of the list members cannot possibly raise
3055 -- Constraint_Error.
3057 --------------------------
3058 -- List_Cannot_Raise_CE --
3059 --------------------------
3061 function List_Cannot_Raise_CE
(L
: List_Id
) return Boolean is
3065 while Present
(N
) loop
3066 if Cannot_Raise_Constraint_Error
(N
) then
3074 end List_Cannot_Raise_CE
;
3076 -- Start of processing for Cannot_Raise_Constraint_Error
3079 if Compile_Time_Known_Value
(Expr
) then
3082 elsif Do_Range_Check
(Expr
) then
3085 elsif Raises_Constraint_Error
(Expr
) then
3089 case Nkind
(Expr
) is
3090 when N_Identifier
=>
3093 when N_Expanded_Name
=>
3096 when N_Indexed_Component
=>
3097 return not Do_Range_Check
(Expr
)
3098 and then Cannot_Raise_Constraint_Error
(Prefix
(Expr
))
3099 and then List_Cannot_Raise_CE
(Expressions
(Expr
));
3101 when N_Selected_Component
=>
3102 return not Do_Discriminant_Check
(Expr
)
3103 and then Cannot_Raise_Constraint_Error
(Prefix
(Expr
));
3105 when N_Attribute_Reference
=>
3106 if Do_Overflow_Check
(Expr
) then
3109 elsif No
(Expressions
(Expr
)) then
3113 return List_Cannot_Raise_CE
(Expressions
(Expr
));
3116 when N_Type_Conversion
=>
3117 if Do_Overflow_Check
(Expr
)
3118 or else Do_Length_Check
(Expr
)
3122 return Cannot_Raise_Constraint_Error
(Expression
(Expr
));
3125 when N_Unchecked_Type_Conversion
=>
3126 return Cannot_Raise_Constraint_Error
(Expression
(Expr
));
3129 if Do_Overflow_Check
(Expr
) then
3132 return Cannot_Raise_Constraint_Error
(Right_Opnd
(Expr
));
3139 if Do_Division_Check
(Expr
)
3141 Do_Overflow_Check
(Expr
)
3146 Cannot_Raise_Constraint_Error
(Left_Opnd
(Expr
))
3148 Cannot_Raise_Constraint_Error
(Right_Opnd
(Expr
));
3167 | N_Op_Shift_Right_Arithmetic
3171 if Do_Overflow_Check
(Expr
) then
3175 Cannot_Raise_Constraint_Error
(Left_Opnd
(Expr
))
3177 Cannot_Raise_Constraint_Error
(Right_Opnd
(Expr
));
3184 end Cannot_Raise_Constraint_Error
;
3186 -------------------------------
3187 -- Check_Ambiguous_Aggregate --
3188 -------------------------------
3190 procedure Check_Ambiguous_Aggregate
(Call
: Node_Id
) is
3194 if Extensions_Allowed
then
3195 Actual
:= First_Actual
(Call
);
3196 while Present
(Actual
) loop
3197 if Nkind
(Actual
) = N_Aggregate
then
3199 ("\add type qualification to aggregate actual", Actual
);
3202 Next_Actual
(Actual
);
3205 end Check_Ambiguous_Aggregate
;
3207 -----------------------------------------
3208 -- Check_Dynamically_Tagged_Expression --
3209 -----------------------------------------
3211 procedure Check_Dynamically_Tagged_Expression
3214 Related_Nod
: Node_Id
)
3217 pragma Assert
(Is_Tagged_Type
(Typ
));
3219 -- In order to avoid spurious errors when analyzing the expanded code,
3220 -- this check is done only for nodes that come from source and for
3221 -- actuals of generic instantiations.
3223 if (Comes_From_Source
(Related_Nod
)
3224 or else In_Generic_Actual
(Expr
))
3225 and then (Is_Class_Wide_Type
(Etype
(Expr
))
3226 or else Is_Dynamically_Tagged
(Expr
))
3227 and then not Is_Class_Wide_Type
(Typ
)
3229 Error_Msg_N
("dynamically tagged expression not allowed!", Expr
);
3231 end Check_Dynamically_Tagged_Expression
;
3233 --------------------------
3234 -- Check_Fully_Declared --
3235 --------------------------
3237 procedure Check_Fully_Declared
(T
: Entity_Id
; N
: Node_Id
) is
3239 if Ekind
(T
) = E_Incomplete_Type
then
3241 -- Ada 2005 (AI-50217): If the type is available through a limited
3242 -- with_clause, verify that its full view has been analyzed.
3244 if From_Limited_With
(T
)
3245 and then Present
(Non_Limited_View
(T
))
3246 and then Ekind
(Non_Limited_View
(T
)) /= E_Incomplete_Type
3248 -- The non-limited view is fully declared
3254 ("premature usage of incomplete}", N
, First_Subtype
(T
));
3257 -- Need comments for these tests ???
3259 elsif Has_Private_Component
(T
)
3260 and then not Is_Generic_Type
(Root_Type
(T
))
3261 and then not In_Spec_Expression
3263 -- Special case: if T is the anonymous type created for a single
3264 -- task or protected object, use the name of the source object.
3266 if Is_Concurrent_Type
(T
)
3267 and then not Comes_From_Source
(T
)
3268 and then Nkind
(N
) = N_Object_Declaration
3271 ("type of& has incomplete component",
3272 N
, Defining_Identifier
(N
));
3275 ("premature usage of incomplete}",
3276 N
, First_Subtype
(T
));
3279 end Check_Fully_Declared
;
3281 -------------------------------------------
3282 -- Check_Function_With_Address_Parameter --
3283 -------------------------------------------
3285 procedure Check_Function_With_Address_Parameter
(Subp_Id
: Entity_Id
) is
3290 F
:= First_Formal
(Subp_Id
);
3291 while Present
(F
) loop
3294 if Is_Private_Type
(T
) and then Present
(Full_View
(T
)) then
3298 if Is_Descendant_Of_Address
(T
) or else Is_Limited_Type
(T
) then
3299 Set_Is_Pure
(Subp_Id
, False);
3305 end Check_Function_With_Address_Parameter
;
3307 -------------------------------------
3308 -- Check_Function_Writable_Actuals --
3309 -------------------------------------
3311 procedure Check_Function_Writable_Actuals
(N
: Node_Id
) is
3312 Writable_Actuals_List
: Elist_Id
:= No_Elist
;
3313 Identifiers_List
: Elist_Id
:= No_Elist
;
3314 Aggr_Error_Node
: Node_Id
:= Empty
;
3315 Error_Node
: Node_Id
:= Empty
;
3317 procedure Collect_Identifiers
(N
: Node_Id
);
3318 -- In a single traversal of subtree N collect in Writable_Actuals_List
3319 -- all the actuals of functions with writable actuals, and in the list
3320 -- Identifiers_List collect all the identifiers that are not actuals of
3321 -- functions with writable actuals. If a writable actual is referenced
3322 -- twice as writable actual then Error_Node is set to reference its
3323 -- second occurrence, the error is reported, and the tree traversal
3326 -------------------------
3327 -- Collect_Identifiers --
3328 -------------------------
3330 procedure Collect_Identifiers
(N
: Node_Id
) is
3332 function Check_Node
(N
: Node_Id
) return Traverse_Result
;
3333 -- Process a single node during the tree traversal to collect the
3334 -- writable actuals of functions and all the identifiers which are
3335 -- not writable actuals of functions.
3337 function Contains
(List
: Elist_Id
; N
: Node_Id
) return Boolean;
3338 -- Returns True if List has a node whose Entity is Entity (N)
3344 function Check_Node
(N
: Node_Id
) return Traverse_Result
is
3345 Is_Writable_Actual
: Boolean := False;
3349 if Nkind
(N
) = N_Identifier
then
3351 -- No analysis possible if the entity is not decorated
3353 if No
(Entity
(N
)) then
3356 -- Don't collect identifiers of packages, called functions, etc
3358 elsif Ekind
(Entity
(N
)) in
3359 E_Package | E_Function | E_Procedure | E_Entry
3363 -- For rewritten nodes, continue the traversal in the original
3364 -- subtree. Needed to handle aggregates in original expressions
3365 -- extracted from the tree by Remove_Side_Effects.
3367 elsif Is_Rewrite_Substitution
(N
) then
3368 Collect_Identifiers
(Original_Node
(N
));
3371 -- For now we skip aggregate discriminants, since they require
3372 -- performing the analysis in two phases to identify conflicts:
3373 -- first one analyzing discriminants and second one analyzing
3374 -- the rest of components (since at run time, discriminants are
3375 -- evaluated prior to components): too much computation cost
3376 -- to identify a corner case???
3378 elsif Nkind
(Parent
(N
)) = N_Component_Association
3379 and then Nkind
(Parent
(Parent
(N
))) in
3380 N_Aggregate | N_Extension_Aggregate
3383 Choice
: constant Node_Id
:= First
(Choices
(Parent
(N
)));
3386 if Ekind
(Entity
(N
)) = E_Discriminant
then
3389 elsif Expression
(Parent
(N
)) = N
3390 and then Nkind
(Choice
) = N_Identifier
3391 and then Ekind
(Entity
(Choice
)) = E_Discriminant
3397 -- Analyze if N is a writable actual of a function
3399 elsif Nkind
(Parent
(N
)) = N_Function_Call
then
3401 Call
: constant Node_Id
:= Parent
(N
);
3406 Id
:= Get_Called_Entity
(Call
);
3408 -- In case of previous error, no check is possible
3414 if Ekind
(Id
) in E_Function | E_Generic_Function
3415 and then Has_Out_Or_In_Out_Parameter
(Id
)
3417 Formal
:= First_Formal
(Id
);
3418 Actual
:= First_Actual
(Call
);
3419 while Present
(Actual
) and then Present
(Formal
) loop
3421 if Ekind
(Formal
) in E_Out_Parameter
3422 | E_In_Out_Parameter
3424 Is_Writable_Actual
:= True;
3430 Next_Formal
(Formal
);
3431 Next_Actual
(Actual
);
3437 if Is_Writable_Actual
then
3439 -- Skip checking the error in non-elementary types since
3440 -- RM 6.4.1(6.15/3) is restricted to elementary types, but
3441 -- store this actual in Writable_Actuals_List since it is
3442 -- needed to perform checks on other constructs that have
3443 -- arbitrary order of evaluation (for example, aggregates).
3445 if not Is_Elementary_Type
(Etype
(N
)) then
3446 if not Contains
(Writable_Actuals_List
, N
) then
3447 Append_New_Elmt
(N
, To
=> Writable_Actuals_List
);
3450 -- Second occurrence of an elementary type writable actual
3452 elsif Contains
(Writable_Actuals_List
, N
) then
3454 -- Report the error on the second occurrence of the
3455 -- identifier. We cannot assume that N is the second
3456 -- occurrence (according to their location in the
3457 -- sources), since Traverse_Func walks through Field2
3458 -- last (see comment in the body of Traverse_Func).
3464 Elmt
:= First_Elmt
(Writable_Actuals_List
);
3465 while Present
(Elmt
)
3466 and then Entity
(Node
(Elmt
)) /= Entity
(N
)
3471 if Sloc
(N
) > Sloc
(Node
(Elmt
)) then
3474 Error_Node
:= Node
(Elmt
);
3478 ("value may be affected by call to & "
3479 & "because order of evaluation is arbitrary",
3484 -- First occurrence of a elementary type writable actual
3487 Append_New_Elmt
(N
, To
=> Writable_Actuals_List
);
3491 if No
(Identifiers_List
) then
3492 Identifiers_List
:= New_Elmt_List
;
3495 Append_Unique_Elmt
(N
, Identifiers_List
);
3508 N
: Node_Id
) return Boolean
3510 pragma Assert
(Nkind
(N
) in N_Has_Entity
);
3519 Elmt
:= First_Elmt
(List
);
3520 while Present
(Elmt
) loop
3521 if Entity
(Node
(Elmt
)) = Entity
(N
) then
3535 procedure Do_Traversal
is new Traverse_Proc
(Check_Node
);
3536 -- The traversal procedure
3538 -- Start of processing for Collect_Identifiers
3541 if Present
(Error_Node
) then
3545 if Nkind
(N
) in N_Subexpr
and then Is_OK_Static_Expression
(N
) then
3550 end Collect_Identifiers
;
3552 -- Start of processing for Check_Function_Writable_Actuals
3555 -- The check only applies to Ada 2012 code on which Check_Actuals has
3556 -- been set, and only to constructs that have multiple constituents
3557 -- whose order of evaluation is not specified by the language.
3559 if Ada_Version
< Ada_2012
3560 or else not Check_Actuals
(N
)
3561 or else Nkind
(N
) not in N_Op
3565 | N_Extension_Aggregate
3566 | N_Full_Type_Declaration
3568 | N_Procedure_Call_Statement
3569 | N_Entry_Call_Statement
3570 or else (Nkind
(N
) = N_Full_Type_Declaration
3571 and then not Is_Record_Type
(Defining_Identifier
(N
)))
3573 -- In addition, this check only applies to source code, not to code
3574 -- generated by constraint checks.
3576 or else not Comes_From_Source
(N
)
3581 -- If a construct C has two or more direct constituents that are names
3582 -- or expressions whose evaluation may occur in an arbitrary order, at
3583 -- least one of which contains a function call with an in out or out
3584 -- parameter, then the construct is legal only if: for each name N that
3585 -- is passed as a parameter of mode in out or out to some inner function
3586 -- call C2 (not including the construct C itself), there is no other
3587 -- name anywhere within a direct constituent of the construct C other
3588 -- than the one containing C2, that is known to refer to the same
3589 -- object (RM 6.4.1(6.17/3)).
3593 Collect_Identifiers
(Low_Bound
(N
));
3594 Collect_Identifiers
(High_Bound
(N
));
3596 when N_Membership_Test
3603 Collect_Identifiers
(Left_Opnd
(N
));
3605 if Present
(Right_Opnd
(N
)) then
3606 Collect_Identifiers
(Right_Opnd
(N
));
3609 if Nkind
(N
) in N_In | N_Not_In
3610 and then Present
(Alternatives
(N
))
3612 Expr
:= First
(Alternatives
(N
));
3613 while Present
(Expr
) loop
3614 Collect_Identifiers
(Expr
);
3621 when N_Full_Type_Declaration
=>
3623 function Get_Record_Part
(N
: Node_Id
) return Node_Id
;
3624 -- Return the record part of this record type definition
3626 function Get_Record_Part
(N
: Node_Id
) return Node_Id
is
3627 Type_Def
: constant Node_Id
:= Type_Definition
(N
);
3629 if Nkind
(Type_Def
) = N_Derived_Type_Definition
then
3630 return Record_Extension_Part
(Type_Def
);
3634 end Get_Record_Part
;
3637 Def_Id
: Entity_Id
:= Defining_Identifier
(N
);
3638 Rec
: Node_Id
:= Get_Record_Part
(N
);
3641 -- No need to perform any analysis if the record has no
3644 if No
(Rec
) or else No
(Component_List
(Rec
)) then
3648 -- Collect the identifiers starting from the deepest
3649 -- derivation. Done to report the error in the deepest
3653 if Present
(Component_List
(Rec
)) then
3654 Comp
:= First
(Component_Items
(Component_List
(Rec
)));
3655 while Present
(Comp
) loop
3656 if Nkind
(Comp
) = N_Component_Declaration
3657 and then Present
(Expression
(Comp
))
3659 Collect_Identifiers
(Expression
(Comp
));
3666 exit when No
(Underlying_Type
(Etype
(Def_Id
)))
3667 or else Base_Type
(Underlying_Type
(Etype
(Def_Id
)))
3670 Def_Id
:= Base_Type
(Underlying_Type
(Etype
(Def_Id
)));
3671 Rec
:= Get_Record_Part
(Parent
(Def_Id
));
3675 when N_Entry_Call_Statement
3679 Id
: constant Entity_Id
:= Get_Called_Entity
(N
);
3684 Formal
:= First_Formal
(Id
);
3685 Actual
:= First_Actual
(N
);
3686 while Present
(Actual
) and then Present
(Formal
) loop
3687 if Ekind
(Formal
) in E_Out_Parameter | E_In_Out_Parameter
3689 Collect_Identifiers
(Actual
);
3692 Next_Formal
(Formal
);
3693 Next_Actual
(Actual
);
3698 | N_Extension_Aggregate
3703 Comp_Expr
: Node_Id
;
3706 -- Handle the N_Others_Choice of array aggregates with static
3707 -- bounds. There is no need to perform this analysis in
3708 -- aggregates without static bounds since we cannot evaluate
3709 -- if the N_Others_Choice covers several elements. There is
3710 -- no need to handle the N_Others choice of record aggregates
3711 -- since at this stage it has been already expanded by
3712 -- Resolve_Record_Aggregate.
3714 if Is_Array_Type
(Etype
(N
))
3715 and then Nkind
(N
) = N_Aggregate
3716 and then Present
(Aggregate_Bounds
(N
))
3717 and then Compile_Time_Known_Bounds
(Etype
(N
))
3718 and then Expr_Value
(High_Bound
(Aggregate_Bounds
(N
)))
3720 Expr_Value
(Low_Bound
(Aggregate_Bounds
(N
)))
3723 Count_Components
: Uint
:= Uint_0
;
3724 Num_Components
: Uint
;
3725 Others_Assoc
: Node_Id
:= Empty
;
3726 Others_Choice
: Node_Id
:= Empty
;
3727 Others_Box_Present
: Boolean := False;
3730 -- Count positional associations
3732 if Present
(Expressions
(N
)) then
3733 Comp_Expr
:= First
(Expressions
(N
));
3734 while Present
(Comp_Expr
) loop
3735 Count_Components
:= Count_Components
+ 1;
3740 -- Count the rest of elements and locate the N_Others
3743 Assoc
:= First
(Component_Associations
(N
));
3744 while Present
(Assoc
) loop
3745 Choice
:= First
(Choices
(Assoc
));
3746 while Present
(Choice
) loop
3747 if Nkind
(Choice
) = N_Others_Choice
then
3748 Others_Assoc
:= Assoc
;
3749 Others_Choice
:= Choice
;
3750 Others_Box_Present
:= Box_Present
(Assoc
);
3752 -- Count several components
3754 elsif Nkind
(Choice
) in
3755 N_Range | N_Subtype_Indication
3756 or else (Is_Entity_Name
(Choice
)
3757 and then Is_Type
(Entity
(Choice
)))
3762 Get_Index_Bounds
(Choice
, L
, H
);
3764 (Compile_Time_Known_Value
(L
)
3765 and then Compile_Time_Known_Value
(H
));
3768 + Expr_Value
(H
) - Expr_Value
(L
) + 1;
3771 -- Count single component. No other case available
3772 -- since we are handling an aggregate with static
3776 pragma Assert
(Is_OK_Static_Expression
(Choice
)
3777 or else Nkind
(Choice
) = N_Identifier
3778 or else Nkind
(Choice
) = N_Integer_Literal
);
3780 Count_Components
:= Count_Components
+ 1;
3790 Expr_Value
(High_Bound
(Aggregate_Bounds
(N
))) -
3791 Expr_Value
(Low_Bound
(Aggregate_Bounds
(N
))) + 1;
3793 pragma Assert
(Count_Components
<= Num_Components
);
3795 -- Handle the N_Others choice if it covers several
3798 if Present
(Others_Choice
)
3799 and then (Num_Components
- Count_Components
) > 1
3801 if not Others_Box_Present
then
3803 -- At this stage, if expansion is active, the
3804 -- expression of the others choice has not been
3805 -- analyzed. Hence we generate a duplicate and
3806 -- we analyze it silently to have available the
3807 -- minimum decoration required to collect the
3810 pragma Assert
(Present
(Others_Assoc
));
3812 if not Expander_Active
then
3813 Comp_Expr
:= Expression
(Others_Assoc
);
3816 New_Copy_Tree
(Expression
(Others_Assoc
));
3817 Preanalyze_Without_Errors
(Comp_Expr
);
3820 Collect_Identifiers
(Comp_Expr
);
3822 if Present
(Writable_Actuals_List
) then
3824 -- As suggested by Robert, at current stage we
3825 -- report occurrences of this case as warnings.
3828 ("writable function parameter may affect "
3829 & "value in other component because order "
3830 & "of evaluation is unspecified??",
3831 Node
(First_Elmt
(Writable_Actuals_List
)));
3837 -- For an array aggregate, a discrete_choice_list that has
3838 -- a nonstatic range is considered as two or more separate
3839 -- occurrences of the expression (RM 6.4.1(20/3)).
3841 elsif Is_Array_Type
(Etype
(N
))
3842 and then Nkind
(N
) = N_Aggregate
3843 and then Present
(Aggregate_Bounds
(N
))
3844 and then not Compile_Time_Known_Bounds
(Etype
(N
))
3846 -- Collect identifiers found in the dynamic bounds
3849 Count_Components
: Natural := 0;
3850 Low
, High
: Node_Id
;
3853 Assoc
:= First
(Component_Associations
(N
));
3854 while Present
(Assoc
) loop
3855 Choice
:= First
(Choices
(Assoc
));
3856 while Present
(Choice
) loop
3857 if Nkind
(Choice
) in
3858 N_Range | N_Subtype_Indication
3859 or else (Is_Entity_Name
(Choice
)
3860 and then Is_Type
(Entity
(Choice
)))
3862 Get_Index_Bounds
(Choice
, Low
, High
);
3864 if not Compile_Time_Known_Value
(Low
) then
3865 Collect_Identifiers
(Low
);
3867 if No
(Aggr_Error_Node
) then
3868 Aggr_Error_Node
:= Low
;
3872 if not Compile_Time_Known_Value
(High
) then
3873 Collect_Identifiers
(High
);
3875 if No
(Aggr_Error_Node
) then
3876 Aggr_Error_Node
:= High
;
3880 -- The RM rule is violated if there is more than
3881 -- a single choice in a component association.
3884 Count_Components
:= Count_Components
+ 1;
3886 if No
(Aggr_Error_Node
)
3887 and then Count_Components
> 1
3889 Aggr_Error_Node
:= Choice
;
3892 if not Compile_Time_Known_Value
(Choice
) then
3893 Collect_Identifiers
(Choice
);
3905 -- Handle ancestor part of extension aggregates
3907 if Nkind
(N
) = N_Extension_Aggregate
then
3908 Collect_Identifiers
(Ancestor_Part
(N
));
3911 -- Handle positional associations
3913 if Present
(Expressions
(N
)) then
3914 Comp_Expr
:= First
(Expressions
(N
));
3915 while Present
(Comp_Expr
) loop
3916 if not Is_OK_Static_Expression
(Comp_Expr
) then
3917 Collect_Identifiers
(Comp_Expr
);
3924 -- Handle discrete associations
3926 if Present
(Component_Associations
(N
)) then
3927 Assoc
:= First
(Component_Associations
(N
));
3928 while Present
(Assoc
) loop
3930 if not Box_Present
(Assoc
) then
3931 Choice
:= First
(Choices
(Assoc
));
3932 while Present
(Choice
) loop
3934 -- For now we skip discriminants since it requires
3935 -- performing the analysis in two phases: first one
3936 -- analyzing discriminants and second one analyzing
3937 -- the rest of components since discriminants are
3938 -- evaluated prior to components: too much extra
3939 -- work to detect a corner case???
3941 if Nkind
(Choice
) in N_Has_Entity
3942 and then Present
(Entity
(Choice
))
3943 and then Ekind
(Entity
(Choice
)) = E_Discriminant
3947 elsif Box_Present
(Assoc
) then
3951 if not Analyzed
(Expression
(Assoc
)) then
3953 New_Copy_Tree
(Expression
(Assoc
));
3954 Set_Parent
(Comp_Expr
, Parent
(N
));
3955 Preanalyze_Without_Errors
(Comp_Expr
);
3957 Comp_Expr
:= Expression
(Assoc
);
3960 Collect_Identifiers
(Comp_Expr
);
3976 -- No further action needed if we already reported an error
3978 if Present
(Error_Node
) then
3982 -- Check violation of RM 6.20/3 in aggregates
3984 if Present
(Aggr_Error_Node
)
3985 and then Present
(Writable_Actuals_List
)
3988 ("value may be affected by call in other component because they "
3989 & "are evaluated in unspecified order",
3990 Node
(First_Elmt
(Writable_Actuals_List
)));
3994 -- Check if some writable argument of a function is referenced
3996 if Present
(Writable_Actuals_List
)
3997 and then Present
(Identifiers_List
)
4004 Elmt_1
:= First_Elmt
(Writable_Actuals_List
);
4005 while Present
(Elmt_1
) loop
4006 Elmt_2
:= First_Elmt
(Identifiers_List
);
4007 while Present
(Elmt_2
) loop
4008 if Entity
(Node
(Elmt_1
)) = Entity
(Node
(Elmt_2
)) then
4009 case Nkind
(Parent
(Node
(Elmt_2
))) is
4011 | N_Component_Association
4012 | N_Component_Declaration
4015 ("value may be affected by call in other "
4016 & "component because they are evaluated "
4017 & "in unspecified order",
4024 ("value may be affected by call in other "
4025 & "alternative because they are evaluated "
4026 & "in unspecified order",
4031 ("value of actual may be affected by call in "
4032 & "other actual because they are evaluated "
4033 & "in unspecified order",
4045 end Check_Function_Writable_Actuals
;
4047 --------------------------------
4048 -- Check_Implicit_Dereference --
4049 --------------------------------
4051 procedure Check_Implicit_Dereference
(N
: Node_Id
; Typ
: Entity_Id
) is
4057 if Nkind
(N
) = N_Indexed_Component
4058 and then Present
(Generalized_Indexing
(N
))
4060 Nam
:= Generalized_Indexing
(N
);
4065 if Ada_Version
< Ada_2012
4066 or else not Has_Implicit_Dereference
(Base_Type
(Typ
))
4070 elsif not Comes_From_Source
(N
)
4071 and then Nkind
(N
) /= N_Indexed_Component
4075 elsif Is_Entity_Name
(Nam
) and then Is_Type
(Entity
(Nam
)) then
4079 Disc
:= First_Discriminant
(Typ
);
4080 while Present
(Disc
) loop
4081 if Has_Implicit_Dereference
(Disc
) then
4082 Desig
:= Designated_Type
(Etype
(Disc
));
4083 Add_One_Interp
(Nam
, Disc
, Desig
);
4085 -- If the node is a generalized indexing, add interpretation
4086 -- to that node as well, for subsequent resolution.
4088 if Nkind
(N
) = N_Indexed_Component
then
4089 Add_One_Interp
(N
, Disc
, Desig
);
4092 -- If the operation comes from a generic unit and the context
4093 -- is a selected component, the selector name may be global
4094 -- and set in the instance already. Remove the entity to
4095 -- force resolution of the selected component, and the
4096 -- generation of an explicit dereference if needed.
4099 and then Nkind
(Parent
(Nam
)) = N_Selected_Component
4101 Set_Entity
(Selector_Name
(Parent
(Nam
)), Empty
);
4107 Next_Discriminant
(Disc
);
4110 end Check_Implicit_Dereference
;
4112 ----------------------------------
4113 -- Check_Internal_Protected_Use --
4114 ----------------------------------
4116 procedure Check_Internal_Protected_Use
(N
: Node_Id
; Nam
: Entity_Id
) is
4124 while Present
(S
) loop
4125 if S
= Standard_Standard
then
4128 elsif Ekind
(S
) = E_Function
4129 and then Ekind
(Scope
(S
)) = E_Protected_Type
4139 and then Scope
(Nam
) = Prot
4140 and then Ekind
(Nam
) /= E_Function
4142 -- An indirect function call (e.g. a callback within a protected
4143 -- function body) is not statically illegal. If the access type is
4144 -- anonymous and is the type of an access parameter, the scope of Nam
4145 -- will be the protected type, but it is not a protected operation.
4147 if Ekind
(Nam
) = E_Subprogram_Type
4148 and then Nkind
(Associated_Node_For_Itype
(Nam
)) =
4149 N_Function_Specification
4153 elsif Nkind
(N
) = N_Subprogram_Renaming_Declaration
then
4155 ("within protected function cannot use protected procedure in "
4156 & "renaming or as generic actual", N
);
4158 elsif Nkind
(N
) = N_Attribute_Reference
then
4160 ("within protected function cannot take access of protected "
4165 ("within protected function, protected object is constant", N
);
4167 ("\cannot call operation that may modify it", N
);
4171 -- Verify that an internal call does not appear within a precondition
4172 -- of a protected operation. This implements AI12-0166.
4173 -- The precondition aspect has been rewritten as a pragma Precondition
4174 -- and we check whether the scope of the called subprogram is the same
4175 -- as that of the entity to which the aspect applies.
4177 if Convention
(Nam
) = Convention_Protected
then
4183 while Present
(P
) loop
4184 if Nkind
(P
) = N_Pragma
4185 and then Chars
(Pragma_Identifier
(P
)) = Name_Precondition
4186 and then From_Aspect_Specification
(P
)
4188 Scope
(Entity
(Corresponding_Aspect
(P
))) = Scope
(Nam
)
4191 ("internal call cannot appear in precondition of "
4192 & "protected operation", N
);
4195 elsif Nkind
(P
) = N_Pragma
4196 and then Chars
(Pragma_Identifier
(P
)) = Name_Contract_Cases
4198 -- Check whether call is in a case guard. It is legal in a
4202 while Present
(P
) loop
4203 if Nkind
(Parent
(P
)) = N_Component_Association
4204 and then P
/= Expression
(Parent
(P
))
4207 ("internal call cannot appear in case guard in a "
4208 & "contract case", N
);
4216 elsif Nkind
(P
) = N_Parameter_Specification
4217 and then Scope
(Current_Scope
) = Scope
(Nam
)
4218 and then Nkind
(Parent
(P
)) in
4219 N_Entry_Declaration | N_Subprogram_Declaration
4222 ("internal call cannot appear in default for formal of "
4223 & "protected operation", N
);
4231 end Check_Internal_Protected_Use
;
4233 ---------------------------------------
4234 -- Check_Later_Vs_Basic_Declarations --
4235 ---------------------------------------
4237 procedure Check_Later_Vs_Basic_Declarations
4239 During_Parsing
: Boolean)
4241 Body_Sloc
: Source_Ptr
;
4244 function Is_Later_Declarative_Item
(Decl
: Node_Id
) return Boolean;
4245 -- Return whether Decl is considered as a declarative item.
4246 -- When During_Parsing is True, the semantics of Ada 83 is followed.
4247 -- When During_Parsing is False, the semantics of SPARK is followed.
4249 -------------------------------
4250 -- Is_Later_Declarative_Item --
4251 -------------------------------
4253 function Is_Later_Declarative_Item
(Decl
: Node_Id
) return Boolean is
4255 if Nkind
(Decl
) in N_Later_Decl_Item
then
4258 elsif Nkind
(Decl
) = N_Pragma
then
4261 elsif During_Parsing
then
4264 -- In SPARK, a package declaration is not considered as a later
4265 -- declarative item.
4267 elsif Nkind
(Decl
) = N_Package_Declaration
then
4270 -- In SPARK, a renaming is considered as a later declarative item
4272 elsif Nkind
(Decl
) in N_Renaming_Declaration
then
4278 end Is_Later_Declarative_Item
;
4280 -- Start of processing for Check_Later_Vs_Basic_Declarations
4283 Decl
:= First
(Decls
);
4285 -- Loop through sequence of basic declarative items
4287 Outer
: while Present
(Decl
) loop
4288 if Nkind
(Decl
) not in
4289 N_Subprogram_Body | N_Package_Body | N_Task_Body
4290 and then Nkind
(Decl
) not in N_Body_Stub
4294 -- Once a body is encountered, we only allow later declarative
4295 -- items. The inner loop checks the rest of the list.
4298 Body_Sloc
:= Sloc
(Decl
);
4300 Inner
: while Present
(Decl
) loop
4301 if not Is_Later_Declarative_Item
(Decl
) then
4302 if During_Parsing
then
4303 if Ada_Version
= Ada_83
then
4304 Error_Msg_Sloc
:= Body_Sloc
;
4306 ("(Ada 83) decl cannot appear after body#", Decl
);
4315 end Check_Later_Vs_Basic_Declarations
;
4317 ---------------------------
4318 -- Check_No_Hidden_State --
4319 ---------------------------
4321 procedure Check_No_Hidden_State
(Id
: Entity_Id
) is
4322 Context
: Entity_Id
:= Empty
;
4323 Not_Visible
: Boolean := False;
4327 pragma Assert
(Ekind
(Id
) in E_Abstract_State | E_Variable
);
4329 -- Nothing to do for internally-generated abstract states and variables
4330 -- because they do not represent the hidden state of the source unit.
4332 if not Comes_From_Source
(Id
) then
4336 -- Find the proper context where the object or state appears
4339 while Present
(Scop
) loop
4342 -- Keep track of the context's visibility
4344 Not_Visible
:= Not_Visible
or else In_Private_Part
(Context
);
4346 -- Prevent the search from going too far
4348 if Context
= Standard_Standard
then
4351 -- Objects and states that appear immediately within a subprogram or
4352 -- entry inside a construct nested within a subprogram do not
4353 -- introduce a hidden state. They behave as local variable
4354 -- declarations. The same is true for elaboration code inside a block
4357 elsif Is_Subprogram_Or_Entry
(Context
)
4358 or else Ekind
(Context
) in E_Block | E_Task_Type
4363 -- Stop the traversal when a package subject to a null abstract state
4366 if Is_Package_Or_Generic_Package
(Context
)
4367 and then Has_Null_Abstract_State
(Context
)
4372 Scop
:= Scope
(Scop
);
4375 -- At this point we know that there is at least one package with a null
4376 -- abstract state in visibility. Emit an error message unconditionally
4377 -- if the entity being processed is a state because the placement of the
4378 -- related package is irrelevant. This is not the case for objects as
4379 -- the intermediate context matters.
4381 if Present
(Context
)
4382 and then (Ekind
(Id
) = E_Abstract_State
or else Not_Visible
)
4384 Error_Msg_N
("cannot introduce hidden state &", Id
);
4385 Error_Msg_NE
("\package & has null abstract state", Id
, Context
);
4387 end Check_No_Hidden_State
;
4389 ---------------------------------------------
4390 -- Check_Nonoverridable_Aspect_Consistency --
4391 ---------------------------------------------
4393 procedure Check_Inherited_Nonoverridable_Aspects
4394 (Inheritor
: Entity_Id
;
4395 Interface_List
: List_Id
;
4396 Parent_Type
: Entity_Id
) is
4398 -- array needed for iterating over subtype values
4399 Nonoverridable_Aspects
: constant array (Positive range <>) of
4400 Nonoverridable_Aspect_Id
:=
4401 (Aspect_Default_Iterator
,
4402 Aspect_Iterator_Element
,
4403 Aspect_Implicit_Dereference
,
4404 Aspect_Constant_Indexing
,
4405 Aspect_Variable_Indexing
,
4407 Aspect_Max_Entry_Queue_Length
4408 -- , Aspect_No_Controlled_Parts
4411 -- Note that none of these 8 aspects can be specified (for a type)
4412 -- via a pragma. For 7 of them, the corresponding pragma does not
4413 -- exist. The Pragma_Id enumeration type does include
4414 -- Pragma_Max_Entry_Queue_Length, but that pragma is only use to
4415 -- specify the aspect for a protected entry or entry family, not for
4416 -- a type, and therefore cannot introduce the sorts of inheritance
4417 -- issues that we are concerned with in this procedure.
4419 type Entity_Array
is array (Nat
range <>) of Entity_Id
;
4421 function Ancestor_Entities
return Entity_Array
;
4422 -- Returns all progenitors (including parent type, if present)
4424 procedure Check_Consistency_For_One_Aspect_Of_Two_Ancestors
4425 (Aspect
: Nonoverridable_Aspect_Id
;
4426 Ancestor_1
: Entity_Id
;
4427 Aspect_Spec_1
: Node_Id
;
4428 Ancestor_2
: Entity_Id
;
4429 Aspect_Spec_2
: Node_Id
);
4430 -- A given aspect has been specified for each of two ancestors;
4431 -- check that the two aspect specifications are compatible (see
4432 -- RM 13.1.1(18.5) and AI12-0211).
4434 -----------------------
4435 -- Ancestor_Entities --
4436 -----------------------
4438 function Ancestor_Entities
return Entity_Array
is
4439 Ifc_Count
: constant Nat
:= List_Length
(Interface_List
);
4440 Ifc_Ancestors
: Entity_Array
(1 .. Ifc_Count
);
4441 Ifc
: Node_Id
:= First
(Interface_List
);
4443 for Idx
in Ifc_Ancestors
'Range loop
4444 Ifc_Ancestors
(Idx
) := Entity
(Ifc
);
4445 pragma Assert
(Present
(Ifc_Ancestors
(Idx
)));
4448 pragma Assert
(not Present
(Ifc
));
4449 if Present
(Parent_Type
) then
4450 return Parent_Type
& Ifc_Ancestors
;
4452 return Ifc_Ancestors
;
4454 end Ancestor_Entities
;
4456 -------------------------------------------------------
4457 -- Check_Consistency_For_One_Aspect_Of_Two_Ancestors --
4458 -------------------------------------------------------
4460 procedure Check_Consistency_For_One_Aspect_Of_Two_Ancestors
4461 (Aspect
: Nonoverridable_Aspect_Id
;
4462 Ancestor_1
: Entity_Id
;
4463 Aspect_Spec_1
: Node_Id
;
4464 Ancestor_2
: Entity_Id
;
4465 Aspect_Spec_2
: Node_Id
) is
4467 if not Is_Confirming
(Aspect
, Aspect_Spec_1
, Aspect_Spec_2
) then
4468 Error_Msg_Name_1
:= Aspect_Names
(Aspect
);
4469 Error_Msg_Name_2
:= Chars
(Ancestor_1
);
4470 Error_Msg_Name_3
:= Chars
(Ancestor_2
);
4473 "incompatible % aspects inherited from ancestors % and %",
4476 end Check_Consistency_For_One_Aspect_Of_Two_Ancestors
;
4478 Ancestors
: constant Entity_Array
:= Ancestor_Entities
;
4480 -- start of processing for Check_Inherited_Nonoverridable_Aspects
4482 -- No Ada_Version check here; AI12-0211 is a binding interpretation.
4484 if Ancestors
'Length < 2 then
4485 return; -- Inconsistency impossible; it takes 2 to disagree.
4486 elsif In_Instance_Body
then
4487 return; -- No legality checking in an instance body.
4490 for Aspect
of Nonoverridable_Aspects
loop
4492 First_Ancestor_With_Aspect
: Entity_Id
:= Empty
;
4493 First_Aspect_Spec
, Current_Aspect_Spec
: Node_Id
:= Empty
;
4495 for Ancestor
of Ancestors
loop
4496 Current_Aspect_Spec
:= Find_Aspect
(Ancestor
, Aspect
);
4497 if Present
(Current_Aspect_Spec
) then
4498 if Present
(First_Ancestor_With_Aspect
) then
4499 Check_Consistency_For_One_Aspect_Of_Two_Ancestors
4501 Ancestor_1
=> First_Ancestor_With_Aspect
,
4502 Aspect_Spec_1
=> First_Aspect_Spec
,
4503 Ancestor_2
=> Ancestor
,
4504 Aspect_Spec_2
=> Current_Aspect_Spec
);
4506 First_Ancestor_With_Aspect
:= Ancestor
;
4507 First_Aspect_Spec
:= Current_Aspect_Spec
;
4513 end Check_Inherited_Nonoverridable_Aspects
;
4515 ----------------------------------------
4516 -- Check_Nonvolatile_Function_Profile --
4517 ----------------------------------------
4519 procedure Check_Nonvolatile_Function_Profile
(Func_Id
: Entity_Id
) is
4523 -- Inspect all formal parameters
4525 Formal
:= First_Formal
(Func_Id
);
4526 while Present
(Formal
) loop
4527 if Is_Effectively_Volatile_For_Reading
(Etype
(Formal
)) then
4529 ("nonvolatile function & cannot have a volatile parameter",
4533 Next_Formal
(Formal
);
4536 -- Inspect the return type
4538 if Is_Effectively_Volatile_For_Reading
(Etype
(Func_Id
)) then
4540 ("nonvolatile function & cannot have a volatile return type",
4541 Result_Definition
(Parent
(Func_Id
)), Func_Id
);
4543 end Check_Nonvolatile_Function_Profile
;
4549 function Check_Parents
(N
: Node_Id
; List
: Elist_Id
) return Boolean is
4552 (Parent_Node
: Node_Id
;
4553 N
: Node_Id
) return Traverse_Result
;
4554 -- Process a single node.
4561 (Parent_Node
: Node_Id
;
4562 N
: Node_Id
) return Traverse_Result
is
4564 if Nkind
(N
) = N_Identifier
4565 and then Parent
(N
) /= Parent_Node
4566 and then Present
(Entity
(N
))
4567 and then Contains
(List
, Entity
(N
))
4575 function Traverse
is new Traverse_Func_With_Parent
(Check_Node
);
4577 -- Start of processing for Check_Parents
4580 return Traverse
(N
) = OK
;
4583 -----------------------------
4584 -- Check_Part_Of_Reference --
4585 -----------------------------
4587 procedure Check_Part_Of_Reference
(Var_Id
: Entity_Id
; Ref
: Node_Id
) is
4588 function Is_Enclosing_Package_Body
4589 (Body_Decl
: Node_Id
;
4590 Obj_Id
: Entity_Id
) return Boolean;
4591 pragma Inline
(Is_Enclosing_Package_Body
);
4592 -- Determine whether package body Body_Decl or its corresponding spec
4593 -- immediately encloses the declaration of object Obj_Id.
4595 function Is_Internal_Declaration_Or_Body
4596 (Decl
: Node_Id
) return Boolean;
4597 pragma Inline
(Is_Internal_Declaration_Or_Body
);
4598 -- Determine whether declaration or body denoted by Decl is internal
4600 function Is_Single_Declaration_Or_Body
4602 Conc_Typ
: Entity_Id
) return Boolean;
4603 pragma Inline
(Is_Single_Declaration_Or_Body
);
4604 -- Determine whether protected/task declaration or body denoted by Decl
4605 -- belongs to single concurrent type Conc_Typ.
4607 function Is_Single_Task_Pragma
4609 Task_Typ
: Entity_Id
) return Boolean;
4610 pragma Inline
(Is_Single_Task_Pragma
);
4611 -- Determine whether pragma Prag belongs to single task type Task_Typ
4613 -------------------------------
4614 -- Is_Enclosing_Package_Body --
4615 -------------------------------
4617 function Is_Enclosing_Package_Body
4618 (Body_Decl
: Node_Id
;
4619 Obj_Id
: Entity_Id
) return Boolean
4621 Obj_Context
: Node_Id
;
4624 -- Find the context of the object declaration
4626 Obj_Context
:= Parent
(Declaration_Node
(Obj_Id
));
4628 if Nkind
(Obj_Context
) = N_Package_Specification
then
4629 Obj_Context
:= Parent
(Obj_Context
);
4632 -- The object appears immediately within the package body
4634 if Obj_Context
= Body_Decl
then
4637 -- The object appears immediately within the corresponding spec
4639 elsif Nkind
(Obj_Context
) = N_Package_Declaration
4640 and then Unit_Declaration_Node
(Corresponding_Spec
(Body_Decl
)) =
4647 end Is_Enclosing_Package_Body
;
4649 -------------------------------------
4650 -- Is_Internal_Declaration_Or_Body --
4651 -------------------------------------
4653 function Is_Internal_Declaration_Or_Body
4654 (Decl
: Node_Id
) return Boolean
4657 if Comes_From_Source
(Decl
) then
4660 -- A body generated for an expression function which has not been
4661 -- inserted into the tree yet (In_Spec_Expression is True) is not
4662 -- considered internal.
4664 elsif Nkind
(Decl
) = N_Subprogram_Body
4665 and then Was_Expression_Function
(Decl
)
4666 and then not In_Spec_Expression
4672 end Is_Internal_Declaration_Or_Body
;
4674 -----------------------------------
4675 -- Is_Single_Declaration_Or_Body --
4676 -----------------------------------
4678 function Is_Single_Declaration_Or_Body
4680 Conc_Typ
: Entity_Id
) return Boolean
4682 Spec_Id
: constant Entity_Id
:= Unique_Defining_Entity
(Decl
);
4686 Present
(Anonymous_Object
(Spec_Id
))
4687 and then Anonymous_Object
(Spec_Id
) = Conc_Typ
;
4688 end Is_Single_Declaration_Or_Body
;
4690 ---------------------------
4691 -- Is_Single_Task_Pragma --
4692 ---------------------------
4694 function Is_Single_Task_Pragma
4696 Task_Typ
: Entity_Id
) return Boolean
4698 Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(Prag
);
4701 -- To qualify, the pragma must be associated with single task type
4705 Is_Single_Task_Object
(Task_Typ
)
4706 and then Nkind
(Decl
) = N_Object_Declaration
4707 and then Defining_Entity
(Decl
) = Task_Typ
;
4708 end Is_Single_Task_Pragma
;
4712 Conc_Obj
: constant Entity_Id
:= Encapsulating_State
(Var_Id
);
4717 -- Start of processing for Check_Part_Of_Reference
4720 -- Nothing to do when the variable was recorded, but did not become a
4721 -- constituent of a single concurrent type.
4723 if No
(Conc_Obj
) then
4727 -- Traverse the parent chain looking for a suitable context for the
4728 -- reference to the concurrent constituent.
4731 Par
:= Parent
(Prev
);
4732 while Present
(Par
) loop
4733 if Nkind
(Par
) = N_Pragma
then
4734 Prag_Nam
:= Pragma_Name
(Par
);
4736 -- A concurrent constituent is allowed to appear in pragmas
4737 -- Initial_Condition and Initializes as this is part of the
4738 -- elaboration checks for the constituent (SPARK RM 9(3)).
4740 if Prag_Nam
in Name_Initial_Condition | Name_Initializes
then
4743 -- When the reference appears within pragma Depends or Global,
4744 -- check whether the pragma applies to a single task type. Note
4745 -- that the pragma may not encapsulated by the type definition,
4746 -- but this is still a valid context.
4748 elsif Prag_Nam
in Name_Depends | Name_Global
4749 and then Is_Single_Task_Pragma
(Par
, Conc_Obj
)
4754 -- The reference appears somewhere in the definition of a single
4755 -- concurrent type (SPARK RM 9(3)).
4757 elsif Nkind
(Par
) in
4758 N_Single_Protected_Declaration | N_Single_Task_Declaration
4759 and then Defining_Entity
(Par
) = Conc_Obj
4763 -- The reference appears within the declaration or body of a single
4764 -- concurrent type (SPARK RM 9(3)).
4766 elsif Nkind
(Par
) in N_Protected_Body
4767 | N_Protected_Type_Declaration
4769 | N_Task_Type_Declaration
4770 and then Is_Single_Declaration_Or_Body
(Par
, Conc_Obj
)
4774 -- The reference appears within the statement list of the object's
4775 -- immediately enclosing package (SPARK RM 9(3)).
4777 elsif Nkind
(Par
) = N_Package_Body
4778 and then Nkind
(Prev
) = N_Handled_Sequence_Of_Statements
4779 and then Is_Enclosing_Package_Body
(Par
, Var_Id
)
4783 -- The reference has been relocated within an internally generated
4784 -- package or subprogram. Assume that the reference is legal as the
4785 -- real check was already performed in the original context of the
4788 elsif Nkind
(Par
) in N_Package_Body
4789 | N_Package_Declaration
4791 | N_Subprogram_Declaration
4792 and then Is_Internal_Declaration_Or_Body
(Par
)
4796 -- The reference has been relocated to an inlined body for GNATprove.
4797 -- Assume that the reference is legal as the real check was already
4798 -- performed in the original context of the reference.
4800 elsif GNATprove_Mode
4801 and then Nkind
(Par
) = N_Subprogram_Body
4802 and then Chars
(Defining_Entity
(Par
)) = Name_uParent
4808 Par
:= Parent
(Prev
);
4811 -- At this point it is known that the reference does not appear within a
4815 ("reference to variable & cannot appear in this context", Ref
, Var_Id
);
4816 Error_Msg_Name_1
:= Chars
(Var_Id
);
4818 if Is_Single_Protected_Object
(Conc_Obj
) then
4820 ("\% is constituent of single protected type &", Ref
, Conc_Obj
);
4824 ("\% is constituent of single task type &", Ref
, Conc_Obj
);
4826 end Check_Part_Of_Reference
;
4828 ------------------------------------------
4829 -- Check_Potentially_Blocking_Operation --
4830 ------------------------------------------
4832 procedure Check_Potentially_Blocking_Operation
(N
: Node_Id
) is
4836 -- N is one of the potentially blocking operations listed in 9.5.1(8).
4837 -- When pragma Detect_Blocking is active, the run time will raise
4838 -- Program_Error. Here we only issue a warning, since we generally
4839 -- support the use of potentially blocking operations in the absence
4842 -- Indirect blocking through a subprogram call cannot be diagnosed
4843 -- statically without interprocedural analysis, so we do not attempt
4846 S
:= Scope
(Current_Scope
);
4847 while Present
(S
) and then S
/= Standard_Standard
loop
4848 if Is_Protected_Type
(S
) then
4850 ("potentially blocking operation in protected operation??", N
);
4856 end Check_Potentially_Blocking_Operation
;
4858 ------------------------------------
4859 -- Check_Previous_Null_Procedure --
4860 ------------------------------------
4862 procedure Check_Previous_Null_Procedure
4867 if Ekind
(Prev
) = E_Procedure
4868 and then Nkind
(Parent
(Prev
)) = N_Procedure_Specification
4869 and then Null_Present
(Parent
(Prev
))
4871 Error_Msg_Sloc
:= Sloc
(Prev
);
4873 ("declaration cannot complete previous null procedure#", Decl
);
4875 end Check_Previous_Null_Procedure
;
4877 ---------------------------------
4878 -- Check_Result_And_Post_State --
4879 ---------------------------------
4881 procedure Check_Result_And_Post_State
(Subp_Id
: Entity_Id
) is
4882 procedure Check_Result_And_Post_State_In_Pragma
4884 Result_Seen
: in out Boolean);
4885 -- Determine whether pragma Prag mentions attribute 'Result and whether
4886 -- the pragma contains an expression that evaluates differently in pre-
4887 -- and post-state. Prag is a [refined] postcondition or a contract-cases
4888 -- pragma. Result_Seen is set when the pragma mentions attribute 'Result
4890 function Is_Trivial_Boolean
(N
: Node_Id
) return Boolean;
4891 -- Determine whether source node N denotes "True" or "False"
4893 -------------------------------------------
4894 -- Check_Result_And_Post_State_In_Pragma --
4895 -------------------------------------------
4897 procedure Check_Result_And_Post_State_In_Pragma
4899 Result_Seen
: in out Boolean)
4901 procedure Check_Conjunct
(Expr
: Node_Id
);
4902 -- Check an individual conjunct in a conjunction of Boolean
4903 -- expressions, connected by "and" or "and then" operators.
4905 procedure Check_Conjuncts
(Expr
: Node_Id
);
4906 -- Apply the post-state check to every conjunct in an expression, in
4907 -- case this is a conjunction of Boolean expressions. Otherwise apply
4908 -- it to the expression as a whole.
4910 procedure Check_Expression
(Expr
: Node_Id
);
4911 -- Perform the 'Result and post-state checks on a given expression
4913 function Is_Function_Result
(N
: Node_Id
) return Traverse_Result
;
4914 -- Attempt to find attribute 'Result in a subtree denoted by N
4916 function Mentions_Post_State
(N
: Node_Id
) return Boolean;
4917 -- Determine whether a subtree denoted by N mentions any construct
4918 -- that denotes a post-state.
4920 procedure Check_Function_Result
is
4921 new Traverse_Proc
(Is_Function_Result
);
4923 --------------------
4924 -- Check_Conjunct --
4925 --------------------
4927 procedure Check_Conjunct
(Expr
: Node_Id
) is
4928 function Adjust_Message
(Msg
: String) return String;
4929 -- Prepend a prefix to the input message Msg denoting that the
4930 -- message applies to a conjunct in the expression, when this
4933 function Applied_On_Conjunct
return Boolean;
4934 -- Returns True if the message applies to a conjunct in the
4935 -- expression, instead of the whole expression.
4937 function Has_Global_Output
(Subp
: Entity_Id
) return Boolean;
4938 -- Returns True if Subp has an output in its Global contract
4940 function Has_No_Output
(Subp
: Entity_Id
) return Boolean;
4941 -- Returns True if Subp has no declared output: no function
4942 -- result, no output parameter, and no output in its Global
4945 --------------------
4946 -- Adjust_Message --
4947 --------------------
4949 function Adjust_Message
(Msg
: String) return String is
4951 if Applied_On_Conjunct
then
4952 return "conjunct in " & Msg
;
4958 -------------------------
4959 -- Applied_On_Conjunct --
4960 -------------------------
4962 function Applied_On_Conjunct
return Boolean is
4964 -- Expr is the conjunct of an enclosing "and" expression
4966 return Nkind
(Parent
(Expr
)) in N_Subexpr
4968 -- or Expr is a conjunct of an enclosing "and then"
4969 -- expression in a postcondition aspect that was split into
4970 -- multiple pragmas. The first conjunct has the "and then"
4971 -- expression as Original_Node, and other conjuncts have
4972 -- Split_PCC set to True.
4974 or else Nkind
(Original_Node
(Expr
)) = N_And_Then
4975 or else Split_PPC
(Prag
);
4976 end Applied_On_Conjunct
;
4978 -----------------------
4979 -- Has_Global_Output --
4980 -----------------------
4982 function Has_Global_Output
(Subp
: Entity_Id
) return Boolean is
4983 Global
: constant Node_Id
:= Get_Pragma
(Subp
, Pragma_Global
);
4992 List
:= Expression
(Get_Argument
(Global
, Subp
));
4994 -- Empty list (no global items) or single global item
4995 -- declaration (only input items).
4997 if Nkind
(List
) in N_Null
5000 | N_Selected_Component
5004 -- Simple global list (only input items) or moded global list
5007 elsif Nkind
(List
) = N_Aggregate
then
5008 if Present
(Expressions
(List
)) then
5012 Assoc
:= First
(Component_Associations
(List
));
5013 while Present
(Assoc
) loop
5014 if Chars
(First
(Choices
(Assoc
))) /= Name_Input
then
5024 -- To accommodate partial decoration of disabled SPARK
5025 -- features, this routine may be called with illegal input.
5026 -- If this is the case, do not raise Program_Error.
5031 end Has_Global_Output
;
5037 function Has_No_Output
(Subp
: Entity_Id
) return Boolean is
5041 -- A function has its result as output
5043 if Ekind
(Subp
) = E_Function
then
5047 -- An OUT or IN OUT parameter is an output
5049 Param
:= First_Formal
(Subp
);
5050 while Present
(Param
) loop
5051 if Ekind
(Param
) in E_Out_Parameter | E_In_Out_Parameter
then
5055 Next_Formal
(Param
);
5058 -- An item of mode Output or In_Out in the Global contract is
5061 if Has_Global_Output
(Subp
) then
5071 -- Error node when reporting a warning on a (refined)
5074 -- Start of processing for Check_Conjunct
5077 if Applied_On_Conjunct
then
5083 -- Do not report missing reference to outcome in postcondition if
5084 -- either the postcondition is trivially True or False, or if the
5085 -- subprogram is ghost and has no declared output.
5087 if not Is_Trivial_Boolean
(Expr
)
5088 and then not Mentions_Post_State
(Expr
)
5089 and then not (Is_Ghost_Entity
(Subp_Id
)
5090 and then Has_No_Output
(Subp_Id
))
5091 and then not Is_Wrapper
(Subp_Id
)
5093 if Pragma_Name
(Prag
) = Name_Contract_Cases
then
5094 Error_Msg_NE
(Adjust_Message
5095 ("contract case does not check the outcome of calling "
5096 & "&?.t?"), Expr
, Subp_Id
);
5098 elsif Pragma_Name
(Prag
) = Name_Refined_Post
then
5099 Error_Msg_NE
(Adjust_Message
5100 ("refined postcondition does not check the outcome of "
5101 & "calling &?.t?"), Err_Node
, Subp_Id
);
5104 Error_Msg_NE
(Adjust_Message
5105 ("postcondition does not check the outcome of calling "
5106 & "&?.t?"), Err_Node
, Subp_Id
);
5111 ---------------------
5112 -- Check_Conjuncts --
5113 ---------------------
5115 procedure Check_Conjuncts
(Expr
: Node_Id
) is
5117 if Nkind
(Expr
) in N_Op_And | N_And_Then
then
5118 Check_Conjuncts
(Left_Opnd
(Expr
));
5119 Check_Conjuncts
(Right_Opnd
(Expr
));
5121 Check_Conjunct
(Expr
);
5123 end Check_Conjuncts
;
5125 ----------------------
5126 -- Check_Expression --
5127 ----------------------
5129 procedure Check_Expression
(Expr
: Node_Id
) is
5131 if not Is_Trivial_Boolean
(Expr
) then
5132 Check_Function_Result
(Expr
);
5133 Check_Conjuncts
(Expr
);
5135 end Check_Expression
;
5137 ------------------------
5138 -- Is_Function_Result --
5139 ------------------------
5141 function Is_Function_Result
(N
: Node_Id
) return Traverse_Result
is
5143 if Is_Attribute_Result
(N
) then
5144 Result_Seen
:= True;
5147 -- Warn on infinite recursion if call is to current function
5149 elsif Nkind
(N
) = N_Function_Call
5150 and then Is_Entity_Name
(Name
(N
))
5151 and then Entity
(Name
(N
)) = Subp_Id
5152 and then not Is_Potentially_Unevaluated
(N
)
5155 ("call to & within its postcondition will lead to infinite "
5156 & "recursion?", N
, Subp_Id
);
5159 -- Continue the traversal
5164 end Is_Function_Result
;
5166 -------------------------
5167 -- Mentions_Post_State --
5168 -------------------------
5170 function Mentions_Post_State
(N
: Node_Id
) return Boolean is
5171 Post_State_Seen
: Boolean := False;
5173 function Is_Post_State
(N
: Node_Id
) return Traverse_Result
;
5174 -- Attempt to find a construct that denotes a post-state. If this
5175 -- is the case, set flag Post_State_Seen.
5181 function Is_Post_State
(N
: Node_Id
) return Traverse_Result
is
5185 if Nkind
(N
) in N_Explicit_Dereference | N_Function_Call
then
5186 Post_State_Seen
:= True;
5189 elsif Nkind
(N
) in N_Expanded_Name | N_Identifier
then
5192 -- Treat an undecorated reference as OK
5196 -- A reference to an assignable entity is considered a
5197 -- change in the post-state of a subprogram.
5199 or else Ekind
(Ent
) in E_Generic_In_Out_Parameter
5200 | E_In_Out_Parameter
5204 -- The reference may be modified through a dereference
5206 or else (Is_Access_Type
(Etype
(Ent
))
5207 and then Nkind
(Parent
(N
)) =
5208 N_Selected_Component
)
5210 Post_State_Seen
:= True;
5214 elsif Nkind
(N
) = N_Attribute_Reference
then
5215 if Attribute_Name
(N
) = Name_Old
then
5218 elsif Attribute_Name
(N
) = Name_Result
then
5219 Post_State_Seen
:= True;
5227 procedure Find_Post_State
is new Traverse_Proc
(Is_Post_State
);
5229 -- Start of processing for Mentions_Post_State
5232 Find_Post_State
(N
);
5234 return Post_State_Seen
;
5235 end Mentions_Post_State
;
5239 Expr
: constant Node_Id
:=
5241 (First
(Pragma_Argument_Associations
(Prag
)));
5242 Nam
: constant Name_Id
:= Pragma_Name
(Prag
);
5245 -- Start of processing for Check_Result_And_Post_State_In_Pragma
5248 -- Examine all consequences
5250 if Nam
= Name_Contract_Cases
then
5251 CCase
:= First
(Component_Associations
(Expr
));
5252 while Present
(CCase
) loop
5253 Check_Expression
(Expression
(CCase
));
5258 -- Examine the expression of a postcondition
5260 else pragma Assert
(Nam
in Name_Postcondition | Name_Refined_Post
);
5261 Check_Expression
(Expr
);
5263 end Check_Result_And_Post_State_In_Pragma
;
5265 ------------------------
5266 -- Is_Trivial_Boolean --
5267 ------------------------
5269 function Is_Trivial_Boolean
(N
: Node_Id
) return Boolean is
5272 Comes_From_Source
(N
)
5273 and then Is_Entity_Name
(N
)
5274 and then (Entity
(N
) = Standard_True
5276 Entity
(N
) = Standard_False
);
5277 end Is_Trivial_Boolean
;
5281 Items
: constant Node_Id
:= Contract
(Subp_Id
);
5282 Subp_Decl
: constant Node_Id
:= Unit_Declaration_Node
(Subp_Id
);
5283 Case_Prag
: Node_Id
:= Empty
;
5284 Post_Prag
: Node_Id
:= Empty
;
5286 Seen_In_Case
: Boolean := False;
5287 Seen_In_Post
: Boolean := False;
5288 Spec_Id
: Entity_Id
;
5290 -- Start of processing for Check_Result_And_Post_State
5293 -- The lack of attribute 'Result or a post-state is classified as a
5294 -- suspicious contract. Do not perform the check if the corresponding
5295 -- swich is not set.
5297 if not Warn_On_Suspicious_Contract
then
5300 -- Nothing to do if there is no contract
5302 elsif No
(Items
) then
5306 -- Retrieve the entity of the subprogram spec (if any)
5308 if Nkind
(Subp_Decl
) = N_Subprogram_Body
5309 and then Present
(Corresponding_Spec
(Subp_Decl
))
5311 Spec_Id
:= Corresponding_Spec
(Subp_Decl
);
5313 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
5314 and then Present
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
5316 Spec_Id
:= Corresponding_Spec_Of_Stub
(Subp_Decl
);
5322 -- Examine all postconditions for attribute 'Result and a post-state
5324 Prag
:= Pre_Post_Conditions
(Items
);
5325 while Present
(Prag
) loop
5326 if Pragma_Name_Unmapped
(Prag
)
5327 in Name_Postcondition | Name_Refined_Post
5328 and then not Error_Posted
(Prag
)
5331 Check_Result_And_Post_State_In_Pragma
(Prag
, Seen_In_Post
);
5334 Prag
:= Next_Pragma
(Prag
);
5337 -- Examine the contract cases of the subprogram for attribute 'Result
5338 -- and a post-state.
5340 Prag
:= Contract_Test_Cases
(Items
);
5341 while Present
(Prag
) loop
5342 if Pragma_Name
(Prag
) = Name_Contract_Cases
5343 and then not Error_Posted
(Prag
)
5346 Check_Result_And_Post_State_In_Pragma
(Prag
, Seen_In_Case
);
5349 Prag
:= Next_Pragma
(Prag
);
5352 -- Do not emit any errors if the subprogram is not a function
5354 if Ekind
(Spec_Id
) not in E_Function | E_Generic_Function
then
5357 -- Regardless of whether the function has postconditions or contract
5358 -- cases, or whether they mention attribute 'Result, an [IN] OUT formal
5359 -- parameter is always treated as a result.
5361 elsif Has_Out_Or_In_Out_Parameter
(Spec_Id
) then
5364 -- The function has both a postcondition and contract cases and they do
5365 -- not mention attribute 'Result.
5367 elsif Present
(Case_Prag
)
5368 and then not Seen_In_Case
5369 and then Present
(Post_Prag
)
5370 and then not Seen_In_Post
5373 ("neither postcondition nor contract cases mention function "
5374 & "result?.t?", Post_Prag
);
5376 -- The function has contract cases only and they do not mention
5377 -- attribute 'Result.
5379 elsif Present
(Case_Prag
) and then not Seen_In_Case
then
5380 Error_Msg_N
("contract cases do not mention result?.t?", Case_Prag
);
5382 -- The function has non-trivial postconditions only and they do not
5383 -- mention attribute 'Result.
5385 elsif Present
(Post_Prag
)
5386 and then not Seen_In_Post
5387 and then not Is_Trivial_Boolean
5388 (Get_Pragma_Arg
(First
(Pragma_Argument_Associations
(Post_Prag
))))
5391 ("postcondition does not mention function result?.t?", Post_Prag
);
5393 end Check_Result_And_Post_State
;
5395 -----------------------------
5396 -- Check_State_Refinements --
5397 -----------------------------
5399 procedure Check_State_Refinements
5401 Is_Main_Unit
: Boolean := False)
5403 procedure Check_Package
(Pack
: Node_Id
);
5404 -- Verify that all abstract states of a [generic] package denoted by its
5405 -- declarative node Pack have proper refinement. Recursively verify the
5406 -- visible and private declarations of the [generic] package for other
5409 procedure Check_Packages_In
(Decls
: List_Id
);
5410 -- Seek out [generic] package declarations within declarative list Decls
5411 -- and verify the status of their abstract state refinement.
5413 function SPARK_Mode_Is_Off
(N
: Node_Id
) return Boolean;
5414 -- Determine whether construct N is subject to pragma SPARK_Mode Off
5420 procedure Check_Package
(Pack
: Node_Id
) is
5421 Body_Id
: constant Entity_Id
:= Corresponding_Body
(Pack
);
5422 Spec
: constant Node_Id
:= Specification
(Pack
);
5423 States
: constant Elist_Id
:=
5424 Abstract_States
(Defining_Entity
(Pack
));
5426 State_Elmt
: Elmt_Id
;
5427 State_Id
: Entity_Id
;
5430 -- Do not verify proper state refinement when the package is subject
5431 -- to pragma SPARK_Mode Off because this disables the requirement for
5432 -- state refinement.
5434 if SPARK_Mode_Is_Off
(Pack
) then
5437 -- State refinement can only occur in a completing package body. Do
5438 -- not verify proper state refinement when the body is subject to
5439 -- pragma SPARK_Mode Off because this disables the requirement for
5440 -- state refinement.
5442 elsif Present
(Body_Id
)
5443 and then SPARK_Mode_Is_Off
(Unit_Declaration_Node
(Body_Id
))
5447 -- Do not verify proper state refinement when the package is an
5448 -- instance as this check was already performed in the generic.
5450 elsif Present
(Generic_Parent
(Spec
)) then
5453 -- Otherwise examine the contents of the package
5456 if Present
(States
) then
5457 State_Elmt
:= First_Elmt
(States
);
5458 while Present
(State_Elmt
) loop
5459 State_Id
:= Node
(State_Elmt
);
5461 -- Emit an error when a non-null state lacks any form of
5464 if not Is_Null_State
(State_Id
)
5465 and then not Has_Null_Refinement
(State_Id
)
5466 and then not Has_Non_Null_Refinement
(State_Id
)
5468 Error_Msg_N
("state & requires refinement", State_Id
);
5469 Error_Msg_N
("\package body should have Refined_State "
5470 & "for state & with constituents", State_Id
);
5473 Next_Elmt
(State_Elmt
);
5477 Check_Packages_In
(Visible_Declarations
(Spec
));
5478 Check_Packages_In
(Private_Declarations
(Spec
));
5482 -----------------------
5483 -- Check_Packages_In --
5484 -----------------------
5486 procedure Check_Packages_In
(Decls
: List_Id
) is
5490 if Present
(Decls
) then
5491 Decl
:= First
(Decls
);
5492 while Present
(Decl
) loop
5493 if Nkind
(Decl
) in N_Generic_Package_Declaration
5494 | N_Package_Declaration
5496 Check_Package
(Decl
);
5502 end Check_Packages_In
;
5504 -----------------------
5505 -- SPARK_Mode_Is_Off --
5506 -----------------------
5508 function SPARK_Mode_Is_Off
(N
: Node_Id
) return Boolean is
5509 Id
: constant Entity_Id
:= Defining_Entity
(N
);
5510 Prag
: constant Node_Id
:= SPARK_Pragma
(Id
);
5513 -- Default the mode to "off" when the context is an instance and all
5514 -- SPARK_Mode pragmas found within are to be ignored.
5516 if Ignore_SPARK_Mode_Pragmas
(Id
) then
5522 and then Get_SPARK_Mode_From_Annotation
(Prag
) = Off
;
5524 end SPARK_Mode_Is_Off
;
5526 -- Start of processing for Check_State_Refinements
5529 -- A block may declare a nested package
5531 if Nkind
(Context
) = N_Block_Statement
then
5532 Check_Packages_In
(Declarations
(Context
));
5534 -- An entry, protected, subprogram, or task body may declare a nested
5537 elsif Nkind
(Context
) in N_Entry_Body
5542 -- Do not verify proper state refinement when the body is subject to
5543 -- pragma SPARK_Mode Off because this disables the requirement for
5544 -- state refinement.
5546 if not SPARK_Mode_Is_Off
(Context
) then
5547 Check_Packages_In
(Declarations
(Context
));
5550 -- A package body may declare a nested package
5552 elsif Nkind
(Context
) = N_Package_Body
then
5553 Check_Package
(Unit_Declaration_Node
(Corresponding_Spec
(Context
)));
5555 -- Do not verify proper state refinement when the body is subject to
5556 -- pragma SPARK_Mode Off because this disables the requirement for
5557 -- state refinement.
5559 if not SPARK_Mode_Is_Off
(Context
) then
5560 Check_Packages_In
(Declarations
(Context
));
5563 -- A library level [generic] package may declare a nested package
5565 elsif Nkind
(Context
) in
5566 N_Generic_Package_Declaration | N_Package_Declaration
5567 and then Is_Main_Unit
5569 Check_Package
(Context
);
5571 end Check_State_Refinements
;
5573 ------------------------------
5574 -- Check_Unprotected_Access --
5575 ------------------------------
5577 procedure Check_Unprotected_Access
5581 Cont_Encl_Typ
: Entity_Id
;
5582 Pref_Encl_Typ
: Entity_Id
;
5584 function Enclosing_Protected_Type
(Obj
: Node_Id
) return Entity_Id
;
5585 -- Check whether Obj is a private component of a protected object.
5586 -- Return the protected type where the component resides, Empty
5589 function Is_Public_Operation
return Boolean;
5590 -- Verify that the enclosing operation is callable from outside the
5591 -- protected object, to minimize false positives.
5593 ------------------------------
5594 -- Enclosing_Protected_Type --
5595 ------------------------------
5597 function Enclosing_Protected_Type
(Obj
: Node_Id
) return Entity_Id
is
5599 if Is_Entity_Name
(Obj
) then
5601 Ent
: Entity_Id
:= Entity
(Obj
);
5604 -- The object can be a renaming of a private component, use
5605 -- the original record component.
5607 if Is_Prival
(Ent
) then
5608 Ent
:= Prival_Link
(Ent
);
5611 if Is_Protected_Type
(Scope
(Ent
)) then
5617 -- For indexed and selected components, recursively check the prefix
5619 if Nkind
(Obj
) in N_Indexed_Component | N_Selected_Component
then
5620 return Enclosing_Protected_Type
(Prefix
(Obj
));
5622 -- The object does not denote a protected component
5627 end Enclosing_Protected_Type
;
5629 -------------------------
5630 -- Is_Public_Operation --
5631 -------------------------
5633 function Is_Public_Operation
return Boolean is
5639 while Present
(S
) and then S
/= Pref_Encl_Typ
loop
5640 if Scope
(S
) = Pref_Encl_Typ
then
5641 E
:= First_Entity
(Pref_Encl_Typ
);
5643 and then E
/= First_Private_Entity
(Pref_Encl_Typ
)
5657 end Is_Public_Operation
;
5659 -- Start of processing for Check_Unprotected_Access
5662 if Nkind
(Expr
) = N_Attribute_Reference
5663 and then Attribute_Name
(Expr
) = Name_Unchecked_Access
5665 Cont_Encl_Typ
:= Enclosing_Protected_Type
(Context
);
5666 Pref_Encl_Typ
:= Enclosing_Protected_Type
(Prefix
(Expr
));
5668 -- Check whether we are trying to export a protected component to a
5669 -- context with an equal or lower access level.
5671 if Present
(Pref_Encl_Typ
)
5672 and then No
(Cont_Encl_Typ
)
5673 and then Is_Public_Operation
5674 and then Scope_Depth
(Pref_Encl_Typ
)
5675 >= Static_Accessibility_Level
5676 (Context
, Object_Decl_Level
)
5679 ("??possible unprotected access to protected data", Expr
);
5682 end Check_Unprotected_Access
;
5684 ------------------------------
5685 -- Check_Unused_Body_States --
5686 ------------------------------
5688 procedure Check_Unused_Body_States
(Body_Id
: Entity_Id
) is
5689 procedure Process_Refinement_Clause
5692 -- Inspect all constituents of refinement clause Clause and remove any
5693 -- matches from body state list States.
5695 procedure Report_Unused_Body_States
(States
: Elist_Id
);
5696 -- Emit errors for each abstract state or object found in list States
5698 -------------------------------
5699 -- Process_Refinement_Clause --
5700 -------------------------------
5702 procedure Process_Refinement_Clause
5706 procedure Process_Constituent
(Constit
: Node_Id
);
5707 -- Remove constituent Constit from body state list States
5709 -------------------------
5710 -- Process_Constituent --
5711 -------------------------
5713 procedure Process_Constituent
(Constit
: Node_Id
) is
5714 Constit_Id
: Entity_Id
;
5717 -- Guard against illegal constituents. Only abstract states and
5718 -- objects can appear on the right hand side of a refinement.
5720 if Is_Entity_Name
(Constit
) then
5721 Constit_Id
:= Entity_Of
(Constit
);
5723 if Present
(Constit_Id
)
5724 and then Ekind
(Constit_Id
) in
5725 E_Abstract_State | E_Constant | E_Variable
5727 Remove
(States
, Constit_Id
);
5730 end Process_Constituent
;
5736 -- Start of processing for Process_Refinement_Clause
5739 if Nkind
(Clause
) = N_Component_Association
then
5740 Constit
:= Expression
(Clause
);
5742 -- Multiple constituents appear as an aggregate
5744 if Nkind
(Constit
) = N_Aggregate
then
5745 Constit
:= First
(Expressions
(Constit
));
5746 while Present
(Constit
) loop
5747 Process_Constituent
(Constit
);
5751 -- Various forms of a single constituent
5754 Process_Constituent
(Constit
);
5757 end Process_Refinement_Clause
;
5759 -------------------------------
5760 -- Report_Unused_Body_States --
5761 -------------------------------
5763 procedure Report_Unused_Body_States
(States
: Elist_Id
) is
5764 Posted
: Boolean := False;
5765 State_Elmt
: Elmt_Id
;
5766 State_Id
: Entity_Id
;
5769 if Present
(States
) then
5770 State_Elmt
:= First_Elmt
(States
);
5771 while Present
(State_Elmt
) loop
5772 State_Id
:= Node
(State_Elmt
);
5774 -- Constants are part of the hidden state of a package, but the
5775 -- compiler cannot determine whether they have variable input
5776 -- (SPARK RM 7.1.1(2)) and cannot classify them properly as a
5777 -- hidden state. Do not emit an error when a constant does not
5778 -- participate in a state refinement, even though it acts as a
5781 if Ekind
(State_Id
) = E_Constant
then
5784 -- Overlays do not contribute to package state
5786 elsif Ekind
(State_Id
) = E_Variable
5787 and then Present
(Ultimate_Overlaid_Entity
(State_Id
))
5791 -- Generate an error message of the form:
5793 -- body of package ... has unused hidden states
5794 -- abstract state ... defined at ...
5795 -- variable ... defined at ...
5801 ("body of package & has unused hidden states", Body_Id
);
5804 Error_Msg_Sloc
:= Sloc
(State_Id
);
5806 if Ekind
(State_Id
) = E_Abstract_State
then
5808 ("\abstract state & defined #", Body_Id
, State_Id
);
5811 SPARK_Msg_NE
("\variable & defined #", Body_Id
, State_Id
);
5815 Next_Elmt
(State_Elmt
);
5818 end Report_Unused_Body_States
;
5822 Prag
: constant Node_Id
:= Get_Pragma
(Body_Id
, Pragma_Refined_State
);
5823 Spec_Id
: constant Entity_Id
:= Spec_Entity
(Body_Id
);
5827 -- Start of processing for Check_Unused_Body_States
5830 -- Inspect the clauses of pragma Refined_State and determine whether all
5831 -- visible states declared within the package body participate in the
5834 if Present
(Prag
) then
5835 Clause
:= Expression
(Get_Argument
(Prag
, Spec_Id
));
5836 States
:= Collect_Body_States
(Body_Id
);
5838 -- Multiple non-null state refinements appear as an aggregate
5840 if Nkind
(Clause
) = N_Aggregate
then
5841 Clause
:= First
(Component_Associations
(Clause
));
5842 while Present
(Clause
) loop
5843 Process_Refinement_Clause
(Clause
, States
);
5847 -- Various forms of a single state refinement
5850 Process_Refinement_Clause
(Clause
, States
);
5853 -- Ensure that all abstract states and objects declared in the
5854 -- package body state space are utilized as constituents.
5856 Report_Unused_Body_States
(States
);
5858 end Check_Unused_Body_States
;
5860 ------------------------------------
5861 -- Check_Volatility_Compatibility --
5862 ------------------------------------
5864 procedure Check_Volatility_Compatibility
5865 (Id1
, Id2
: Entity_Id
;
5866 Description_1
, Description_2
: String;
5867 Srcpos_Bearer
: Node_Id
) is
5870 if SPARK_Mode
/= On
then
5875 AR1
: constant Boolean := Async_Readers_Enabled
(Id1
);
5876 AW1
: constant Boolean := Async_Writers_Enabled
(Id1
);
5877 ER1
: constant Boolean := Effective_Reads_Enabled
(Id1
);
5878 EW1
: constant Boolean := Effective_Writes_Enabled
(Id1
);
5879 AR2
: constant Boolean := Async_Readers_Enabled
(Id2
);
5880 AW2
: constant Boolean := Async_Writers_Enabled
(Id2
);
5881 ER2
: constant Boolean := Effective_Reads_Enabled
(Id2
);
5882 EW2
: constant Boolean := Effective_Writes_Enabled
(Id2
);
5884 AR_Check_Failed
: constant Boolean := AR1
and not AR2
;
5885 AW_Check_Failed
: constant Boolean := AW1
and not AW2
;
5886 ER_Check_Failed
: constant Boolean := ER1
and not ER2
;
5887 EW_Check_Failed
: constant Boolean := EW1
and not EW2
;
5889 package Failure_Description
is
5890 procedure Note_If_Failure
5891 (Failed
: Boolean; Aspect_Name
: String);
5892 -- If Failed is False, do nothing.
5893 -- If Failed is True, add Aspect_Name to the failure description.
5895 function Failure_Text
return String;
5896 -- returns accumulated list of failing aspects
5897 end Failure_Description
;
5899 package body Failure_Description
is
5900 Description_Buffer
: Bounded_String
;
5902 ---------------------
5903 -- Note_If_Failure --
5904 ---------------------
5906 procedure Note_If_Failure
5907 (Failed
: Boolean; Aspect_Name
: String) is
5910 if Description_Buffer
.Length
/= 0 then
5911 Append
(Description_Buffer
, ", ");
5913 Append
(Description_Buffer
, Aspect_Name
);
5915 end Note_If_Failure
;
5921 function Failure_Text
return String is
5923 return +Description_Buffer
;
5925 end Failure_Description
;
5927 use Failure_Description
;
5934 Note_If_Failure
(AR_Check_Failed
, "Async_Readers");
5935 Note_If_Failure
(AW_Check_Failed
, "Async_Writers");
5936 Note_If_Failure
(ER_Check_Failed
, "Effective_Reads");
5937 Note_If_Failure
(EW_Check_Failed
, "Effective_Writes");
5943 & " are not compatible with respect to volatility due to "
5948 end Check_Volatility_Compatibility
;
5954 function Choice_List
(N
: Node_Id
) return List_Id
is
5956 if Nkind
(N
) = N_Iterated_Component_Association
then
5957 return Discrete_Choices
(N
);
5963 ---------------------
5964 -- Class_Condition --
5965 ---------------------
5967 function Class_Condition
5968 (Kind
: Condition_Kind
;
5969 Subp
: Entity_Id
) return Node_Id
is
5973 when Class_Postcondition
=>
5974 return Class_Postconditions
(Subp
);
5976 when Class_Precondition
=>
5977 return Class_Preconditions
(Subp
);
5979 when Ignored_Class_Postcondition
=>
5980 return Ignored_Class_Postconditions
(Subp
);
5982 when Ignored_Class_Precondition
=>
5983 return Ignored_Class_Preconditions
(Subp
);
5985 end Class_Condition
;
5987 -------------------------
5988 -- Collect_Body_States --
5989 -------------------------
5991 function Collect_Body_States
(Body_Id
: Entity_Id
) return Elist_Id
is
5992 function Is_Visible_Object
(Obj_Id
: Entity_Id
) return Boolean;
5993 -- Determine whether object Obj_Id is a suitable visible state of a
5996 procedure Collect_Visible_States
5997 (Pack_Id
: Entity_Id
;
5998 States
: in out Elist_Id
);
5999 -- Gather the entities of all abstract states and objects declared in
6000 -- the visible state space of package Pack_Id.
6002 ----------------------------
6003 -- Collect_Visible_States --
6004 ----------------------------
6006 procedure Collect_Visible_States
6007 (Pack_Id
: Entity_Id
;
6008 States
: in out Elist_Id
)
6010 Item_Id
: Entity_Id
;
6013 -- Traverse the entity chain of the package and inspect all visible
6016 Item_Id
:= First_Entity
(Pack_Id
);
6017 while Present
(Item_Id
) and then not In_Private_Part
(Item_Id
) loop
6019 -- Do not consider internally generated items as those cannot be
6020 -- named and participate in refinement.
6022 if not Comes_From_Source
(Item_Id
) then
6025 elsif Ekind
(Item_Id
) = E_Abstract_State
then
6026 Append_New_Elmt
(Item_Id
, States
);
6028 elsif Ekind
(Item_Id
) in E_Constant | E_Variable
6029 and then Is_Visible_Object
(Item_Id
)
6031 Append_New_Elmt
(Item_Id
, States
);
6033 -- Recursively gather the visible states of a nested package
6035 elsif Ekind
(Item_Id
) = E_Package
then
6036 Collect_Visible_States
(Item_Id
, States
);
6039 Next_Entity
(Item_Id
);
6041 end Collect_Visible_States
;
6043 -----------------------
6044 -- Is_Visible_Object --
6045 -----------------------
6047 function Is_Visible_Object
(Obj_Id
: Entity_Id
) return Boolean is
6049 -- Objects that map generic formals to their actuals are not visible
6050 -- from outside the generic instantiation.
6052 if Present
(Corresponding_Generic_Association
6053 (Declaration_Node
(Obj_Id
)))
6057 -- Constituents of a single protected/task type act as components of
6058 -- the type and are not visible from outside the type.
6060 elsif Ekind
(Obj_Id
) = E_Variable
6061 and then Present
(Encapsulating_State
(Obj_Id
))
6062 and then Is_Single_Concurrent_Object
(Encapsulating_State
(Obj_Id
))
6069 end Is_Visible_Object
;
6073 Body_Decl
: constant Node_Id
:= Unit_Declaration_Node
(Body_Id
);
6075 Item_Id
: Entity_Id
;
6076 States
: Elist_Id
:= No_Elist
;
6078 -- Start of processing for Collect_Body_States
6081 -- Inspect the declarations of the body looking for source objects,
6082 -- packages and package instantiations. Note that even though this
6083 -- processing is very similar to Collect_Visible_States, a package
6084 -- body does not have a First/Next_Entity list.
6086 Decl
:= First
(Declarations
(Body_Decl
));
6087 while Present
(Decl
) loop
6089 -- Capture source objects as internally generated temporaries cannot
6090 -- be named and participate in refinement.
6092 if Nkind
(Decl
) = N_Object_Declaration
then
6093 Item_Id
:= Defining_Entity
(Decl
);
6095 if Comes_From_Source
(Item_Id
)
6096 and then Is_Visible_Object
(Item_Id
)
6098 Append_New_Elmt
(Item_Id
, States
);
6101 -- Capture the visible abstract states and objects of a source
6102 -- package [instantiation].
6104 elsif Nkind
(Decl
) = N_Package_Declaration
then
6105 Item_Id
:= Defining_Entity
(Decl
);
6107 if Comes_From_Source
(Item_Id
) then
6108 Collect_Visible_States
(Item_Id
, States
);
6116 end Collect_Body_States
;
6118 ------------------------
6119 -- Collect_Interfaces --
6120 ------------------------
6122 procedure Collect_Interfaces
6124 Ifaces_List
: out Elist_Id
;
6125 Exclude_Parents
: Boolean := False;
6126 Use_Full_View
: Boolean := True)
6128 procedure Collect
(Typ
: Entity_Id
);
6129 -- Subsidiary subprogram used to traverse the whole list
6130 -- of directly and indirectly implemented interfaces
6136 procedure Collect
(Typ
: Entity_Id
) is
6137 Ancestor
: Entity_Id
;
6145 -- Handle private types and subtypes
6148 and then Is_Private_Type
(Typ
)
6149 and then Present
(Full_View
(Typ
))
6151 Full_T
:= Full_View
(Typ
);
6153 if Ekind
(Full_T
) = E_Record_Subtype
then
6154 Full_T
:= Etype
(Typ
);
6156 if Present
(Full_View
(Full_T
)) then
6157 Full_T
:= Full_View
(Full_T
);
6162 -- Include the ancestor if we are generating the whole list of
6163 -- abstract interfaces.
6165 if Etype
(Full_T
) /= Typ
6167 -- Protect the frontend against wrong sources. For example:
6170 -- type A is tagged null record;
6171 -- type B is new A with private;
6172 -- type C is new A with private;
6174 -- type B is new C with null record;
6175 -- type C is new B with null record;
6178 and then Etype
(Full_T
) /= T
6180 Ancestor
:= Etype
(Full_T
);
6183 if Is_Interface
(Ancestor
) and then not Exclude_Parents
then
6184 Append_Unique_Elmt
(Ancestor
, Ifaces_List
);
6188 -- Traverse the graph of ancestor interfaces
6190 Id
:= First
(Abstract_Interface_List
(Full_T
));
6191 while Present
(Id
) loop
6192 Iface
:= Etype
(Id
);
6194 -- Protect against wrong uses. For example:
6195 -- type I is interface;
6196 -- type O is tagged null record;
6197 -- type Wrong is new I and O with null record; -- ERROR
6199 if Is_Interface
(Iface
) then
6201 and then Etype
(T
) /= T
6202 and then Interface_Present_In_Ancestor
(Etype
(T
), Iface
)
6207 Append_Unique_Elmt
(Iface
, Ifaces_List
);
6215 -- Start of processing for Collect_Interfaces
6218 pragma Assert
(Is_Tagged_Type
(T
) or else Is_Concurrent_Type
(T
));
6219 Ifaces_List
:= New_Elmt_List
;
6221 end Collect_Interfaces
;
6223 ----------------------------------
6224 -- Collect_Interface_Components --
6225 ----------------------------------
6227 procedure Collect_Interface_Components
6228 (Tagged_Type
: Entity_Id
;
6229 Components_List
: out Elist_Id
)
6231 procedure Collect
(Typ
: Entity_Id
);
6232 -- Subsidiary subprogram used to climb to the parents
6238 procedure Collect
(Typ
: Entity_Id
) is
6239 Tag_Comp
: Entity_Id
;
6240 Parent_Typ
: Entity_Id
;
6243 -- Handle private types
6245 if Present
(Full_View
(Etype
(Typ
))) then
6246 Parent_Typ
:= Full_View
(Etype
(Typ
));
6248 Parent_Typ
:= Etype
(Typ
);
6251 if Parent_Typ
/= Typ
6253 -- Protect the frontend against wrong sources. For example:
6256 -- type A is tagged null record;
6257 -- type B is new A with private;
6258 -- type C is new A with private;
6260 -- type B is new C with null record;
6261 -- type C is new B with null record;
6264 and then Parent_Typ
/= Tagged_Type
6266 Collect
(Parent_Typ
);
6269 -- Collect the components containing tags of secondary dispatch
6272 Tag_Comp
:= Next_Tag_Component
(First_Tag_Component
(Typ
));
6273 while Present
(Tag_Comp
) loop
6274 pragma Assert
(Present
(Related_Type
(Tag_Comp
)));
6275 Append_Elmt
(Tag_Comp
, Components_List
);
6277 Tag_Comp
:= Next_Tag_Component
(Tag_Comp
);
6281 -- Start of processing for Collect_Interface_Components
6284 pragma Assert
(Ekind
(Tagged_Type
) = E_Record_Type
6285 and then Is_Tagged_Type
(Tagged_Type
));
6287 Components_List
:= New_Elmt_List
;
6288 Collect
(Tagged_Type
);
6289 end Collect_Interface_Components
;
6291 -----------------------------
6292 -- Collect_Interfaces_Info --
6293 -----------------------------
6295 procedure Collect_Interfaces_Info
6297 Ifaces_List
: out Elist_Id
;
6298 Components_List
: out Elist_Id
;
6299 Tags_List
: out Elist_Id
)
6301 Comps_List
: Elist_Id
;
6302 Comp_Elmt
: Elmt_Id
;
6303 Comp_Iface
: Entity_Id
;
6304 Iface_Elmt
: Elmt_Id
;
6307 function Search_Tag
(Iface
: Entity_Id
) return Entity_Id
;
6308 -- Search for the secondary tag associated with the interface type
6309 -- Iface that is implemented by T.
6315 function Search_Tag
(Iface
: Entity_Id
) return Entity_Id
is
6318 if not Is_CPP_Class
(T
) then
6319 ADT
:= Next_Elmt
(Next_Elmt
(First_Elmt
(Access_Disp_Table
(T
))));
6321 ADT
:= Next_Elmt
(First_Elmt
(Access_Disp_Table
(T
)));
6325 and then Is_Tag
(Node
(ADT
))
6326 and then Related_Type
(Node
(ADT
)) /= Iface
6328 -- Skip secondary dispatch table referencing thunks to user
6329 -- defined primitives covered by this interface.
6331 pragma Assert
(Has_Suffix
(Node
(ADT
), 'P'));
6334 -- Skip secondary dispatch tables of Ada types
6336 if not Is_CPP_Class
(T
) then
6338 -- Skip secondary dispatch table referencing thunks to
6339 -- predefined primitives.
6341 pragma Assert
(Has_Suffix
(Node
(ADT
), 'Y'));
6344 -- Skip secondary dispatch table referencing user-defined
6345 -- primitives covered by this interface.
6347 pragma Assert
(Has_Suffix
(Node
(ADT
), 'D'));
6350 -- Skip secondary dispatch table referencing predefined
6353 pragma Assert
(Has_Suffix
(Node
(ADT
), 'Z'));
6358 pragma Assert
(Is_Tag
(Node
(ADT
)));
6362 -- Start of processing for Collect_Interfaces_Info
6365 Collect_Interfaces
(T
, Ifaces_List
);
6366 Collect_Interface_Components
(T
, Comps_List
);
6368 -- Search for the record component and tag associated with each
6369 -- interface type of T.
6371 Components_List
:= New_Elmt_List
;
6372 Tags_List
:= New_Elmt_List
;
6374 Iface_Elmt
:= First_Elmt
(Ifaces_List
);
6375 while Present
(Iface_Elmt
) loop
6376 Iface
:= Node
(Iface_Elmt
);
6378 -- Associate the primary tag component and the primary dispatch table
6379 -- with all the interfaces that are parents of T
6381 if Is_Ancestor
(Iface
, T
, Use_Full_View
=> True) then
6382 Append_Elmt
(First_Tag_Component
(T
), Components_List
);
6383 Append_Elmt
(Node
(First_Elmt
(Access_Disp_Table
(T
))), Tags_List
);
6385 -- Otherwise search for the tag component and secondary dispatch
6389 Comp_Elmt
:= First_Elmt
(Comps_List
);
6390 while Present
(Comp_Elmt
) loop
6391 Comp_Iface
:= Related_Type
(Node
(Comp_Elmt
));
6393 if Comp_Iface
= Iface
6394 or else Is_Ancestor
(Iface
, Comp_Iface
, Use_Full_View
=> True)
6396 Append_Elmt
(Node
(Comp_Elmt
), Components_List
);
6397 Append_Elmt
(Search_Tag
(Comp_Iface
), Tags_List
);
6401 Next_Elmt
(Comp_Elmt
);
6403 pragma Assert
(Present
(Comp_Elmt
));
6406 Next_Elmt
(Iface_Elmt
);
6408 end Collect_Interfaces_Info
;
6410 ---------------------
6411 -- Collect_Parents --
6412 ---------------------
6414 procedure Collect_Parents
6416 List
: out Elist_Id
;
6417 Use_Full_View
: Boolean := True)
6419 Current_Typ
: Entity_Id
:= T
;
6420 Parent_Typ
: Entity_Id
;
6423 List
:= New_Elmt_List
;
6425 -- No action if the if the type has no parents
6427 if T
= Etype
(T
) then
6432 Parent_Typ
:= Etype
(Current_Typ
);
6434 if Is_Private_Type
(Parent_Typ
)
6435 and then Present
(Full_View
(Parent_Typ
))
6436 and then Use_Full_View
6438 Parent_Typ
:= Full_View
(Base_Type
(Parent_Typ
));
6441 Append_Elmt
(Parent_Typ
, List
);
6443 exit when Parent_Typ
= Current_Typ
;
6444 Current_Typ
:= Parent_Typ
;
6446 end Collect_Parents
;
6448 ----------------------------------
6449 -- Collect_Primitive_Operations --
6450 ----------------------------------
6452 function Collect_Primitive_Operations
(T
: Entity_Id
) return Elist_Id
is
6453 B_Type
: constant Entity_Id
:= Base_Type
(T
);
6455 function Match
(E
: Entity_Id
) return Boolean;
6456 -- True if E's base type is B_Type, or E is of an anonymous access type
6457 -- and the base type of its designated type is B_Type.
6463 function Match
(E
: Entity_Id
) return Boolean is
6464 Etyp
: Entity_Id
:= Etype
(E
);
6467 if Ekind
(Etyp
) = E_Anonymous_Access_Type
then
6468 Etyp
:= Designated_Type
(Etyp
);
6471 -- In Ada 2012 a primitive operation may have a formal of an
6472 -- incomplete view of the parent type.
6474 return Base_Type
(Etyp
) = B_Type
6476 (Ada_Version
>= Ada_2012
6477 and then Ekind
(Etyp
) = E_Incomplete_Type
6478 and then Full_View
(Etyp
) = B_Type
);
6483 B_Decl
: constant Node_Id
:= Original_Node
(Parent
(B_Type
));
6484 B_Scope
: Entity_Id
:= Scope
(B_Type
);
6486 Eq_Prims_List
: Elist_Id
:= No_Elist
;
6489 Is_Type_In_Pkg
: Boolean;
6490 Formal_Derived
: Boolean := False;
6493 -- Start of processing for Collect_Primitive_Operations
6496 -- For tagged types, the primitive operations are collected as they
6497 -- are declared, and held in an explicit list which is simply returned.
6499 if Is_Tagged_Type
(B_Type
) then
6500 return Primitive_Operations
(B_Type
);
6502 -- An untagged generic type that is a derived type inherits the
6503 -- primitive operations of its parent type. Other formal types only
6504 -- have predefined operators, which are not explicitly represented.
6506 elsif Is_Generic_Type
(B_Type
) then
6507 if Nkind
(B_Decl
) = N_Formal_Type_Declaration
6508 and then Nkind
(Formal_Type_Definition
(B_Decl
)) =
6509 N_Formal_Derived_Type_Definition
6511 Formal_Derived
:= True;
6513 return New_Elmt_List
;
6517 Op_List
:= New_Elmt_List
;
6519 if B_Scope
= Standard_Standard
then
6520 if B_Type
= Standard_String
then
6521 Append_Elmt
(Standard_Op_Concat
, Op_List
);
6523 elsif B_Type
= Standard_Wide_String
then
6524 Append_Elmt
(Standard_Op_Concatw
, Op_List
);
6530 -- Locate the primitive subprograms of the type
6533 -- The primitive operations appear after the base type, except if the
6534 -- derivation happens within the private part of B_Scope and the type
6535 -- is a private type, in which case both the type and some primitive
6536 -- operations may appear before the base type, and the list of
6537 -- candidates starts after the type.
6539 if In_Open_Scopes
(B_Scope
)
6540 and then Scope
(T
) = B_Scope
6541 and then In_Private_Part
(B_Scope
)
6543 Id
:= Next_Entity
(T
);
6545 -- In Ada 2012, If the type has an incomplete partial view, there may
6546 -- be primitive operations declared before the full view, so we need
6547 -- to start scanning from the incomplete view, which is earlier on
6548 -- the entity chain.
6550 elsif Nkind
(Parent
(B_Type
)) = N_Full_Type_Declaration
6551 and then Present
(Incomplete_View
(Parent
(B_Type
)))
6553 Id
:= Incomplete_View
(Parent
(B_Type
));
6555 -- If T is a derived from a type with an incomplete view declared
6556 -- elsewhere, that incomplete view is irrelevant, we want the
6557 -- operations in the scope of T.
6559 if Scope
(Id
) /= Scope
(B_Type
) then
6560 Id
:= Next_Entity
(B_Type
);
6564 Id
:= Next_Entity
(B_Type
);
6567 -- Set flag if this is a type in a package spec
6570 Is_Package_Or_Generic_Package
(B_Scope
)
6572 Parent_Kind
(Declaration_Node
(First_Subtype
(T
))) /=
6575 while Present
(Id
) loop
6577 -- Test whether the result type or any of the parameter types of
6578 -- each subprogram following the type match that type when the
6579 -- type is declared in a package spec, is a derived type, or the
6580 -- subprogram is marked as primitive. (The Is_Primitive test is
6581 -- needed to find primitives of nonderived types in declarative
6582 -- parts that happen to override the predefined "=" operator.)
6584 -- Note that generic formal subprograms are not considered to be
6585 -- primitive operations and thus are never inherited.
6587 if Is_Overloadable
(Id
)
6588 and then (Is_Type_In_Pkg
6589 or else Is_Derived_Type
(B_Type
)
6590 or else Is_Primitive
(Id
))
6591 and then Parent_Kind
(Parent
(Id
))
6592 not in N_Formal_Subprogram_Declaration
6600 Formal
:= First_Formal
(Id
);
6601 while Present
(Formal
) loop
6602 if Match
(Formal
) then
6607 Next_Formal
(Formal
);
6611 -- For a formal derived type, the only primitives are the ones
6612 -- inherited from the parent type. Operations appearing in the
6613 -- package declaration are not primitive for it.
6616 and then (not Formal_Derived
or else Present
(Alias
(Id
)))
6618 -- In the special case of an equality operator aliased to
6619 -- an overriding dispatching equality belonging to the same
6620 -- type, we don't include it in the list of primitives.
6621 -- This avoids inheriting multiple equality operators when
6622 -- deriving from untagged private types whose full type is
6623 -- tagged, which can otherwise cause ambiguities. Note that
6624 -- this should only happen for this kind of untagged parent
6625 -- type, since normally dispatching operations are inherited
6626 -- using the type's Primitive_Operations list.
6628 if Chars
(Id
) = Name_Op_Eq
6629 and then Is_Dispatching_Operation
(Id
)
6630 and then Present
(Alias
(Id
))
6631 and then Present
(Overridden_Operation
(Alias
(Id
)))
6632 and then Base_Type
(Etype
(First_Entity
(Id
))) =
6633 Base_Type
(Etype
(First_Entity
(Alias
(Id
))))
6637 -- Include the subprogram in the list of primitives
6640 Append_Elmt
(Id
, Op_List
);
6642 -- Save collected equality primitives for later filtering
6643 -- (if we are processing a private type for which we can
6644 -- collect several candidates).
6646 if Inherits_From_Tagged_Full_View
(T
)
6647 and then Chars
(Id
) = Name_Op_Eq
6648 and then Etype
(First_Formal
(Id
)) =
6649 Etype
(Next_Formal
(First_Formal
(Id
)))
6651 Append_New_Elmt
(Id
, Eq_Prims_List
);
6659 -- For a type declared in System, some of its operations may
6660 -- appear in the target-specific extension to System.
6663 and then Is_RTU
(B_Scope
, System
)
6664 and then Present_System_Aux
6666 B_Scope
:= System_Aux_Id
;
6667 Id
:= First_Entity
(System_Aux_Id
);
6671 -- Filter collected equality primitives
6673 if Inherits_From_Tagged_Full_View
(T
)
6674 and then Present
(Eq_Prims_List
)
6677 First
: constant Elmt_Id
:= First_Elmt
(Eq_Prims_List
);
6681 pragma Assert
(No
(Next_Elmt
(First
))
6682 or else No
(Next_Elmt
(Next_Elmt
(First
))));
6684 -- No action needed if we have collected a single equality
6687 if Present
(Next_Elmt
(First
)) then
6688 Second
:= Next_Elmt
(First
);
6690 if Is_Dispatching_Operation
6691 (Ultimate_Alias
(Node
(First
)))
6693 Remove
(Op_List
, Node
(First
));
6695 elsif Is_Dispatching_Operation
6696 (Ultimate_Alias
(Node
(Second
)))
6698 Remove
(Op_List
, Node
(Second
));
6701 raise Program_Error
;
6709 end Collect_Primitive_Operations
;
6711 -----------------------------------
6712 -- Compile_Time_Constraint_Error --
6713 -----------------------------------
6715 function Compile_Time_Constraint_Error
6718 Ent
: Entity_Id
:= Empty
;
6719 Loc
: Source_Ptr
:= No_Location
;
6720 Warn
: Boolean := False;
6721 Extra_Msg
: String := "") return Node_Id
6723 Msgc
: String (1 .. Msg
'Length + 3);
6724 -- Copy of message, with room for possible ?? or << and ! at end
6730 -- Start of processing for Compile_Time_Constraint_Error
6733 -- If this is a warning, convert it into an error if we are in code
6734 -- subject to SPARK_Mode being set On, unless Warn is True to force a
6735 -- warning. The rationale is that a compile-time constraint error should
6736 -- lead to an error instead of a warning when SPARK_Mode is On, but in
6737 -- a few cases we prefer to issue a warning and generate both a suitable
6738 -- run-time error in GNAT and a suitable check message in GNATprove.
6739 -- Those cases are those that likely correspond to deactivated SPARK
6740 -- code, so that this kind of code can be compiled and analyzed instead
6741 -- of being rejected.
6743 Error_Msg_Warn
:= Warn
or SPARK_Mode
/= On
;
6745 -- A static constraint error in an instance body is not a fatal error.
6746 -- We choose to inhibit the message altogether, because there is no
6747 -- obvious node (for now) on which to post it. On the other hand the
6748 -- offending node must be replaced with a constraint_error in any case.
6750 -- No messages are generated if we already posted an error on this node
6752 if not Error_Posted
(N
) then
6753 if Loc
/= No_Location
then
6759 -- Copy message to Msgc, converting any ? in the message into <
6760 -- instead, so that we have an error in GNATprove mode.
6764 for J
in 1 .. Msgl
loop
6765 if Msg
(J
) = '?' and then (J
= 1 or else Msg
(J
- 1) /= ''') then
6768 Msgc
(J
) := Msg
(J
);
6772 -- Message is a warning, even in Ada 95 case
6774 if Msg
(Msg
'Last) = '?' or else Msg
(Msg
'Last) = '<' then
6777 -- In Ada 83, all messages are warnings. In the private part and the
6778 -- body of an instance, constraint_checks are only warnings. We also
6779 -- make this a warning if the Warn parameter is set.
6782 or else (Ada_Version
= Ada_83
and then Comes_From_Source
(N
))
6783 or else In_Instance_Not_Visible
6791 -- Otherwise we have a real error message (Ada 95 static case) and we
6792 -- make this an unconditional message. Note that in the warning case
6793 -- we do not make the message unconditional, it seems reasonable to
6794 -- delete messages like this (about exceptions that will be raised)
6803 -- One more test, skip the warning if the related expression is
6804 -- statically unevaluated, since we don't want to warn about what
6805 -- will happen when something is evaluated if it never will be
6808 -- Suppress error reporting when checking that the expression of a
6809 -- static expression function is a potentially static expression,
6810 -- because we don't want additional errors being reported during the
6811 -- preanalysis of the expression (see Analyze_Expression_Function).
6813 if not Is_Statically_Unevaluated
(N
)
6814 and then not Checking_Potentially_Static_Expression
6816 if Present
(Ent
) then
6817 Error_Msg_NEL
(Msgc
(1 .. Msgl
), N
, Ent
, Eloc
);
6819 Error_Msg_NEL
(Msgc
(1 .. Msgl
), N
, Etype
(N
), Eloc
);
6822 -- Emit any extra message as a continuation
6824 if Extra_Msg
/= "" then
6825 Error_Msg_N
('\' & Extra_Msg
, N
);
6830 -- Check whether the context is an Init_Proc
6832 if Inside_Init_Proc
then
6834 Init_Proc_Type
: constant Entity_Id
:=
6835 Etype
(First_Formal
(Current_Scope_No_Loops
));
6837 Conc_Typ
: constant Entity_Id
:=
6838 (if Present
(Init_Proc_Type
)
6839 and then Init_Proc_Type
in E_Record_Type_Id
6840 then Corresponding_Concurrent_Type
(Init_Proc_Type
)
6844 -- Don't complain if the corresponding concurrent type
6845 -- doesn't come from source (i.e. a single task/protected
6848 if Present
(Conc_Typ
)
6849 and then not Comes_From_Source
(Conc_Typ
)
6851 Error_Msg
("\& [<<", Eloc
, N
);
6854 if GNATprove_Mode
then
6856 ("\Constraint_Error would have been raised"
6857 & " for objects of this type", Eloc
, N
);
6860 ("\Constraint_Error will be raised"
6861 & " for objects of this type??", Eloc
, N
);
6867 Error_Msg
("\Constraint_Error [<<", Eloc
, N
);
6871 Error_Msg
("\static expression fails Constraint_Check", Eloc
);
6872 Set_Error_Posted
(N
);
6878 end Compile_Time_Constraint_Error
;
6880 ----------------------------
6881 -- Compute_Returns_By_Ref --
6882 ----------------------------
6884 procedure Compute_Returns_By_Ref
(Func
: Entity_Id
) is
6885 Kind
: constant Entity_Kind
:= Ekind
(Func
);
6886 Typ
: constant Entity_Id
:= Etype
(Func
);
6889 -- Nothing to do for procedures
6891 if Kind
in E_Procedure | E_Generic_Procedure
6892 or else (Kind
= E_Subprogram_Type
and then Typ
= Standard_Void_Type
)
6896 -- The build-in-place protocols return a reference to the result
6898 elsif Is_Build_In_Place_Function
(Func
) then
6899 Set_Returns_By_Ref
(Func
);
6901 -- In Ada 95, limited types are returned by reference
6903 elsif Is_Limited_View
(Typ
) then
6904 Set_Returns_By_Ref
(Func
);
6906 end Compute_Returns_By_Ref
;
6908 --------------------------------
6909 -- Collect_Types_In_Hierarchy --
6910 --------------------------------
6912 function Collect_Types_In_Hierarchy
6914 Examine_Components
: Boolean := False) return Elist_Id
6918 procedure Process_Type
(Typ
: Entity_Id
);
6919 -- Collect type Typ if it satisfies function Predicate. Do so for its
6920 -- parent type, base type, progenitor types, and any component types.
6926 procedure Process_Type
(Typ
: Entity_Id
) is
6928 Iface_Elmt
: Elmt_Id
;
6931 if not Is_Type
(Typ
) or else Error_Posted
(Typ
) then
6935 -- Collect the current type if it satisfies the predicate
6937 if Predicate
(Typ
) then
6938 Append_Elmt
(Typ
, Results
);
6941 -- Process component types
6943 if Examine_Components
then
6945 -- Examine components and discriminants
6947 if Is_Concurrent_Type
(Typ
)
6948 or else Is_Incomplete_Or_Private_Type
(Typ
)
6949 or else Is_Record_Type
(Typ
)
6950 or else Has_Discriminants
(Typ
)
6952 Comp
:= First_Component_Or_Discriminant
(Typ
);
6954 while Present
(Comp
) loop
6955 Process_Type
(Etype
(Comp
));
6957 Next_Component_Or_Discriminant
(Comp
);
6960 -- Examine array components
6962 elsif Ekind
(Typ
) = E_Array_Type
then
6963 Process_Type
(Component_Type
(Typ
));
6967 -- Examine parent type
6969 if Etype
(Typ
) /= Typ
then
6970 Process_Type
(Etype
(Typ
));
6973 -- Examine base type
6975 if Base_Type
(Typ
) /= Typ
then
6976 Process_Type
(Base_Type
(Typ
));
6979 -- Examine interfaces
6981 if Is_Record_Type
(Typ
)
6982 and then Present
(Interfaces
(Typ
))
6984 Iface_Elmt
:= First_Elmt
(Interfaces
(Typ
));
6985 while Present
(Iface_Elmt
) loop
6986 Process_Type
(Node
(Iface_Elmt
));
6988 Next_Elmt
(Iface_Elmt
);
6993 -- Start of processing for Collect_Types_In_Hierarchy
6996 Results
:= New_Elmt_List
;
6999 end Collect_Types_In_Hierarchy
;
7001 -----------------------
7002 -- Conditional_Delay --
7003 -----------------------
7005 procedure Conditional_Delay
(New_Ent
, Old_Ent
: Entity_Id
) is
7007 if Has_Delayed_Freeze
(Old_Ent
) and then not Is_Frozen
(Old_Ent
) then
7008 Set_Has_Delayed_Freeze
(New_Ent
);
7010 end Conditional_Delay
;
7012 -------------------------
7013 -- Copy_Component_List --
7014 -------------------------
7016 function Copy_Component_List
7018 Loc
: Source_Ptr
) return List_Id
7021 Comps
: constant List_Id
:= New_List
;
7024 Comp
:= First_Component
(Underlying_Type
(R_Typ
));
7025 while Present
(Comp
) loop
7026 if Comes_From_Source
(Comp
) then
7028 Comp_Decl
: constant Node_Id
:= Declaration_Node
(Comp
);
7031 Make_Component_Declaration
(Loc
,
7032 Defining_Identifier
=>
7033 Make_Defining_Identifier
(Loc
, Chars
(Comp
)),
7034 Component_Definition
=>
7036 (Component_Definition
(Comp_Decl
), New_Sloc
=> Loc
)));
7040 Next_Component
(Comp
);
7044 end Copy_Component_List
;
7046 -------------------------
7047 -- Copy_Parameter_List --
7048 -------------------------
7050 function Copy_Parameter_List
(Subp_Id
: Entity_Id
) return List_Id
is
7051 Loc
: constant Source_Ptr
:= Sloc
(Subp_Id
);
7053 Formal
: Entity_Id
:= First_Formal
(Subp_Id
);
7056 if Present
(Formal
) then
7058 while Present
(Formal
) loop
7060 Make_Parameter_Specification
(Loc
,
7061 Defining_Identifier
=>
7062 Make_Defining_Identifier
(Sloc
(Formal
), Chars
(Formal
)),
7063 In_Present
=> In_Present
(Parent
(Formal
)),
7064 Out_Present
=> Out_Present
(Parent
(Formal
)),
7066 New_Occurrence_Of
(Etype
(Formal
), Loc
),
7068 New_Copy_Tree
(Expression
(Parent
(Formal
)))));
7070 Next_Formal
(Formal
);
7077 end Copy_Parameter_List
;
7079 ----------------------------
7080 -- Copy_SPARK_Mode_Aspect --
7081 ----------------------------
7083 procedure Copy_SPARK_Mode_Aspect
(From
: Node_Id
; To
: Node_Id
) is
7084 pragma Assert
(not Has_Aspects
(To
));
7088 if Has_Aspects
(From
) then
7089 Asp
:= Find_Aspect
(Defining_Entity
(From
), Aspect_SPARK_Mode
);
7091 if Present
(Asp
) then
7092 Set_Aspect_Specifications
(To
, New_List
(New_Copy_Tree
(Asp
)));
7093 Set_Has_Aspects
(To
, True);
7096 end Copy_SPARK_Mode_Aspect
;
7098 --------------------------
7099 -- Copy_Subprogram_Spec --
7100 --------------------------
7102 function Copy_Subprogram_Spec
7104 New_Sloc
: Source_Ptr
:= No_Location
) return Node_Id
7107 Formal_Spec
: Node_Id
;
7111 -- The structure of the original tree must be replicated without any
7112 -- alterations. Use New_Copy_Tree for this purpose.
7114 Result
:= New_Copy_Tree
(Spec
, New_Sloc
=> New_Sloc
);
7116 -- However, the spec of a null procedure carries the corresponding null
7117 -- statement of the body (created by the parser), and this cannot be
7118 -- shared with the new subprogram spec.
7120 if Nkind
(Result
) = N_Procedure_Specification
then
7121 Set_Null_Statement
(Result
, Empty
);
7124 -- Create a new entity for the defining unit name
7126 Def_Id
:= Defining_Unit_Name
(Result
);
7127 Set_Defining_Unit_Name
(Result
,
7128 Make_Defining_Identifier
(Sloc
(Def_Id
), Chars
(Def_Id
)));
7130 -- Create new entities for the formal parameters
7132 Formal_Spec
:= First
(Parameter_Specifications
(Result
));
7133 while Present
(Formal_Spec
) loop
7134 Def_Id
:= Defining_Identifier
(Formal_Spec
);
7135 Set_Defining_Identifier
(Formal_Spec
,
7136 Make_Defining_Identifier
(Sloc
(Def_Id
), Chars
(Def_Id
)));
7142 end Copy_Subprogram_Spec
;
7144 --------------------------------
7145 -- Corresponding_Generic_Type --
7146 --------------------------------
7148 function Corresponding_Generic_Type
(T
: Entity_Id
) return Entity_Id
is
7154 if not Is_Generic_Actual_Type
(T
) then
7157 -- If the actual is the actual of an enclosing instance, resolution
7158 -- was correct in the generic.
7160 elsif Nkind
(Parent
(T
)) = N_Subtype_Declaration
7161 and then Is_Entity_Name
(Subtype_Indication
(Parent
(T
)))
7163 Is_Generic_Actual_Type
(Entity
(Subtype_Indication
(Parent
(T
))))
7170 if Is_Wrapper_Package
(Inst
) then
7171 Inst
:= Related_Instance
(Inst
);
7176 (Specification
(Unit_Declaration_Node
(Inst
)));
7178 -- Generic actual has the same name as the corresponding formal
7180 Typ
:= First_Entity
(Gen
);
7181 while Present
(Typ
) loop
7182 if Chars
(Typ
) = Chars
(T
) then
7191 end Corresponding_Generic_Type
;
7193 --------------------------------
7194 -- Corresponding_Primitive_Op --
7195 --------------------------------
7197 function Corresponding_Primitive_Op
7198 (Ancestor_Op
: Entity_Id
;
7199 Descendant_Type
: Entity_Id
) return Entity_Id
7201 Typ
: constant Entity_Id
:= Find_Dispatching_Type
(Ancestor_Op
);
7206 pragma Assert
(Is_Dispatching_Operation
(Ancestor_Op
));
7207 pragma Assert
(Is_Ancestor
(Typ
, Descendant_Type
)
7208 or else Is_Progenitor
(Typ
, Descendant_Type
));
7210 Elmt
:= First_Elmt
(Primitive_Operations
(Descendant_Type
));
7212 while Present
(Elmt
) loop
7213 Subp
:= Node
(Elmt
);
7215 -- For regular primitives we only need to traverse the chain of
7216 -- ancestors when the name matches the name of Ancestor_Op, but
7217 -- for predefined dispatching operations we cannot rely on the
7218 -- name of the primitive to identify a candidate since their name
7219 -- is internally built adding a suffix to the name of the tagged
7222 if Chars
(Subp
) = Chars
(Ancestor_Op
)
7223 or else Is_Predefined_Dispatching_Operation
(Subp
)
7225 -- Handle case where Ancestor_Op is a primitive of a progenitor.
7226 -- We rely on internal entities that map interface primitives:
7227 -- their attribute Interface_Alias references the interface
7228 -- primitive, and their Alias attribute references the primitive
7229 -- of Descendant_Type implementing that interface primitive.
7231 if Present
(Interface_Alias
(Subp
)) then
7232 if Interface_Alias
(Subp
) = Ancestor_Op
then
7233 return Alias
(Subp
);
7236 -- Traverse the chain of ancestors searching for Ancestor_Op.
7237 -- Overridden primitives have attribute Overridden_Operation;
7238 -- inherited primitives have attribute Alias.
7243 while Present
(Overridden_Operation
(Prim
))
7244 or else Present
(Alias
(Prim
))
7246 if Present
(Overridden_Operation
(Prim
)) then
7247 Prim
:= Overridden_Operation
(Prim
);
7249 Prim
:= Alias
(Prim
);
7252 if Prim
= Ancestor_Op
then
7262 pragma Assert
(False);
7264 end Corresponding_Primitive_Op
;
7266 --------------------
7267 -- Current_Entity --
7268 --------------------
7270 -- The currently visible definition for a given identifier is the
7271 -- one most chained at the start of the visibility chain, i.e. the
7272 -- one that is referenced by the Node_Id value of the name of the
7273 -- given identifier.
7275 function Current_Entity
(N
: Node_Id
) return Entity_Id
is
7277 return Get_Name_Entity_Id
(Chars
(N
));
7280 -----------------------------
7281 -- Current_Entity_In_Scope --
7282 -----------------------------
7284 function Current_Entity_In_Scope
(N
: Name_Id
) return Entity_Id
is
7285 CS
: constant Entity_Id
:= Current_Scope
;
7290 E
:= Get_Name_Entity_Id
(N
);
7295 elsif Scope_Is_Transient
then
7296 while Present
(E
) loop
7297 exit when Scope
(E
) = CS
or else Scope
(E
) = Scope
(CS
);
7303 while Present
(E
) loop
7304 exit when Scope
(E
) = CS
;
7311 end Current_Entity_In_Scope
;
7313 -----------------------------
7314 -- Current_Entity_In_Scope --
7315 -----------------------------
7317 function Current_Entity_In_Scope
(N
: Node_Id
) return Entity_Id
is
7319 return Current_Entity_In_Scope
(Chars
(N
));
7320 end Current_Entity_In_Scope
;
7326 function Current_Scope
return Entity_Id
is
7328 if Scope_Stack
.Last
= -1 then
7329 return Standard_Standard
;
7332 C
: constant Entity_Id
:=
7333 Scope_Stack
.Table
(Scope_Stack
.Last
).Entity
;
7338 return Standard_Standard
;
7344 ----------------------------
7345 -- Current_Scope_No_Loops --
7346 ----------------------------
7348 function Current_Scope_No_Loops
return Entity_Id
is
7352 -- Examine the scope stack starting from the current scope and skip any
7353 -- internally generated loops.
7356 while Present
(S
) and then S
/= Standard_Standard
loop
7357 if Ekind
(S
) = E_Loop
and then not Comes_From_Source
(S
) then
7365 end Current_Scope_No_Loops
;
7367 ------------------------
7368 -- Current_Subprogram --
7369 ------------------------
7371 function Current_Subprogram
return Entity_Id
is
7372 Scop
: constant Entity_Id
:= Current_Scope
;
7374 if Is_Subprogram_Or_Generic_Subprogram
(Scop
) then
7377 return Enclosing_Subprogram
(Scop
);
7379 end Current_Subprogram
;
7381 ------------------------------
7382 -- CW_Or_Needs_Finalization --
7383 ------------------------------
7385 function CW_Or_Needs_Finalization
(Typ
: Entity_Id
) return Boolean is
7387 return Is_Class_Wide_Type
(Typ
) or else Needs_Finalization
(Typ
);
7388 end CW_Or_Needs_Finalization
;
7390 -------------------------------
7391 -- Deepest_Type_Access_Level --
7392 -------------------------------
7394 function Deepest_Type_Access_Level
7396 Allow_Alt_Model
: Boolean := True) return Uint
7399 if Ekind
(Typ
) = E_Anonymous_Access_Type
7400 and then not Is_Local_Anonymous_Access
(Typ
)
7401 and then Nkind
(Associated_Node_For_Itype
(Typ
)) = N_Object_Declaration
7403 -- No_Dynamic_Accessibility_Checks override for alternative
7404 -- accessibility model.
7407 and then No_Dynamic_Accessibility_Checks_Enabled
(Typ
)
7409 return Type_Access_Level
(Typ
, Allow_Alt_Model
);
7412 -- Typ is the type of an Ada 2012 stand-alone object of an anonymous
7416 Scope_Depth
(Enclosing_Dynamic_Scope
7417 (Defining_Identifier
7418 (Associated_Node_For_Itype
(Typ
))));
7420 -- For generic formal type, return Int'Last (infinite).
7421 -- See comment preceding Is_Generic_Type call in Type_Access_Level.
7423 elsif Is_Generic_Type
(Root_Type
(Typ
)) then
7424 return UI_From_Int
(Int
'Last);
7427 return Type_Access_Level
(Typ
, Allow_Alt_Model
);
7429 end Deepest_Type_Access_Level
;
7431 ---------------------
7432 -- Defining_Entity --
7433 ---------------------
7435 function Defining_Entity
(N
: Node_Id
) return Entity_Id
is
7436 Ent
: constant Entity_Id
:= Defining_Entity_Or_Empty
(N
);
7439 if Present
(Ent
) then
7443 raise Program_Error
;
7445 end Defining_Entity
;
7447 ------------------------------
7448 -- Defining_Entity_Or_Empty --
7449 ------------------------------
7451 function Defining_Entity_Or_Empty
(N
: Node_Id
) return Entity_Id
is
7454 when N_Abstract_Subprogram_Declaration
7455 | N_Expression_Function
7456 | N_Formal_Subprogram_Declaration
7457 | N_Generic_Package_Declaration
7458 | N_Generic_Subprogram_Declaration
7459 | N_Package_Declaration
7461 | N_Subprogram_Body_Stub
7462 | N_Subprogram_Declaration
7463 | N_Subprogram_Renaming_Declaration
7465 return Defining_Entity
(Specification
(N
));
7467 when N_Component_Declaration
7468 | N_Defining_Program_Unit_Name
7469 | N_Discriminant_Specification
7471 | N_Entry_Declaration
7472 | N_Entry_Index_Specification
7473 | N_Exception_Declaration
7474 | N_Exception_Renaming_Declaration
7475 | N_Formal_Object_Declaration
7476 | N_Formal_Package_Declaration
7477 | N_Formal_Type_Declaration
7478 | N_Full_Type_Declaration
7479 | N_Implicit_Label_Declaration
7480 | N_Incomplete_Type_Declaration
7481 | N_Iterator_Specification
7482 | N_Loop_Parameter_Specification
7483 | N_Number_Declaration
7484 | N_Object_Declaration
7485 | N_Object_Renaming_Declaration
7486 | N_Package_Body_Stub
7487 | N_Parameter_Specification
7488 | N_Private_Extension_Declaration
7489 | N_Private_Type_Declaration
7491 | N_Protected_Body_Stub
7492 | N_Protected_Type_Declaration
7493 | N_Single_Protected_Declaration
7494 | N_Single_Task_Declaration
7495 | N_Subtype_Declaration
7498 | N_Task_Type_Declaration
7500 return Defining_Identifier
(N
);
7502 when N_Compilation_Unit
=>
7503 return Defining_Entity
(Unit
(N
));
7506 return Defining_Entity
(Proper_Body
(N
));
7508 when N_Function_Instantiation
7509 | N_Function_Specification
7510 | N_Generic_Function_Renaming_Declaration
7511 | N_Generic_Package_Renaming_Declaration
7512 | N_Generic_Procedure_Renaming_Declaration
7514 | N_Package_Instantiation
7515 | N_Package_Renaming_Declaration
7516 | N_Package_Specification
7517 | N_Procedure_Instantiation
7518 | N_Procedure_Specification
7521 Nam
: constant Node_Id
:= Defining_Unit_Name
(N
);
7522 Err
: Entity_Id
:= Empty
;
7525 if Nkind
(Nam
) in N_Entity
then
7528 -- For Error, make up a name and attach to declaration so we
7529 -- can continue semantic analysis.
7531 elsif Nam
= Error
then
7532 Err
:= Make_Temporary
(Sloc
(N
), 'T');
7533 Set_Defining_Unit_Name
(N
, Err
);
7537 -- If not an entity, get defining identifier
7540 return Defining_Identifier
(Nam
);
7544 when N_Block_Statement
7547 return Entity
(Identifier
(N
));
7552 end Defining_Entity_Or_Empty
;
7554 --------------------------
7555 -- Denotes_Discriminant --
7556 --------------------------
7558 function Denotes_Discriminant
7560 Check_Concurrent
: Boolean := False) return Boolean
7565 if not Is_Entity_Name
(N
) or else No
(Entity
(N
)) then
7571 -- If we are checking for a protected type, the discriminant may have
7572 -- been rewritten as the corresponding discriminal of the original type
7573 -- or of the corresponding concurrent record, depending on whether we
7574 -- are in the spec or body of the protected type.
7576 return Ekind
(E
) = E_Discriminant
7579 and then Ekind
(E
) = E_In_Parameter
7580 and then Present
(Discriminal_Link
(E
))
7582 (Is_Concurrent_Type
(Scope
(Discriminal_Link
(E
)))
7584 Is_Concurrent_Record_Type
(Scope
(Discriminal_Link
(E
)))));
7585 end Denotes_Discriminant
;
7587 -------------------------
7588 -- Denotes_Same_Object --
7589 -------------------------
7591 function Denotes_Same_Object
(A1
, A2
: Node_Id
) return Boolean is
7592 function Is_Object_Renaming
(N
: Node_Id
) return Boolean;
7593 -- Return true if N names an object renaming entity
7595 function Is_Valid_Renaming
(N
: Node_Id
) return Boolean;
7596 -- For renamings, return False if the prefix of any dereference within
7597 -- the renamed object_name is a variable, or any expression within the
7598 -- renamed object_name contains references to variables or calls on
7599 -- nonstatic functions; otherwise return True (RM 6.4.1(6.10/3))
7601 ------------------------
7602 -- Is_Object_Renaming --
7603 ------------------------
7605 function Is_Object_Renaming
(N
: Node_Id
) return Boolean is
7607 return Is_Entity_Name
(N
)
7608 and then Ekind
(Entity
(N
)) in E_Variable | E_Constant
7609 and then Present
(Renamed_Object
(Entity
(N
)));
7610 end Is_Object_Renaming
;
7612 -----------------------
7613 -- Is_Valid_Renaming --
7614 -----------------------
7616 function Is_Valid_Renaming
(N
: Node_Id
) return Boolean is
7618 if Is_Object_Renaming
(N
)
7619 and then not Is_Valid_Renaming
(Renamed_Object
(Entity
(N
)))
7624 -- Check if any expression within the renamed object_name contains no
7625 -- references to variables nor calls on nonstatic functions.
7627 if Nkind
(N
) = N_Indexed_Component
then
7632 Indx
:= First
(Expressions
(N
));
7633 while Present
(Indx
) loop
7634 if not Is_OK_Static_Expression
(Indx
) then
7642 elsif Nkind
(N
) = N_Slice
then
7644 Rng
: constant Node_Id
:= Discrete_Range
(N
);
7646 -- Bounds specified as a range
7648 if Nkind
(Rng
) = N_Range
then
7649 if not Is_OK_Static_Range
(Rng
) then
7653 -- Bounds specified as a constrained subtype indication
7655 elsif Nkind
(Rng
) = N_Subtype_Indication
then
7656 if not Is_OK_Static_Range
7657 (Range_Expression
(Constraint
(Rng
)))
7662 -- Bounds specified as a subtype name
7664 elsif not Is_OK_Static_Expression
(Rng
) then
7670 if Has_Prefix
(N
) then
7672 P
: constant Node_Id
:= Prefix
(N
);
7675 if Nkind
(N
) = N_Explicit_Dereference
7676 and then Is_Variable
(P
)
7680 elsif Is_Entity_Name
(P
)
7681 and then Ekind
(Entity
(P
)) = E_Function
7685 elsif Nkind
(P
) = N_Function_Call
then
7689 -- Recursion to continue traversing the prefix of the
7690 -- renaming expression
7692 return Is_Valid_Renaming
(P
);
7697 end Is_Valid_Renaming
;
7699 -- Start of processing for Denotes_Same_Object
7702 -- Both names statically denote the same stand-alone object or
7703 -- parameter (RM 6.4.1(6.6/3)).
7705 if Is_Entity_Name
(A1
)
7706 and then Is_Entity_Name
(A2
)
7707 and then Entity
(A1
) = Entity
(A2
)
7711 -- Both names are selected_components, their prefixes are known to
7712 -- denote the same object, and their selector_names denote the same
7713 -- component (RM 6.4.1(6.7/3)).
7715 elsif Nkind
(A1
) = N_Selected_Component
7716 and then Nkind
(A2
) = N_Selected_Component
7718 return Denotes_Same_Object
(Prefix
(A1
), Prefix
(A2
))
7720 Entity
(Selector_Name
(A1
)) = Entity
(Selector_Name
(A2
));
7722 -- Both names are dereferences and the dereferenced names are known to
7723 -- denote the same object (RM 6.4.1(6.8/3)).
7725 elsif Nkind
(A1
) = N_Explicit_Dereference
7726 and then Nkind
(A2
) = N_Explicit_Dereference
7728 return Denotes_Same_Object
(Prefix
(A1
), Prefix
(A2
));
7730 -- Both names are indexed_components, their prefixes are known to denote
7731 -- the same object, and each of the pairs of corresponding index values
7732 -- are either both static expressions with the same static value or both
7733 -- names that are known to denote the same object (RM 6.4.1(6.9/3)).
7735 elsif Nkind
(A1
) = N_Indexed_Component
7736 and then Nkind
(A2
) = N_Indexed_Component
7738 if not Denotes_Same_Object
(Prefix
(A1
), Prefix
(A2
)) then
7746 Indx1
:= First
(Expressions
(A1
));
7747 Indx2
:= First
(Expressions
(A2
));
7748 while Present
(Indx1
) loop
7750 -- Indexes must denote the same static value or same object
7752 if Is_OK_Static_Expression
(Indx1
) then
7753 if not Is_OK_Static_Expression
(Indx2
) then
7756 elsif Expr_Value
(Indx1
) /= Expr_Value
(Indx2
) then
7760 elsif not Denotes_Same_Object
(Indx1
, Indx2
) then
7772 -- Both names are slices, their prefixes are known to denote the same
7773 -- object, and the two slices have statically matching index constraints
7774 -- (RM 6.4.1(6.10/3)).
7776 elsif Nkind
(A1
) = N_Slice
7777 and then Nkind
(A2
) = N_Slice
7779 if not Denotes_Same_Object
(Prefix
(A1
), Prefix
(A2
)) then
7783 Lo1
, Lo2
, Hi1
, Hi2
: Node_Id
;
7786 Get_Index_Bounds
(Discrete_Range
(A1
), Lo1
, Hi1
);
7787 Get_Index_Bounds
(Discrete_Range
(A2
), Lo2
, Hi2
);
7789 -- Check whether bounds are statically identical. There is no
7790 -- attempt to detect partial overlap of slices.
7792 return Is_OK_Static_Expression
(Lo1
)
7793 and then Is_OK_Static_Expression
(Lo2
)
7794 and then Is_OK_Static_Expression
(Hi1
)
7795 and then Is_OK_Static_Expression
(Hi2
)
7796 and then Expr_Value
(Lo1
) = Expr_Value
(Lo2
)
7797 and then Expr_Value
(Hi1
) = Expr_Value
(Hi2
);
7801 -- One of the two names statically denotes a renaming declaration whose
7802 -- renamed object_name is known to denote the same object as the other;
7803 -- the prefix of any dereference within the renamed object_name is not a
7804 -- variable, and any expression within the renamed object_name contains
7805 -- no references to variables nor calls on nonstatic functions (RM
7808 elsif Is_Object_Renaming
(A1
)
7809 and then Is_Valid_Renaming
(A1
)
7811 return Denotes_Same_Object
(Renamed_Object
(Entity
(A1
)), A2
);
7813 elsif Is_Object_Renaming
(A2
)
7814 and then Is_Valid_Renaming
(A2
)
7816 return Denotes_Same_Object
(A1
, Renamed_Object
(Entity
(A2
)));
7821 end Denotes_Same_Object
;
7823 -------------------------
7824 -- Denotes_Same_Prefix --
7825 -------------------------
7827 function Denotes_Same_Prefix
(A1
, A2
: Node_Id
) return Boolean is
7829 if Is_Entity_Name
(A1
) then
7830 if Nkind
(A2
) in N_Selected_Component | N_Indexed_Component
7831 and then not Is_Access_Type
(Etype
(A1
))
7833 return Denotes_Same_Object
(A1
, Prefix
(A2
))
7834 or else Denotes_Same_Prefix
(A1
, Prefix
(A2
));
7839 elsif Is_Entity_Name
(A2
) then
7840 return Denotes_Same_Prefix
(A1
=> A2
, A2
=> A1
);
7842 elsif Nkind
(A1
) in N_Selected_Component | N_Indexed_Component | N_Slice
7844 Nkind
(A2
) in N_Selected_Component | N_Indexed_Component | N_Slice
7847 Root1
, Root2
: Node_Id
;
7848 Depth1
, Depth2
: Nat
:= 0;
7851 Root1
:= Prefix
(A1
);
7852 while not Is_Entity_Name
(Root1
) loop
7853 if Nkind
(Root1
) not in
7854 N_Selected_Component | N_Indexed_Component
7858 Root1
:= Prefix
(Root1
);
7861 Depth1
:= Depth1
+ 1;
7864 Root2
:= Prefix
(A2
);
7865 while not Is_Entity_Name
(Root2
) loop
7866 if Nkind
(Root2
) not in
7867 N_Selected_Component | N_Indexed_Component
7871 Root2
:= Prefix
(Root2
);
7874 Depth2
:= Depth2
+ 1;
7877 -- If both have the same depth and they do not denote the same
7878 -- object, they are disjoint and no warning is needed.
7880 if Depth1
= Depth2
then
7883 elsif Depth1
> Depth2
then
7884 Root1
:= Prefix
(A1
);
7885 for J
in 1 .. Depth1
- Depth2
- 1 loop
7886 Root1
:= Prefix
(Root1
);
7889 return Denotes_Same_Object
(Root1
, A2
);
7892 Root2
:= Prefix
(A2
);
7893 for J
in 1 .. Depth2
- Depth1
- 1 loop
7894 Root2
:= Prefix
(Root2
);
7897 return Denotes_Same_Object
(A1
, Root2
);
7904 end Denotes_Same_Prefix
;
7906 ----------------------
7907 -- Denotes_Variable --
7908 ----------------------
7910 function Denotes_Variable
(N
: Node_Id
) return Boolean is
7912 return Is_Variable
(N
) and then Paren_Count
(N
) = 0;
7913 end Denotes_Variable
;
7915 -----------------------------
7916 -- Depends_On_Discriminant --
7917 -----------------------------
7919 function Depends_On_Discriminant
(N
: Node_Id
) return Boolean is
7924 Get_Index_Bounds
(N
, L
, H
);
7925 return Denotes_Discriminant
(L
) or else Denotes_Discriminant
(H
);
7926 end Depends_On_Discriminant
;
7928 -------------------------------------
7929 -- Derivation_Too_Early_To_Inherit --
7930 -------------------------------------
7932 function Derivation_Too_Early_To_Inherit
7933 (Typ
: Entity_Id
; Streaming_Op
: TSS_Name_Type
) return Boolean is
7935 Btyp
: constant Entity_Id
:= Implementation_Base_Type
(Typ
);
7936 Parent_Type
: Entity_Id
;
7940 -- Start of processing for Derivation_Too_Early_To_Inherit
7943 if Is_Derived_Type
(Btyp
) then
7944 Parent_Type
:= Implementation_Base_Type
(Etype
(Btyp
));
7945 pragma Assert
(Parent_Type
/= Btyp
);
7947 if Has_Stream_Attribute_Definition
7948 (Parent_Type
, Streaming_Op
, Real_Rep
=> Real_Rep
)
7950 and then In_Same_Extended_Unit
(Btyp
, Parent_Type
)
7951 and then Instantiation
(Get_Source_File_Index
(Sloc
(Btyp
))) =
7952 Instantiation
(Get_Source_File_Index
(Sloc
(Parent_Type
)))
7954 return Earlier_In_Extended_Unit
(Btyp
, Real_Rep
);
7959 end Derivation_Too_Early_To_Inherit
;
7961 -------------------------
7962 -- Designate_Same_Unit --
7963 -------------------------
7965 function Designate_Same_Unit
7967 Name2
: Node_Id
) return Boolean
7969 K1
: constant Node_Kind
:= Nkind
(Name1
);
7970 K2
: constant Node_Kind
:= Nkind
(Name2
);
7972 function Prefix_Node
(N
: Node_Id
) return Node_Id
;
7973 -- Returns the parent unit name node of a defining program unit name
7974 -- or the prefix if N is a selected component or an expanded name.
7976 function Select_Node
(N
: Node_Id
) return Node_Id
;
7977 -- Returns the defining identifier node of a defining program unit
7978 -- name or the selector node if N is a selected component or an
7985 function Prefix_Node
(N
: Node_Id
) return Node_Id
is
7987 if Nkind
(N
) = N_Defining_Program_Unit_Name
then
7998 function Select_Node
(N
: Node_Id
) return Node_Id
is
8000 if Nkind
(N
) = N_Defining_Program_Unit_Name
then
8001 return Defining_Identifier
(N
);
8003 return Selector_Name
(N
);
8007 -- Start of processing for Designate_Same_Unit
8010 if K1
in N_Identifier | N_Defining_Identifier
8012 K2
in N_Identifier | N_Defining_Identifier
8014 return Chars
(Name1
) = Chars
(Name2
);
8016 elsif K1
in N_Expanded_Name
8017 | N_Selected_Component
8018 | N_Defining_Program_Unit_Name
8020 K2
in N_Expanded_Name
8021 | N_Selected_Component
8022 | N_Defining_Program_Unit_Name
8025 (Chars
(Select_Node
(Name1
)) = Chars
(Select_Node
(Name2
)))
8027 Designate_Same_Unit
(Prefix_Node
(Name1
), Prefix_Node
(Name2
));
8032 end Designate_Same_Unit
;
8034 ---------------------------------------------
8035 -- Diagnose_Iterated_Component_Association --
8036 ---------------------------------------------
8038 procedure Diagnose_Iterated_Component_Association
(N
: Node_Id
) is
8039 Def_Id
: constant Entity_Id
:= Defining_Identifier
(N
);
8043 -- Determine whether the iterated component association appears within
8044 -- an aggregate. If this is the case, raise Program_Error because the
8045 -- iterated component association cannot be left in the tree as is and
8046 -- must always be processed by the related aggregate.
8049 while Present
(Aggr
) loop
8050 if Nkind
(Aggr
) = N_Aggregate
then
8051 raise Program_Error
;
8053 -- Prevent the search from going too far
8055 elsif Is_Body_Or_Package_Declaration
(Aggr
) then
8059 Aggr
:= Parent
(Aggr
);
8062 -- At this point it is known that the iterated component association is
8063 -- not within an aggregate. This is really a quantified expression with
8064 -- a missing "all" or "some" quantifier.
8066 Error_Msg_N
("missing quantifier", Def_Id
);
8068 -- Rewrite the iterated component association as True to prevent any
8071 Rewrite
(N
, New_Occurrence_Of
(Standard_True
, Sloc
(N
)));
8073 end Diagnose_Iterated_Component_Association
;
8075 ------------------------
8076 -- Discriminated_Size --
8077 ------------------------
8079 function Discriminated_Size
(Comp
: Entity_Id
) return Boolean is
8080 function Non_Static_Bound
(Bound
: Node_Id
) return Boolean;
8081 -- Check whether the bound of an index is non-static and does denote
8082 -- a discriminant, in which case any object of the type (protected or
8083 -- otherwise) will have a non-static size.
8085 ----------------------
8086 -- Non_Static_Bound --
8087 ----------------------
8089 function Non_Static_Bound
(Bound
: Node_Id
) return Boolean is
8091 if Is_OK_Static_Expression
(Bound
) then
8094 -- If the bound is given by a discriminant it is non-static
8095 -- (A static constraint replaces the reference with the value).
8096 -- In an protected object the discriminant has been replaced by
8097 -- the corresponding discriminal within the protected operation.
8099 elsif Is_Entity_Name
(Bound
)
8101 (Ekind
(Entity
(Bound
)) = E_Discriminant
8102 or else Present
(Discriminal_Link
(Entity
(Bound
))))
8109 end Non_Static_Bound
;
8113 Typ
: constant Entity_Id
:= Etype
(Comp
);
8116 -- Start of processing for Discriminated_Size
8119 if not Is_Array_Type
(Typ
) then
8123 if Ekind
(Typ
) = E_Array_Subtype
then
8124 Index
:= First_Index
(Typ
);
8125 while Present
(Index
) loop
8126 if Non_Static_Bound
(Low_Bound
(Index
))
8127 or else Non_Static_Bound
(High_Bound
(Index
))
8139 end Discriminated_Size
;
8141 -----------------------------------
8142 -- Effective_Extra_Accessibility --
8143 -----------------------------------
8145 function Effective_Extra_Accessibility
(Id
: Entity_Id
) return Entity_Id
is
8147 if Present
(Renamed_Object
(Id
))
8148 and then Is_Entity_Name
(Renamed_Object
(Id
))
8150 return Effective_Extra_Accessibility
(Entity
(Renamed_Object
(Id
)));
8152 return Extra_Accessibility
(Id
);
8154 end Effective_Extra_Accessibility
;
8156 -----------------------------
8157 -- Effective_Reads_Enabled --
8158 -----------------------------
8160 function Effective_Reads_Enabled
(Id
: Entity_Id
) return Boolean is
8162 return Has_Enabled_Property
(Id
, Name_Effective_Reads
);
8163 end Effective_Reads_Enabled
;
8165 ------------------------------
8166 -- Effective_Writes_Enabled --
8167 ------------------------------
8169 function Effective_Writes_Enabled
(Id
: Entity_Id
) return Boolean is
8171 return Has_Enabled_Property
(Id
, Name_Effective_Writes
);
8172 end Effective_Writes_Enabled
;
8174 ------------------------------
8175 -- Enclosing_Comp_Unit_Node --
8176 ------------------------------
8178 function Enclosing_Comp_Unit_Node
(N
: Node_Id
) return Node_Id
is
8179 Current_Node
: Node_Id
;
8183 while Present
(Current_Node
)
8184 and then Nkind
(Current_Node
) /= N_Compilation_Unit
8186 Current_Node
:= Parent
(Current_Node
);
8189 return Current_Node
;
8190 end Enclosing_Comp_Unit_Node
;
8192 --------------------------
8193 -- Enclosing_CPP_Parent --
8194 --------------------------
8196 function Enclosing_CPP_Parent
(Typ
: Entity_Id
) return Entity_Id
is
8197 Parent_Typ
: Entity_Id
:= Typ
;
8200 while not Is_CPP_Class
(Parent_Typ
)
8201 and then Etype
(Parent_Typ
) /= Parent_Typ
8203 Parent_Typ
:= Etype
(Parent_Typ
);
8205 if Is_Private_Type
(Parent_Typ
) then
8206 Parent_Typ
:= Full_View
(Base_Type
(Parent_Typ
));
8210 pragma Assert
(Is_CPP_Class
(Parent_Typ
));
8212 end Enclosing_CPP_Parent
;
8214 ---------------------------
8215 -- Enclosing_Declaration --
8216 ---------------------------
8218 function Enclosing_Declaration
(N
: Node_Id
) return Node_Id
is
8219 Decl
: Node_Id
:= N
;
8222 while Present
(Decl
)
8223 and then not (Nkind
(Decl
) in N_Declaration
8225 Nkind
(Decl
) in N_Later_Decl_Item
8227 Nkind
(Decl
) in N_Renaming_Declaration
8229 Nkind
(Decl
) = N_Number_Declaration
)
8231 Decl
:= Parent
(Decl
);
8235 end Enclosing_Declaration
;
8237 ----------------------------
8238 -- Enclosing_Generic_Body --
8239 ----------------------------
8241 function Enclosing_Generic_Body
(N
: Node_Id
) return Node_Id
is
8243 Spec_Id
: Entity_Id
;
8247 while Present
(Par
) loop
8248 if Nkind
(Par
) in N_Package_Body | N_Subprogram_Body
then
8249 Spec_Id
:= Corresponding_Spec
(Par
);
8251 if Present
(Spec_Id
)
8252 and then Nkind
(Unit_Declaration_Node
(Spec_Id
)) in
8253 N_Generic_Declaration
8259 Par
:= Parent
(Par
);
8263 end Enclosing_Generic_Body
;
8265 ----------------------------
8266 -- Enclosing_Generic_Unit --
8267 ----------------------------
8269 function Enclosing_Generic_Unit
(N
: Node_Id
) return Node_Id
is
8271 Spec_Decl
: Node_Id
;
8272 Spec_Id
: Entity_Id
;
8276 while Present
(Par
) loop
8277 if Nkind
(Par
) in N_Generic_Declaration
then
8280 elsif Nkind
(Par
) in N_Package_Body | N_Subprogram_Body
then
8281 Spec_Id
:= Corresponding_Spec
(Par
);
8283 if Present
(Spec_Id
) then
8284 Spec_Decl
:= Unit_Declaration_Node
(Spec_Id
);
8286 if Nkind
(Spec_Decl
) in N_Generic_Declaration
then
8292 Par
:= Parent
(Par
);
8296 end Enclosing_Generic_Unit
;
8302 function Enclosing_HSS
(Stmt
: Node_Id
) return Node_Id
is
8305 pragma Assert
(Is_Statement
(Stmt
));
8307 Par
:= Parent
(Stmt
);
8308 while Present
(Par
) loop
8310 if Nkind
(Par
) = N_Handled_Sequence_Of_Statements
then
8313 -- Prevent the search from going too far
8315 elsif Is_Body_Or_Package_Declaration
(Par
) then
8320 Par
:= Parent
(Par
);
8326 -------------------------------
8327 -- Enclosing_Lib_Unit_Entity --
8328 -------------------------------
8330 function Enclosing_Lib_Unit_Entity
8331 (E
: Entity_Id
:= Current_Scope
) return Entity_Id
8333 Unit_Entity
: Entity_Id
;
8336 -- Look for enclosing library unit entity by following scope links.
8337 -- Equivalent to, but faster than indexing through the scope stack.
8340 while (Present
(Scope
(Unit_Entity
))
8341 and then Scope
(Unit_Entity
) /= Standard_Standard
)
8342 and not Is_Child_Unit
(Unit_Entity
)
8344 Unit_Entity
:= Scope
(Unit_Entity
);
8348 end Enclosing_Lib_Unit_Entity
;
8350 -----------------------------
8351 -- Enclosing_Lib_Unit_Node --
8352 -----------------------------
8354 function Enclosing_Lib_Unit_Node
(N
: Node_Id
) return Node_Id
is
8355 Encl_Unit
: Node_Id
;
8358 Encl_Unit
:= Enclosing_Comp_Unit_Node
(N
);
8359 while Present
(Encl_Unit
)
8360 and then Nkind
(Unit
(Encl_Unit
)) = N_Subunit
8362 Encl_Unit
:= Library_Unit
(Encl_Unit
);
8365 pragma Assert
(Nkind
(Encl_Unit
) = N_Compilation_Unit
);
8367 end Enclosing_Lib_Unit_Node
;
8369 -----------------------
8370 -- Enclosing_Package --
8371 -----------------------
8373 function Enclosing_Package
(N
: Node_Or_Entity_Id
) return Entity_Id
is
8374 Dynamic_Scope
: Entity_Id
;
8377 -- Obtain the enclosing scope when N is a Node_Id - taking care to
8378 -- handle the case when the enclosing scope is already a package.
8380 if Nkind
(N
) not in N_Entity
then
8382 Encl_Scop
: constant Entity_Id
:= Find_Enclosing_Scope
(N
);
8384 if No
(Encl_Scop
) then
8386 elsif Ekind
(Encl_Scop
) in
8387 E_Generic_Package | E_Package | E_Package_Body
8392 return Enclosing_Package
(Encl_Scop
);
8396 -- When N is already an Entity_Id proceed
8398 Dynamic_Scope
:= Enclosing_Dynamic_Scope
(N
);
8399 if Dynamic_Scope
= Standard_Standard
then
8400 return Standard_Standard
;
8402 elsif Dynamic_Scope
= Empty
then
8405 elsif Ekind
(Dynamic_Scope
) in
8406 E_Generic_Package | E_Package | E_Package_Body
8408 return Dynamic_Scope
;
8411 return Enclosing_Package
(Dynamic_Scope
);
8413 end Enclosing_Package
;
8415 -------------------------------------
8416 -- Enclosing_Package_Or_Subprogram --
8417 -------------------------------------
8419 function Enclosing_Package_Or_Subprogram
(E
: Entity_Id
) return Entity_Id
is
8424 while Present
(S
) loop
8425 if Is_Package_Or_Generic_Package
(S
)
8426 or else Is_Subprogram_Or_Generic_Subprogram
(S
)
8436 end Enclosing_Package_Or_Subprogram
;
8438 --------------------------
8439 -- Enclosing_Subprogram --
8440 --------------------------
8442 function Enclosing_Subprogram
(N
: Node_Or_Entity_Id
) return Entity_Id
is
8443 Dyn_Scop
: Entity_Id
;
8444 Encl_Scop
: Entity_Id
;
8447 -- Obtain the enclosing scope when N is a Node_Id - taking care to
8448 -- handle the case when the enclosing scope is already a subprogram.
8450 if Nkind
(N
) not in N_Entity
then
8451 Encl_Scop
:= Find_Enclosing_Scope
(N
);
8453 if No
(Encl_Scop
) then
8455 elsif Ekind
(Encl_Scop
) in Subprogram_Kind
then
8459 return Enclosing_Subprogram
(Encl_Scop
);
8462 -- When N is already an Entity_Id proceed
8464 Dyn_Scop
:= Enclosing_Dynamic_Scope
(N
);
8465 if Dyn_Scop
= Standard_Standard
then
8468 elsif Dyn_Scop
= Empty
then
8471 elsif Ekind
(Dyn_Scop
) = E_Subprogram_Body
then
8472 return Corresponding_Spec
(Parent
(Parent
(Dyn_Scop
)));
8474 elsif Ekind
(Dyn_Scop
) in E_Block | E_Loop | E_Return_Statement
then
8475 return Enclosing_Subprogram
(Dyn_Scop
);
8477 elsif Ekind
(Dyn_Scop
) in E_Entry | E_Entry_Family
then
8479 -- For a task entry or entry family, return the enclosing subprogram
8480 -- of the task itself.
8482 if Ekind
(Scope
(Dyn_Scop
)) = E_Task_Type
then
8483 return Enclosing_Subprogram
(Dyn_Scop
);
8485 -- A protected entry or entry family is rewritten as a protected
8486 -- procedure which is the desired enclosing subprogram. This is
8487 -- relevant when unnesting a procedure local to an entry body.
8490 return Protected_Body_Subprogram
(Dyn_Scop
);
8493 elsif Ekind
(Dyn_Scop
) = E_Task_Type
then
8494 return Get_Task_Body_Procedure
(Dyn_Scop
);
8496 -- The scope may appear as a private type or as a private extension
8497 -- whose completion is a task or protected type.
8499 elsif Ekind
(Dyn_Scop
) in
8500 E_Limited_Private_Type | E_Record_Type_With_Private
8501 and then Present
(Full_View
(Dyn_Scop
))
8502 and then Ekind
(Full_View
(Dyn_Scop
)) in E_Task_Type | E_Protected_Type
8504 return Get_Task_Body_Procedure
(Full_View
(Dyn_Scop
));
8506 -- No body is generated if the protected operation is eliminated
8508 elsif not Is_Eliminated
(Dyn_Scop
)
8509 and then Present
(Protected_Body_Subprogram
(Dyn_Scop
))
8511 return Protected_Body_Subprogram
(Dyn_Scop
);
8516 end Enclosing_Subprogram
;
8518 --------------------------
8519 -- End_Keyword_Location --
8520 --------------------------
8522 function End_Keyword_Location
(N
: Node_Id
) return Source_Ptr
is
8523 function End_Label_Loc
(Nod
: Node_Id
) return Source_Ptr
;
8524 -- Return the source location of Nod's end label according to the
8525 -- following precedence rules:
8527 -- 1) If the end label exists, return its location
8528 -- 2) If Nod exists, return its location
8529 -- 3) Return the location of N
8535 function End_Label_Loc
(Nod
: Node_Id
) return Source_Ptr
is
8539 if Present
(Nod
) then
8540 Label
:= End_Label
(Nod
);
8542 if Present
(Label
) then
8543 return Sloc
(Label
);
8555 Owner
: Node_Id
:= Empty
;
8557 -- Start of processing for End_Keyword_Location
8560 if Nkind
(N
) in N_Block_Statement
8566 Owner
:= Handled_Statement_Sequence
(N
);
8568 elsif Nkind
(N
) = N_Package_Declaration
then
8569 Owner
:= Specification
(N
);
8571 elsif Nkind
(N
) = N_Protected_Body
then
8574 elsif Nkind
(N
) in N_Protected_Type_Declaration
8575 | N_Single_Protected_Declaration
8577 Owner
:= Protected_Definition
(N
);
8579 elsif Nkind
(N
) in N_Single_Task_Declaration | N_Task_Type_Declaration
8581 Owner
:= Task_Definition
(N
);
8583 -- This routine should not be called with other contexts
8586 pragma Assert
(False);
8590 return End_Label_Loc
(Owner
);
8591 end End_Keyword_Location
;
8593 ------------------------
8594 -- Ensure_Freeze_Node --
8595 ------------------------
8597 procedure Ensure_Freeze_Node
(E
: Entity_Id
) is
8600 if No
(Freeze_Node
(E
)) then
8601 FN
:= Make_Freeze_Entity
(Sloc
(E
));
8602 Set_Has_Delayed_Freeze
(E
);
8603 Set_Freeze_Node
(E
, FN
);
8604 Set_Access_Types_To_Process
(FN
, No_Elist
);
8605 Set_TSS_Elist
(FN
, No_Elist
);
8608 end Ensure_Freeze_Node
;
8614 procedure Enter_Name
(Def_Id
: Entity_Id
) is
8615 C
: constant Entity_Id
:= Current_Entity
(Def_Id
);
8616 E
: constant Entity_Id
:= Current_Entity_In_Scope
(Def_Id
);
8617 S
: constant Entity_Id
:= Current_Scope
;
8620 Generate_Definition
(Def_Id
);
8622 -- Add new name to current scope declarations. Check for duplicate
8623 -- declaration, which may or may not be a genuine error.
8627 -- Case of previous entity entered because of a missing declaration
8628 -- or else a bad subtype indication. Best is to use the new entity,
8629 -- and make the previous one invisible.
8631 if Etype
(E
) = Any_Type
then
8632 Set_Is_Immediately_Visible
(E
, False);
8634 -- Case of renaming declaration constructed for package instances.
8635 -- if there is an explicit declaration with the same identifier,
8636 -- the renaming is not immediately visible any longer, but remains
8637 -- visible through selected component notation.
8639 elsif Nkind
(Parent
(E
)) = N_Package_Renaming_Declaration
8640 and then not Comes_From_Source
(E
)
8642 Set_Is_Immediately_Visible
(E
, False);
8644 -- The new entity may be the package renaming, which has the same
8645 -- same name as a generic formal which has been seen already.
8647 elsif Nkind
(Parent
(Def_Id
)) = N_Package_Renaming_Declaration
8648 and then not Comes_From_Source
(Def_Id
)
8650 Set_Is_Immediately_Visible
(E
, False);
8652 -- For a fat pointer corresponding to a remote access to subprogram,
8653 -- we use the same identifier as the RAS type, so that the proper
8654 -- name appears in the stub. This type is only retrieved through
8655 -- the RAS type and never by visibility, and is not added to the
8656 -- visibility list (see below).
8658 elsif Nkind
(Parent
(Def_Id
)) = N_Full_Type_Declaration
8659 and then Ekind
(Def_Id
) = E_Record_Type
8660 and then Present
(Corresponding_Remote_Type
(Def_Id
))
8664 -- Case of an implicit operation or derived literal. The new entity
8665 -- hides the implicit one, which is removed from all visibility,
8666 -- i.e. the entity list of its scope, and homonym chain of its name.
8668 elsif (Is_Overloadable
(E
) and then Is_Inherited_Operation
(E
))
8669 or else Is_Internal
(E
)
8672 Decl
: constant Node_Id
:= Parent
(E
);
8674 Prev_Vis
: Entity_Id
;
8677 -- If E is an implicit declaration, it cannot be the first
8678 -- entity in the scope.
8680 Prev
:= First_Entity
(Current_Scope
);
8681 while Present
(Prev
) and then Next_Entity
(Prev
) /= E
loop
8687 -- If E is not on the entity chain of the current scope,
8688 -- it is an implicit declaration in the generic formal
8689 -- part of a generic subprogram. When analyzing the body,
8690 -- the generic formals are visible but not on the entity
8691 -- chain of the subprogram. The new entity will become
8692 -- the visible one in the body.
8695 (Nkind
(Parent
(Decl
)) = N_Generic_Subprogram_Declaration
);
8699 Link_Entities
(Prev
, Next_Entity
(E
));
8701 if No
(Next_Entity
(Prev
)) then
8702 Set_Last_Entity
(Current_Scope
, Prev
);
8705 if E
= Current_Entity
(E
) then
8709 Prev_Vis
:= Current_Entity
(E
);
8710 while Homonym
(Prev_Vis
) /= E
loop
8711 Prev_Vis
:= Homonym
(Prev_Vis
);
8715 if Present
(Prev_Vis
) then
8717 -- Skip E in the visibility chain
8719 Set_Homonym
(Prev_Vis
, Homonym
(E
));
8722 Set_Name_Entity_Id
(Chars
(E
), Homonym
(E
));
8725 -- The inherited operation cannot be retrieved
8726 -- by name, even though it may remain accesssible
8727 -- in some cases involving subprogram bodies without
8728 -- specs appearing in with_clauses..
8730 Set_Is_Immediately_Visible
(E
, False);
8734 -- This section of code could use a comment ???
8736 elsif Present
(Etype
(E
))
8737 and then Is_Concurrent_Type
(Etype
(E
))
8742 -- If the homograph is a protected component renaming, it should not
8743 -- be hiding the current entity. Such renamings are treated as weak
8746 elsif Is_Prival
(E
) then
8747 Set_Is_Immediately_Visible
(E
, False);
8749 -- In this case the current entity is a protected component renaming.
8750 -- Perform minimal decoration by setting the scope and return since
8751 -- the prival should not be hiding other visible entities.
8753 elsif Is_Prival
(Def_Id
) then
8754 Set_Scope
(Def_Id
, Current_Scope
);
8757 -- Analogous to privals, the discriminal generated for an entry index
8758 -- parameter acts as a weak declaration. Perform minimal decoration
8759 -- to avoid bogus errors.
8761 elsif Is_Discriminal
(Def_Id
)
8762 and then Ekind
(Discriminal_Link
(Def_Id
)) = E_Entry_Index_Parameter
8764 Set_Scope
(Def_Id
, Current_Scope
);
8767 -- In the body or private part of an instance, a type extension may
8768 -- introduce a component with the same name as that of an actual. The
8769 -- legality rule is not enforced, but the semantics of the full type
8770 -- with two components of same name are not clear at this point???
8772 elsif In_Instance_Not_Visible
then
8775 -- When compiling a package body, some child units may have become
8776 -- visible. They cannot conflict with local entities that hide them.
8778 elsif Is_Child_Unit
(E
)
8779 and then In_Open_Scopes
(Scope
(E
))
8780 and then not Is_Immediately_Visible
(E
)
8784 -- Conversely, with front-end inlining we may compile the parent body
8785 -- first, and a child unit subsequently. The context is now the
8786 -- parent spec, and body entities are not visible.
8788 elsif Is_Child_Unit
(Def_Id
)
8789 and then Is_Package_Body_Entity
(E
)
8790 and then not In_Package_Body
(Current_Scope
)
8794 -- Case of genuine duplicate declaration
8797 Error_Msg_Sloc
:= Sloc
(E
);
8799 -- If the previous declaration is an incomplete type declaration
8800 -- this may be an attempt to complete it with a private type. The
8801 -- following avoids confusing cascaded errors.
8803 if Nkind
(Parent
(E
)) = N_Incomplete_Type_Declaration
8804 and then Nkind
(Parent
(Def_Id
)) = N_Private_Type_Declaration
8807 ("incomplete type cannot be completed with a private " &
8808 "declaration", Parent
(Def_Id
));
8809 Set_Is_Immediately_Visible
(E
, False);
8810 Set_Full_View
(E
, Def_Id
);
8812 -- An inherited component of a record conflicts with a new
8813 -- discriminant. The discriminant is inserted first in the scope,
8814 -- but the error should be posted on it, not on the component.
8816 elsif Ekind
(E
) = E_Discriminant
8817 and then Present
(Scope
(Def_Id
))
8818 and then Scope
(Def_Id
) /= Current_Scope
8820 Error_Msg_Sloc
:= Sloc
(Def_Id
);
8821 Error_Msg_N
("& conflicts with declaration#", E
);
8824 -- If the name of the unit appears in its own context clause, a
8825 -- dummy package with the name has already been created, and the
8826 -- error emitted. Try to continue quietly.
8828 elsif Error_Posted
(E
)
8829 and then Sloc
(E
) = No_Location
8830 and then Nkind
(Parent
(E
)) = N_Package_Specification
8831 and then Current_Scope
= Standard_Standard
8833 Set_Scope
(Def_Id
, Current_Scope
);
8837 Error_Msg_N
("& conflicts with declaration#", Def_Id
);
8839 -- Avoid cascaded messages with duplicate components in
8842 if Ekind
(E
) in E_Component | E_Discriminant
then
8847 if Nkind
(Parent
(Parent
(Def_Id
))) =
8848 N_Generic_Subprogram_Declaration
8850 Defining_Entity
(Specification
(Parent
(Parent
(Def_Id
))))
8852 Error_Msg_N
("\generic units cannot be overloaded", Def_Id
);
8855 -- If entity is in standard, then we are in trouble, because it
8856 -- means that we have a library package with a duplicated name.
8857 -- That's hard to recover from, so abort.
8859 if S
= Standard_Standard
then
8860 raise Unrecoverable_Error
;
8862 -- Otherwise we continue with the declaration. Having two
8863 -- identical declarations should not cause us too much trouble.
8871 -- If we fall through, declaration is OK, at least OK enough to continue
8873 -- If Def_Id is a discriminant or a record component we are in the midst
8874 -- of inheriting components in a derived record definition. Preserve
8875 -- their Ekind and Etype.
8877 if Ekind
(Def_Id
) in E_Discriminant | E_Component
then
8880 -- If a type is already set, leave it alone (happens when a type
8881 -- declaration is reanalyzed following a call to the optimizer).
8883 elsif Present
(Etype
(Def_Id
)) then
8886 -- Otherwise, the kind E_Void insures that premature uses of the entity
8887 -- will be detected. Any_Type insures that no cascaded errors will occur
8890 Mutate_Ekind
(Def_Id
, E_Void
);
8891 Set_Etype
(Def_Id
, Any_Type
);
8894 -- All entities except Itypes are immediately visible
8896 if not Is_Itype
(Def_Id
) then
8897 Set_Is_Immediately_Visible
(Def_Id
);
8898 Set_Current_Entity
(Def_Id
);
8901 Set_Homonym
(Def_Id
, C
);
8902 Append_Entity
(Def_Id
, S
);
8903 Set_Public_Status
(Def_Id
);
8905 -- Warn if new entity hides an old one
8907 if Warn_On_Hiding
and then Present
(C
) then
8908 Warn_On_Hiding_Entity
(Def_Id
, Hidden
=> C
, Visible
=> Def_Id
,
8909 On_Use_Clause
=> False);
8917 function Entity_Of
(N
: Node_Id
) return Entity_Id
is
8922 -- Assume that the arbitrary node does not have an entity
8926 if Is_Entity_Name
(N
) then
8929 -- Follow a possible chain of renamings to reach the earliest renamed
8933 and then Is_Object
(Id
)
8934 and then Present
(Renamed_Object
(Id
))
8936 Ren
:= Renamed_Object
(Id
);
8938 -- The reference renames an abstract state or a whole object
8941 -- Ren : ... renames Obj;
8943 if Is_Entity_Name
(Ren
) then
8945 -- Do not follow a renaming that goes through a generic formal,
8946 -- because these entities are hidden and must not be referenced
8947 -- from outside the generic.
8949 if Is_Hidden
(Entity
(Ren
)) then
8956 -- The reference renames a function result. Check the original
8957 -- node in case expansion relocates the function call.
8959 -- Ren : ... renames Func_Call;
8961 elsif Nkind
(Original_Node
(Ren
)) = N_Function_Call
then
8964 -- Otherwise the reference renames something which does not yield
8965 -- an abstract state or a whole object. Treat the reference as not
8966 -- having a proper entity for SPARK legality purposes.
8978 --------------------------
8979 -- Examine_Array_Bounds --
8980 --------------------------
8982 procedure Examine_Array_Bounds
8984 All_Static
: out Boolean;
8985 Has_Empty
: out Boolean)
8987 function Is_OK_Static_Bound
(Bound
: Node_Id
) return Boolean;
8988 -- Determine whether bound Bound is a suitable static bound
8990 ------------------------
8991 -- Is_OK_Static_Bound --
8992 ------------------------
8994 function Is_OK_Static_Bound
(Bound
: Node_Id
) return Boolean is
8997 not Error_Posted
(Bound
)
8998 and then Is_OK_Static_Expression
(Bound
);
8999 end Is_OK_Static_Bound
;
9007 -- Start of processing for Examine_Array_Bounds
9010 -- An unconstrained array type does not have static bounds, and it is
9011 -- not known whether they are empty or not.
9013 if not Is_Constrained
(Typ
) then
9014 All_Static
:= False;
9017 -- A string literal has static bounds, and is not empty as long as it
9018 -- contains at least one character.
9020 elsif Ekind
(Typ
) = E_String_Literal_Subtype
then
9022 Has_Empty
:= String_Literal_Length
(Typ
) > 0;
9025 -- Assume that all bounds are static and not empty
9030 -- Examine each index
9032 Index
:= First_Index
(Typ
);
9033 while Present
(Index
) loop
9034 if Is_Discrete_Type
(Etype
(Index
)) then
9035 Get_Index_Bounds
(Index
, Lo_Bound
, Hi_Bound
);
9037 if Is_OK_Static_Bound
(Lo_Bound
)
9039 Is_OK_Static_Bound
(Hi_Bound
)
9041 -- The static bounds produce an empty range
9043 if Is_Null_Range
(Lo_Bound
, Hi_Bound
) then
9047 -- Otherwise at least one of the bounds is not static
9050 All_Static
:= False;
9053 -- Otherwise the index is non-discrete, therefore not static
9056 All_Static
:= False;
9061 end Examine_Array_Bounds
;
9067 function Exceptions_OK
return Boolean is
9070 not (Restriction_Active
(No_Exception_Handlers
) or else
9071 Restriction_Active
(No_Exception_Propagation
) or else
9072 Restriction_Active
(No_Exceptions
));
9075 --------------------------
9076 -- Explain_Limited_Type --
9077 --------------------------
9079 procedure Explain_Limited_Type
(T
: Entity_Id
; N
: Node_Id
) is
9083 -- For array, component type must be limited
9085 if Is_Array_Type
(T
) then
9086 Error_Msg_Node_2
:= T
;
9088 ("\component type& of type& is limited", N
, Component_Type
(T
));
9089 Explain_Limited_Type
(Component_Type
(T
), N
);
9091 elsif Is_Record_Type
(T
) then
9093 -- No need for extra messages if explicit limited record
9095 if Is_Limited_Record
(Base_Type
(T
)) then
9099 -- Otherwise find a limited component. Check only components that
9100 -- come from source, or inherited components that appear in the
9101 -- source of the ancestor.
9103 C
:= First_Component
(T
);
9104 while Present
(C
) loop
9105 if Is_Limited_Type
(Etype
(C
))
9107 (Comes_From_Source
(C
)
9109 (Present
(Original_Record_Component
(C
))
9111 Comes_From_Source
(Original_Record_Component
(C
))))
9113 Error_Msg_Node_2
:= T
;
9114 Error_Msg_NE
("\component& of type& has limited type", N
, C
);
9115 Explain_Limited_Type
(Etype
(C
), N
);
9122 -- The type may be declared explicitly limited, even if no component
9123 -- of it is limited, in which case we fall out of the loop.
9126 end Explain_Limited_Type
;
9128 ---------------------------------------
9129 -- Expression_Of_Expression_Function --
9130 ---------------------------------------
9132 function Expression_Of_Expression_Function
9133 (Subp
: Entity_Id
) return Node_Id
9135 Expr_Func
: Node_Id
:= Empty
;
9138 pragma Assert
(Is_Expression_Function_Or_Completion
(Subp
));
9140 if Nkind
(Original_Node
(Subprogram_Spec
(Subp
))) =
9141 N_Expression_Function
9143 Expr_Func
:= Original_Node
(Subprogram_Spec
(Subp
));
9145 elsif Nkind
(Original_Node
(Subprogram_Body
(Subp
))) =
9146 N_Expression_Function
9148 Expr_Func
:= Original_Node
(Subprogram_Body
(Subp
));
9151 pragma Assert
(False);
9155 return Original_Node
(Expression
(Expr_Func
));
9156 end Expression_Of_Expression_Function
;
9158 -------------------------------
9159 -- Extensions_Visible_Status --
9160 -------------------------------
9162 function Extensions_Visible_Status
9163 (Id
: Entity_Id
) return Extensions_Visible_Mode
9172 -- When a formal parameter is subject to Extensions_Visible, the pragma
9173 -- is stored in the contract of related subprogram.
9175 if Is_Formal
(Id
) then
9178 elsif Is_Subprogram_Or_Generic_Subprogram
(Id
) then
9181 -- No other construct carries this pragma
9184 return Extensions_Visible_None
;
9187 Prag
:= Get_Pragma
(Subp
, Pragma_Extensions_Visible
);
9189 -- In certain cases analysis may request the Extensions_Visible status
9190 -- of an expression function before the pragma has been analyzed yet.
9191 -- Inspect the declarative items after the expression function looking
9192 -- for the pragma (if any).
9194 if No
(Prag
) and then Is_Expression_Function
(Subp
) then
9195 Decl
:= Next
(Unit_Declaration_Node
(Subp
));
9196 while Present
(Decl
) loop
9197 if Nkind
(Decl
) = N_Pragma
9198 and then Pragma_Name
(Decl
) = Name_Extensions_Visible
9203 -- A source construct ends the region where Extensions_Visible may
9204 -- appear, stop the traversal. An expanded expression function is
9205 -- no longer a source construct, but it must still be recognized.
9207 elsif Comes_From_Source
(Decl
)
9209 (Nkind
(Decl
) in N_Subprogram_Body | N_Subprogram_Declaration
9210 and then Is_Expression_Function
(Defining_Entity
(Decl
)))
9219 -- Extract the value from the Boolean expression (if any)
9221 if Present
(Prag
) then
9222 Arg
:= First
(Pragma_Argument_Associations
(Prag
));
9224 if Present
(Arg
) then
9225 Expr
:= Get_Pragma_Arg
(Arg
);
9227 -- When the associated subprogram is an expression function, the
9228 -- argument of the pragma may not have been analyzed.
9230 if not Analyzed
(Expr
) then
9231 Preanalyze_And_Resolve
(Expr
, Standard_Boolean
);
9234 -- Guard against cascading errors when the argument of pragma
9235 -- Extensions_Visible is not a valid static Boolean expression.
9237 if Error_Posted
(Expr
) then
9238 return Extensions_Visible_None
;
9240 elsif Is_True
(Expr_Value
(Expr
)) then
9241 return Extensions_Visible_True
;
9244 return Extensions_Visible_False
;
9247 -- Otherwise the aspect or pragma defaults to True
9250 return Extensions_Visible_True
;
9253 -- Otherwise aspect or pragma Extensions_Visible is not inherited or
9254 -- directly specified. In SPARK code, its value defaults to "False".
9256 elsif SPARK_Mode
= On
then
9257 return Extensions_Visible_False
;
9259 -- In non-SPARK code, aspect or pragma Extensions_Visible defaults to
9263 return Extensions_Visible_True
;
9265 end Extensions_Visible_Status
;
9271 procedure Find_Actual
9273 Formal
: out Entity_Id
;
9276 Context
: constant Node_Id
:= Parent
(N
);
9281 if Nkind
(Context
) in N_Indexed_Component | N_Selected_Component
9282 and then N
= Prefix
(Context
)
9284 Find_Actual
(Context
, Formal
, Call
);
9287 elsif Nkind
(Context
) = N_Parameter_Association
9288 and then N
= Explicit_Actual_Parameter
(Context
)
9290 Call
:= Parent
(Context
);
9292 elsif Nkind
(Context
) in N_Entry_Call_Statement
9294 | N_Procedure_Call_Statement
9304 -- If we have a call to a subprogram look for the parameter. Note that
9305 -- we exclude overloaded calls, since we don't know enough to be sure
9306 -- of giving the right answer in this case.
9308 if Nkind
(Call
) in N_Entry_Call_Statement
9310 | N_Procedure_Call_Statement
9312 Call_Nam
:= Name
(Call
);
9314 -- A call to an entry family may appear as an indexed component
9316 if Nkind
(Call_Nam
) = N_Indexed_Component
then
9317 Call_Nam
:= Prefix
(Call_Nam
);
9320 -- A call to a protected or task entry appears as a selected
9321 -- component rather than an expanded name.
9323 if Nkind
(Call_Nam
) = N_Selected_Component
then
9324 Call_Nam
:= Selector_Name
(Call_Nam
);
9327 if Is_Entity_Name
(Call_Nam
)
9328 and then Present
(Entity
(Call_Nam
))
9329 and then (Is_Generic_Subprogram
(Entity
(Call_Nam
))
9330 or else Is_Overloadable
(Entity
(Call_Nam
))
9331 or else Ekind
(Entity
(Call_Nam
)) in E_Entry_Family
9333 | E_Subprogram_Type
)
9334 and then not Is_Overloaded
(Call_Nam
)
9336 -- If node is name in call it is not an actual
9338 if N
= Call_Nam
then
9344 -- Fall here if we are definitely a parameter
9346 Actual
:= First_Actual
(Call
);
9347 Formal
:= First_Formal
(Entity
(Call_Nam
));
9348 while Present
(Formal
) and then Present
(Actual
) loop
9352 -- An actual that is the prefix in a prefixed call may have
9353 -- been rewritten in the call. Check if sloc and kinds and
9356 elsif Sloc
(Actual
) = Sloc
(N
)
9357 and then Nkind
(Actual
) = N_Identifier
9358 and then Nkind
(Actual
) = Nkind
(N
)
9359 and then Chars
(Actual
) = Chars
(N
)
9364 Next_Actual
(Actual
);
9365 Next_Formal
(Formal
);
9371 -- Fall through here if we did not find matching actual
9377 ---------------------------
9378 -- Find_Body_Discriminal --
9379 ---------------------------
9381 function Find_Body_Discriminal
9382 (Spec_Discriminant
: Entity_Id
) return Entity_Id
9388 -- If expansion is suppressed, then the scope can be the concurrent type
9389 -- itself rather than a corresponding concurrent record type.
9391 if Is_Concurrent_Type
(Scope
(Spec_Discriminant
)) then
9392 Tsk
:= Scope
(Spec_Discriminant
);
9395 pragma Assert
(Is_Concurrent_Record_Type
(Scope
(Spec_Discriminant
)));
9397 Tsk
:= Corresponding_Concurrent_Type
(Scope
(Spec_Discriminant
));
9400 -- Find discriminant of original concurrent type, and use its current
9401 -- discriminal, which is the renaming within the task/protected body.
9403 Disc
:= First_Discriminant
(Tsk
);
9404 while Present
(Disc
) loop
9405 if Chars
(Disc
) = Chars
(Spec_Discriminant
) then
9406 return Discriminal
(Disc
);
9409 Next_Discriminant
(Disc
);
9412 -- That loop should always succeed in finding a matching entry and
9413 -- returning. Fatal error if not.
9415 raise Program_Error
;
9416 end Find_Body_Discriminal
;
9418 -------------------------------------
9419 -- Find_Corresponding_Discriminant --
9420 -------------------------------------
9422 function Find_Corresponding_Discriminant
9424 Typ
: Entity_Id
) return Entity_Id
9426 Par_Disc
: Entity_Id
;
9427 Old_Disc
: Entity_Id
;
9428 New_Disc
: Entity_Id
;
9431 Par_Disc
:= Original_Record_Component
(Original_Discriminant
(Id
));
9433 -- The original type may currently be private, and the discriminant
9434 -- only appear on its full view.
9436 if Is_Private_Type
(Scope
(Par_Disc
))
9437 and then not Has_Discriminants
(Scope
(Par_Disc
))
9438 and then Present
(Full_View
(Scope
(Par_Disc
)))
9440 Old_Disc
:= First_Discriminant
(Full_View
(Scope
(Par_Disc
)));
9442 Old_Disc
:= First_Discriminant
(Scope
(Par_Disc
));
9445 if Is_Class_Wide_Type
(Typ
) then
9446 New_Disc
:= First_Discriminant
(Root_Type
(Typ
));
9448 New_Disc
:= First_Discriminant
(Typ
);
9451 while Present
(Old_Disc
) and then Present
(New_Disc
) loop
9452 if Old_Disc
= Par_Disc
then
9456 Next_Discriminant
(Old_Disc
);
9457 Next_Discriminant
(New_Disc
);
9460 -- Should always find it
9462 raise Program_Error
;
9463 end Find_Corresponding_Discriminant
;
9469 function Find_DIC_Type
(Typ
: Entity_Id
) return Entity_Id
is
9470 Curr_Typ
: Entity_Id
;
9471 -- The current type being examined in the parent hierarchy traversal
9473 DIC_Typ
: Entity_Id
;
9474 -- The type which carries the DIC pragma. This variable denotes the
9475 -- partial view when private types are involved.
9477 Par_Typ
: Entity_Id
;
9478 -- The parent type of the current type. This variable denotes the full
9479 -- view when private types are involved.
9482 -- The input type defines its own DIC pragma, therefore it is the owner
9484 if Has_Own_DIC
(Typ
) then
9487 -- Otherwise the DIC pragma is inherited from a parent type
9490 pragma Assert
(Has_Inherited_DIC
(Typ
));
9492 -- Climb the parent chain
9496 -- Inspect the parent type. Do not consider subtypes as they
9497 -- inherit the DIC attributes from their base types.
9499 DIC_Typ
:= Base_Type
(Etype
(Curr_Typ
));
9501 -- Look at the full view of a private type because the type may
9502 -- have a hidden parent introduced in the full view.
9506 if Is_Private_Type
(Par_Typ
)
9507 and then Present
(Full_View
(Par_Typ
))
9509 Par_Typ
:= Full_View
(Par_Typ
);
9512 -- Stop the climb once the nearest parent type which defines a DIC
9513 -- pragma of its own is encountered or when the root of the parent
9514 -- chain is reached.
9516 exit when Has_Own_DIC
(DIC_Typ
) or else Curr_Typ
= Par_Typ
;
9518 Curr_Typ
:= Par_Typ
;
9525 ----------------------------------
9526 -- Find_Enclosing_Iterator_Loop --
9527 ----------------------------------
9529 function Find_Enclosing_Iterator_Loop
(Id
: Entity_Id
) return Entity_Id
is
9534 -- Traverse the scope chain looking for an iterator loop. Such loops are
9535 -- usually transformed into blocks, hence the use of Original_Node.
9538 while Present
(S
) and then S
/= Standard_Standard
loop
9539 if Ekind
(S
) = E_Loop
9540 and then Nkind
(Parent
(S
)) = N_Implicit_Label_Declaration
9542 Constr
:= Original_Node
(Label_Construct
(Parent
(S
)));
9544 if Nkind
(Constr
) = N_Loop_Statement
9545 and then Present
(Iteration_Scheme
(Constr
))
9546 and then Nkind
(Iterator_Specification
9547 (Iteration_Scheme
(Constr
))) =
9548 N_Iterator_Specification
9558 end Find_Enclosing_Iterator_Loop
;
9560 --------------------------
9561 -- Find_Enclosing_Scope --
9562 --------------------------
9564 function Find_Enclosing_Scope
(N
: Node_Id
) return Entity_Id
is
9568 -- Examine the parent chain looking for a construct which defines a
9572 while Present
(Par
) loop
9575 -- The construct denotes a declaration, the proper scope is its
9578 when N_Entry_Declaration
9579 | N_Expression_Function
9580 | N_Full_Type_Declaration
9581 | N_Generic_Package_Declaration
9582 | N_Generic_Subprogram_Declaration
9583 | N_Package_Declaration
9584 | N_Private_Extension_Declaration
9585 | N_Protected_Type_Declaration
9586 | N_Single_Protected_Declaration
9587 | N_Single_Task_Declaration
9588 | N_Subprogram_Declaration
9589 | N_Task_Type_Declaration
9591 return Defining_Entity
(Par
);
9593 -- The construct denotes a body, the proper scope is the entity of
9594 -- the corresponding spec or that of the body if the body does not
9595 -- complete a previous declaration.
9603 return Unique_Defining_Entity
(Par
);
9607 -- Blocks carry either a source or an internally-generated scope,
9608 -- unless the block is a byproduct of exception handling.
9610 when N_Block_Statement
=>
9611 if not Exception_Junk
(Par
) then
9612 return Entity
(Identifier
(Par
));
9615 -- Loops carry an internally-generated scope
9617 when N_Loop_Statement
=>
9618 return Entity
(Identifier
(Par
));
9620 -- Extended return statements carry an internally-generated scope
9622 when N_Extended_Return_Statement
=>
9623 return Return_Statement_Entity
(Par
);
9625 -- A traversal from a subunit continues via the corresponding stub
9628 Par
:= Corresponding_Stub
(Par
);
9634 Par
:= Parent
(Par
);
9637 return Standard_Standard
;
9638 end Find_Enclosing_Scope
;
9640 ------------------------------------
9641 -- Find_Loop_In_Conditional_Block --
9642 ------------------------------------
9644 function Find_Loop_In_Conditional_Block
(N
: Node_Id
) return Node_Id
is
9650 if Nkind
(Stmt
) = N_If_Statement
then
9651 Stmt
:= First
(Then_Statements
(Stmt
));
9654 pragma Assert
(Nkind
(Stmt
) = N_Block_Statement
);
9656 -- Inspect the statements of the conditional block. In general the loop
9657 -- should be the first statement in the statement sequence of the block,
9658 -- but the finalization machinery may have introduced extra object
9661 Stmt
:= First
(Statements
(Handled_Statement_Sequence
(Stmt
)));
9662 while Present
(Stmt
) loop
9663 if Nkind
(Stmt
) = N_Loop_Statement
then
9670 -- The expansion of attribute 'Loop_Entry produced a malformed block
9672 raise Program_Error
;
9673 end Find_Loop_In_Conditional_Block
;
9675 --------------------------
9676 -- Find_Overlaid_Entity --
9677 --------------------------
9679 procedure Find_Overlaid_Entity
9681 Ent
: out Entity_Id
;
9685 (Nkind
(N
) = N_Attribute_Definition_Clause
9686 and then Chars
(N
) = Name_Address
);
9691 -- We are looking for one of the two following forms:
9693 -- for X'Address use Y'Address
9697 -- Const : constant Address := expr;
9699 -- for X'Address use Const;
9701 -- In the second case, the expr is either Y'Address, or recursively a
9702 -- constant that eventually references Y'Address.
9707 Expr
:= Expression
(N
);
9709 -- This loop checks the form of the expression for Y'Address, using
9710 -- recursion to deal with intermediate constants.
9713 -- Check for Y'Address
9715 if Nkind
(Expr
) = N_Attribute_Reference
9716 and then Attribute_Name
(Expr
) = Name_Address
9718 Expr
:= Prefix
(Expr
);
9721 -- Check for Const where Const is a constant entity
9723 elsif Is_Entity_Name
(Expr
)
9724 and then Ekind
(Entity
(Expr
)) = E_Constant
9726 Expr
:= Constant_Value
(Entity
(Expr
));
9728 -- Anything else does not need checking
9735 -- This loop checks the form of the prefix for an entity, using
9736 -- recursion to deal with intermediate components.
9739 -- Check for Y where Y is an entity
9741 if Is_Entity_Name
(Expr
) then
9742 Ent
:= Entity
(Expr
);
9744 -- If expansion is disabled, then we might see an entity of a
9745 -- protected component or of a discriminant of a concurrent unit.
9746 -- Ignore such entities, because further warnings for overlays
9747 -- expect this routine to only collect entities of entire objects.
9749 if Ekind
(Ent
) in E_Component | E_Discriminant
then
9751 (not Expander_Active
9752 and then Is_Concurrent_Type
(Scope
(Ent
)));
9757 -- Check for components
9759 elsif Nkind
(Expr
) in N_Selected_Component | N_Indexed_Component
then
9760 Expr
:= Prefix
(Expr
);
9763 -- Anything else does not need checking
9769 end Find_Overlaid_Entity
;
9771 -------------------------
9772 -- Find_Parameter_Type --
9773 -------------------------
9775 function Find_Parameter_Type
(Param
: Node_Id
) return Entity_Id
is
9777 if Nkind
(Param
) /= N_Parameter_Specification
then
9780 -- For an access parameter, obtain the type from the formal entity
9781 -- itself, because access to subprogram nodes do not carry a type.
9782 -- Shouldn't we always use the formal entity ???
9784 elsif Nkind
(Parameter_Type
(Param
)) = N_Access_Definition
then
9785 return Etype
(Defining_Identifier
(Param
));
9788 return Etype
(Parameter_Type
(Param
));
9790 end Find_Parameter_Type
;
9792 -----------------------------------
9793 -- Find_Placement_In_State_Space --
9794 -----------------------------------
9796 procedure Find_Placement_In_State_Space
9797 (Item_Id
: Entity_Id
;
9798 Placement
: out State_Space_Kind
;
9799 Pack_Id
: out Entity_Id
)
9801 function Inside_Package_Body
(Id
: Entity_Id
) return Boolean;
9802 function Inside_Private_Part
(Id
: Entity_Id
) return Boolean;
9803 -- Return True if Id is declared directly within the package body
9804 -- and the package private parts, respectively. We cannot use
9805 -- In_Private_Part/In_Body_Part flags, as these are only set during the
9806 -- analysis of the package itself, while Find_Placement_In_State_Space
9807 -- can be called on an entity of another package.
9809 ------------------------
9810 -- Inside_Package_Body --
9811 ------------------------
9813 function Inside_Package_Body
(Id
: Entity_Id
) return Boolean is
9814 Spec_Id
: constant Entity_Id
:= Scope
(Id
);
9815 Body_Decl
: constant Opt_N_Package_Body_Id
:= Package_Body
(Spec_Id
);
9816 Decl
: constant Node_Id
:= Enclosing_Declaration
(Id
);
9818 if Present
(Body_Decl
)
9819 and then Is_List_Member
(Decl
)
9820 and then List_Containing
(Decl
) = Declarations
(Body_Decl
)
9826 end Inside_Package_Body
;
9828 -------------------------
9829 -- Inside_Private_Part --
9830 -------------------------
9832 function Inside_Private_Part
(Id
: Entity_Id
) return Boolean is
9833 Spec_Id
: constant Entity_Id
:= Scope
(Id
);
9834 Private_Decls
: constant List_Id
:=
9835 Private_Declarations
(Package_Specification
(Spec_Id
));
9836 Decl
: constant Node_Id
:= Enclosing_Declaration
(Id
);
9838 if Is_List_Member
(Decl
)
9839 and then List_Containing
(Decl
) = Private_Decls
9843 elsif Ekind
(Id
) = E_Package
9844 and then Is_Private_Library_Unit
(Id
)
9851 end Inside_Private_Part
;
9855 Context
: Entity_Id
;
9857 -- Start of processing for Find_Placement_In_State_Space
9860 -- Assume that the item does not appear in the state space of a package
9862 Placement
:= Not_In_Package
;
9864 -- Climb the scope stack and examine the enclosing context
9867 Pack_Id
:= Scope
(Context
);
9868 while Present
(Pack_Id
) and then Pack_Id
/= Standard_Standard
loop
9869 if Is_Package_Or_Generic_Package
(Pack_Id
) then
9871 -- A package body is a cut off point for the traversal as the
9872 -- item cannot be visible to the outside from this point on.
9874 if Inside_Package_Body
(Context
) then
9875 Placement
:= Body_State_Space
;
9878 -- The private part of a package is a cut off point for the
9879 -- traversal as the item cannot be visible to the outside
9880 -- from this point on.
9882 elsif Inside_Private_Part
(Context
) then
9883 Placement
:= Private_State_Space
;
9886 -- When the item appears in the visible state space of a package,
9887 -- continue to climb the scope stack as this may not be the final
9891 Placement
:= Visible_State_Space
;
9893 -- The visible state space of a child unit acts as the proper
9894 -- placement of an item, unless this is a private child unit.
9896 if Is_Child_Unit
(Pack_Id
)
9897 and then not Is_Private_Library_Unit
(Pack_Id
)
9903 -- The item or its enclosing package appear in a construct that has
9907 Placement
:= Not_In_Package
;
9912 Context
:= Scope
(Context
);
9913 Pack_Id
:= Scope
(Context
);
9915 end Find_Placement_In_State_Space
;
9917 -----------------------
9918 -- Find_Primitive_Eq --
9919 -----------------------
9921 function Find_Primitive_Eq
(Typ
: Entity_Id
) return Entity_Id
is
9922 function Find_Eq_Prim
(Prims_List
: Elist_Id
) return Entity_Id
;
9923 -- Search for the equality primitive; return Empty if the primitive is
9930 function Find_Eq_Prim
(Prims_List
: Elist_Id
) return Entity_Id
is
9932 Prim_Elmt
: Elmt_Id
;
9935 Prim_Elmt
:= First_Elmt
(Prims_List
);
9936 while Present
(Prim_Elmt
) loop
9937 Prim
:= Node
(Prim_Elmt
);
9939 -- Locate primitive equality with the right signature
9941 if Chars
(Prim
) = Name_Op_Eq
9942 and then Etype
(First_Formal
(Prim
)) =
9943 Etype
(Next_Formal
(First_Formal
(Prim
)))
9944 and then Base_Type
(Etype
(Prim
)) = Standard_Boolean
9949 Next_Elmt
(Prim_Elmt
);
9957 Eq_Prim
: Entity_Id
;
9958 Full_Type
: Entity_Id
;
9960 -- Start of processing for Find_Primitive_Eq
9963 if Is_Private_Type
(Typ
) then
9964 Full_Type
:= Underlying_Type
(Typ
);
9969 if No
(Full_Type
) then
9973 Full_Type
:= Base_Type
(Full_Type
);
9975 -- When the base type itself is private, use the full view
9977 if Is_Private_Type
(Full_Type
) then
9978 Full_Type
:= Underlying_Type
(Full_Type
);
9981 if Is_Class_Wide_Type
(Full_Type
) then
9982 Full_Type
:= Root_Type
(Full_Type
);
9985 if not Is_Tagged_Type
(Full_Type
) then
9986 Eq_Prim
:= Find_Eq_Prim
(Collect_Primitive_Operations
(Typ
));
9988 -- If this is an untagged private type completed with a derivation of
9989 -- an untagged private type whose full view is a tagged type, we use
9990 -- the primitive operations of the private parent type (since it does
9991 -- not have a full view, and also because its equality primitive may
9992 -- have been overridden in its untagged full view). If no equality was
9993 -- defined for it then take its dispatching equality primitive.
9995 elsif Inherits_From_Tagged_Full_View
(Typ
) then
9996 Eq_Prim
:= Find_Eq_Prim
(Collect_Primitive_Operations
(Typ
));
9998 if No
(Eq_Prim
) then
9999 Eq_Prim
:= Find_Eq_Prim
(Primitive_Operations
(Full_Type
));
10003 Eq_Prim
:= Find_Eq_Prim
(Primitive_Operations
(Full_Type
));
10007 end Find_Primitive_Eq
;
10009 ------------------------
10010 -- Find_Specific_Type --
10011 ------------------------
10013 function Find_Specific_Type
(CW
: Entity_Id
) return Entity_Id
is
10014 Typ
: Entity_Id
:= Root_Type
(CW
);
10017 if Ekind
(Typ
) = E_Incomplete_Type
then
10018 if From_Limited_With
(Typ
) then
10019 Typ
:= Non_Limited_View
(Typ
);
10021 Typ
:= Full_View
(Typ
);
10025 if Is_Private_Type
(Typ
)
10026 and then not Is_Tagged_Type
(Typ
)
10027 and then Present
(Full_View
(Typ
))
10029 return Full_View
(Typ
);
10033 end Find_Specific_Type
;
10035 -----------------------------
10036 -- Find_Static_Alternative --
10037 -----------------------------
10039 function Find_Static_Alternative
(N
: Node_Id
) return Node_Id
is
10040 Expr
: constant Node_Id
:= Expression
(N
);
10041 Val
: constant Uint
:= Expr_Value
(Expr
);
10046 Alt
:= First
(Alternatives
(N
));
10049 if Nkind
(Alt
) /= N_Pragma
then
10050 Choice
:= First
(Discrete_Choices
(Alt
));
10051 while Present
(Choice
) loop
10053 -- Others choice, always matches
10055 if Nkind
(Choice
) = N_Others_Choice
then
10058 -- Range, check if value is in the range
10060 elsif Nkind
(Choice
) = N_Range
then
10062 Val
>= Expr_Value
(Low_Bound
(Choice
))
10064 Val
<= Expr_Value
(High_Bound
(Choice
));
10066 -- Choice is a subtype name. Note that we know it must
10067 -- be a static subtype, since otherwise it would have
10068 -- been diagnosed as illegal.
10070 elsif Is_Entity_Name
(Choice
)
10071 and then Is_Type
(Entity
(Choice
))
10073 exit Search
when Is_In_Range
(Expr
, Etype
(Choice
),
10074 Assume_Valid
=> False);
10076 -- Choice is a subtype indication
10078 elsif Nkind
(Choice
) = N_Subtype_Indication
then
10080 C
: constant Node_Id
:= Constraint
(Choice
);
10081 R
: constant Node_Id
:= Range_Expression
(C
);
10085 Val
>= Expr_Value
(Low_Bound
(R
))
10087 Val
<= Expr_Value
(High_Bound
(R
));
10090 -- Choice is a simple expression
10093 exit Search
when Val
= Expr_Value
(Choice
);
10101 pragma Assert
(Present
(Alt
));
10104 -- The above loop *must* terminate by finding a match, since we know the
10105 -- case statement is valid, and the value of the expression is known at
10106 -- compile time. When we fall out of the loop, Alt points to the
10107 -- alternative that we know will be selected at run time.
10110 end Find_Static_Alternative
;
10116 function First_Actual
(Node
: Node_Id
) return Node_Id
is
10120 if No
(Parameter_Associations
(Node
)) then
10124 N
:= First
(Parameter_Associations
(Node
));
10126 if Nkind
(N
) = N_Parameter_Association
then
10127 return First_Named_Actual
(Node
);
10137 function First_Global
10139 Global_Mode
: Name_Id
;
10140 Refined
: Boolean := False) return Node_Id
10142 function First_From_Global_List
10144 Global_Mode
: Name_Id
:= Name_Input
) return Entity_Id
;
10145 -- Get the first item with suitable mode from List
10147 ----------------------------
10148 -- First_From_Global_List --
10149 ----------------------------
10151 function First_From_Global_List
10153 Global_Mode
: Name_Id
:= Name_Input
) return Entity_Id
10158 -- Empty list (no global items)
10160 if Nkind
(List
) = N_Null
then
10163 -- Single global item declaration (only input items)
10165 elsif Nkind
(List
) in N_Expanded_Name | N_Identifier
then
10166 if Global_Mode
= Name_Input
then
10172 -- Simple global list (only input items) or moded global list
10175 elsif Nkind
(List
) = N_Aggregate
then
10176 if Present
(Expressions
(List
)) then
10177 if Global_Mode
= Name_Input
then
10178 return First
(Expressions
(List
));
10184 Assoc
:= First
(Component_Associations
(List
));
10185 while Present
(Assoc
) loop
10187 -- When we find the desired mode in an association, call
10188 -- recursively First_From_Global_List as if the mode was
10189 -- Name_Input, in order to reuse the existing machinery
10190 -- for the other cases.
10192 if Chars
(First
(Choices
(Assoc
))) = Global_Mode
then
10193 return First_From_Global_List
(Expression
(Assoc
));
10202 -- To accommodate partial decoration of disabled SPARK features,
10203 -- this routine may be called with illegal input. If this is the
10204 -- case, do not raise Program_Error.
10209 end First_From_Global_List
;
10213 Global
: Node_Id
:= Empty
;
10214 Body_Id
: Entity_Id
;
10216 -- Start of processing for First_Global
10219 pragma Assert
(Global_Mode
in Name_In_Out
10224 -- Retrieve the suitable pragma Global or Refined_Global. In the second
10225 -- case, it can only be located on the body entity.
10228 if Is_Subprogram_Or_Generic_Subprogram
(Subp
) then
10229 Body_Id
:= Subprogram_Body_Entity
(Subp
);
10231 elsif Is_Entry
(Subp
) or else Is_Task_Type
(Subp
) then
10232 Body_Id
:= Corresponding_Body
(Parent
(Subp
));
10234 -- ??? It should be possible to retrieve the Refined_Global on the
10235 -- task body associated to the task object. This is not yet possible.
10237 elsif Is_Single_Task_Object
(Subp
) then
10244 if Present
(Body_Id
) then
10245 Global
:= Get_Pragma
(Body_Id
, Pragma_Refined_Global
);
10248 Global
:= Get_Pragma
(Subp
, Pragma_Global
);
10251 -- No corresponding global if pragma is not present
10253 if No
(Global
) then
10256 -- Otherwise retrieve the corresponding list of items depending on the
10260 return First_From_Global_List
10261 (Expression
(Get_Argument
(Global
, Subp
)), Global_Mode
);
10269 function Fix_Msg
(Id
: Entity_Id
; Msg
: String) return String is
10270 Is_Task
: constant Boolean :=
10271 Ekind
(Id
) in E_Task_Body | E_Task_Type
10272 or else Is_Single_Task_Object
(Id
);
10273 Msg_Last
: constant Natural := Msg
'Last;
10274 Msg_Index
: Natural;
10275 Res
: String (Msg
'Range) := (others => ' ');
10276 Res_Index
: Natural;
10279 -- Copy all characters from the input message Msg to result Res with
10280 -- suitable replacements.
10282 Msg_Index
:= Msg
'First;
10283 Res_Index
:= Res
'First;
10284 while Msg_Index
<= Msg_Last
loop
10286 -- Replace "subprogram" with a different word
10288 if Msg_Index
<= Msg_Last
- 10
10289 and then Msg
(Msg_Index
.. Msg_Index
+ 9) = "subprogram"
10291 if Is_Entry
(Id
) then
10292 Res
(Res_Index
.. Res_Index
+ 4) := "entry";
10293 Res_Index
:= Res_Index
+ 5;
10296 Res
(Res_Index
.. Res_Index
+ 8) := "task type";
10297 Res_Index
:= Res_Index
+ 9;
10300 Res
(Res_Index
.. Res_Index
+ 9) := "subprogram";
10301 Res_Index
:= Res_Index
+ 10;
10304 Msg_Index
:= Msg_Index
+ 10;
10306 -- Replace "protected" with a different word
10308 elsif Msg_Index
<= Msg_Last
- 9
10309 and then Msg
(Msg_Index
.. Msg_Index
+ 8) = "protected"
10312 Res
(Res_Index
.. Res_Index
+ 3) := "task";
10313 Res_Index
:= Res_Index
+ 4;
10314 Msg_Index
:= Msg_Index
+ 9;
10316 -- Otherwise copy the character
10319 Res
(Res_Index
) := Msg
(Msg_Index
);
10320 Msg_Index
:= Msg_Index
+ 1;
10321 Res_Index
:= Res_Index
+ 1;
10325 return Res
(Res
'First .. Res_Index
- 1);
10328 -------------------------
10329 -- From_Nested_Package --
10330 -------------------------
10332 function From_Nested_Package
(T
: Entity_Id
) return Boolean is
10333 Pack
: constant Entity_Id
:= Scope
(T
);
10337 Ekind
(Pack
) = E_Package
10338 and then not Is_Frozen
(Pack
)
10339 and then not Scope_Within_Or_Same
(Current_Scope
, Pack
)
10340 and then In_Open_Scopes
(Scope
(Pack
));
10341 end From_Nested_Package
;
10343 -----------------------
10344 -- Gather_Components --
10345 -----------------------
10347 procedure Gather_Components
10349 Comp_List
: Node_Id
;
10350 Governed_By
: List_Id
;
10352 Report_Errors
: out Boolean;
10353 Allow_Compile_Time
: Boolean := False;
10354 Include_Interface_Tag
: Boolean := False)
10358 Discrete_Choice
: Node_Id
;
10359 Comp_Item
: Node_Id
;
10360 Discrim
: Entity_Id
;
10361 Discrim_Name
: Node_Id
;
10363 type Discriminant_Value_Status
is
10364 (Static_Expr
, Static_Subtype
, Bad
);
10365 subtype Good_Discrim_Value_Status
is Discriminant_Value_Status
10366 range Static_Expr
.. Static_Subtype
; -- range excludes Bad
10368 Discrim_Value
: Node_Id
;
10369 Discrim_Value_Subtype
: Node_Id
;
10370 Discrim_Value_Status
: Discriminant_Value_Status
:= Bad
;
10372 function OK_Scope_For_Discrim_Value_Error_Messages
return Boolean is
10373 (Scope
(Original_Record_Component
10374 (Entity
(First
(Choices
(Assoc
))))) = Typ
);
10375 -- Used to avoid generating error messages having a source position
10376 -- which refers to somewhere (e.g., a discriminant value in a derived
10377 -- tagged type declaration) unrelated to the offending construct. This
10378 -- is required for correctness - clients of Gather_Components such as
10379 -- Sem_Ch3.Create_Constrained_Components depend on this function
10380 -- returning True while processing semantically correct examples;
10381 -- generating an error message in this case would be wrong.
10384 Report_Errors
:= False;
10386 if No
(Comp_List
) or else Null_Present
(Comp_List
) then
10389 elsif Present
(Component_Items
(Comp_List
)) then
10390 Comp_Item
:= First
(Component_Items
(Comp_List
));
10393 Comp_Item
:= Empty
;
10396 while Present
(Comp_Item
) loop
10398 -- Skip the tag of a tagged record, as well as all items that are not
10399 -- user components (anonymous types, rep clauses, Parent field,
10400 -- controller field).
10402 if Nkind
(Comp_Item
) = N_Component_Declaration
then
10404 Comp
: constant Entity_Id
:= Defining_Identifier
(Comp_Item
);
10406 if not (Is_Tag
(Comp
)
10408 (Include_Interface_Tag
10409 and then Etype
(Comp
) = RTE
(RE_Interface_Tag
)))
10410 and then Chars
(Comp
) /= Name_uParent
10412 Append_Elmt
(Comp
, Into
);
10420 if No
(Variant_Part
(Comp_List
)) then
10423 Discrim_Name
:= Name
(Variant_Part
(Comp_List
));
10424 Variant
:= First_Non_Pragma
(Variants
(Variant_Part
(Comp_List
)));
10427 -- Look for the discriminant that governs this variant part.
10428 -- The discriminant *must* be in the Governed_By List
10430 Assoc
:= First
(Governed_By
);
10431 Find_Constraint
: loop
10432 Discrim
:= First
(Choices
(Assoc
));
10433 exit Find_Constraint
when
10434 Chars
(Discrim_Name
) = Chars
(Discrim
)
10436 (Present
(Corresponding_Discriminant
(Entity
(Discrim
)))
10437 and then Chars
(Corresponding_Discriminant
10438 (Entity
(Discrim
))) = Chars
(Discrim_Name
))
10440 Chars
(Original_Record_Component
(Entity
(Discrim
))) =
10441 Chars
(Discrim_Name
);
10443 if No
(Next
(Assoc
)) then
10444 if not Is_Constrained
(Typ
) and then Is_Derived_Type
(Typ
) then
10446 -- If the type is a tagged type with inherited discriminants,
10447 -- use the stored constraint on the parent in order to find
10448 -- the values of discriminants that are otherwise hidden by an
10449 -- explicit constraint. Renamed discriminants are handled in
10452 -- If several parent discriminants are renamed by a single
10453 -- discriminant of the derived type, the call to obtain the
10454 -- Corresponding_Discriminant field only retrieves the last
10455 -- of them. We recover the constraint on the others from the
10456 -- Stored_Constraint as well.
10458 -- An inherited discriminant may have been constrained in a
10459 -- later ancestor (not the immediate parent) so we must examine
10460 -- the stored constraint of all of them to locate the inherited
10466 T
: Entity_Id
:= Typ
;
10469 while Is_Derived_Type
(T
) loop
10470 if Present
(Stored_Constraint
(T
)) then
10471 D
:= First_Discriminant
(Etype
(T
));
10472 C
:= First_Elmt
(Stored_Constraint
(T
));
10473 while Present
(D
) and then Present
(C
) loop
10474 if Chars
(Discrim_Name
) = Chars
(D
) then
10475 if Is_Entity_Name
(Node
(C
))
10476 and then Entity
(Node
(C
)) = Entity
(Discrim
)
10478 -- D is renamed by Discrim, whose value is
10485 Make_Component_Association
(Sloc
(Typ
),
10487 (New_Occurrence_Of
(D
, Sloc
(Typ
))),
10488 Duplicate_Subexpr_No_Checks
(Node
(C
)));
10491 exit Find_Constraint
;
10494 Next_Discriminant
(D
);
10499 -- Discriminant may be inherited from ancestor
10507 if No
(Next
(Assoc
)) then
10509 (" missing value for discriminant&",
10510 First
(Governed_By
), Discrim_Name
);
10512 Report_Errors
:= True;
10517 end loop Find_Constraint
;
10519 Discrim_Value
:= Expression
(Assoc
);
10521 if Is_OK_Static_Expression
(Discrim_Value
)
10522 or else (Allow_Compile_Time
10523 and then Compile_Time_Known_Value
(Discrim_Value
))
10525 Discrim_Value_Status
:= Static_Expr
;
10527 if Ada_Version
>= Ada_2022
then
10528 if Is_Rewrite_Substitution
(Discrim_Value
)
10529 and then Nkind
(Discrim_Value
) = N_Type_Conversion
10530 and then Etype
(Original_Node
(Discrim_Value
))
10531 = Etype
(Expression
(Discrim_Value
))
10533 Discrim_Value_Subtype
:= Etype
(Original_Node
(Discrim_Value
));
10534 -- An unhelpful (for this code) type conversion may be
10535 -- introduced in some cases; deal with it.
10537 Discrim_Value_Subtype
:= Etype
(Discrim_Value
);
10540 if Is_OK_Static_Subtype
(Discrim_Value_Subtype
) and then
10541 not Is_Null_Range
(Type_Low_Bound
(Discrim_Value_Subtype
),
10542 Type_High_Bound
(Discrim_Value_Subtype
))
10544 -- Is_Null_Range test doesn't account for predicates, as in
10545 -- subtype Null_By_Predicate is Natural
10546 -- with Static_Predicate => Null_By_Predicate < 0;
10547 -- so test for that null case separately.
10549 if (not Has_Static_Predicate
(Discrim_Value_Subtype
))
10550 or else Present
(First
(Static_Discrete_Predicate
10551 (Discrim_Value_Subtype
)))
10553 Discrim_Value_Status
:= Static_Subtype
;
10558 if Discrim_Value_Status
= Bad
then
10560 -- If the variant part is governed by a discriminant of the type
10561 -- this is an error. If the variant part and the discriminant are
10562 -- inherited from an ancestor this is legal (AI05-220) unless the
10563 -- components are being gathered for an aggregate, in which case
10564 -- the caller must check Report_Errors.
10566 -- In Ada 2022 the above rules are relaxed. A nonstatic governing
10567 -- discriminant is OK as long as it has a static subtype and
10568 -- every value of that subtype (and there must be at least one)
10569 -- selects the same variant.
10571 if OK_Scope_For_Discrim_Value_Error_Messages
then
10572 if Ada_Version
>= Ada_2022
then
10574 ("value for discriminant & must be static or " &
10575 "discriminant's nominal subtype must be static " &
10577 Discrim_Value
, Discrim
);
10580 ("value for discriminant & must be static!",
10581 Discrim_Value
, Discrim
);
10583 Why_Not_Static
(Discrim_Value
);
10586 Report_Errors
:= True;
10591 Search_For_Discriminant_Value
: declare
10597 UI_Discrim_Value
: Uint
;
10600 case Good_Discrim_Value_Status
'(Discrim_Value_Status) is
10601 when Static_Expr =>
10602 UI_Discrim_Value := Expr_Value (Discrim_Value);
10603 when Static_Subtype =>
10604 -- Arbitrarily pick one value of the subtype and look
10605 -- for the variant associated with that value; we will
10606 -- check later that the same variant is associated with
10607 -- all of the other values of the subtype.
10608 if Has_Static_Predicate (Discrim_Value_Subtype) then
10610 Range_Or_Expr : constant Node_Id :=
10611 First (Static_Discrete_Predicate
10612 (Discrim_Value_Subtype));
10614 if Nkind (Range_Or_Expr) = N_Range then
10615 UI_Discrim_Value :=
10616 Expr_Value (Low_Bound (Range_Or_Expr));
10618 UI_Discrim_Value := Expr_Value (Range_Or_Expr);
10623 := Expr_Value (Type_Low_Bound (Discrim_Value_Subtype));
10627 Find_Discrete_Value : while Present (Variant) loop
10629 -- If a choice is a subtype with a static predicate, it must
10630 -- be rewritten as an explicit list of non-predicated choices.
10632 Expand_Static_Predicates_In_Choices (Variant);
10634 Discrete_Choice := First (Discrete_Choices (Variant));
10635 while Present (Discrete_Choice) loop
10636 exit Find_Discrete_Value when
10637 Nkind (Discrete_Choice) = N_Others_Choice;
10639 Get_Index_Bounds (Discrete_Choice, Low, High);
10641 UI_Low := Expr_Value (Low);
10642 UI_High := Expr_Value (High);
10644 exit Find_Discrete_Value when
10645 UI_Low <= UI_Discrim_Value
10647 UI_High >= UI_Discrim_Value;
10649 Next (Discrete_Choice);
10652 Next_Non_Pragma (Variant);
10653 end loop Find_Discrete_Value;
10654 end Search_For_Discriminant_Value;
10656 -- The case statement must include a variant that corresponds to the
10657 -- value of the discriminant, unless the discriminant type has a
10658 -- static predicate. In that case the absence of an others_choice that
10659 -- would cover this value becomes a run-time error (3.8.1 (21.1/2)).
10662 and then not Has_Static_Predicate (Etype (Discrim_Name))
10665 ("value of discriminant & is out of range", Discrim_Value, Discrim);
10666 Report_Errors := True;
10670 -- If we have found the corresponding choice, recursively add its
10671 -- components to the Into list. The nested components are part of
10672 -- the same record type.
10674 if Present (Variant) then
10675 if Discrim_Value_Status = Static_Subtype then
10677 Discrim_Value_Subtype_Intervals
10678 : constant Interval_Lists.Discrete_Interval_List
10679 := Interval_Lists.Type_Intervals (Discrim_Value_Subtype);
10682 : constant Interval_Lists.Discrete_Interval_List
10683 := Interval_Lists.Choice_List_Intervals
10684 (Discrete_Choices => Discrete_Choices (Variant));
10686 if not Interval_Lists.Is_Subset
10687 (Subset => Discrim_Value_Subtype_Intervals,
10688 Of_Set => Variant_Intervals)
10690 if OK_Scope_For_Discrim_Value_Error_Messages then
10692 ("no single variant is associated with all values of " &
10693 "the subtype of discriminant value &",
10694 Discrim_Value, Discrim);
10696 Report_Errors := True;
10703 (Typ, Component_List (Variant), Governed_By, Into,
10704 Report_Errors, Allow_Compile_Time);
10706 end Gather_Components;
10708 -------------------------------
10709 -- Get_Dynamic_Accessibility --
10710 -------------------------------
10712 function Get_Dynamic_Accessibility (E : Entity_Id) return Entity_Id is
10714 -- When minimum accessibility is set for E then we utilize it - except
10715 -- in a few edge cases like the expansion of select statements where
10716 -- generated subprogram may attempt to unnecessarily use a minimum
10717 -- accessibility object declared outside of scope.
10719 -- To avoid these situations where expansion may get complex we verify
10720 -- that the minimum accessibility object is within scope.
10723 and then Present (Minimum_Accessibility (E))
10724 and then In_Open_Scopes (Scope (Minimum_Accessibility (E)))
10726 return Minimum_Accessibility (E);
10729 return Extra_Accessibility (E);
10730 end Get_Dynamic_Accessibility;
10732 ------------------------
10733 -- Get_Actual_Subtype --
10734 ------------------------
10736 function Get_Actual_Subtype (N : Node_Id) return Entity_Id is
10737 Typ : constant Entity_Id := Etype (N);
10738 Utyp : Entity_Id := Underlying_Type (Typ);
10747 -- If what we have is an identifier that references a subprogram
10748 -- formal, or a variable or constant object, then we get the actual
10749 -- subtype from the referenced entity if one has been built.
10751 if Nkind (N) = N_Identifier
10753 (Is_Formal (Entity (N))
10754 or else Ekind (Entity (N)) = E_Constant
10755 or else Ekind (Entity (N)) = E_Variable)
10756 and then Present (Actual_Subtype (Entity (N)))
10758 return Actual_Subtype (Entity (N));
10760 -- Actual subtype of unchecked union is always itself. We never need
10761 -- the "real" actual subtype. If we did, we couldn't get it anyway
10762 -- because the discriminant is not available. The restrictions on
10763 -- Unchecked_Union are designed to make sure that this is OK.
10765 elsif Is_Unchecked_Union (Base_Type (Utyp)) then
10768 -- Here for the unconstrained case, we must find actual subtype
10769 -- No actual subtype is available, so we must build it on the fly.
10771 -- Checking the type, not the underlying type, for constrainedness
10772 -- seems to be necessary. Maybe all the tests should be on the type???
10774 elsif (not Is_Constrained (Typ))
10775 and then (Is_Array_Type (Utyp)
10776 or else (Is_Record_Type (Utyp)
10777 and then Has_Discriminants (Utyp)))
10778 and then not Has_Unknown_Discriminants (Utyp)
10779 and then not (Ekind (Utyp) = E_String_Literal_Subtype)
10781 -- Nothing to do if in spec expression (why not???)
10783 if In_Spec_Expression then
10786 elsif Is_Private_Type (Typ) and then not Has_Discriminants (Typ) then
10788 -- If the type has no discriminants, there is no subtype to
10789 -- build, even if the underlying type is discriminated.
10793 -- Else build the actual subtype
10796 Decl := Build_Actual_Subtype (Typ, N);
10798 -- The call may yield a declaration, or just return the entity
10804 Atyp := Defining_Identifier (Decl);
10806 -- If Build_Actual_Subtype generated a new declaration then use it
10808 if Atyp /= Typ then
10810 -- The actual subtype is an Itype, so analyze the declaration,
10811 -- but do not attach it to the tree, to get the type defined.
10813 Set_Parent (Decl, N);
10814 Set_Is_Itype (Atyp);
10815 Analyze (Decl, Suppress => All_Checks);
10816 Set_Associated_Node_For_Itype (Atyp, N);
10817 if Expander_Active then
10818 Set_Has_Delayed_Freeze (Atyp, False);
10820 -- We need to freeze the actual subtype immediately. This is
10821 -- needed because otherwise this Itype will not get frozen
10822 -- at all; it is always safe to freeze on creation because
10823 -- any associated types must be frozen at this point.
10825 -- On the other hand, if we are performing preanalysis on
10826 -- a conjured-up copy of a name (see calls to
10827 -- Preanalyze_Range in sem_ch5.adb) then we don't want
10828 -- to freeze Atyp, now or ever. In this case, the tree
10829 -- we eventually pass to the back end should contain no
10830 -- references to Atyp (and a freeze node would contain
10831 -- such a reference). That's why Expander_Active is tested.
10833 Freeze_Itype (Atyp, N);
10837 -- Otherwise we did not build a declaration, so return original
10844 -- For all remaining cases, the actual subtype is the same as
10845 -- the nominal type.
10850 end Get_Actual_Subtype;
10852 -------------------------------------
10853 -- Get_Actual_Subtype_If_Available --
10854 -------------------------------------
10856 function Get_Actual_Subtype_If_Available (N : Node_Id) return Entity_Id is
10857 Typ : constant Entity_Id := Etype (N);
10860 -- If what we have is an identifier that references a subprogram
10861 -- formal, or a variable or constant object, then we get the actual
10862 -- subtype from the referenced entity if one has been built.
10864 if Nkind (N) = N_Identifier
10866 (Is_Formal (Entity (N))
10867 or else Ekind (Entity (N)) = E_Constant
10868 or else Ekind (Entity (N)) = E_Variable)
10869 and then Present (Actual_Subtype (Entity (N)))
10871 return Actual_Subtype (Entity (N));
10873 -- Otherwise the Etype of N is returned unchanged
10878 end Get_Actual_Subtype_If_Available;
10880 ------------------------
10881 -- Get_Body_From_Stub --
10882 ------------------------
10884 function Get_Body_From_Stub (N : Node_Id) return Node_Id is
10886 return Proper_Body (Unit (Library_Unit (N)));
10887 end Get_Body_From_Stub;
10889 ---------------------
10890 -- Get_Cursor_Type --
10891 ---------------------
10893 function Get_Cursor_Type
10895 Typ : Entity_Id) return Entity_Id
10899 First_Op : Entity_Id;
10900 Cursor : Entity_Id;
10903 -- If error already detected, return
10905 if Error_Posted (Aspect) then
10909 -- The cursor type for an Iterable aspect is the return type of a
10910 -- non-overloaded First primitive operation. Locate association for
10913 Assoc := First (Component_Associations (Expression (Aspect)));
10914 First_Op := Any_Id;
10915 while Present (Assoc) loop
10916 if Chars (First (Choices (Assoc))) = Name_First then
10917 First_Op := Expression (Assoc);
10924 if First_Op = Any_Id then
10925 Error_Msg_N ("aspect Iterable must specify First operation", Aspect);
10928 elsif not Analyzed (First_Op) then
10929 Analyze (First_Op);
10932 Cursor := Any_Type;
10934 -- Locate function with desired name and profile in scope of type
10935 -- In the rare case where the type is an integer type, a base type
10936 -- is created for it, check that the base type of the first formal
10937 -- of First matches the base type of the domain.
10939 Func := First_Entity (Scope (Typ));
10940 while Present (Func) loop
10941 if Chars (Func) = Chars (First_Op)
10942 and then Ekind (Func) = E_Function
10943 and then Present (First_Formal (Func))
10944 and then Base_Type (Etype (First_Formal (Func))) = Base_Type (Typ)
10945 and then No (Next_Formal (First_Formal (Func)))
10947 if Cursor /= Any_Type then
10949 ("operation First for iterable type must be unique", Aspect);
10952 Cursor := Etype (Func);
10956 Next_Entity (Func);
10959 -- If not found, no way to resolve remaining primitives
10961 if Cursor = Any_Type then
10963 ("primitive operation for Iterable type must appear in the same "
10964 & "list of declarations as the type", Aspect);
10968 end Get_Cursor_Type;
10970 function Get_Cursor_Type (Typ : Entity_Id) return Entity_Id is
10972 return Etype (Get_Iterable_Type_Primitive (Typ, Name_First));
10973 end Get_Cursor_Type;
10975 -------------------------------
10976 -- Get_Default_External_Name --
10977 -------------------------------
10979 function Get_Default_External_Name (E : Node_Or_Entity_Id) return Node_Id is
10981 Get_Decoded_Name_String (Chars (E));
10983 if Opt.External_Name_Imp_Casing = Uppercase then
10984 Set_Casing (All_Upper_Case);
10986 Set_Casing (All_Lower_Case);
10990 Make_String_Literal (Sloc (E),
10991 Strval => String_From_Name_Buffer);
10992 end Get_Default_External_Name;
10994 --------------------------
10995 -- Get_Enclosing_Object --
10996 --------------------------
10998 function Get_Enclosing_Object (N : Node_Id) return Entity_Id is
11000 if Is_Entity_Name (N) then
11004 when N_Indexed_Component
11005 | N_Selected_Component
11008 -- If not generating code, a dereference may be left implicit.
11009 -- In thoses cases, return Empty.
11011 if Is_Access_Type (Etype (Prefix (N))) then
11014 return Get_Enclosing_Object (Prefix (N));
11017 when N_Type_Conversion =>
11018 return Get_Enclosing_Object (Expression (N));
11024 end Get_Enclosing_Object;
11026 ---------------------------
11027 -- Get_Enum_Lit_From_Pos --
11028 ---------------------------
11030 function Get_Enum_Lit_From_Pos
11033 Loc : Source_Ptr) return Node_Id
11035 Btyp : Entity_Id := Base_Type (T);
11040 -- In the case where the literal is of type Character, Wide_Character
11041 -- or Wide_Wide_Character or of a type derived from them, there needs
11042 -- to be some special handling since there is no explicit chain of
11043 -- literals to search. Instead, an N_Character_Literal node is created
11044 -- with the appropriate Char_Code and Chars fields.
11046 if Is_Standard_Character_Type (T) then
11047 Set_Character_Literal_Name (UI_To_CC (Pos));
11050 Make_Character_Literal (Loc,
11051 Chars => Name_Find,
11052 Char_Literal_Value => Pos);
11054 -- For all other cases, we have a complete table of literals, and
11055 -- we simply iterate through the chain of literal until the one
11056 -- with the desired position value is found.
11059 if Is_Private_Type (Btyp) and then Present (Full_View (Btyp)) then
11060 Btyp := Full_View (Btyp);
11063 Lit := First_Literal (Btyp);
11065 -- Position in the enumeration type starts at 0
11068 raise Constraint_Error;
11071 for J in 1 .. UI_To_Int (Pos) loop
11072 Next_Literal (Lit);
11074 -- If Lit is Empty, Pos is not in range, so raise Constraint_Error
11075 -- inside the loop to avoid calling Next_Literal on Empty.
11078 raise Constraint_Error;
11082 -- Create a new node from Lit, with source location provided by Loc
11083 -- if not equal to No_Location, or by copying the source location of
11088 if LLoc = No_Location then
11089 LLoc := Sloc (Lit);
11092 return New_Occurrence_Of (Lit, LLoc);
11094 end Get_Enum_Lit_From_Pos;
11096 ----------------------
11097 -- Get_Fullest_View --
11098 ----------------------
11100 function Get_Fullest_View
11102 Include_PAT : Boolean := True;
11103 Recurse : Boolean := True) return Entity_Id
11105 New_E : Entity_Id := Empty;
11108 -- Prevent cascaded errors
11114 -- Look at each kind of entity to see where we may need to go deeper.
11117 when Incomplete_Kind =>
11118 if From_Limited_With (E) then
11119 New_E := Non_Limited_View (E);
11120 elsif Present (Full_View (E)) then
11121 New_E := Full_View (E);
11122 elsif Ekind (E) = E_Incomplete_Subtype then
11123 New_E := Etype (E);
11126 when Private_Kind =>
11127 if Present (Underlying_Full_View (E)) then
11128 New_E := Underlying_Full_View (E);
11129 elsif Present (Full_View (E)) then
11130 New_E := Full_View (E);
11131 elsif Etype (E) /= E then
11132 New_E := Etype (E);
11136 if Include_PAT and then Present (Packed_Array_Impl_Type (E)) then
11137 New_E := Packed_Array_Impl_Type (E);
11140 when E_Record_Subtype =>
11141 if Present (Cloned_Subtype (E)) then
11142 New_E := Cloned_Subtype (E);
11145 when E_Class_Wide_Type =>
11146 New_E := Root_Type (E);
11148 when E_Class_Wide_Subtype =>
11149 if Present (Equivalent_Type (E)) then
11150 New_E := Equivalent_Type (E);
11151 elsif Present (Cloned_Subtype (E)) then
11152 New_E := Cloned_Subtype (E);
11155 when E_Protected_Subtype
11160 if Present (Corresponding_Record_Type (E)) then
11161 New_E := Corresponding_Record_Type (E);
11164 when E_Access_Protected_Subprogram_Type
11165 | E_Anonymous_Access_Protected_Subprogram_Type
11167 if Present (Equivalent_Type (E)) then
11168 New_E := Equivalent_Type (E);
11171 when E_Access_Subtype =>
11172 New_E := Base_Type (E);
11178 -- If we found a fuller view, either return it or recurse. Otherwise,
11179 -- return our input.
11181 return (if No (New_E) then E
11182 elsif Recurse then Get_Fullest_View (New_E, Include_PAT, Recurse)
11184 end Get_Fullest_View;
11186 ------------------------
11187 -- Get_Generic_Entity --
11188 ------------------------
11190 function Get_Generic_Entity (N : Node_Id) return Entity_Id is
11191 Ent : constant Entity_Id := Entity (Name (N));
11193 if Present (Renamed_Entity (Ent)) then
11194 return Renamed_Entity (Ent);
11198 end Get_Generic_Entity;
11200 -------------------------------------
11201 -- Get_Incomplete_View_Of_Ancestor --
11202 -------------------------------------
11204 function Get_Incomplete_View_Of_Ancestor (E : Entity_Id) return Entity_Id is
11205 Cur_Unit : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
11206 Par_Scope : Entity_Id;
11207 Par_Type : Entity_Id;
11210 -- The incomplete view of an ancestor is only relevant for private
11211 -- derived types in child units.
11213 if not Is_Derived_Type (E)
11214 or else not Is_Child_Unit (Cur_Unit)
11219 Par_Scope := Scope (Cur_Unit);
11220 if No (Par_Scope) then
11224 Par_Type := Etype (Base_Type (E));
11226 -- Traverse list of ancestor types until we find one declared in
11227 -- a parent or grandparent unit (two levels seem sufficient).
11229 while Present (Par_Type) loop
11230 if Scope (Par_Type) = Par_Scope
11231 or else Scope (Par_Type) = Scope (Par_Scope)
11235 elsif not Is_Derived_Type (Par_Type) then
11239 Par_Type := Etype (Base_Type (Par_Type));
11243 -- If none found, there is no relevant ancestor type.
11247 end Get_Incomplete_View_Of_Ancestor;
11249 ----------------------
11250 -- Get_Index_Bounds --
11251 ----------------------
11253 procedure Get_Index_Bounds
11257 Use_Full_View : Boolean := False)
11259 function Scalar_Range_Of_Type (Typ : Entity_Id) return Node_Id;
11260 -- Obtain the scalar range of type Typ. If flag Use_Full_View is set and
11261 -- Typ qualifies, the scalar range is obtained from the full view of the
11264 --------------------------
11265 -- Scalar_Range_Of_Type --
11266 --------------------------
11268 function Scalar_Range_Of_Type (Typ : Entity_Id) return Node_Id is
11269 T : Entity_Id := Typ;
11272 if Use_Full_View and then Present (Full_View (T)) then
11273 T := Full_View (T);
11276 return Scalar_Range (T);
11277 end Scalar_Range_Of_Type;
11281 Kind : constant Node_Kind := Nkind (N);
11284 -- Start of processing for Get_Index_Bounds
11287 if Kind = N_Range then
11288 L := Low_Bound (N);
11289 H := High_Bound (N);
11291 elsif Kind = N_Subtype_Indication then
11292 Rng := Range_Expression (Constraint (N));
11294 if Rng = Error then
11300 L := Low_Bound (Range_Expression (Constraint (N)));
11301 H := High_Bound (Range_Expression (Constraint (N)));
11304 elsif Is_Entity_Name (N) and then Is_Type (Entity (N)) then
11305 Rng := Scalar_Range_Of_Type (Entity (N));
11307 if Error_Posted (Rng) then
11311 elsif Nkind (Rng) = N_Subtype_Indication then
11312 Get_Index_Bounds (Rng, L, H);
11315 L := Low_Bound (Rng);
11316 H := High_Bound (Rng);
11320 -- N is an expression, indicating a range with one value
11325 end Get_Index_Bounds;
11327 function Get_Index_Bounds
11329 Use_Full_View : Boolean := False) return Range_Nodes is
11330 Result : Range_Nodes;
11332 Get_Index_Bounds (N, Result.First, Result.Last, Use_Full_View);
11334 end Get_Index_Bounds;
11336 function Get_Index_Bounds
11338 Use_Full_View : Boolean := False) return Range_Values is
11339 Nodes : constant Range_Nodes := Get_Index_Bounds (N, Use_Full_View);
11341 return (Expr_Value (Nodes.First), Expr_Value (Nodes.Last));
11342 end Get_Index_Bounds;
11344 -----------------------------
11345 -- Get_Interfacing_Aspects --
11346 -----------------------------
11348 procedure Get_Interfacing_Aspects
11349 (Iface_Asp : Node_Id;
11350 Conv_Asp : out Node_Id;
11351 EN_Asp : out Node_Id;
11352 Expo_Asp : out Node_Id;
11353 Imp_Asp : out Node_Id;
11354 LN_Asp : out Node_Id;
11355 Do_Checks : Boolean := False)
11357 procedure Save_Or_Duplication_Error
11359 To : in out Node_Id);
11360 -- Save the value of aspect Asp in node To. If To already has a value,
11361 -- then this is considered a duplicate use of aspect. Emit an error if
11362 -- flag Do_Checks is set.
11364 -------------------------------
11365 -- Save_Or_Duplication_Error --
11366 -------------------------------
11368 procedure Save_Or_Duplication_Error
11370 To : in out Node_Id)
11373 -- Detect an extra aspect and issue an error
11375 if Present (To) then
11377 Error_Msg_Name_1 := Chars (Identifier (Asp));
11378 Error_Msg_Sloc := Sloc (To);
11379 Error_Msg_N ("aspect % previously given #", Asp);
11382 -- Otherwise capture the aspect
11387 end Save_Or_Duplication_Error;
11392 Asp_Id : Aspect_Id;
11394 -- The following variables capture each individual aspect
11396 Conv : Node_Id := Empty;
11397 EN : Node_Id := Empty;
11398 Expo : Node_Id := Empty;
11399 Imp : Node_Id := Empty;
11400 LN : Node_Id := Empty;
11402 -- Start of processing for Get_Interfacing_Aspects
11405 -- The input interfacing aspect should reside in an aspect specification
11408 pragma Assert (Is_List_Member (Iface_Asp));
11410 -- Examine the aspect specifications of the related entity. Find and
11411 -- capture all interfacing aspects. Detect duplicates and emit errors
11414 Asp := First (List_Containing (Iface_Asp));
11415 while Present (Asp) loop
11416 Asp_Id := Get_Aspect_Id (Asp);
11418 if Asp_Id = Aspect_Convention then
11419 Save_Or_Duplication_Error (Asp, Conv);
11421 elsif Asp_Id = Aspect_External_Name then
11422 Save_Or_Duplication_Error (Asp, EN);
11424 elsif Asp_Id = Aspect_Export then
11425 Save_Or_Duplication_Error (Asp, Expo);
11427 elsif Asp_Id = Aspect_Import then
11428 Save_Or_Duplication_Error (Asp, Imp);
11430 elsif Asp_Id = Aspect_Link_Name then
11431 Save_Or_Duplication_Error (Asp, LN);
11442 end Get_Interfacing_Aspects;
11444 ---------------------------------
11445 -- Get_Iterable_Type_Primitive --
11446 ---------------------------------
11448 function Get_Iterable_Type_Primitive
11450 Nam : Name_Id) return Entity_Id
11455 Nam in Name_Element
11462 Funcs : constant Node_Id := Find_Value_Of_Aspect (Typ, Aspect_Iterable);
11470 Assoc := First (Component_Associations (Funcs));
11471 while Present (Assoc) loop
11472 if Chars (First (Choices (Assoc))) = Nam then
11473 return Entity (Expression (Assoc));
11481 end Get_Iterable_Type_Primitive;
11483 ---------------------------
11484 -- Get_Library_Unit_Name --
11485 ---------------------------
11487 function Get_Library_Unit_Name (Decl_Node : Node_Id) return String_Id is
11488 Unit_Name_Id : constant Unit_Name_Type := Get_Unit_Name (Decl_Node);
11489 Buf : Bounded_String;
11491 Get_Unit_Name_String (Buf, Unit_Name_Id);
11493 -- Remove the last seven characters (" (spec)" or " (body)")
11495 Buf.Length := Buf.Length - 7;
11496 pragma Assert (Buf.Chars (Buf.Length + 1) = ' ');
11498 return String_From_Name_Buffer (Buf);
11499 end Get_Library_Unit_Name;
11501 --------------------------
11502 -- Get_Max_Queue_Length --
11503 --------------------------
11505 function Get_Max_Queue_Length (Id : Entity_Id) return Uint is
11506 pragma Assert (Is_Entry (Id));
11507 Prag : constant Entity_Id := Get_Pragma (Id, Pragma_Max_Queue_Length);
11511 -- A value of 0 or -1 represents no maximum specified, and entries and
11512 -- entry families with no Max_Queue_Length aspect or pragma default to
11515 if not Present (Prag) then
11520 (Expression (First (Pragma_Argument_Associations (Prag))));
11522 -- Since -1 and 0 are equivalent, return 0 for instances of -1 for
11530 end Get_Max_Queue_Length;
11532 ------------------------
11533 -- Get_Name_Entity_Id --
11534 ------------------------
11536 function Get_Name_Entity_Id (Id : Name_Id) return Entity_Id is
11538 return Entity_Id (Get_Name_Table_Int (Id));
11539 end Get_Name_Entity_Id;
11541 ------------------------------
11542 -- Get_Name_From_CTC_Pragma --
11543 ------------------------------
11545 function Get_Name_From_CTC_Pragma (N : Node_Id) return String_Id is
11546 Arg : constant Node_Id :=
11547 Get_Pragma_Arg (First (Pragma_Argument_Associations (N)));
11549 return Strval (Expr_Value_S (Arg));
11550 end Get_Name_From_CTC_Pragma;
11552 -----------------------
11553 -- Get_Parent_Entity --
11554 -----------------------
11556 function Get_Parent_Entity (Unit : Node_Id) return Entity_Id is
11558 if Nkind (Unit) = N_Package_Body
11559 and then Nkind (Original_Node (Unit)) = N_Package_Instantiation
11561 return Defining_Entity
11562 (Specification (Instance_Spec (Original_Node (Unit))));
11563 elsif Nkind (Unit) = N_Package_Instantiation then
11564 return Defining_Entity (Specification (Instance_Spec (Unit)));
11566 return Defining_Entity (Unit);
11568 end Get_Parent_Entity;
11570 -------------------
11571 -- Get_Pragma_Id --
11572 -------------------
11574 function Get_Pragma_Id (N : Node_Id) return Pragma_Id is
11576 return Get_Pragma_Id (Pragma_Name_Unmapped (N));
11579 ------------------------
11580 -- Get_Qualified_Name --
11581 ------------------------
11583 function Get_Qualified_Name
11585 Suffix : Entity_Id := Empty) return Name_Id
11587 Suffix_Nam : Name_Id := No_Name;
11590 if Present (Suffix) then
11591 Suffix_Nam := Chars (Suffix);
11594 return Get_Qualified_Name (Chars (Id), Suffix_Nam, Scope (Id));
11595 end Get_Qualified_Name;
11597 function Get_Qualified_Name
11599 Suffix : Name_Id := No_Name;
11600 Scop : Entity_Id := Current_Scope) return Name_Id
11602 procedure Add_Scope (S : Entity_Id);
11603 -- Add the fully qualified form of scope S to the name buffer. The
11611 procedure Add_Scope (S : Entity_Id) is
11616 elsif S = Standard_Standard then
11620 Add_Scope (Scope (S));
11621 Get_Name_String_And_Append (Chars (S));
11622 Add_Str_To_Name_Buffer ("__");
11626 -- Start of processing for Get_Qualified_Name
11632 -- Append the base name after all scopes have been chained
11634 Get_Name_String_And_Append (Nam);
11636 -- Append the suffix (if present)
11638 if Suffix /= No_Name then
11639 Add_Str_To_Name_Buffer ("__");
11640 Get_Name_String_And_Append (Suffix);
11644 end Get_Qualified_Name;
11646 -----------------------
11647 -- Get_Reason_String --
11648 -----------------------
11650 procedure Get_Reason_String (N : Node_Id) is
11652 if Nkind (N) = N_String_Literal then
11653 Store_String_Chars (Strval (N));
11655 elsif Nkind (N) = N_Op_Concat then
11656 Get_Reason_String (Left_Opnd (N));
11657 Get_Reason_String (Right_Opnd (N));
11659 -- If not of required form, error
11663 ("Reason for pragma Warnings has wrong form", N);
11665 ("\must be string literal or concatenation of string literals", N);
11668 end Get_Reason_String;
11670 --------------------------------
11671 -- Get_Reference_Discriminant --
11672 --------------------------------
11674 function Get_Reference_Discriminant (Typ : Entity_Id) return Entity_Id is
11678 D := First_Discriminant (Typ);
11679 while Present (D) loop
11680 if Has_Implicit_Dereference (D) then
11683 Next_Discriminant (D);
11687 end Get_Reference_Discriminant;
11689 ---------------------------
11690 -- Get_Referenced_Object --
11691 ---------------------------
11693 function Get_Referenced_Object (N : Node_Id) return Node_Id is
11698 while Is_Entity_Name (R)
11699 and then Is_Object (Entity (R))
11700 and then Present (Renamed_Object (Entity (R)))
11702 R := Renamed_Object (Entity (R));
11706 end Get_Referenced_Object;
11708 ------------------------
11709 -- Get_Renamed_Entity --
11710 ------------------------
11712 function Get_Renamed_Entity (E : Entity_Id) return Entity_Id is
11713 R : Entity_Id := E;
11715 while Present (Renamed_Entity (R)) loop
11716 R := Renamed_Entity (R);
11720 end Get_Renamed_Entity;
11722 -----------------------
11723 -- Get_Return_Object --
11724 -----------------------
11726 function Get_Return_Object (N : Node_Id) return Entity_Id is
11730 Decl := First (Return_Object_Declarations (N));
11731 while Present (Decl) loop
11732 exit when Nkind (Decl) = N_Object_Declaration
11733 and then Is_Return_Object (Defining_Identifier (Decl));
11737 pragma Assert (Present (Decl));
11738 return Defining_Identifier (Decl);
11739 end Get_Return_Object;
11741 ---------------------------
11742 -- Get_Subprogram_Entity --
11743 ---------------------------
11745 function Get_Subprogram_Entity (Nod : Node_Id) return Entity_Id is
11747 Subp_Id : Entity_Id;
11750 if Nkind (Nod) = N_Accept_Statement then
11751 Subp := Entry_Direct_Name (Nod);
11753 elsif Nkind (Nod) = N_Slice then
11754 Subp := Prefix (Nod);
11757 Subp := Name (Nod);
11760 -- Strip the subprogram call
11763 if Nkind (Subp) in N_Explicit_Dereference
11764 | N_Indexed_Component
11765 | N_Selected_Component
11767 Subp := Prefix (Subp);
11769 elsif Nkind (Subp) in N_Type_Conversion
11770 | N_Unchecked_Type_Conversion
11772 Subp := Expression (Subp);
11779 -- Extract the entity of the subprogram call
11781 if Is_Entity_Name (Subp) then
11782 Subp_Id := Entity (Subp);
11784 if Ekind (Subp_Id) = E_Access_Subprogram_Type then
11785 Subp_Id := Directly_Designated_Type (Subp_Id);
11788 if Is_Subprogram (Subp_Id) then
11794 -- The search did not find a construct that denotes a subprogram
11799 end Get_Subprogram_Entity;
11801 -----------------------------
11802 -- Get_Task_Body_Procedure --
11803 -----------------------------
11805 function Get_Task_Body_Procedure (E : Entity_Id) return Entity_Id is
11807 -- Note: A task type may be the completion of a private type with
11808 -- discriminants. When performing elaboration checks on a task
11809 -- declaration, the current view of the type may be the private one,
11810 -- and the procedure that holds the body of the task is held in its
11811 -- underlying type.
11813 -- This is an odd function, why not have Task_Body_Procedure do
11814 -- the following digging???
11816 return Task_Body_Procedure (Underlying_Type (Root_Type (E)));
11817 end Get_Task_Body_Procedure;
11819 -------------------------------
11820 -- Get_User_Defined_Equality --
11821 -------------------------------
11823 function Get_User_Defined_Equality (E : Entity_Id) return Entity_Id is
11827 Prim := First_Elmt (Collect_Primitive_Operations (E));
11828 while Present (Prim) loop
11829 if Is_User_Defined_Equality (Node (Prim)) then
11830 return Node (Prim);
11837 end Get_User_Defined_Equality;
11843 procedure Get_Views
11845 Priv_Typ : out Entity_Id;
11846 Full_Typ : out Entity_Id;
11847 UFull_Typ : out Entity_Id;
11848 CRec_Typ : out Entity_Id)
11850 IP_View : Entity_Id;
11853 -- Assume that none of the views can be recovered
11857 UFull_Typ := Empty;
11860 -- The input type is the corresponding record type of a protected or a
11863 if Ekind (Typ) = E_Record_Type
11864 and then Is_Concurrent_Record_Type (Typ)
11867 Full_Typ := Corresponding_Concurrent_Type (CRec_Typ);
11868 Priv_Typ := Incomplete_Or_Partial_View (Full_Typ);
11870 -- Otherwise the input type denotes an arbitrary type
11873 IP_View := Incomplete_Or_Partial_View (Typ);
11875 -- The input type denotes the full view of a private type
11877 if Present (IP_View) then
11878 Priv_Typ := IP_View;
11881 -- The input type is a private type
11883 elsif Is_Private_Type (Typ) then
11885 Full_Typ := Full_View (Priv_Typ);
11887 -- Otherwise the input type does not have any views
11893 if Present (Full_Typ) and then Is_Private_Type (Full_Typ) then
11894 UFull_Typ := Underlying_Full_View (Full_Typ);
11896 if Present (UFull_Typ)
11897 and then Ekind (UFull_Typ) in E_Protected_Type | E_Task_Type
11899 CRec_Typ := Corresponding_Record_Type (UFull_Typ);
11903 if Present (Full_Typ)
11904 and then Ekind (Full_Typ) in E_Protected_Type | E_Task_Type
11906 CRec_Typ := Corresponding_Record_Type (Full_Typ);
11912 -----------------------
11913 -- Has_Access_Values --
11914 -----------------------
11916 function Has_Access_Values (T : Entity_Id) return Boolean
11918 Typ : constant Entity_Id := Underlying_Type (T);
11921 -- Case of a private type which is not completed yet. This can only
11922 -- happen in the case of a generic formal type appearing directly, or
11923 -- as a component of the type to which this function is being applied
11924 -- at the top level. Return False in this case, since we certainly do
11925 -- not know that the type contains access types.
11930 elsif Is_Access_Type (Typ) then
11933 elsif Is_Array_Type (Typ) then
11934 return Has_Access_Values (Component_Type (Typ));
11936 elsif Is_Record_Type (Typ) then
11941 -- Loop to check components
11943 Comp := First_Component_Or_Discriminant (Typ);
11944 while Present (Comp) loop
11946 -- Check for access component, tag field does not count, even
11947 -- though it is implemented internally using an access type.
11949 if Has_Access_Values (Etype (Comp))
11950 and then Chars (Comp) /= Name_uTag
11955 Next_Component_Or_Discriminant (Comp);
11964 end Has_Access_Values;
11966 ---------------------------------------
11967 -- Has_Anonymous_Access_Discriminant --
11968 ---------------------------------------
11970 function Has_Anonymous_Access_Discriminant (Typ : Entity_Id) return Boolean
11975 if not Has_Discriminants (Typ) then
11979 Disc := First_Discriminant (Typ);
11980 while Present (Disc) loop
11981 if Ekind (Etype (Disc)) = E_Anonymous_Access_Type then
11985 Next_Discriminant (Disc);
11989 end Has_Anonymous_Access_Discriminant;
11991 ------------------------------
11992 -- Has_Compatible_Alignment --
11993 ------------------------------
11995 function Has_Compatible_Alignment
11998 Layout_Done : Boolean) return Alignment_Result
12000 function Has_Compatible_Alignment_Internal
12003 Layout_Done : Boolean;
12004 Default : Alignment_Result) return Alignment_Result;
12005 -- This is the internal recursive function that actually does the work.
12006 -- There is one additional parameter, which says what the result should
12007 -- be if no alignment information is found, and there is no definite
12008 -- indication of compatible alignments. At the outer level, this is set
12009 -- to Unknown, but for internal recursive calls in the case where types
12010 -- are known to be correct, it is set to Known_Compatible.
12012 ---------------------------------------
12013 -- Has_Compatible_Alignment_Internal --
12014 ---------------------------------------
12016 function Has_Compatible_Alignment_Internal
12019 Layout_Done : Boolean;
12020 Default : Alignment_Result) return Alignment_Result
12022 Result : Alignment_Result := Known_Compatible;
12023 -- Holds the current status of the result. Note that once a value of
12024 -- Known_Incompatible is set, it is sticky and does not get changed
12025 -- to Unknown (the value in Result only gets worse as we go along,
12028 Offs : Uint := No_Uint;
12029 -- Set to a factor of the offset from the base object when Expr is a
12030 -- selected or indexed component, based on Component_Bit_Offset and
12031 -- Component_Size respectively. A negative value is used to represent
12032 -- a value that is not known at compile time.
12034 procedure Check_Prefix;
12035 -- Checks the prefix recursively in the case where the expression
12036 -- is an indexed or selected component.
12038 procedure Set_Result (R : Alignment_Result);
12039 -- If R represents a worse outcome (unknown instead of known
12040 -- compatible, or known incompatible), then set Result to R.
12046 procedure Check_Prefix is
12048 -- The subtlety here is that in doing a recursive call to check
12049 -- the prefix, we have to decide what to do in the case where we
12050 -- don't find any specific indication of an alignment problem.
12052 -- At the outer level, we normally set Unknown as the result in
12053 -- this case, since we can only set Known_Compatible if we really
12054 -- know that the alignment value is OK, but for the recursive
12055 -- call, in the case where the types match, and we have not
12056 -- specified a peculiar alignment for the object, we are only
12057 -- concerned about suspicious rep clauses, the default case does
12058 -- not affect us, since the compiler will, in the absence of such
12059 -- rep clauses, ensure that the alignment is correct.
12061 if Default = Known_Compatible
12063 (Etype (Obj) = Etype (Expr)
12064 and then (not Known_Alignment (Obj)
12066 Alignment (Obj) = Alignment (Etype (Obj))))
12069 (Has_Compatible_Alignment_Internal
12070 (Obj, Prefix (Expr), Layout_Done, Known_Compatible));
12072 -- In all other cases, we need a full check on the prefix
12076 (Has_Compatible_Alignment_Internal
12077 (Obj, Prefix (Expr), Layout_Done, Unknown));
12085 procedure Set_Result (R : Alignment_Result) is
12092 -- Start of processing for Has_Compatible_Alignment_Internal
12095 -- If Expr is a selected component, we must make sure there is no
12096 -- potentially troublesome component clause and that the record is
12097 -- not packed if the layout is not done.
12099 if Nkind (Expr) = N_Selected_Component then
12101 -- Packing generates unknown alignment if layout is not done
12103 if Is_Packed (Etype (Prefix (Expr))) and then not Layout_Done then
12104 Set_Result (Unknown);
12107 -- Check prefix and component offset
12110 Offs := Component_Bit_Offset (Entity (Selector_Name (Expr)));
12112 -- If Expr is an indexed component, we must make sure there is no
12113 -- potentially troublesome Component_Size clause and that the array
12114 -- is not bit-packed if the layout is not done.
12116 elsif Nkind (Expr) = N_Indexed_Component then
12118 Typ : constant Entity_Id := Etype (Prefix (Expr));
12121 -- Packing generates unknown alignment if layout is not done
12123 if Is_Bit_Packed_Array (Typ) and then not Layout_Done then
12124 Set_Result (Unknown);
12127 -- Check prefix and component offset (or at least size)
12130 Offs := Indexed_Component_Bit_Offset (Expr);
12132 Offs := Component_Size (Typ);
12137 -- If we have a null offset, the result is entirely determined by
12138 -- the base object and has already been computed recursively.
12140 if Present (Offs) and then Offs = Uint_0 then
12143 -- Case where we know the alignment of the object
12145 elsif Known_Alignment (Obj) then
12147 ObjA : constant Uint := Alignment (Obj);
12148 ExpA : Uint := No_Uint;
12149 SizA : Uint := No_Uint;
12152 -- If alignment of Obj is 1, then we are always OK
12155 Set_Result (Known_Compatible);
12157 -- Alignment of Obj is greater than 1, so we need to check
12160 -- If we have an offset, see if it is compatible
12162 if Present (Offs) and then Offs > Uint_0 then
12163 if Offs mod (System_Storage_Unit * ObjA) /= 0 then
12164 Set_Result (Known_Incompatible);
12167 -- See if Expr is an object with known alignment
12169 elsif Is_Entity_Name (Expr)
12170 and then Known_Alignment (Entity (Expr))
12173 ExpA := Alignment (Entity (Expr));
12175 -- Otherwise, we can use the alignment of the type of Expr
12176 -- given that we already checked for discombobulating rep
12177 -- clauses for the cases of indexed and selected components
12180 elsif Known_Alignment (Etype (Expr)) then
12181 ExpA := Alignment (Etype (Expr));
12183 -- Otherwise the alignment is unknown
12186 Set_Result (Default);
12189 -- If we got an alignment, see if it is acceptable
12191 if Present (ExpA) and then ExpA < ObjA then
12192 Set_Result (Known_Incompatible);
12195 -- If Expr is a component or an entire object with a known
12196 -- alignment, then we are fine. Otherwise, if its size is
12197 -- known, it must be big enough for the required alignment.
12199 if Present (Offs) then
12202 -- See if Expr is an object with known size
12204 elsif Is_Entity_Name (Expr)
12205 and then Known_Static_Esize (Entity (Expr))
12207 SizA := Esize (Entity (Expr));
12209 -- Otherwise, we check the object size of the Expr type
12211 elsif Known_Static_Esize (Etype (Expr)) then
12212 SizA := Esize (Etype (Expr));
12215 -- If we got a size, see if it is a multiple of the Obj
12216 -- alignment; if not, then the alignment cannot be
12217 -- acceptable, since the size is always a multiple of the
12220 if Present (SizA) then
12221 if SizA mod (ObjA * Ttypes.System_Storage_Unit) /= 0 then
12222 Set_Result (Known_Incompatible);
12228 -- If we do not know required alignment, any non-zero offset is a
12229 -- potential problem (but certainly may be OK, so result is unknown).
12231 elsif Present (Offs) then
12232 Set_Result (Unknown);
12234 -- If we can't find the result by direct comparison of alignment
12235 -- values, then there is still one case that we can determine known
12236 -- result, and that is when we can determine that the types are the
12237 -- same, and no alignments are specified. Then we known that the
12238 -- alignments are compatible, even if we don't know the alignment
12239 -- value in the front end.
12241 elsif Etype (Obj) = Etype (Expr) then
12243 -- Types are the same, but we have to check for possible size
12244 -- and alignments on the Expr object that may make the alignment
12245 -- different, even though the types are the same.
12247 if Is_Entity_Name (Expr) then
12249 -- First check alignment of the Expr object. Any alignment less
12250 -- than Maximum_Alignment is worrisome since this is the case
12251 -- where we do not know the alignment of Obj.
12253 if Known_Alignment (Entity (Expr))
12254 and then Alignment (Entity (Expr)) < Ttypes.Maximum_Alignment
12256 Set_Result (Unknown);
12258 -- Now check size of Expr object. Any size that is not an even
12259 -- multiple of Maximum_Alignment is also worrisome since it
12260 -- may cause the alignment of the object to be less than the
12261 -- alignment of the type.
12263 elsif Known_Static_Esize (Entity (Expr))
12265 Esize (Entity (Expr)) mod
12266 (Ttypes.Maximum_Alignment * Ttypes.System_Storage_Unit)
12269 Set_Result (Unknown);
12271 -- Otherwise same type is decisive
12274 Set_Result (Known_Compatible);
12278 -- Another case to deal with is when there is an explicit size or
12279 -- alignment clause when the types are not the same. If so, then the
12280 -- result is Unknown. We don't need to do this test if the Default is
12281 -- Unknown, since that result will be set in any case.
12283 elsif Default /= Unknown
12284 and then (Has_Size_Clause (Etype (Expr))
12286 Has_Alignment_Clause (Etype (Expr)))
12288 Set_Result (Unknown);
12290 -- If no indication found, set default
12293 Set_Result (Default);
12296 -- Return worst result found
12299 end Has_Compatible_Alignment_Internal;
12301 -- Start of processing for Has_Compatible_Alignment
12304 -- If Obj has no specified alignment, then set alignment from the type
12305 -- alignment. Perhaps we should always do this, but for sure we should
12306 -- do it when there is an address clause since we can do more if the
12307 -- alignment is known.
12309 if not Known_Alignment (Obj) and then Known_Alignment (Etype (Obj)) then
12310 Set_Alignment (Obj, Alignment (Etype (Obj)));
12313 -- Now do the internal call that does all the work
12316 Has_Compatible_Alignment_Internal (Obj, Expr, Layout_Done, Unknown);
12317 end Has_Compatible_Alignment;
12319 ----------------------
12320 -- Has_Declarations --
12321 ----------------------
12323 function Has_Declarations (N : Node_Id) return Boolean is
12325 return Nkind (N) in N_Accept_Statement
12326 | N_Block_Statement
12327 | N_Compilation_Unit_Aux
12331 | N_Subprogram_Body
12333 | N_Package_Specification;
12334 end Has_Declarations;
12336 ---------------------------------
12337 -- Has_Defaulted_Discriminants --
12338 ---------------------------------
12340 function Has_Defaulted_Discriminants (Typ : Entity_Id) return Boolean is
12342 return Has_Discriminants (Typ)
12343 and then Present (Discriminant_Default_Value
12344 (First_Discriminant (Typ)));
12345 end Has_Defaulted_Discriminants;
12347 -------------------
12348 -- Has_Denormals --
12349 -------------------
12351 function Has_Denormals (E : Entity_Id) return Boolean is
12353 return Is_Floating_Point_Type (E) and then Denorm_On_Target;
12356 -------------------------------------------
12357 -- Has_Discriminant_Dependent_Constraint --
12358 -------------------------------------------
12360 function Has_Discriminant_Dependent_Constraint
12361 (Comp : Entity_Id) return Boolean
12363 Comp_Decl : constant Node_Id := Parent (Comp);
12364 Subt_Indic : Node_Id;
12369 -- Discriminants can't depend on discriminants
12371 if Ekind (Comp) = E_Discriminant then
12375 Subt_Indic := Subtype_Indication (Component_Definition (Comp_Decl));
12377 if Nkind (Subt_Indic) = N_Subtype_Indication then
12378 Constr := Constraint (Subt_Indic);
12380 if Nkind (Constr) = N_Index_Or_Discriminant_Constraint then
12381 Assn := First (Constraints (Constr));
12382 while Present (Assn) loop
12383 case Nkind (Assn) is
12386 | N_Subtype_Indication
12388 if Depends_On_Discriminant (Assn) then
12392 when N_Discriminant_Association =>
12393 if Depends_On_Discriminant (Expression (Assn)) then
12408 end Has_Discriminant_Dependent_Constraint;
12410 --------------------------------------
12411 -- Has_Effectively_Volatile_Profile --
12412 --------------------------------------
12414 function Has_Effectively_Volatile_Profile
12415 (Subp_Id : Entity_Id) return Boolean
12417 Formal : Entity_Id;
12420 -- Inspect the formal parameters looking for an effectively volatile
12421 -- type for reading.
12423 Formal := First_Formal (Subp_Id);
12424 while Present (Formal) loop
12425 if Is_Effectively_Volatile_For_Reading (Etype (Formal)) then
12429 Next_Formal (Formal);
12432 -- Inspect the return type of functions
12434 if Ekind (Subp_Id) in E_Function | E_Generic_Function
12435 and then Is_Effectively_Volatile_For_Reading (Etype (Subp_Id))
12441 end Has_Effectively_Volatile_Profile;
12443 --------------------------
12444 -- Has_Enabled_Property --
12445 --------------------------
12447 function Has_Enabled_Property
12448 (Item_Id : Entity_Id;
12449 Property : Name_Id) return Boolean
12451 function Protected_Type_Or_Variable_Has_Enabled_Property return Boolean;
12452 -- Determine whether a protected type or variable denoted by Item_Id
12453 -- has the property enabled.
12455 function State_Has_Enabled_Property return Boolean;
12456 -- Determine whether a state denoted by Item_Id has the property enabled
12458 function Type_Or_Variable_Has_Enabled_Property
12459 (Item_Id : Entity_Id) return Boolean;
12460 -- Determine whether type or variable denoted by Item_Id has the
12461 -- property enabled.
12463 -----------------------------------------------------
12464 -- Protected_Type_Or_Variable_Has_Enabled_Property --
12465 -----------------------------------------------------
12467 function Protected_Type_Or_Variable_Has_Enabled_Property return Boolean
12470 -- Protected entities always have the properties Async_Readers and
12471 -- Async_Writers (SPARK RM 7.1.2(16)).
12473 if Property = Name_Async_Readers
12474 or else Property = Name_Async_Writers
12478 -- Protected objects that have Part_Of components also inherit their
12479 -- properties Effective_Reads and Effective_Writes
12480 -- (SPARK RM 7.1.2(16)).
12482 elsif Is_Single_Protected_Object (Item_Id) then
12484 Constit_Elmt : Elmt_Id;
12485 Constit_Id : Entity_Id;
12486 Constits : constant Elist_Id
12487 := Part_Of_Constituents (Item_Id);
12489 if Present (Constits) then
12490 Constit_Elmt := First_Elmt (Constits);
12491 while Present (Constit_Elmt) loop
12492 Constit_Id := Node (Constit_Elmt);
12494 if Has_Enabled_Property (Constit_Id, Property) then
12498 Next_Elmt (Constit_Elmt);
12505 end Protected_Type_Or_Variable_Has_Enabled_Property;
12507 --------------------------------
12508 -- State_Has_Enabled_Property --
12509 --------------------------------
12511 function State_Has_Enabled_Property return Boolean is
12512 Decl : constant Node_Id := Parent (Item_Id);
12514 procedure Find_Simple_Properties
12515 (Has_External : out Boolean;
12516 Has_Synchronous : out Boolean);
12517 -- Extract the simple properties associated with declaration Decl
12519 function Is_Enabled_External_Property return Boolean;
12520 -- Determine whether property Property appears within the external
12521 -- property list of declaration Decl, and return its status.
12523 ----------------------------
12524 -- Find_Simple_Properties --
12525 ----------------------------
12527 procedure Find_Simple_Properties
12528 (Has_External : out Boolean;
12529 Has_Synchronous : out Boolean)
12534 -- Assume that none of the properties are available
12536 Has_External := False;
12537 Has_Synchronous := False;
12539 Opt := First (Expressions (Decl));
12540 while Present (Opt) loop
12541 if Nkind (Opt) = N_Identifier then
12542 if Chars (Opt) = Name_External then
12543 Has_External := True;
12545 elsif Chars (Opt) = Name_Synchronous then
12546 Has_Synchronous := True;
12552 end Find_Simple_Properties;
12554 ----------------------------------
12555 -- Is_Enabled_External_Property --
12556 ----------------------------------
12558 function Is_Enabled_External_Property return Boolean is
12562 Prop_Nam : Node_Id;
12566 Opt := First (Component_Associations (Decl));
12567 while Present (Opt) loop
12568 Opt_Nam := First (Choices (Opt));
12570 if Nkind (Opt_Nam) = N_Identifier
12571 and then Chars (Opt_Nam) = Name_External
12573 Props := Expression (Opt);
12575 -- Multiple properties appear as an aggregate
12577 if Nkind (Props) = N_Aggregate then
12579 -- Simple property form
12581 Prop := First (Expressions (Props));
12582 while Present (Prop) loop
12583 if Chars (Prop) = Property then
12590 -- Property with expression form
12592 Prop := First (Component_Associations (Props));
12593 while Present (Prop) loop
12594 Prop_Nam := First (Choices (Prop));
12596 -- The property can be represented in two ways:
12597 -- others => <value>
12598 -- <property> => <value>
12600 if Nkind (Prop_Nam) = N_Others_Choice
12601 or else (Nkind (Prop_Nam) = N_Identifier
12602 and then Chars (Prop_Nam) = Property)
12604 return Is_True (Expr_Value (Expression (Prop)));
12613 return Chars (Props) = Property;
12621 end Is_Enabled_External_Property;
12625 Has_External : Boolean;
12626 Has_Synchronous : Boolean;
12628 -- Start of processing for State_Has_Enabled_Property
12631 -- The declaration of an external abstract state appears as an
12632 -- extension aggregate. If this is not the case, properties can
12635 if Nkind (Decl) /= N_Extension_Aggregate then
12639 Find_Simple_Properties (Has_External, Has_Synchronous);
12641 -- Simple option External enables all properties (SPARK RM 7.1.2(2))
12643 if Has_External then
12646 -- Option External may enable or disable specific properties
12648 elsif Is_Enabled_External_Property then
12651 -- Simple option Synchronous
12653 -- enables disables
12654 -- Async_Readers Effective_Reads
12655 -- Async_Writers Effective_Writes
12657 -- Note that both forms of External have higher precedence than
12658 -- Synchronous (SPARK RM 7.1.4(9)).
12660 elsif Has_Synchronous then
12661 return Property in Name_Async_Readers | Name_Async_Writers;
12665 end State_Has_Enabled_Property;
12667 -------------------------------------------
12668 -- Type_Or_Variable_Has_Enabled_Property --
12669 -------------------------------------------
12671 function Type_Or_Variable_Has_Enabled_Property
12672 (Item_Id : Entity_Id) return Boolean
12674 AR : constant Node_Id :=
12675 Get_Pragma (Item_Id, Pragma_Async_Readers);
12676 AW : constant Node_Id :=
12677 Get_Pragma (Item_Id, Pragma_Async_Writers);
12678 ER : constant Node_Id :=
12679 Get_Pragma (Item_Id, Pragma_Effective_Reads);
12680 EW : constant Node_Id :=
12681 Get_Pragma (Item_Id, Pragma_Effective_Writes);
12683 Is_Derived_Type_With_Volatile_Parent_Type : constant Boolean :=
12684 Is_Derived_Type (Item_Id)
12685 and then Is_Effectively_Volatile (Etype (Base_Type (Item_Id)));
12688 -- A non-effectively volatile object can never possess external
12691 if not Is_Effectively_Volatile (Item_Id) then
12694 -- External properties related to variables come in two flavors -
12695 -- explicit and implicit. The explicit case is characterized by the
12696 -- presence of a property pragma with an optional Boolean flag. The
12697 -- property is enabled when the flag evaluates to True or the flag is
12698 -- missing altogether.
12700 elsif Property = Name_Async_Readers and then Present (AR) then
12701 return Is_Enabled_Pragma (AR);
12703 elsif Property = Name_Async_Writers and then Present (AW) then
12704 return Is_Enabled_Pragma (AW);
12706 elsif Property = Name_Effective_Reads and then Present (ER) then
12707 return Is_Enabled_Pragma (ER);
12709 elsif Property = Name_Effective_Writes and then Present (EW) then
12710 return Is_Enabled_Pragma (EW);
12712 -- If other properties are set explicitly, then this one is set
12713 -- implicitly to False, except in the case of a derived type
12714 -- whose parent type is volatile (in that case, we will inherit
12715 -- from the parent type, below).
12717 elsif (Present (AR)
12718 or else Present (AW)
12719 or else Present (ER)
12720 or else Present (EW))
12721 and then not Is_Derived_Type_With_Volatile_Parent_Type
12725 -- For a private type (including subtype of a private types), look at
12728 elsif Is_Private_Type (Item_Id) and then Present (Full_View (Item_Id))
12730 return Type_Or_Variable_Has_Enabled_Property (Full_View (Item_Id));
12732 -- For a derived type whose parent type is volatile, the
12733 -- property may be inherited (but ignore a non-volatile parent).
12735 elsif Is_Derived_Type_With_Volatile_Parent_Type then
12736 return Type_Or_Variable_Has_Enabled_Property
12737 (First_Subtype (Etype (Base_Type (Item_Id))));
12739 -- For a subtype, the property will be inherited from its base type.
12741 elsif Is_Type (Item_Id)
12742 and then not Is_Base_Type (Item_Id)
12744 return Type_Or_Variable_Has_Enabled_Property (Etype (Item_Id));
12746 -- If not specified explicitly for an object and its type
12747 -- is effectively volatile, then take result from the type.
12749 elsif Is_Object (Item_Id)
12750 and then Is_Effectively_Volatile (Etype (Item_Id))
12752 return Has_Enabled_Property (Etype (Item_Id), Property);
12754 -- The implicit case lacks all property pragmas
12756 elsif No (AR) and then No (AW) and then No (ER) and then No (EW) then
12757 if Is_Protected_Type (Etype (Item_Id)) then
12758 return Protected_Type_Or_Variable_Has_Enabled_Property;
12766 end Type_Or_Variable_Has_Enabled_Property;
12768 -- Start of processing for Has_Enabled_Property
12771 -- Abstract states and variables have a flexible scheme of specifying
12772 -- external properties.
12774 if Ekind (Item_Id) = E_Abstract_State then
12775 return State_Has_Enabled_Property;
12777 elsif Ekind (Item_Id) in E_Variable | E_Constant then
12778 return Type_Or_Variable_Has_Enabled_Property (Item_Id);
12780 -- Other objects can only inherit properties through their type. We
12781 -- cannot call directly Type_Or_Variable_Has_Enabled_Property on
12782 -- these as they don't have contracts attached, which is expected by
12785 elsif Is_Object (Item_Id) then
12786 return Type_Or_Variable_Has_Enabled_Property (Etype (Item_Id));
12788 elsif Is_Type (Item_Id) then
12789 return Type_Or_Variable_Has_Enabled_Property
12790 (Item_Id => First_Subtype (Item_Id));
12792 -- Otherwise a property is enabled when the related item is effectively
12796 return Is_Effectively_Volatile (Item_Id);
12798 end Has_Enabled_Property;
12800 -------------------------------------
12801 -- Has_Full_Default_Initialization --
12802 -------------------------------------
12804 function Has_Full_Default_Initialization (Typ : Entity_Id) return Boolean is
12808 -- A type subject to pragma Default_Initial_Condition may be fully
12809 -- default initialized depending on inheritance and the argument of
12810 -- the pragma. Since any type may act as the full view of a private
12811 -- type, this check must be performed prior to the specialized tests
12814 if Has_Fully_Default_Initializing_DIC_Pragma (Typ) then
12818 -- A scalar type is fully default initialized if it is subject to aspect
12821 if Is_Scalar_Type (Typ) then
12822 return Has_Default_Aspect (Typ);
12824 -- An access type is fully default initialized by default
12826 elsif Is_Access_Type (Typ) then
12829 -- An array type is fully default initialized if its element type is
12830 -- scalar and the array type carries aspect Default_Component_Value or
12831 -- the element type is fully default initialized.
12833 elsif Is_Array_Type (Typ) then
12835 Has_Default_Aspect (Typ)
12836 or else Has_Full_Default_Initialization (Component_Type (Typ));
12838 -- A protected type, record type, or type extension is fully default
12839 -- initialized if all its components either carry an initialization
12840 -- expression or have a type that is fully default initialized. The
12841 -- parent type of a type extension must be fully default initialized.
12843 elsif Is_Record_Type (Typ) or else Is_Protected_Type (Typ) then
12845 -- Inspect all entities defined in the scope of the type, looking for
12846 -- uninitialized components.
12848 Comp := First_Component (Typ);
12849 while Present (Comp) loop
12850 if Comes_From_Source (Comp)
12851 and then No (Expression (Parent (Comp)))
12852 and then not Has_Full_Default_Initialization (Etype (Comp))
12857 Next_Component (Comp);
12860 -- Ensure that the parent type of a type extension is fully default
12863 if Etype (Typ) /= Typ
12864 and then not Has_Full_Default_Initialization (Etype (Typ))
12869 -- If we get here, then all components and parent portion are fully
12870 -- default initialized.
12874 -- A task type is fully default initialized by default
12876 elsif Is_Task_Type (Typ) then
12879 -- Otherwise the type is not fully default initialized
12884 end Has_Full_Default_Initialization;
12886 -----------------------------------------------
12887 -- Has_Fully_Default_Initializing_DIC_Pragma --
12888 -----------------------------------------------
12890 function Has_Fully_Default_Initializing_DIC_Pragma
12891 (Typ : Entity_Id) return Boolean
12897 -- A type that inherits pragma Default_Initial_Condition from a parent
12898 -- type is automatically fully default initialized.
12900 if Has_Inherited_DIC (Typ) then
12903 -- Otherwise the type is fully default initialized only when the pragma
12904 -- appears without an argument, or the argument is non-null.
12906 elsif Has_Own_DIC (Typ) then
12907 Prag := Get_Pragma (Typ, Pragma_Default_Initial_Condition);
12908 pragma Assert (Present (Prag));
12909 Args := Pragma_Argument_Associations (Prag);
12911 -- The pragma appears without an argument in which case it defaults
12917 -- The pragma appears with a non-null expression
12919 elsif Nkind (Get_Pragma_Arg (First (Args))) /= N_Null then
12925 end Has_Fully_Default_Initializing_DIC_Pragma;
12927 ---------------------------------
12928 -- Has_Inferable_Discriminants --
12929 ---------------------------------
12931 function Has_Inferable_Discriminants (N : Node_Id) return Boolean is
12933 function Prefix_Is_Formal_Parameter (N : Node_Id) return Boolean;
12934 -- Determines whether the left-most prefix of a selected component is a
12935 -- formal parameter in a subprogram. Assumes N is a selected component.
12937 --------------------------------
12938 -- Prefix_Is_Formal_Parameter --
12939 --------------------------------
12941 function Prefix_Is_Formal_Parameter (N : Node_Id) return Boolean is
12942 Sel_Comp : Node_Id;
12945 -- Move to the left-most prefix by climbing up the tree
12948 while Present (Parent (Sel_Comp))
12949 and then Nkind (Parent (Sel_Comp)) = N_Selected_Component
12951 Sel_Comp := Parent (Sel_Comp);
12954 return Is_Formal (Entity (Prefix (Sel_Comp)));
12955 end Prefix_Is_Formal_Parameter;
12957 -- Start of processing for Has_Inferable_Discriminants
12960 -- For selected components, the subtype of the selector must be a
12961 -- constrained Unchecked_Union. If the component is subject to a
12962 -- per-object constraint, then the enclosing object must have inferable
12965 if Nkind (N) = N_Selected_Component then
12966 if Has_Per_Object_Constraint (Entity (Selector_Name (N))) then
12968 -- A small hack. If we have a per-object constrained selected
12969 -- component of a formal parameter, return True since we do not
12970 -- know the actual parameter association yet.
12972 if Prefix_Is_Formal_Parameter (N) then
12975 -- Otherwise, check the enclosing object and the selector
12978 return Has_Inferable_Discriminants (Prefix (N))
12979 and then Has_Inferable_Discriminants (Selector_Name (N));
12982 -- The call to Has_Inferable_Discriminants will determine whether
12983 -- the selector has a constrained Unchecked_Union nominal type.
12986 return Has_Inferable_Discriminants (Selector_Name (N));
12989 -- A qualified expression has inferable discriminants if its subtype
12990 -- mark is a constrained Unchecked_Union subtype.
12992 elsif Nkind (N) = N_Qualified_Expression then
12993 return Is_Unchecked_Union (Etype (Subtype_Mark (N)))
12994 and then Is_Constrained (Etype (Subtype_Mark (N)));
12996 -- For all other names, it is sufficient to have a constrained
12997 -- Unchecked_Union nominal subtype.
13000 return Is_Unchecked_Union (Base_Type (Etype (N)))
13001 and then Is_Constrained (Etype (N));
13003 end Has_Inferable_Discriminants;
13005 --------------------
13006 -- Has_Infinities --
13007 --------------------
13009 function Has_Infinities (E : Entity_Id) return Boolean is
13012 Is_Floating_Point_Type (E)
13013 and then Nkind (Scalar_Range (E)) = N_Range
13014 and then Includes_Infinities (Scalar_Range (E));
13015 end Has_Infinities;
13017 --------------------
13018 -- Has_Interfaces --
13019 --------------------
13021 function Has_Interfaces
13023 Use_Full_View : Boolean := True) return Boolean
13025 Typ : Entity_Id := Base_Type (T);
13028 -- Handle concurrent types
13030 if Is_Concurrent_Type (Typ) then
13031 Typ := Corresponding_Record_Type (Typ);
13034 if not Present (Typ)
13035 or else not Is_Record_Type (Typ)
13036 or else not Is_Tagged_Type (Typ)
13041 -- Handle private types
13043 if Use_Full_View and then Present (Full_View (Typ)) then
13044 Typ := Full_View (Typ);
13047 -- Handle concurrent record types
13049 if Is_Concurrent_Record_Type (Typ)
13050 and then Is_Non_Empty_List (Abstract_Interface_List (Typ))
13056 if Is_Interface (Typ)
13058 (Is_Record_Type (Typ)
13059 and then Present (Interfaces (Typ))
13060 and then not Is_Empty_Elmt_List (Interfaces (Typ)))
13065 exit when Etype (Typ) = Typ
13067 -- Handle private types
13069 or else (Present (Full_View (Etype (Typ)))
13070 and then Full_View (Etype (Typ)) = Typ)
13072 -- Protect frontend against wrong sources with cyclic derivations
13074 or else Etype (Typ) = T;
13076 -- Climb to the ancestor type handling private types
13078 if Present (Full_View (Etype (Typ))) then
13079 Typ := Full_View (Etype (Typ));
13081 Typ := Etype (Typ);
13086 end Has_Interfaces;
13088 --------------------------
13089 -- Has_Max_Queue_Length --
13090 --------------------------
13092 function Has_Max_Queue_Length (Id : Entity_Id) return Boolean is
13095 Ekind (Id) = E_Entry
13096 and then Present (Get_Pragma (Id, Pragma_Max_Queue_Length));
13097 end Has_Max_Queue_Length;
13099 ---------------------------------
13100 -- Has_No_Obvious_Side_Effects --
13101 ---------------------------------
13103 function Has_No_Obvious_Side_Effects (N : Node_Id) return Boolean is
13105 -- For now handle literals, constants, and non-volatile variables and
13106 -- expressions combining these with operators or short circuit forms.
13108 if Nkind (N) in N_Numeric_Or_String_Literal then
13111 elsif Nkind (N) = N_Character_Literal then
13114 elsif Nkind (N) in N_Unary_Op then
13115 return Has_No_Obvious_Side_Effects (Right_Opnd (N));
13117 elsif Nkind (N) in N_Binary_Op or else Nkind (N) in N_Short_Circuit then
13118 return Has_No_Obvious_Side_Effects (Left_Opnd (N))
13120 Has_No_Obvious_Side_Effects (Right_Opnd (N));
13122 elsif Nkind (N) = N_Expression_With_Actions
13123 and then Is_Empty_List (Actions (N))
13125 return Has_No_Obvious_Side_Effects (Expression (N));
13127 elsif Nkind (N) in N_Has_Entity then
13128 return Present (Entity (N))
13130 Ekind (Entity (N)) in
13131 E_Variable | E_Constant | E_Enumeration_Literal |
13132 E_In_Parameter | E_Out_Parameter | E_In_Out_Parameter
13133 and then not Is_Volatile (Entity (N));
13138 end Has_No_Obvious_Side_Effects;
13140 -----------------------------
13141 -- Has_Non_Null_Refinement --
13142 -----------------------------
13144 function Has_Non_Null_Refinement (Id : Entity_Id) return Boolean is
13145 Constits : Elist_Id;
13148 pragma Assert (Ekind (Id) = E_Abstract_State);
13149 Constits := Refinement_Constituents (Id);
13151 -- For a refinement to be non-null, the first constituent must be
13152 -- anything other than null.
13156 and then Nkind (Node (First_Elmt (Constits))) /= N_Null;
13157 end Has_Non_Null_Refinement;
13159 -----------------------------
13160 -- Has_Non_Null_Statements --
13161 -----------------------------
13163 function Has_Non_Null_Statements (L : List_Id) return Boolean is
13169 while Present (Node) loop
13170 if Nkind (Node) not in N_Null_Statement | N_Call_Marker then
13178 end Has_Non_Null_Statements;
13180 ----------------------------------
13181 -- Is_Access_Subprogram_Wrapper --
13182 ----------------------------------
13184 function Is_Access_Subprogram_Wrapper (E : Entity_Id) return Boolean is
13185 Formal : constant Entity_Id := Last_Formal (E);
13187 return Present (Formal)
13188 and then Ekind (Etype (Formal)) in Access_Subprogram_Kind
13189 and then Access_Subprogram_Wrapper
13190 (Directly_Designated_Type (Etype (Formal))) = E;
13191 end Is_Access_Subprogram_Wrapper;
13193 ---------------------------
13194 -- Is_Explicitly_Aliased --
13195 ---------------------------
13197 function Is_Explicitly_Aliased (N : Node_Id) return Boolean is
13199 return Is_Formal (N)
13200 and then Present (Parent (N))
13201 and then Nkind (Parent (N)) = N_Parameter_Specification
13202 and then Aliased_Present (Parent (N));
13203 end Is_Explicitly_Aliased;
13205 ----------------------------
13206 -- Is_Container_Aggregate --
13207 ----------------------------
13209 function Is_Container_Aggregate (Exp : Node_Id) return Boolean is
13211 function Is_Record_Aggregate return Boolean is (False);
13212 -- ??? Unimplemented. Given an aggregate whose type is a
13213 -- record type with specified Aggregate aspect, how do we
13214 -- determine whether it is a record aggregate or a container
13215 -- aggregate? If the code where the aggregate occurs can see only
13216 -- a partial view of the aggregate's type then the aggregate
13217 -- cannot be a record type; an aggregate of a private type has to
13218 -- be a container aggregate.
13221 return Nkind (Exp) = N_Aggregate
13222 and then Present (Find_Aspect (Etype (Exp), Aspect_Aggregate))
13223 and then not Is_Record_Aggregate;
13224 end Is_Container_Aggregate;
13226 ---------------------------------
13227 -- Side_Effect_Free_Statements --
13228 ---------------------------------
13230 function Side_Effect_Free_Statements (L : List_Id) return Boolean is
13236 while Present (Node) loop
13237 case Nkind (Node) is
13238 when N_Null_Statement | N_Call_Marker | N_Raise_xxx_Error =>
13241 when N_Object_Declaration =>
13242 if Present (Expression (Node))
13243 and then not Side_Effect_Free (Expression (Node))
13256 end Side_Effect_Free_Statements;
13258 ---------------------------
13259 -- Side_Effect_Free_Loop --
13260 ---------------------------
13262 function Side_Effect_Free_Loop (N : Node_Id) return Boolean is
13268 -- If this is not a loop (e.g. because the loop has been rewritten),
13269 -- then return false.
13271 if Nkind (N) /= N_Loop_Statement then
13275 -- First check the statements
13277 if Side_Effect_Free_Statements (Statements (N)) then
13279 -- Then check the loop condition/indexes
13281 if Present (Iteration_Scheme (N)) then
13282 Scheme := Iteration_Scheme (N);
13284 if Present (Condition (Scheme))
13285 or else Present (Iterator_Specification (Scheme))
13288 elsif Present (Loop_Parameter_Specification (Scheme)) then
13289 Spec := Loop_Parameter_Specification (Scheme);
13290 Subt := Discrete_Subtype_Definition (Spec);
13292 if Present (Subt) then
13293 if Nkind (Subt) = N_Range then
13294 return Side_Effect_Free (Low_Bound (Subt))
13295 and then Side_Effect_Free (High_Bound (Subt));
13297 -- subtype indication
13307 end Side_Effect_Free_Loop;
13309 ----------------------------------
13310 -- Has_Non_Trivial_Precondition --
13311 ----------------------------------
13313 function Has_Non_Trivial_Precondition (Subp : Entity_Id) return Boolean is
13314 Pre : constant Node_Id := Find_Aspect (Subp, Aspect_Pre,
13315 Class_Present => True);
13319 and then not Is_Entity_Name (Expression (Pre));
13320 end Has_Non_Trivial_Precondition;
13322 -------------------
13323 -- Has_Null_Body --
13324 -------------------
13326 function Has_Null_Body (Proc_Id : Entity_Id) return Boolean is
13327 Body_Id : Entity_Id;
13334 Spec := Parent (Proc_Id);
13335 Decl := Parent (Spec);
13337 -- Retrieve the entity of the procedure body (e.g. invariant proc).
13339 if Nkind (Spec) = N_Procedure_Specification
13340 and then Nkind (Decl) = N_Subprogram_Declaration
13342 Body_Id := Corresponding_Body (Decl);
13344 -- The body acts as a spec
13347 Body_Id := Proc_Id;
13350 -- The body will be generated later
13352 if No (Body_Id) then
13356 Spec := Parent (Body_Id);
13357 Decl := Parent (Spec);
13360 (Nkind (Spec) = N_Procedure_Specification
13361 and then Nkind (Decl) = N_Subprogram_Body);
13363 Stmt1 := First (Statements (Handled_Statement_Sequence (Decl)));
13365 -- Look for a null statement followed by an optional return
13368 if Nkind (Stmt1) = N_Null_Statement then
13369 Stmt2 := Next (Stmt1);
13371 if Present (Stmt2) then
13372 return Nkind (Stmt2) = N_Simple_Return_Statement;
13381 ------------------------
13382 -- Has_Null_Exclusion --
13383 ------------------------
13385 function Has_Null_Exclusion (N : Node_Id) return Boolean is
13388 when N_Access_Definition
13389 | N_Access_Function_Definition
13390 | N_Access_Procedure_Definition
13391 | N_Access_To_Object_Definition
13393 | N_Derived_Type_Definition
13394 | N_Function_Specification
13395 | N_Subtype_Declaration
13397 return Null_Exclusion_Present (N);
13399 when N_Component_Definition
13400 | N_Formal_Object_Declaration
13402 if Present (Subtype_Mark (N)) then
13403 return Null_Exclusion_Present (N);
13404 else pragma Assert (Present (Access_Definition (N)));
13405 return Null_Exclusion_Present (Access_Definition (N));
13408 when N_Object_Renaming_Declaration =>
13409 if Present (Subtype_Mark (N)) then
13410 return Null_Exclusion_Present (N);
13411 elsif Present (Access_Definition (N)) then
13412 return Null_Exclusion_Present (Access_Definition (N));
13414 return False; -- Case of no subtype in renaming (AI12-0275)
13417 when N_Discriminant_Specification =>
13418 if Nkind (Discriminant_Type (N)) = N_Access_Definition then
13419 return Null_Exclusion_Present (Discriminant_Type (N));
13421 return Null_Exclusion_Present (N);
13424 when N_Object_Declaration =>
13425 if Nkind (Object_Definition (N)) = N_Access_Definition then
13426 return Null_Exclusion_Present (Object_Definition (N));
13428 return Null_Exclusion_Present (N);
13431 when N_Parameter_Specification =>
13432 if Nkind (Parameter_Type (N)) = N_Access_Definition then
13433 return Null_Exclusion_Present (Parameter_Type (N))
13434 or else Null_Exclusion_Present (N);
13436 return Null_Exclusion_Present (N);
13442 end Has_Null_Exclusion;
13444 ------------------------
13445 -- Has_Null_Extension --
13446 ------------------------
13448 function Has_Null_Extension (T : Entity_Id) return Boolean is
13449 B : constant Entity_Id := Base_Type (T);
13454 if Nkind (Parent (B)) = N_Full_Type_Declaration
13455 and then Present (Record_Extension_Part (Type_Definition (Parent (B))))
13457 Ext := Record_Extension_Part (Type_Definition (Parent (B)));
13459 if Present (Ext) then
13460 if Null_Present (Ext) then
13463 Comps := Component_List (Ext);
13465 -- The null component list is rewritten during analysis to
13466 -- include the parent component. Any other component indicates
13467 -- that the extension was not originally null.
13469 return Null_Present (Comps)
13470 or else No (Next (First (Component_Items (Comps))));
13479 end Has_Null_Extension;
13481 -------------------------
13482 -- Has_Null_Refinement --
13483 -------------------------
13485 function Has_Null_Refinement (Id : Entity_Id) return Boolean is
13486 Constits : Elist_Id;
13489 pragma Assert (Ekind (Id) = E_Abstract_State);
13490 Constits := Refinement_Constituents (Id);
13492 -- For a refinement to be null, the state's sole constituent must be a
13497 and then Nkind (Node (First_Elmt (Constits))) = N_Null;
13498 end Has_Null_Refinement;
13500 ------------------------------------------
13501 -- Has_Nonstatic_Class_Wide_Pre_Or_Post --
13502 ------------------------------------------
13504 function Is_Prim_Of_Abst_Type_With_Nonstatic_CW_Pre_Post
13505 (Subp : Entity_Id) return Boolean
13507 Disp_Type : constant Entity_Id := Find_Dispatching_Type (Subp);
13509 Pragma_Arg : Node_Id;
13512 if Present (Disp_Type)
13513 and then Is_Abstract_Type (Disp_Type)
13514 and then Present (Contract (Subp))
13516 Prag := Pre_Post_Conditions (Contract (Subp));
13518 while Present (Prag) loop
13519 if Pragma_Name (Prag) in Name_Precondition | Name_Postcondition
13520 and then Class_Present (Prag)
13524 (Pragma_Argument_Associations (Prag));
13526 if not Is_Static_Expression (Expression (Pragma_Arg)) then
13531 Prag := Next_Pragma (Prag);
13536 end Is_Prim_Of_Abst_Type_With_Nonstatic_CW_Pre_Post;
13538 -------------------------------
13539 -- Has_Overriding_Initialize --
13540 -------------------------------
13542 function Has_Overriding_Initialize (T : Entity_Id) return Boolean is
13543 BT : constant Entity_Id := Base_Type (T);
13547 if Is_Controlled (BT) then
13548 if Is_RTU (Scope (BT), Ada_Finalization) then
13551 elsif Present (Primitive_Operations (BT)) then
13552 P := First_Elmt (Primitive_Operations (BT));
13553 while Present (P) loop
13555 Init : constant Entity_Id := Node (P);
13556 Formal : constant Entity_Id := First_Formal (Init);
13558 if Ekind (Init) = E_Procedure
13559 and then Chars (Init) = Name_Initialize
13560 and then Comes_From_Source (Init)
13561 and then Present (Formal)
13562 and then Etype (Formal) = BT
13563 and then No (Next_Formal (Formal))
13564 and then (Ada_Version < Ada_2012
13565 or else not Null_Present (Parent (Init)))
13575 -- Here if type itself does not have a non-null Initialize operation:
13576 -- check immediate ancestor.
13578 if Is_Derived_Type (BT)
13579 and then Has_Overriding_Initialize (Etype (BT))
13586 end Has_Overriding_Initialize;
13588 --------------------------------------
13589 -- Has_Preelaborable_Initialization --
13590 --------------------------------------
13592 function Has_Preelaborable_Initialization
13594 Preelab_Init_Expr : Node_Id := Empty) return Boolean
13598 procedure Check_Components (E : Entity_Id);
13599 -- Check component/discriminant chain, sets Has_PE False if a component
13600 -- or discriminant does not meet the preelaborable initialization rules.
13602 function Type_Named_In_Preelab_Init_Expression
13604 Expr : Node_Id) return Boolean;
13605 -- Returns True iff Typ'Preelaborable_Initialization occurs in Expr
13606 -- (where Expr may be a conjunction of one or more P_I attributes).
13608 ----------------------
13609 -- Check_Components --
13610 ----------------------
13612 procedure Check_Components (E : Entity_Id) is
13617 -- Loop through entities of record or protected type
13620 while Present (Ent) loop
13622 -- We are interested only in components and discriminants
13626 case Ekind (Ent) is
13627 when E_Component =>
13629 -- Get default expression if any. If there is no declaration
13630 -- node, it means we have an internal entity. The parent and
13631 -- tag fields are examples of such entities. For such cases,
13632 -- we just test the type of the entity.
13634 if Present (Declaration_Node (Ent)) then
13635 Exp := Expression (Declaration_Node (Ent));
13638 when E_Discriminant =>
13640 -- Note: for a renamed discriminant, the Declaration_Node
13641 -- may point to the one from the ancestor, and have a
13642 -- different expression, so use the proper attribute to
13643 -- retrieve the expression from the derived constraint.
13645 Exp := Discriminant_Default_Value (Ent);
13648 goto Check_Next_Entity;
13651 -- A component has PI if it has no default expression and the
13652 -- component type has PI.
13655 if not Has_Preelaborable_Initialization
13656 (Etype (Ent), Preelab_Init_Expr)
13662 -- Require the default expression to be preelaborable
13664 elsif not Is_Preelaborable_Construct (Exp) then
13669 <<Check_Next_Entity>>
13672 end Check_Components;
13674 --------------------------------------
13675 -- Type_Named_In_Preelab_Expression --
13676 --------------------------------------
13678 function Type_Named_In_Preelab_Init_Expression
13680 Expr : Node_Id) return Boolean
13683 -- Return True if Expr is a Preelaborable_Initialization attribute
13684 -- and the prefix is a subtype that has the same type as Typ.
13686 if Nkind (Expr) = N_Attribute_Reference
13687 and then Attribute_Name (Expr) = Name_Preelaborable_Initialization
13688 and then Is_Entity_Name (Prefix (Expr))
13689 and then Base_Type (Entity (Prefix (Expr))) = Base_Type (Typ)
13693 -- In the case where Expr is a conjunction, test whether either
13694 -- operand is a Preelaborable_Initialization attribute whose prefix
13695 -- has the same type as Typ, and return True if so.
13697 elsif Nkind (Expr) = N_Op_And
13699 (Type_Named_In_Preelab_Init_Expression (Typ, Left_Opnd (Expr))
13701 Type_Named_In_Preelab_Init_Expression (Typ, Right_Opnd (Expr)))
13705 -- Typ not named in a Preelaborable_Initialization attribute of Expr
13710 end Type_Named_In_Preelab_Init_Expression;
13712 -- Start of processing for Has_Preelaborable_Initialization
13715 -- Immediate return if already marked as known preelaborable init. This
13716 -- covers types for which this function has already been called once
13717 -- and returned True (in which case the result is cached), and also
13718 -- types to which a pragma Preelaborable_Initialization applies.
13720 if Known_To_Have_Preelab_Init (E) then
13724 -- If the type is a subtype representing a generic actual type, then
13725 -- test whether its base type has preelaborable initialization since
13726 -- the subtype representing the actual does not inherit this attribute
13727 -- from the actual or formal. (but maybe it should???)
13729 if Is_Generic_Actual_Type (E) then
13730 return Has_Preelaborable_Initialization (Base_Type (E));
13733 -- All elementary types have preelaborable initialization
13735 if Is_Elementary_Type (E) then
13738 -- Array types have PI if the component type has PI
13740 elsif Is_Array_Type (E) then
13741 Has_PE := Has_Preelaborable_Initialization
13742 (Component_Type (E), Preelab_Init_Expr);
13744 -- A derived type has preelaborable initialization if its parent type
13745 -- has preelaborable initialization and (in the case of a derived record
13746 -- extension) if the non-inherited components all have preelaborable
13747 -- initialization. However, a user-defined controlled type with an
13748 -- overriding Initialize procedure does not have preelaborable
13751 elsif Is_Derived_Type (E) then
13753 -- When the rule of RM 10.2.1(11.8/5) applies, we presume a component
13754 -- of a generic formal derived type has preelaborable initialization.
13755 -- (See comment on spec of Has_Preelaborable_Initialization.)
13757 if Is_Generic_Type (E)
13758 and then Present (Preelab_Init_Expr)
13760 Type_Named_In_Preelab_Init_Expression (E, Preelab_Init_Expr)
13765 -- If the derived type is a private extension then it doesn't have
13766 -- preelaborable initialization.
13768 if Ekind (Base_Type (E)) = E_Record_Type_With_Private then
13772 -- First check whether ancestor type has preelaborable initialization
13774 Has_PE := Has_Preelaborable_Initialization
13775 (Etype (Base_Type (E)), Preelab_Init_Expr);
13777 -- If OK, check extension components (if any)
13779 if Has_PE and then Is_Record_Type (E) then
13780 Check_Components (First_Entity (E));
13783 -- Check specifically for 10.2.1(11.4/2) exception: a controlled type
13784 -- with a user defined Initialize procedure does not have PI. If
13785 -- the type is untagged, the control primitives come from a component
13786 -- that has already been checked.
13789 and then Is_Controlled (E)
13790 and then Is_Tagged_Type (E)
13791 and then Has_Overriding_Initialize (E)
13796 -- Private types not derived from a type having preelaborable init and
13797 -- that are not marked with pragma Preelaborable_Initialization do not
13798 -- have preelaborable initialization.
13800 elsif Is_Private_Type (E) then
13802 -- When the rule of RM 10.2.1(11.8/5) applies, we presume a component
13803 -- of a generic formal private type has preelaborable initialization.
13804 -- (See comment on spec of Has_Preelaborable_Initialization.)
13806 if Is_Generic_Type (E)
13807 and then Present (Preelab_Init_Expr)
13809 Type_Named_In_Preelab_Init_Expression (E, Preelab_Init_Expr)
13816 -- Record type has PI if it is non private and all components have PI
13818 elsif Is_Record_Type (E) then
13820 Check_Components (First_Entity (E));
13822 -- Protected types must not have entries, and components must meet
13823 -- same set of rules as for record components.
13825 elsif Is_Protected_Type (E) then
13826 if Has_Entries (E) then
13830 Check_Components (First_Entity (E));
13831 Check_Components (First_Private_Entity (E));
13834 -- Type System.Address always has preelaborable initialization
13836 elsif Is_RTE (E, RE_Address) then
13839 -- In all other cases, type does not have preelaborable initialization
13845 -- If type has preelaborable initialization, cache result
13848 Set_Known_To_Have_Preelab_Init (E);
13852 end Has_Preelaborable_Initialization;
13858 function Has_Prefix (N : Node_Id) return Boolean is
13860 return Nkind (N) in
13861 N_Attribute_Reference | N_Expanded_Name | N_Explicit_Dereference |
13862 N_Indexed_Component | N_Reference | N_Selected_Component |
13866 ---------------------------
13867 -- Has_Private_Component --
13868 ---------------------------
13870 function Has_Private_Component (Type_Id : Entity_Id) return Boolean is
13871 Btype : Entity_Id := Base_Type (Type_Id);
13872 Component : Entity_Id;
13875 if Error_Posted (Type_Id)
13876 or else Error_Posted (Btype)
13881 if Is_Class_Wide_Type (Btype) then
13882 Btype := Root_Type (Btype);
13885 if Is_Private_Type (Btype) then
13887 UT : constant Entity_Id := Underlying_Type (Btype);
13890 if No (Full_View (Btype)) then
13891 return not Is_Generic_Type (Btype)
13893 not Is_Generic_Type (Root_Type (Btype));
13895 return not Is_Generic_Type (Root_Type (Full_View (Btype)));
13898 return not Is_Frozen (UT) and then Has_Private_Component (UT);
13902 elsif Is_Array_Type (Btype) then
13903 return Has_Private_Component (Component_Type (Btype));
13905 elsif Is_Record_Type (Btype) then
13906 Component := First_Component (Btype);
13907 while Present (Component) loop
13908 if Has_Private_Component (Etype (Component)) then
13912 Next_Component (Component);
13917 elsif Is_Protected_Type (Btype)
13918 and then Present (Corresponding_Record_Type (Btype))
13920 return Has_Private_Component (Corresponding_Record_Type (Btype));
13925 end Has_Private_Component;
13927 --------------------------------
13928 -- Has_Relaxed_Initialization --
13929 --------------------------------
13931 function Has_Relaxed_Initialization (E : Entity_Id) return Boolean is
13933 function Denotes_Relaxed_Parameter
13937 -- Returns True iff expression Expr denotes a formal parameter or
13938 -- function Param (through its attribute Result).
13940 -------------------------------
13941 -- Denotes_Relaxed_Parameter --
13942 -------------------------------
13944 function Denotes_Relaxed_Parameter
13946 Param : Entity_Id) return Boolean is
13948 if Nkind (Expr) in N_Identifier | N_Expanded_Name then
13949 return Entity (Expr) = Param;
13951 pragma Assert (Is_Attribute_Result (Expr));
13952 return Entity (Prefix (Expr)) = Param;
13954 end Denotes_Relaxed_Parameter;
13956 -- Start of processing for Has_Relaxed_Initialization
13959 -- When analyzing, we checked all syntax legality rules for the aspect
13960 -- Relaxed_Initialization, but didn't store the property anywhere (e.g.
13961 -- as an Einfo flag). To query the property we look directly at the AST,
13962 -- but now without any syntactic checks.
13965 -- Abstract states have option Relaxed_Initialization
13967 when E_Abstract_State =>
13968 return Is_Relaxed_Initialization_State (E);
13970 -- Constants have this aspect attached directly; for deferred
13971 -- constants, the aspect is attached to the partial view.
13974 return Has_Aspect (E, Aspect_Relaxed_Initialization);
13976 -- Variables have this aspect attached directly
13979 return Has_Aspect (E, Aspect_Relaxed_Initialization);
13981 -- Types have this aspect attached directly (though we only allow it
13982 -- to be specified for the first subtype). For private types, the
13983 -- aspect is attached to the partial view.
13986 pragma Assert (Is_First_Subtype (E));
13987 return Has_Aspect (E, Aspect_Relaxed_Initialization);
13989 -- Formal parameters and functions have the Relaxed_Initialization
13990 -- aspect attached to the subprogram entity and must be listed in
13991 -- the aspect expression.
13997 Subp_Id : Entity_Id;
13998 Aspect_Expr : Node_Id;
13999 Param_Expr : Node_Id;
14003 if Is_Formal (E) then
14004 Subp_Id := Scope (E);
14009 if Has_Aspect (Subp_Id, Aspect_Relaxed_Initialization) then
14011 Find_Value_Of_Aspect
14012 (Subp_Id, Aspect_Relaxed_Initialization);
14014 -- Aspect expression is either an aggregate with an optional
14015 -- Boolean expression (which defaults to True), e.g.:
14017 -- function F (X : Integer) return Integer
14018 -- with Relaxed_Initialization => (X => True, F'Result);
14020 if Nkind (Aspect_Expr) = N_Aggregate then
14022 if Present (Component_Associations (Aspect_Expr)) then
14023 Assoc := First (Component_Associations (Aspect_Expr));
14025 while Present (Assoc) loop
14026 if Denotes_Relaxed_Parameter
14027 (First (Choices (Assoc)), E)
14031 (Static_Boolean (Expression (Assoc)));
14038 Param_Expr := First (Expressions (Aspect_Expr));
14040 while Present (Param_Expr) loop
14041 if Denotes_Relaxed_Parameter (Param_Expr, E) then
14050 -- or it is a single identifier, e.g.:
14052 -- function F (X : Integer) return Integer
14053 -- with Relaxed_Initialization => X;
14056 return Denotes_Relaxed_Parameter (Aspect_Expr, E);
14064 raise Program_Error;
14066 end Has_Relaxed_Initialization;
14068 ----------------------
14069 -- Has_Signed_Zeros --
14070 ----------------------
14072 function Has_Signed_Zeros (E : Entity_Id) return Boolean is
14074 return Is_Floating_Point_Type (E) and then Signed_Zeros_On_Target;
14075 end Has_Signed_Zeros;
14077 ------------------------------
14078 -- Has_Significant_Contract --
14079 ------------------------------
14081 function Has_Significant_Contract (Subp_Id : Entity_Id) return Boolean is
14082 Subp_Nam : constant Name_Id := Chars (Subp_Id);
14085 -- _Finalizer procedure
14087 if Subp_Nam = Name_uFinalizer then
14090 -- _Postconditions procedure
14092 elsif Subp_Nam = Name_uPostconditions then
14095 -- Predicate function
14097 elsif Ekind (Subp_Id) = E_Function
14098 and then Is_Predicate_Function (Subp_Id)
14104 elsif Get_TSS_Name (Subp_Id) /= TSS_Null then
14110 end Has_Significant_Contract;
14112 -----------------------------
14113 -- Has_Static_Array_Bounds --
14114 -----------------------------
14116 function Has_Static_Array_Bounds (Typ : Node_Id) return Boolean is
14117 All_Static : Boolean;
14121 Examine_Array_Bounds (Typ, All_Static, Dummy);
14124 end Has_Static_Array_Bounds;
14126 ---------------------------------------
14127 -- Has_Static_Non_Empty_Array_Bounds --
14128 ---------------------------------------
14130 function Has_Static_Non_Empty_Array_Bounds (Typ : Node_Id) return Boolean is
14131 All_Static : Boolean;
14132 Has_Empty : Boolean;
14135 Examine_Array_Bounds (Typ, All_Static, Has_Empty);
14137 return All_Static and not Has_Empty;
14138 end Has_Static_Non_Empty_Array_Bounds;
14144 function Has_Stream (T : Entity_Id) return Boolean is
14151 elsif Is_RTE (Root_Type (T), RE_Root_Stream_Type) then
14154 elsif Is_Array_Type (T) then
14155 return Has_Stream (Component_Type (T));
14157 elsif Is_Record_Type (T) then
14158 E := First_Component (T);
14159 while Present (E) loop
14160 if Has_Stream (Etype (E)) then
14163 Next_Component (E);
14169 elsif Is_Private_Type (T) then
14170 return Has_Stream (Underlying_Type (T));
14181 function Has_Suffix (E : Entity_Id; Suffix : Character) return Boolean is
14183 Get_Name_String (Chars (E));
14184 return Name_Buffer (Name_Len) = Suffix;
14191 function Add_Suffix (E : Entity_Id; Suffix : Character) return Name_Id is
14193 Get_Name_String (Chars (E));
14194 Add_Char_To_Name_Buffer (Suffix);
14198 -------------------
14199 -- Remove_Suffix --
14200 -------------------
14202 function Remove_Suffix (E : Entity_Id; Suffix : Character) return Name_Id is
14204 pragma Assert (Has_Suffix (E, Suffix));
14205 Get_Name_String (Chars (E));
14206 Name_Len := Name_Len - 1;
14210 ----------------------------------
14211 -- Replace_Null_By_Null_Address --
14212 ----------------------------------
14214 procedure Replace_Null_By_Null_Address (N : Node_Id) is
14215 procedure Replace_Null_Operand (Op : Node_Id; Other_Op : Node_Id);
14216 -- Replace operand Op with a reference to Null_Address when the operand
14217 -- denotes a null Address. Other_Op denotes the other operand.
14219 --------------------------
14220 -- Replace_Null_Operand --
14221 --------------------------
14223 procedure Replace_Null_Operand (Op : Node_Id; Other_Op : Node_Id) is
14225 -- Check the type of the complementary operand since the N_Null node
14226 -- has not been decorated yet.
14228 if Nkind (Op) = N_Null
14229 and then Is_Descendant_Of_Address (Etype (Other_Op))
14231 Rewrite (Op, New_Occurrence_Of (RTE (RE_Null_Address), Sloc (Op)));
14233 end Replace_Null_Operand;
14235 -- Start of processing for Replace_Null_By_Null_Address
14238 pragma Assert (Relaxed_RM_Semantics);
14239 pragma Assert (Nkind (N) in N_Null | N_Op_Compare);
14241 if Nkind (N) = N_Null then
14242 Rewrite (N, New_Occurrence_Of (RTE (RE_Null_Address), Sloc (N)));
14246 L : constant Node_Id := Left_Opnd (N);
14247 R : constant Node_Id := Right_Opnd (N);
14250 Replace_Null_Operand (L, Other_Op => R);
14251 Replace_Null_Operand (R, Other_Op => L);
14254 end Replace_Null_By_Null_Address;
14256 --------------------------
14257 -- Has_Tagged_Component --
14258 --------------------------
14260 function Has_Tagged_Component (Typ : Entity_Id) return Boolean is
14264 if Is_Private_Type (Typ) and then Present (Underlying_Type (Typ)) then
14265 return Has_Tagged_Component (Underlying_Type (Typ));
14267 elsif Is_Array_Type (Typ) then
14268 return Has_Tagged_Component (Component_Type (Typ));
14270 elsif Is_Tagged_Type (Typ) then
14273 elsif Is_Record_Type (Typ) then
14274 Comp := First_Component (Typ);
14275 while Present (Comp) loop
14276 if Has_Tagged_Component (Etype (Comp)) then
14280 Next_Component (Comp);
14288 end Has_Tagged_Component;
14290 --------------------------------------------
14291 -- Has_Unconstrained_Access_Discriminants --
14292 --------------------------------------------
14294 function Has_Unconstrained_Access_Discriminants
14295 (Subtyp : Entity_Id) return Boolean
14300 if Has_Discriminants (Subtyp)
14301 and then not Is_Constrained (Subtyp)
14303 Discr := First_Discriminant (Subtyp);
14304 while Present (Discr) loop
14305 if Ekind (Etype (Discr)) = E_Anonymous_Access_Type then
14309 Next_Discriminant (Discr);
14314 end Has_Unconstrained_Access_Discriminants;
14316 -----------------------------
14317 -- Has_Undefined_Reference --
14318 -----------------------------
14320 function Has_Undefined_Reference (Expr : Node_Id) return Boolean is
14321 Has_Undef_Ref : Boolean := False;
14322 -- Flag set when expression Expr contains at least one undefined
14325 function Is_Undefined_Reference (N : Node_Id) return Traverse_Result;
14326 -- Determine whether N denotes a reference and if it does, whether it is
14329 ----------------------------
14330 -- Is_Undefined_Reference --
14331 ----------------------------
14333 function Is_Undefined_Reference (N : Node_Id) return Traverse_Result is
14335 if Is_Entity_Name (N)
14336 and then Present (Entity (N))
14337 and then Entity (N) = Any_Id
14339 Has_Undef_Ref := True;
14344 end Is_Undefined_Reference;
14346 procedure Find_Undefined_References is
14347 new Traverse_Proc (Is_Undefined_Reference);
14349 -- Start of processing for Has_Undefined_Reference
14352 Find_Undefined_References (Expr);
14354 return Has_Undef_Ref;
14355 end Has_Undefined_Reference;
14357 ----------------------------
14358 -- Has_Volatile_Component --
14359 ----------------------------
14361 function Has_Volatile_Component (Typ : Entity_Id) return Boolean is
14365 if Has_Volatile_Components (Typ) then
14368 elsif Is_Array_Type (Typ) then
14369 return Is_Volatile (Component_Type (Typ));
14371 elsif Is_Record_Type (Typ) then
14372 Comp := First_Component (Typ);
14373 while Present (Comp) loop
14374 if Is_Volatile_Object_Ref (Comp) then
14378 Next_Component (Comp);
14383 end Has_Volatile_Component;
14385 -------------------------
14386 -- Implementation_Kind --
14387 -------------------------
14389 function Implementation_Kind (Subp : Entity_Id) return Name_Id is
14390 Impl_Prag : constant Node_Id := Get_Rep_Pragma (Subp, Name_Implemented);
14393 pragma Assert (Present (Impl_Prag));
14394 Arg := Last (Pragma_Argument_Associations (Impl_Prag));
14395 return Chars (Get_Pragma_Arg (Arg));
14396 end Implementation_Kind;
14398 --------------------------
14399 -- Implements_Interface --
14400 --------------------------
14402 function Implements_Interface
14403 (Typ_Ent : Entity_Id;
14404 Iface_Ent : Entity_Id;
14405 Exclude_Parents : Boolean := False) return Boolean
14407 Ifaces_List : Elist_Id;
14409 Iface : Entity_Id := Base_Type (Iface_Ent);
14410 Typ : Entity_Id := Base_Type (Typ_Ent);
14413 if Is_Class_Wide_Type (Typ) then
14414 Typ := Root_Type (Typ);
14417 if not Has_Interfaces (Typ) then
14421 if Is_Class_Wide_Type (Iface) then
14422 Iface := Root_Type (Iface);
14425 Collect_Interfaces (Typ, Ifaces_List);
14427 Elmt := First_Elmt (Ifaces_List);
14428 while Present (Elmt) loop
14429 if Is_Ancestor (Node (Elmt), Typ, Use_Full_View => True)
14430 and then Exclude_Parents
14434 elsif Node (Elmt) = Iface then
14442 end Implements_Interface;
14444 --------------------------------
14445 -- Implicitly_Designated_Type --
14446 --------------------------------
14448 function Implicitly_Designated_Type (Typ : Entity_Id) return Entity_Id is
14449 Desig : constant Entity_Id := Designated_Type (Typ);
14452 -- An implicit dereference is a legal occurrence of an incomplete type
14453 -- imported through a limited_with clause, if the full view is visible.
14455 if Is_Incomplete_Type (Desig)
14456 and then From_Limited_With (Desig)
14457 and then not From_Limited_With (Scope (Desig))
14459 (Is_Immediately_Visible (Scope (Desig))
14461 (Is_Child_Unit (Scope (Desig))
14462 and then Is_Visible_Lib_Unit (Scope (Desig))))
14464 return Available_View (Desig);
14468 end Implicitly_Designated_Type;
14470 ------------------------------------
14471 -- In_Assertion_Expression_Pragma --
14472 ------------------------------------
14474 function In_Assertion_Expression_Pragma (N : Node_Id) return Boolean is
14476 Prag : Node_Id := Empty;
14479 -- Climb the parent chain looking for an enclosing pragma
14482 while Present (Par) loop
14483 if Nkind (Par) = N_Pragma then
14487 -- Precondition-like pragmas are expanded into if statements, check
14488 -- the original node instead.
14490 elsif Nkind (Original_Node (Par)) = N_Pragma then
14491 Prag := Original_Node (Par);
14494 -- The expansion of attribute 'Old generates a
constant to capture
14495 -- the result of the prefix. If the parent traversal reaches
14496 -- one of these constants, then the node technically came from a
14497 -- postcondition-like pragma. Note that the Ekind is not tested here
14498 -- because N may be the expression of an object declaration which is
14499 -- currently being analyzed. Such objects carry Ekind of E_Void.
14501 elsif Nkind
(Par
) = N_Object_Declaration
14502 and then Constant_Present
(Par
)
14503 and then Stores_Attribute_Old_Prefix
(Defining_Entity
(Par
))
14507 -- Prevent the search from going too far
14509 elsif Is_Body_Or_Package_Declaration
(Par
) then
14513 Par
:= Parent
(Par
);
14518 and then Assertion_Expression_Pragma
(Get_Pragma_Id
(Prag
));
14519 end In_Assertion_Expression_Pragma
;
14521 -------------------
14522 -- In_Check_Node --
14523 -------------------
14525 function In_Check_Node
(N
: Node_Id
) return Boolean is
14526 Par
: Node_Id
:= Parent
(N
);
14528 while Present
(Par
) loop
14529 if Nkind
(Par
) in N_Raise_xxx_Error
then
14532 -- Prevent the search from going too far
14534 elsif Is_Body_Or_Package_Declaration
(Par
) then
14538 Par
:= Parent
(Par
);
14545 -------------------------------
14546 -- In_Generic_Formal_Package --
14547 -------------------------------
14549 function In_Generic_Formal_Package
(E
: Entity_Id
) return Boolean is
14554 while Present
(Par
) loop
14555 if Nkind
(Par
) = N_Formal_Package_Declaration
14556 or else Nkind
(Original_Node
(Par
)) = N_Formal_Package_Declaration
14561 Par
:= Parent
(Par
);
14565 end In_Generic_Formal_Package
;
14567 ----------------------
14568 -- In_Generic_Scope --
14569 ----------------------
14571 function In_Generic_Scope
(E
: Entity_Id
) return Boolean is
14576 while Present
(S
) and then S
/= Standard_Standard
loop
14577 if Is_Generic_Unit
(S
) then
14585 end In_Generic_Scope
;
14591 function In_Instance
return Boolean is
14592 Curr_Unit
: constant Entity_Id
:= Cunit_Entity
(Current_Sem_Unit
);
14596 S
:= Current_Scope
;
14597 while Present
(S
) and then S
/= Standard_Standard
loop
14598 if Is_Generic_Instance
(S
) then
14600 -- A child instance is always compiled in the context of a parent
14601 -- instance. Nevertheless, its actuals must not be analyzed in an
14602 -- instance context. We detect this case by examining the current
14603 -- compilation unit, which must be a child instance, and checking
14604 -- that it has not been analyzed yet.
14606 if Is_Child_Unit
(Curr_Unit
)
14607 and then Nkind
(Unit
(Cunit
(Current_Sem_Unit
))) =
14608 N_Package_Instantiation
14609 and then Ekind
(Curr_Unit
) = E_Void
14623 ----------------------
14624 -- In_Instance_Body --
14625 ----------------------
14627 function In_Instance_Body
return Boolean is
14631 S
:= Current_Scope
;
14632 while Present
(S
) and then S
/= Standard_Standard
loop
14633 if Ekind
(S
) in E_Function | E_Procedure
14634 and then Is_Generic_Instance
(S
)
14638 elsif Ekind
(S
) = E_Package
14639 and then In_Package_Body
(S
)
14640 and then Is_Generic_Instance
(S
)
14649 end In_Instance_Body
;
14651 -----------------------------
14652 -- In_Instance_Not_Visible --
14653 -----------------------------
14655 function In_Instance_Not_Visible
return Boolean is
14659 S
:= Current_Scope
;
14660 while Present
(S
) and then S
/= Standard_Standard
loop
14661 if Ekind
(S
) in E_Function | E_Procedure
14662 and then Is_Generic_Instance
(S
)
14666 elsif Ekind
(S
) = E_Package
14667 and then (In_Package_Body
(S
) or else In_Private_Part
(S
))
14668 and then Is_Generic_Instance
(S
)
14677 end In_Instance_Not_Visible
;
14679 ------------------------------
14680 -- In_Instance_Visible_Part --
14681 ------------------------------
14683 function In_Instance_Visible_Part
14684 (Id
: Entity_Id
:= Current_Scope
) return Boolean
14690 while Present
(Inst
) and then Inst
/= Standard_Standard
loop
14691 if Ekind
(Inst
) = E_Package
14692 and then Is_Generic_Instance
(Inst
)
14693 and then not In_Package_Body
(Inst
)
14694 and then not In_Private_Part
(Inst
)
14699 Inst
:= Scope
(Inst
);
14703 end In_Instance_Visible_Part
;
14705 ---------------------
14706 -- In_Package_Body --
14707 ---------------------
14709 function In_Package_Body
return Boolean is
14713 S
:= Current_Scope
;
14714 while Present
(S
) and then S
/= Standard_Standard
loop
14715 if Ekind
(S
) = E_Package
and then In_Package_Body
(S
) then
14723 end In_Package_Body
;
14725 --------------------------
14726 -- In_Pragma_Expression --
14727 --------------------------
14729 function In_Pragma_Expression
(N
: Node_Id
; Nam
: Name_Id
) return Boolean is
14736 elsif Nkind
(P
) = N_Pragma
and then Pragma_Name
(P
) = Nam
then
14742 end In_Pragma_Expression
;
14744 ---------------------------
14745 -- In_Pre_Post_Condition --
14746 ---------------------------
14748 function In_Pre_Post_Condition
14749 (N
: Node_Id
; Class_Wide_Only
: Boolean := False) return Boolean
14752 Prag
: Node_Id
:= Empty
;
14753 Prag_Id
: Pragma_Id
;
14756 -- Climb the parent chain looking for an enclosing pragma
14759 while Present
(Par
) loop
14760 if Nkind
(Par
) = N_Pragma
then
14764 -- Prevent the search from going too far
14766 elsif Is_Body_Or_Package_Declaration
(Par
) then
14770 Par
:= Parent
(Par
);
14773 if Present
(Prag
) then
14774 Prag_Id
:= Get_Pragma_Id
(Prag
);
14776 if Class_Wide_Only
then
14778 Prag_Id
= Pragma_Post_Class
14779 or else Prag_Id
= Pragma_Pre_Class
14780 or else (Class_Present
(Prag
)
14781 and then (Prag_Id
= Pragma_Post
14782 or else Prag_Id
= Pragma_Postcondition
14783 or else Prag_Id
= Pragma_Pre
14784 or else Prag_Id
= Pragma_Precondition
));
14787 Prag_Id
= Pragma_Post
14788 or else Prag_Id
= Pragma_Post_Class
14789 or else Prag_Id
= Pragma_Postcondition
14790 or else Prag_Id
= Pragma_Pre
14791 or else Prag_Id
= Pragma_Pre_Class
14792 or else Prag_Id
= Pragma_Precondition
;
14795 -- Otherwise the node is not enclosed by a pre/postcondition pragma
14800 end In_Pre_Post_Condition
;
14802 ------------------------------
14803 -- In_Quantified_Expression --
14804 ------------------------------
14806 function In_Quantified_Expression
(N
: Node_Id
) return Boolean is
14813 elsif Nkind
(P
) = N_Quantified_Expression
then
14819 end In_Quantified_Expression
;
14821 -------------------------------------
14822 -- In_Reverse_Storage_Order_Object --
14823 -------------------------------------
14825 function In_Reverse_Storage_Order_Object
(N
: Node_Id
) return Boolean is
14827 Btyp
: Entity_Id
:= Empty
;
14830 -- Climb up indexed components
14834 case Nkind
(Pref
) is
14835 when N_Selected_Component
=>
14836 Pref
:= Prefix
(Pref
);
14839 when N_Indexed_Component
=>
14840 Pref
:= Prefix
(Pref
);
14848 if Present
(Pref
) then
14849 Btyp
:= Base_Type
(Etype
(Pref
));
14852 return Present
(Btyp
)
14853 and then (Is_Record_Type
(Btyp
) or else Is_Array_Type
(Btyp
))
14854 and then Reverse_Storage_Order
(Btyp
);
14855 end In_Reverse_Storage_Order_Object
;
14857 ------------------------------
14858 -- In_Same_Declarative_Part --
14859 ------------------------------
14861 function In_Same_Declarative_Part
14862 (Context
: Node_Id
;
14863 N
: Node_Id
) return Boolean
14865 Cont
: Node_Id
:= Context
;
14869 if Nkind
(Cont
) = N_Compilation_Unit_Aux
then
14870 Cont
:= Parent
(Cont
);
14874 while Present
(Nod
) loop
14878 elsif Nkind
(Nod
) in N_Accept_Statement
14879 | N_Block_Statement
14880 | N_Compilation_Unit
14883 | N_Package_Declaration
14885 | N_Subprogram_Body
14890 elsif Nkind
(Nod
) = N_Subunit
then
14891 Nod
:= Corresponding_Stub
(Nod
);
14894 Nod
:= Parent
(Nod
);
14899 end In_Same_Declarative_Part
;
14901 --------------------------------------
14902 -- In_Subprogram_Or_Concurrent_Unit --
14903 --------------------------------------
14905 function In_Subprogram_Or_Concurrent_Unit
return Boolean is
14910 -- Use scope chain to check successively outer scopes
14912 E
:= Current_Scope
;
14916 if K
in Subprogram_Kind
14917 or else K
in Concurrent_Kind
14918 or else K
in Generic_Subprogram_Kind
14922 elsif E
= Standard_Standard
then
14928 end In_Subprogram_Or_Concurrent_Unit
;
14934 function In_Subtree
(N
: Node_Id
; Root
: Node_Id
) return Boolean is
14939 while Present
(Curr
) loop
14940 if Curr
= Root
then
14944 Curr
:= Parent
(Curr
);
14954 function In_Subtree
14957 Root2
: Node_Id
) return Boolean
14963 while Present
(Curr
) loop
14964 if Curr
= Root1
or else Curr
= Root2
then
14968 Curr
:= Parent
(Curr
);
14974 ---------------------
14975 -- In_Return_Value --
14976 ---------------------
14978 function In_Return_Value
(Expr
: Node_Id
) return Boolean is
14980 Prev_Par
: Node_Id
;
14982 In_Function_Call
: Boolean := False;
14985 -- Move through parent nodes to determine if Expr contributes to the
14986 -- return value of the current subprogram.
14990 while Present
(Par
) loop
14992 case Nkind
(Par
) is
14993 -- Ignore ranges and they don't contribute to the result
14998 -- An object declaration whose parent is an extended return
14999 -- statement is a return object.
15001 when N_Object_Declaration
=>
15002 if Present
(Parent
(Par
))
15003 and then Nkind
(Parent
(Par
)) = N_Extended_Return_Statement
15008 -- We hit a simple return statement, so we know we are in one
15010 when N_Simple_Return_Statement
=>
15013 -- Only include one nexting level of function calls
15015 when N_Function_Call
=>
15016 if not In_Function_Call
then
15017 In_Function_Call
:= True;
15019 -- When the function return type has implicit dereference
15020 -- specified we know it cannot directly contribute to the
15023 if Present
(Etype
(Par
))
15024 and then Has_Implicit_Dereference
15025 (Get_Full_View
(Etype
(Par
)))
15033 -- Check if we are on the right-hand side of an assignment
15034 -- statement to a return object.
15036 -- This is not specified in the RM ???
15038 when N_Assignment_Statement
=>
15039 if Prev_Par
= Name
(Par
) then
15044 while Present
(Pre
) loop
15045 if Is_Entity_Name
(Pre
)
15046 and then Is_Return_Object
(Entity
(Pre
))
15051 exit when Nkind
(Pre
) not in N_Selected_Component
15052 | N_Indexed_Component
15055 Pre
:= Prefix
(Pre
);
15058 -- Otherwise, we hit a master which was not relevant
15061 if Is_Master
(Par
) then
15066 -- Iterate up to the next parent, keeping track of the previous one
15069 Par
:= Parent
(Par
);
15073 end In_Return_Value
;
15075 -----------------------------------------
15076 -- In_Statement_Condition_With_Actions --
15077 -----------------------------------------
15079 function In_Statement_Condition_With_Actions
(N
: Node_Id
) return Boolean is
15080 Prev
: Node_Id
:= N
;
15081 P
: Node_Id
:= Parent
(N
);
15082 -- P and Prev will be used for traversing the AST, while maintaining an
15083 -- invariant that P = Parent (Prev).
15085 while Present
(P
) loop
15086 if Nkind
(P
) = N_Iteration_Scheme
15087 and then Prev
= Condition
(P
)
15091 elsif Nkind
(P
) = N_Elsif_Part
15092 and then Prev
= Condition
(P
)
15096 -- No point in going beyond statements
15098 elsif Nkind
(N
) in N_Statement_Other_Than_Procedure_Call
15099 | N_Procedure_Call_Statement
15103 -- Prevent the search from going too far
15105 elsif Is_Body_Or_Package_Declaration
(P
) then
15114 end In_Statement_Condition_With_Actions
;
15116 ---------------------
15117 -- In_Visible_Part --
15118 ---------------------
15120 function In_Visible_Part
(Scope_Id
: Entity_Id
) return Boolean is
15122 return Is_Package_Or_Generic_Package
(Scope_Id
)
15123 and then In_Open_Scopes
(Scope_Id
)
15124 and then not In_Package_Body
(Scope_Id
)
15125 and then not In_Private_Part
(Scope_Id
);
15126 end In_Visible_Part
;
15128 --------------------------------
15129 -- Incomplete_Or_Partial_View --
15130 --------------------------------
15132 function Incomplete_Or_Partial_View
(Id
: Entity_Id
) return Entity_Id
is
15133 S
: constant Entity_Id
:= Scope
(Id
);
15135 function Inspect_Decls
15137 Taft
: Boolean := False) return Entity_Id
;
15138 -- Check whether a declarative region contains the incomplete or partial
15141 -------------------
15142 -- Inspect_Decls --
15143 -------------------
15145 function Inspect_Decls
15147 Taft
: Boolean := False) return Entity_Id
15153 Decl
:= First
(Decls
);
15154 while Present
(Decl
) loop
15157 -- The partial view of a Taft-amendment type is an incomplete
15161 if Nkind
(Decl
) = N_Incomplete_Type_Declaration
then
15162 Match
:= Defining_Identifier
(Decl
);
15165 -- Otherwise look for a private type whose full view matches the
15166 -- input type. Note that this checks full_type_declaration nodes
15167 -- to account for derivations from a private type where the type
15168 -- declaration hold the partial view and the full view is an
15171 elsif Nkind
(Decl
) in N_Full_Type_Declaration
15172 | N_Private_Extension_Declaration
15173 | N_Private_Type_Declaration
15175 Match
:= Defining_Identifier
(Decl
);
15178 -- Guard against unanalyzed entities
15181 and then Is_Type
(Match
)
15182 and then Present
(Full_View
(Match
))
15183 and then Full_View
(Match
) = Id
15198 -- Start of processing for Incomplete_Or_Partial_View
15201 -- Deferred constant or incomplete type case
15203 Prev
:= Current_Entity
(Id
);
15205 while Present
(Prev
) loop
15206 exit when Scope
(Prev
) = S
;
15208 Prev
:= Homonym
(Prev
);
15212 and then (Is_Incomplete_Type
(Prev
) or else Ekind
(Prev
) = E_Constant
)
15213 and then Present
(Full_View
(Prev
))
15214 and then Full_View
(Prev
) = Id
15219 -- Private or Taft amendment type case
15221 if Present
(S
) and then Is_Package_Or_Generic_Package
(S
) then
15223 Pkg_Decl
: constant Node_Id
:= Package_Specification
(S
);
15226 -- It is knows that Typ has a private view, look for it in the
15227 -- visible declarations of the enclosing scope. A special case
15228 -- of this is when the two views have been exchanged - the full
15229 -- appears earlier than the private.
15231 if Has_Private_Declaration
(Id
) then
15232 Prev
:= Inspect_Decls
(Visible_Declarations
(Pkg_Decl
));
15234 -- Exchanged view case, look in the private declarations
15237 Prev
:= Inspect_Decls
(Private_Declarations
(Pkg_Decl
));
15242 -- Otherwise if this is the package body, then Typ is a potential
15243 -- Taft amendment type. The incomplete view should be located in
15244 -- the private declarations of the enclosing scope.
15246 elsif In_Package_Body
(S
) then
15247 return Inspect_Decls
(Private_Declarations
(Pkg_Decl
), True);
15252 -- The type has no incomplete or private view
15255 end Incomplete_Or_Partial_View
;
15257 ---------------------------------------
15258 -- Incomplete_View_From_Limited_With --
15259 ---------------------------------------
15261 function Incomplete_View_From_Limited_With
15262 (Typ
: Entity_Id
) return Entity_Id
15265 -- It might make sense to make this an attribute in Einfo, and set it
15266 -- in Sem_Ch10 in Build_Shadow_Entity. However, we're running short on
15267 -- slots for new attributes, and it seems a bit simpler to just search
15268 -- the Limited_View (if it exists) for an incomplete type whose
15269 -- Non_Limited_View is Typ.
15271 if Ekind
(Scope
(Typ
)) = E_Package
15272 and then Present
(Limited_View
(Scope
(Typ
)))
15275 Ent
: Entity_Id
:= First_Entity
(Limited_View
(Scope
(Typ
)));
15277 while Present
(Ent
) loop
15278 if Is_Incomplete_Type
(Ent
)
15279 and then Non_Limited_View
(Ent
) = Typ
15290 end Incomplete_View_From_Limited_With
;
15292 ----------------------------------
15293 -- Indexed_Component_Bit_Offset --
15294 ----------------------------------
15296 function Indexed_Component_Bit_Offset
(N
: Node_Id
) return Uint
is
15297 Exp
: constant Node_Id
:= First
(Expressions
(N
));
15298 Typ
: constant Entity_Id
:= Etype
(Prefix
(N
));
15299 Off
: constant Uint
:= Component_Size
(Typ
);
15303 -- Return early if the component size is not known or variable
15305 if No
(Off
) or else Off
< Uint_0
then
15309 -- Deal with the degenerate case of an empty component
15311 if Off
= Uint_0
then
15315 -- Check that both the index value and the low bound are known
15317 if not Compile_Time_Known_Value
(Exp
) then
15321 Ind
:= First_Index
(Typ
);
15326 -- Do not attempt to compute offsets within multi-dimensional arrays
15328 if Present
(Next_Index
(Ind
)) then
15332 if Nkind
(Ind
) = N_Subtype_Indication
then
15333 Ind
:= Constraint
(Ind
);
15335 if Nkind
(Ind
) = N_Range_Constraint
then
15336 Ind
:= Range_Expression
(Ind
);
15340 if Nkind
(Ind
) /= N_Range
15341 or else not Compile_Time_Known_Value
(Low_Bound
(Ind
))
15346 -- Return the scaled offset
15348 return Off
* (Expr_Value
(Exp
) - Expr_Value
(Low_Bound
(Ind
)));
15349 end Indexed_Component_Bit_Offset
;
15351 -----------------------------
15352 -- Inherit_Predicate_Flags --
15353 -----------------------------
15355 procedure Inherit_Predicate_Flags
(Subt
, Par
: Entity_Id
) is
15357 if Ada_Version
< Ada_2012
15358 or else Present
(Predicate_Function
(Subt
))
15363 Set_Has_Predicates
(Subt
, Has_Predicates
(Par
));
15364 Set_Has_Static_Predicate_Aspect
15365 (Subt
, Has_Static_Predicate_Aspect
(Par
));
15366 Set_Has_Dynamic_Predicate_Aspect
15367 (Subt
, Has_Dynamic_Predicate_Aspect
(Par
));
15369 -- A named subtype does not inherit the predicate function of its
15370 -- parent but an itype declared for a loop index needs the discrete
15371 -- predicate information of its parent to execute the loop properly.
15372 -- A non-discrete type may has a static predicate (for example True)
15373 -- but has no static_discrete_predicate.
15375 if Is_Itype
(Subt
) and then Present
(Predicate_Function
(Par
)) then
15376 Set_Subprograms_For_Type
(Subt
, Subprograms_For_Type
(Par
));
15378 if Has_Static_Predicate
(Par
) and then Is_Discrete_Type
(Par
) then
15379 Set_Static_Discrete_Predicate
15380 (Subt
, Static_Discrete_Predicate
(Par
));
15383 end Inherit_Predicate_Flags
;
15385 ----------------------------
15386 -- Inherit_Rep_Item_Chain --
15387 ----------------------------
15389 procedure Inherit_Rep_Item_Chain
(Typ
: Entity_Id
; From_Typ
: Entity_Id
) is
15391 Next_Item
: Node_Id
;
15394 -- There are several inheritance scenarios to consider depending on
15395 -- whether both types have rep item chains and whether the destination
15396 -- type already inherits part of the source type's rep item chain.
15398 -- 1) The source type lacks a rep item chain
15399 -- From_Typ ---> Empty
15401 -- Typ --------> Item (or Empty)
15403 -- In this case inheritance cannot take place because there are no items
15406 -- 2) The destination type lacks a rep item chain
15407 -- From_Typ ---> Item ---> ...
15409 -- Typ --------> Empty
15411 -- Inheritance takes place by setting the First_Rep_Item of the
15412 -- destination type to the First_Rep_Item of the source type.
15413 -- From_Typ ---> Item ---> ...
15415 -- Typ -----------+
15417 -- 3.1) Both source and destination types have at least one rep item.
15418 -- The destination type does NOT inherit a rep item from the source
15420 -- From_Typ ---> Item ---> Item
15422 -- Typ --------> Item ---> Item
15424 -- Inheritance takes place by setting the Next_Rep_Item of the last item
15425 -- of the destination type to the First_Rep_Item of the source type.
15426 -- From_Typ -------------------> Item ---> Item
15428 -- Typ --------> Item ---> Item --+
15430 -- 3.2) Both source and destination types have at least one rep item.
15431 -- The destination type DOES inherit part of the rep item chain of the
15433 -- From_Typ ---> Item ---> Item ---> Item
15435 -- Typ --------> Item ------+
15437 -- This rare case arises when the full view of a private extension must
15438 -- inherit the rep item chain from the full view of its parent type and
15439 -- the full view of the parent type contains extra rep items. Currently
15440 -- only invariants may lead to such form of inheritance.
15442 -- type From_Typ is tagged private
15443 -- with Type_Invariant'Class => Item_2;
15445 -- type Typ is new From_Typ with private
15446 -- with Type_Invariant => Item_4;
15448 -- At this point the rep item chains contain the following items
15450 -- From_Typ -----------> Item_2 ---> Item_3
15452 -- Typ --------> Item_4 --+
15454 -- The full views of both types may introduce extra invariants
15456 -- type From_Typ is tagged null record
15457 -- with Type_Invariant => Item_1;
15459 -- type Typ is new From_Typ with null record;
15461 -- The full view of Typ would have to inherit any new rep items added to
15462 -- the full view of From_Typ.
15464 -- From_Typ -----------> Item_1 ---> Item_2 ---> Item_3
15466 -- Typ --------> Item_4 --+
15468 -- To achieve this form of inheritance, the destination type must first
15469 -- sever the link between its own rep chain and that of the source type,
15470 -- then inheritance 3.1 takes place.
15472 -- Case 1: The source type lacks a rep item chain
15474 if No
(First_Rep_Item
(From_Typ
)) then
15477 -- Case 2: The destination type lacks a rep item chain
15479 elsif No
(First_Rep_Item
(Typ
)) then
15480 Set_First_Rep_Item
(Typ
, First_Rep_Item
(From_Typ
));
15482 -- Case 3: Both the source and destination types have at least one rep
15483 -- item. Traverse the rep item chain of the destination type to find the
15488 Next_Item
:= First_Rep_Item
(Typ
);
15489 while Present
(Next_Item
) loop
15491 -- Detect a link between the destination type's rep chain and that
15492 -- of the source type. There are two possibilities:
15497 -- From_Typ ---> Item_1 --->
15499 -- Typ -----------+
15506 -- From_Typ ---> Item_1 ---> Item_2 --->
15508 -- Typ --------> Item_3 ------+
15512 if Present_In_Rep_Item
(From_Typ
, Next_Item
) then
15517 Next_Item
:= Next_Rep_Item
(Next_Item
);
15520 -- Inherit the source type's rep item chain
15522 if Present
(Item
) then
15523 Set_Next_Rep_Item
(Item
, First_Rep_Item
(From_Typ
));
15525 Set_First_Rep_Item
(Typ
, First_Rep_Item
(From_Typ
));
15528 end Inherit_Rep_Item_Chain
;
15530 ------------------------------------
15531 -- Inherits_From_Tagged_Full_View --
15532 ------------------------------------
15534 function Inherits_From_Tagged_Full_View
(Typ
: Entity_Id
) return Boolean is
15536 return Is_Private_Type
(Typ
)
15537 and then Present
(Full_View
(Typ
))
15538 and then Is_Private_Type
(Full_View
(Typ
))
15539 and then not Is_Tagged_Type
(Full_View
(Typ
))
15540 and then Present
(Underlying_Type
(Full_View
(Typ
)))
15541 and then Is_Tagged_Type
(Underlying_Type
(Full_View
(Typ
)));
15542 end Inherits_From_Tagged_Full_View
;
15544 ---------------------------------
15545 -- Insert_Explicit_Dereference --
15546 ---------------------------------
15548 procedure Insert_Explicit_Dereference
(N
: Node_Id
) is
15549 New_Prefix
: constant Node_Id
:= Relocate_Node
(N
);
15550 Ent
: Entity_Id
:= Empty
;
15551 Pref
: Node_Id
:= Empty
;
15557 Save_Interps
(N
, New_Prefix
);
15560 Make_Explicit_Dereference
(Sloc
(Parent
(N
)),
15561 Prefix
=> New_Prefix
));
15563 Set_Etype
(N
, Designated_Type
(Etype
(New_Prefix
)));
15565 if Is_Overloaded
(New_Prefix
) then
15567 -- The dereference is also overloaded, and its interpretations are
15568 -- the designated types of the interpretations of the original node.
15570 Set_Etype
(N
, Any_Type
);
15572 Get_First_Interp
(New_Prefix
, I
, It
);
15573 while Present
(It
.Nam
) loop
15576 if Is_Access_Type
(T
) then
15577 Add_One_Interp
(N
, Designated_Type
(T
), Designated_Type
(T
));
15580 Get_Next_Interp
(I
, It
);
15584 -- Prefix is unambiguous: mark the original prefix (which might
15585 -- Come_From_Source) as a reference, since the new (relocated) one
15586 -- won't be taken into account.
15588 if Is_Entity_Name
(New_Prefix
) then
15589 Ent
:= Entity
(New_Prefix
);
15590 Pref
:= New_Prefix
;
15592 -- For a retrieval of a subcomponent of some composite object,
15593 -- retrieve the ultimate entity if there is one.
15595 elsif Nkind
(New_Prefix
) in N_Selected_Component | N_Indexed_Component
15597 Pref
:= Prefix
(New_Prefix
);
15598 while Present
(Pref
)
15599 and then Nkind
(Pref
) in
15600 N_Selected_Component | N_Indexed_Component
15602 Pref
:= Prefix
(Pref
);
15605 if Present
(Pref
) and then Is_Entity_Name
(Pref
) then
15606 Ent
:= Entity
(Pref
);
15610 -- Place the reference on the entity node
15612 if Present
(Ent
) then
15613 Generate_Reference
(Ent
, Pref
);
15616 end Insert_Explicit_Dereference
;
15618 ------------------------------------------
15619 -- Inspect_Deferred_Constant_Completion --
15620 ------------------------------------------
15622 procedure Inspect_Deferred_Constant_Completion
(Decls
: List_Id
) is
15626 Decl
:= First
(Decls
);
15627 while Present
(Decl
) loop
15629 -- Deferred constant signature
15631 if Nkind
(Decl
) = N_Object_Declaration
15632 and then Constant_Present
(Decl
)
15633 and then No
(Expression
(Decl
))
15635 -- No need to check internally generated constants
15637 and then Comes_From_Source
(Decl
)
15639 -- The constant is not completed. A full object declaration or a
15640 -- pragma Import complete a deferred constant.
15642 and then not Has_Completion
(Defining_Identifier
(Decl
))
15645 ("constant declaration requires initialization expression",
15646 Defining_Identifier
(Decl
));
15651 end Inspect_Deferred_Constant_Completion
;
15653 -------------------------------
15654 -- Install_Elaboration_Model --
15655 -------------------------------
15657 procedure Install_Elaboration_Model
(Unit_Id
: Entity_Id
) is
15658 function Find_Elaboration_Checks_Pragma
(L
: List_Id
) return Node_Id
;
15659 -- Try to find pragma Elaboration_Checks in arbitrary list L. Return
15660 -- Empty if there is no such pragma.
15662 ------------------------------------
15663 -- Find_Elaboration_Checks_Pragma --
15664 ------------------------------------
15666 function Find_Elaboration_Checks_Pragma
(L
: List_Id
) return Node_Id
is
15671 while Present
(Item
) loop
15672 if Nkind
(Item
) = N_Pragma
15673 and then Pragma_Name
(Item
) = Name_Elaboration_Checks
15682 end Find_Elaboration_Checks_Pragma
;
15691 -- Start of processing for Install_Elaboration_Model
15694 -- Nothing to do when the unit does not exist
15696 if No
(Unit_Id
) then
15700 Unit
:= Parent
(Unit_Declaration_Node
(Unit_Id
));
15702 -- Nothing to do when the unit is not a library unit
15704 if Nkind
(Unit
) /= N_Compilation_Unit
then
15708 Prag
:= Find_Elaboration_Checks_Pragma
(Context_Items
(Unit
));
15710 -- The compilation unit is subject to pragma Elaboration_Checks. Set the
15711 -- elaboration model as specified by the pragma.
15713 if Present
(Prag
) then
15714 Args
:= Pragma_Argument_Associations
(Prag
);
15716 -- Guard against an illegal pragma. The sole argument must be an
15717 -- identifier which specifies either Dynamic or Static model.
15719 if Present
(Args
) then
15720 Model
:= Get_Pragma_Arg
(First
(Args
));
15722 if Nkind
(Model
) = N_Identifier
then
15723 Dynamic_Elaboration_Checks
:= Chars
(Model
) = Name_Dynamic
;
15727 end Install_Elaboration_Model
;
15729 -----------------------------
15730 -- Install_Generic_Formals --
15731 -----------------------------
15733 procedure Install_Generic_Formals
(Subp_Id
: Entity_Id
) is
15737 pragma Assert
(Is_Generic_Subprogram
(Subp_Id
));
15739 E
:= First_Entity
(Subp_Id
);
15740 while Present
(E
) loop
15741 Install_Entity
(E
);
15744 end Install_Generic_Formals
;
15746 ------------------------
15747 -- Install_SPARK_Mode --
15748 ------------------------
15750 procedure Install_SPARK_Mode
(Mode
: SPARK_Mode_Type
; Prag
: Node_Id
) is
15752 SPARK_Mode
:= Mode
;
15753 SPARK_Mode_Pragma
:= Prag
;
15754 end Install_SPARK_Mode
;
15756 --------------------------
15757 -- Invalid_Scalar_Value --
15758 --------------------------
15760 function Invalid_Scalar_Value
15762 Scal_Typ
: Scalar_Id
) return Node_Id
15764 function Invalid_Binder_Value
return Node_Id
;
15765 -- Return a reference to the corresponding invalid value for type
15766 -- Scal_Typ as defined in unit System.Scalar_Values.
15768 function Invalid_Float_Value
return Node_Id
;
15769 -- Return the invalid value of float type Scal_Typ
15771 function Invalid_Integer_Value
return Node_Id
;
15772 -- Return the invalid value of integer type Scal_Typ
15774 procedure Set_Invalid_Binder_Values
;
15775 -- Set the contents of collection Invalid_Binder_Values
15777 --------------------------
15778 -- Invalid_Binder_Value --
15779 --------------------------
15781 function Invalid_Binder_Value
return Node_Id
is
15782 Val_Id
: Entity_Id
;
15785 -- Initialize the collection of invalid binder values the first time
15788 Set_Invalid_Binder_Values
;
15790 -- Obtain the corresponding variable from System.Scalar_Values which
15791 -- holds the invalid value for this type.
15793 Val_Id
:= Invalid_Binder_Values
(Scal_Typ
);
15794 pragma Assert
(Present
(Val_Id
));
15796 return New_Occurrence_Of
(Val_Id
, Loc
);
15797 end Invalid_Binder_Value
;
15799 -------------------------
15800 -- Invalid_Float_Value --
15801 -------------------------
15803 function Invalid_Float_Value
return Node_Id
is
15804 Value
: constant Ureal
:= Invalid_Floats
(Scal_Typ
);
15807 -- Pragma Invalid_Scalars did not specify an invalid value for this
15808 -- type. Fall back to the value provided by the binder.
15810 if Value
= No_Ureal
then
15811 return Invalid_Binder_Value
;
15813 return Make_Real_Literal
(Loc
, Realval
=> Value
);
15815 end Invalid_Float_Value
;
15817 ---------------------------
15818 -- Invalid_Integer_Value --
15819 ---------------------------
15821 function Invalid_Integer_Value
return Node_Id
is
15822 Value
: constant Uint
:= Invalid_Integers
(Scal_Typ
);
15825 -- Pragma Invalid_Scalars did not specify an invalid value for this
15826 -- type. Fall back to the value provided by the binder.
15829 return Invalid_Binder_Value
;
15831 return Make_Integer_Literal
(Loc
, Intval
=> Value
);
15833 end Invalid_Integer_Value
;
15835 -------------------------------
15836 -- Set_Invalid_Binder_Values --
15837 -------------------------------
15839 procedure Set_Invalid_Binder_Values
is
15841 if not Invalid_Binder_Values_Set
then
15842 Invalid_Binder_Values_Set
:= True;
15844 -- Initialize the contents of the collection once since RTE calls
15847 Invalid_Binder_Values
:=
15848 (Name_Short_Float
=> RTE
(RE_IS_Isf
),
15849 Name_Float
=> RTE
(RE_IS_Ifl
),
15850 Name_Long_Float
=> RTE
(RE_IS_Ilf
),
15851 Name_Long_Long_Float
=> RTE
(RE_IS_Ill
),
15852 Name_Signed_8
=> RTE
(RE_IS_Is1
),
15853 Name_Signed_16
=> RTE
(RE_IS_Is2
),
15854 Name_Signed_32
=> RTE
(RE_IS_Is4
),
15855 Name_Signed_64
=> RTE
(RE_IS_Is8
),
15856 Name_Signed_128
=> Empty
,
15857 Name_Unsigned_8
=> RTE
(RE_IS_Iu1
),
15858 Name_Unsigned_16
=> RTE
(RE_IS_Iu2
),
15859 Name_Unsigned_32
=> RTE
(RE_IS_Iu4
),
15860 Name_Unsigned_64
=> RTE
(RE_IS_Iu8
),
15861 Name_Unsigned_128
=> Empty
);
15863 if System_Max_Integer_Size
< 128 then
15864 Invalid_Binder_Values
(Name_Signed_128
) := RTE
(RE_IS_Is8
);
15865 Invalid_Binder_Values
(Name_Unsigned_128
) := RTE
(RE_IS_Iu8
);
15867 Invalid_Binder_Values
(Name_Signed_128
) := RTE
(RE_IS_Is16
);
15868 Invalid_Binder_Values
(Name_Unsigned_128
) := RTE
(RE_IS_Iu16
);
15871 end Set_Invalid_Binder_Values
;
15873 -- Start of processing for Invalid_Scalar_Value
15876 if Scal_Typ
in Float_Scalar_Id
then
15877 return Invalid_Float_Value
;
15879 else pragma Assert
(Scal_Typ
in Integer_Scalar_Id
);
15880 return Invalid_Integer_Value
;
15882 end Invalid_Scalar_Value
;
15884 --------------------------------
15885 -- Is_Anonymous_Access_Actual --
15886 --------------------------------
15888 function Is_Anonymous_Access_Actual
(N
: Node_Id
) return Boolean is
15891 if Ekind
(Etype
(N
)) /= E_Anonymous_Access_Type
then
15896 while Present
(Par
)
15897 and then Nkind
(Par
) in N_Case_Expression
15899 | N_Parameter_Association
15901 Par
:= Parent
(Par
);
15903 return Nkind
(Par
) in N_Subprogram_Call
;
15904 end Is_Anonymous_Access_Actual
;
15906 ------------------------
15907 -- Is_Access_Variable --
15908 ------------------------
15910 function Is_Access_Variable
(E
: Entity_Id
) return Boolean is
15912 return Is_Access_Type
(E
)
15913 and then not Is_Access_Constant
(E
)
15914 and then Ekind
(Directly_Designated_Type
(E
)) /= E_Subprogram_Type
;
15915 end Is_Access_Variable
;
15917 -----------------------------
15918 -- Is_Actual_Out_Parameter --
15919 -----------------------------
15921 function Is_Actual_Out_Parameter
(N
: Node_Id
) return Boolean is
15922 Formal
: Entity_Id
;
15925 Find_Actual
(N
, Formal
, Call
);
15926 return Present
(Formal
) and then Ekind
(Formal
) = E_Out_Parameter
;
15927 end Is_Actual_Out_Parameter
;
15929 --------------------------------
15930 -- Is_Actual_In_Out_Parameter --
15931 --------------------------------
15933 function Is_Actual_In_Out_Parameter
(N
: Node_Id
) return Boolean is
15934 Formal
: Entity_Id
;
15937 Find_Actual
(N
, Formal
, Call
);
15938 return Present
(Formal
) and then Ekind
(Formal
) = E_In_Out_Parameter
;
15939 end Is_Actual_In_Out_Parameter
;
15941 ---------------------------------------
15942 -- Is_Actual_Out_Or_In_Out_Parameter --
15943 ---------------------------------------
15945 function Is_Actual_Out_Or_In_Out_Parameter
(N
: Node_Id
) return Boolean is
15946 Formal
: Entity_Id
;
15949 Find_Actual
(N
, Formal
, Call
);
15950 return Present
(Formal
)
15951 and then Ekind
(Formal
) in E_Out_Parameter | E_In_Out_Parameter
;
15952 end Is_Actual_Out_Or_In_Out_Parameter
;
15954 -------------------------
15955 -- Is_Actual_Parameter --
15956 -------------------------
15958 function Is_Actual_Parameter
(N
: Node_Id
) return Boolean is
15959 PK
: constant Node_Kind
:= Nkind
(Parent
(N
));
15963 when N_Parameter_Association
=>
15964 return N
= Explicit_Actual_Parameter
(Parent
(N
));
15966 when N_Entry_Call_Statement
15967 | N_Subprogram_Call
15969 return Is_List_Member
(N
)
15971 List_Containing
(N
) = Parameter_Associations
(Parent
(N
));
15976 end Is_Actual_Parameter
;
15978 --------------------------------
15979 -- Is_Actual_Tagged_Parameter --
15980 --------------------------------
15982 function Is_Actual_Tagged_Parameter
(N
: Node_Id
) return Boolean is
15983 Formal
: Entity_Id
;
15986 Find_Actual
(N
, Formal
, Call
);
15987 return Present
(Formal
) and then Is_Tagged_Type
(Etype
(Formal
));
15988 end Is_Actual_Tagged_Parameter
;
15990 ---------------------
15991 -- Is_Aliased_View --
15992 ---------------------
15994 function Is_Aliased_View
(Obj
: Node_Id
) return Boolean is
15998 if Is_Entity_Name
(Obj
) then
16005 or else (Present
(Renamed_Object
(E
))
16006 and then Is_Aliased_View
(Renamed_Object
(E
)))))
16008 or else ((Is_Formal
(E
) or else Is_Formal_Object
(E
))
16009 and then Is_Tagged_Type
(Etype
(E
)))
16011 or else (Is_Concurrent_Type
(E
) and then In_Open_Scopes
(E
))
16013 -- Current instance of type, either directly or as rewritten
16014 -- reference to the current object.
16016 or else (Is_Entity_Name
(Original_Node
(Obj
))
16017 and then Present
(Entity
(Original_Node
(Obj
)))
16018 and then Is_Type
(Entity
(Original_Node
(Obj
))))
16020 or else (Is_Type
(E
) and then E
= Current_Scope
)
16022 or else (Is_Incomplete_Or_Private_Type
(E
)
16023 and then Full_View
(E
) = Current_Scope
)
16025 -- Ada 2012 AI05-0053: the return object of an extended return
16026 -- statement is aliased if its type is immutably limited.
16028 or else (Is_Return_Object
(E
)
16029 and then Is_Limited_View
(Etype
(E
)))
16031 -- The current instance of a limited type is aliased, so
16032 -- we want to allow uses of T'Access in the init proc for
16033 -- a limited type T. However, we don't want to mark the formal
16034 -- parameter as being aliased since that could impact callers.
16036 or else (Is_Formal
(E
)
16037 and then Chars
(E
) = Name_uInit
16038 and then Is_Limited_View
(Etype
(E
)));
16040 elsif Nkind
(Obj
) = N_Selected_Component
then
16041 return Is_Aliased
(Entity
(Selector_Name
(Obj
)));
16043 elsif Nkind
(Obj
) = N_Indexed_Component
then
16044 return Has_Aliased_Components
(Etype
(Prefix
(Obj
)))
16046 (Is_Access_Type
(Etype
(Prefix
(Obj
)))
16047 and then Has_Aliased_Components
16048 (Designated_Type
(Etype
(Prefix
(Obj
)))));
16050 elsif Nkind
(Obj
) in N_Unchecked_Type_Conversion | N_Type_Conversion
then
16051 return Is_Tagged_Type
(Etype
(Obj
))
16052 and then Is_Aliased_View
(Expression
(Obj
));
16054 -- Ada 2022 AI12-0228
16056 elsif Nkind
(Obj
) = N_Qualified_Expression
16057 and then Ada_Version
>= Ada_2012
16059 return Is_Aliased_View
(Expression
(Obj
));
16061 elsif Nkind
(Obj
) = N_Explicit_Dereference
then
16062 return Nkind
(Original_Node
(Obj
)) /= N_Function_Call
;
16067 end Is_Aliased_View
;
16069 -------------------------
16070 -- Is_Ancestor_Package --
16071 -------------------------
16073 function Is_Ancestor_Package
16075 E2
: Entity_Id
) return Boolean
16081 while Present
(Par
) and then Par
/= Standard_Standard
loop
16086 Par
:= Scope
(Par
);
16090 end Is_Ancestor_Package
;
16092 ----------------------
16093 -- Is_Atomic_Object --
16094 ----------------------
16096 function Is_Atomic_Object
(N
: Node_Id
) return Boolean is
16097 function Prefix_Has_Atomic_Components
(P
: Node_Id
) return Boolean;
16098 -- Determine whether prefix P has atomic components. This requires the
16099 -- presence of an Atomic_Components aspect/pragma.
16101 ---------------------------------
16102 -- Prefix_Has_Atomic_Components --
16103 ---------------------------------
16105 function Prefix_Has_Atomic_Components
(P
: Node_Id
) return Boolean is
16106 Typ
: constant Entity_Id
:= Etype
(P
);
16109 if Is_Access_Type
(Typ
) then
16110 return Has_Atomic_Components
(Designated_Type
(Typ
));
16112 elsif Has_Atomic_Components
(Typ
) then
16115 elsif Is_Entity_Name
(P
)
16116 and then Has_Atomic_Components
(Entity
(P
))
16123 end Prefix_Has_Atomic_Components
;
16125 -- Start of processing for Is_Atomic_Object
16128 if Is_Entity_Name
(N
) then
16129 return Is_Atomic_Object_Entity
(Entity
(N
));
16131 elsif Is_Atomic
(Etype
(N
)) then
16134 elsif Nkind
(N
) = N_Indexed_Component
then
16135 return Prefix_Has_Atomic_Components
(Prefix
(N
));
16137 elsif Nkind
(N
) = N_Selected_Component
then
16138 return Is_Atomic
(Entity
(Selector_Name
(N
)));
16143 end Is_Atomic_Object
;
16145 -----------------------------
16146 -- Is_Atomic_Object_Entity --
16147 -----------------------------
16149 function Is_Atomic_Object_Entity
(Id
: Entity_Id
) return Boolean is
16153 and then (Is_Atomic
(Id
) or else Is_Atomic
(Etype
(Id
)));
16154 end Is_Atomic_Object_Entity
;
16156 -----------------------------
16157 -- Is_Attribute_Loop_Entry --
16158 -----------------------------
16160 function Is_Attribute_Loop_Entry
(N
: Node_Id
) return Boolean is
16162 return Nkind
(N
) = N_Attribute_Reference
16163 and then Attribute_Name
(N
) = Name_Loop_Entry
;
16164 end Is_Attribute_Loop_Entry
;
16166 ----------------------
16167 -- Is_Attribute_Old --
16168 ----------------------
16170 function Is_Attribute_Old
(N
: Node_Id
) return Boolean is
16172 return Nkind
(N
) = N_Attribute_Reference
16173 and then Attribute_Name
(N
) = Name_Old
;
16174 end Is_Attribute_Old
;
16176 -------------------------
16177 -- Is_Attribute_Result --
16178 -------------------------
16180 function Is_Attribute_Result
(N
: Node_Id
) return Boolean is
16182 return Nkind
(N
) = N_Attribute_Reference
16183 and then Attribute_Name
(N
) = Name_Result
;
16184 end Is_Attribute_Result
;
16186 -------------------------
16187 -- Is_Attribute_Update --
16188 -------------------------
16190 function Is_Attribute_Update
(N
: Node_Id
) return Boolean is
16192 return Nkind
(N
) = N_Attribute_Reference
16193 and then Attribute_Name
(N
) = Name_Update
;
16194 end Is_Attribute_Update
;
16196 ------------------------------------
16197 -- Is_Body_Or_Package_Declaration --
16198 ------------------------------------
16200 function Is_Body_Or_Package_Declaration
(N
: Node_Id
) return Boolean is
16202 return Is_Body
(N
) or else Nkind
(N
) = N_Package_Declaration
;
16203 end Is_Body_Or_Package_Declaration
;
16205 -----------------------
16206 -- Is_Bounded_String --
16207 -----------------------
16209 function Is_Bounded_String
(T
: Entity_Id
) return Boolean is
16210 Under
: constant Entity_Id
:= Underlying_Type
(Root_Type
(T
));
16213 -- Check whether T is ultimately derived from Ada.Strings.Superbounded.
16214 -- Super_String, or one of the [Wide_]Wide_ versions. This will
16215 -- be True for all the Bounded_String types in instances of the
16216 -- Generic_Bounded_Length generics, and for types derived from those.
16218 return Present
(Under
)
16219 and then (Is_RTE
(Root_Type
(Under
), RO_SU_Super_String
) or else
16220 Is_RTE
(Root_Type
(Under
), RO_WI_Super_String
) or else
16221 Is_RTE
(Root_Type
(Under
), RO_WW_Super_String
));
16222 end Is_Bounded_String
;
16224 -------------------------------
16225 -- Is_By_Protected_Procedure --
16226 -------------------------------
16228 function Is_By_Protected_Procedure
(Id
: Entity_Id
) return Boolean is
16230 return Ekind
(Id
) = E_Procedure
16231 and then Present
(Get_Rep_Pragma
(Id
, Name_Implemented
))
16232 and then Implementation_Kind
(Id
) = Name_By_Protected_Procedure
;
16233 end Is_By_Protected_Procedure
;
16235 ---------------------
16236 -- Is_CCT_Instance --
16237 ---------------------
16239 function Is_CCT_Instance
16240 (Ref_Id
: Entity_Id
;
16241 Context_Id
: Entity_Id
) return Boolean
16244 pragma Assert
(Ekind
(Ref_Id
) in E_Protected_Type | E_Task_Type
);
16246 if Is_Single_Task_Object
(Context_Id
) then
16247 return Scope_Within_Or_Same
(Etype
(Context_Id
), Ref_Id
);
16251 (Ekind
(Context_Id
) in
16252 E_Entry | E_Entry_Family | E_Function | E_Package |
16253 E_Procedure | E_Protected_Type | E_Task_Type
16254 or else Is_Record_Type
(Context_Id
));
16255 return Scope_Within_Or_Same
(Context_Id
, Ref_Id
);
16257 end Is_CCT_Instance
;
16259 -------------------------
16260 -- Is_Child_Or_Sibling --
16261 -------------------------
16263 function Is_Child_Or_Sibling
16264 (Pack_1
: Entity_Id
;
16265 Pack_2
: Entity_Id
) return Boolean
16267 function Distance_From_Standard
(Pack
: Entity_Id
) return Nat
;
16268 -- Given an arbitrary package, return the number of "climbs" necessary
16269 -- to reach scope Standard_Standard.
16271 procedure Equalize_Depths
16272 (Pack
: in out Entity_Id
;
16273 Depth
: in out Nat
;
16274 Depth_To_Reach
: Nat
);
16275 -- Given an arbitrary package, its depth and a target depth to reach,
16276 -- climb the scope chain until the said depth is reached. The pointer
16277 -- to the package and its depth a modified during the climb.
16279 ----------------------------
16280 -- Distance_From_Standard --
16281 ----------------------------
16283 function Distance_From_Standard
(Pack
: Entity_Id
) return Nat
is
16290 while Present
(Scop
) and then Scop
/= Standard_Standard
loop
16292 Scop
:= Scope
(Scop
);
16296 end Distance_From_Standard
;
16298 ---------------------
16299 -- Equalize_Depths --
16300 ---------------------
16302 procedure Equalize_Depths
16303 (Pack
: in out Entity_Id
;
16304 Depth
: in out Nat
;
16305 Depth_To_Reach
: Nat
)
16308 -- The package must be at a greater or equal depth
16310 if Depth
< Depth_To_Reach
then
16311 raise Program_Error
;
16314 -- Climb the scope chain until the desired depth is reached
16316 while Present
(Pack
) and then Depth
/= Depth_To_Reach
loop
16317 Pack
:= Scope
(Pack
);
16318 Depth
:= Depth
- 1;
16320 end Equalize_Depths
;
16324 P_1
: Entity_Id
:= Pack_1
;
16325 P_1_Child
: Boolean := False;
16326 P_1_Depth
: Nat
:= Distance_From_Standard
(P_1
);
16327 P_2
: Entity_Id
:= Pack_2
;
16328 P_2_Child
: Boolean := False;
16329 P_2_Depth
: Nat
:= Distance_From_Standard
(P_2
);
16331 -- Start of processing for Is_Child_Or_Sibling
16335 (Ekind
(Pack_1
) = E_Package
and then Ekind
(Pack_2
) = E_Package
);
16337 -- Both packages denote the same entity, therefore they cannot be
16338 -- children or siblings.
16343 -- One of the packages is at a deeper level than the other. Note that
16344 -- both may still come from different hierarchies.
16352 elsif P_1_Depth
> P_2_Depth
then
16355 Depth
=> P_1_Depth
,
16356 Depth_To_Reach
=> P_2_Depth
);
16365 elsif P_2_Depth
> P_1_Depth
then
16368 Depth
=> P_2_Depth
,
16369 Depth_To_Reach
=> P_1_Depth
);
16373 -- At this stage the package pointers have been elevated to the same
16374 -- depth. If the related entities are the same, then one package is a
16375 -- potential child of the other:
16379 -- X became P_1 P_2 or vice versa
16385 return Is_Child_Unit
(Pack_1
);
16387 else pragma Assert
(P_2_Child
);
16388 return Is_Child_Unit
(Pack_2
);
16391 -- The packages may come from the same package chain or from entirely
16392 -- different hierarchies. To determine this, climb the scope stack until
16393 -- a common root is found.
16395 -- (root) (root 1) (root 2)
16400 while Present
(P_1
) and then Present
(P_2
) loop
16402 -- The two packages may be siblings
16405 return Is_Child_Unit
(Pack_1
) and then Is_Child_Unit
(Pack_2
);
16408 P_1
:= Scope
(P_1
);
16409 P_2
:= Scope
(P_2
);
16414 end Is_Child_Or_Sibling
;
16416 -------------------
16417 -- Is_Confirming --
16418 -------------------
16420 function Is_Confirming
(Aspect
: Nonoverridable_Aspect_Id
;
16421 Aspect_Spec_1
, Aspect_Spec_2
: Node_Id
)
16423 function Names_Match
(Nm1
, Nm2
: Node_Id
) return Boolean;
16429 function Names_Match
(Nm1
, Nm2
: Node_Id
) return Boolean is
16431 if Nkind
(Nm1
) /= Nkind
(Nm2
) then
16433 -- This may be too restrictive given that visibility
16434 -- may allow an identifier in one case and an expanded
16435 -- name in the other.
16437 case Nkind
(Nm1
) is
16438 when N_Identifier
=>
16439 return Name_Equals
(Chars
(Nm1
), Chars
(Nm2
));
16441 when N_Expanded_Name
=>
16442 -- An inherited operation has the same name as its
16443 -- ancestor, but they may have different scopes.
16444 -- This may be too permissive for Iterator_Element, which
16445 -- is intended to be identical in parent and derived type.
16447 return Names_Match
(Selector_Name
(Nm1
),
16448 Selector_Name
(Nm2
));
16451 return True; -- needed for Aggregate aspect checking
16454 -- e.g., 'Class attribute references
16455 if Is_Entity_Name
(Nm1
) and Is_Entity_Name
(Nm2
) then
16456 return Entity
(Nm1
) = Entity
(Nm2
);
16459 raise Program_Error
;
16463 -- allow users to disable "shall be confirming" check, at least for now
16464 if Relaxed_RM_Semantics
then
16468 -- ??? Type conversion here (along with "when others =>" below) is a
16469 -- workaround for a bootstrapping problem related to casing on a
16470 -- static-predicate-bearing subtype.
16472 case Aspect_Id
(Aspect
) is
16473 -- name-valued aspects; compare text of names, not resolution.
16474 when Aspect_Default_Iterator
16475 | Aspect_Iterator_Element
16476 | Aspect_Constant_Indexing
16477 | Aspect_Variable_Indexing
=>
16479 Item_1
: constant Node_Id
:= Aspect_Rep_Item
(Aspect_Spec_1
);
16480 Item_2
: constant Node_Id
:= Aspect_Rep_Item
(Aspect_Spec_2
);
16482 if (Nkind
(Item_1
) /= N_Attribute_Definition_Clause
)
16483 or (Nkind
(Item_2
) /= N_Attribute_Definition_Clause
)
16485 pragma Assert
(Serious_Errors_Detected
> 0);
16489 return Names_Match
(Expression
(Item_1
),
16490 Expression
(Item_2
));
16493 -- A confirming aspect for Implicit_Derenfence on a derived type
16494 -- has already been checked in Analyze_Aspect_Implicit_Dereference,
16495 -- including the presence of renamed discriminants.
16497 when Aspect_Implicit_Dereference
=>
16501 when Aspect_Aggregate
=>
16512 Assign_Indexed_2
: Node_Id
:= Empty
;
16514 Parse_Aspect_Aggregate
16515 (N
=> Expression
(Aspect_Spec_1
),
16516 Empty_Subp
=> Empty_1
,
16517 Add_Named_Subp
=> Add_Named_1
,
16518 Add_Unnamed_Subp
=> Add_Unnamed_1
,
16519 New_Indexed_Subp
=> New_Indexed_1
,
16520 Assign_Indexed_Subp
=> Assign_Indexed_1
);
16521 Parse_Aspect_Aggregate
16522 (N
=> Expression
(Aspect_Spec_2
),
16523 Empty_Subp
=> Empty_2
,
16524 Add_Named_Subp
=> Add_Named_2
,
16525 Add_Unnamed_Subp
=> Add_Unnamed_2
,
16526 New_Indexed_Subp
=> New_Indexed_2
,
16527 Assign_Indexed_Subp
=> Assign_Indexed_2
);
16529 Names_Match
(Empty_1
, Empty_2
) and then
16530 Names_Match
(Add_Named_1
, Add_Named_2
) and then
16531 Names_Match
(Add_Unnamed_1
, Add_Unnamed_2
) and then
16532 Names_Match
(New_Indexed_1
, New_Indexed_2
) and then
16533 Names_Match
(Assign_Indexed_1
, Assign_Indexed_2
);
16536 -- Checking for this aspect is performed elsewhere during freezing
16537 when Aspect_No_Controlled_Parts
=>
16540 -- scalar-valued aspects; compare (static) values.
16541 when Aspect_Max_Entry_Queue_Length
=>
16542 -- This should be unreachable. Max_Entry_Queue_Length is
16543 -- supported only for protected entries, not for types.
16544 pragma Assert
(Serious_Errors_Detected
/= 0);
16548 raise Program_Error
;
16552 -----------------------------
16553 -- Is_Concurrent_Interface --
16554 -----------------------------
16556 function Is_Concurrent_Interface
(T
: Entity_Id
) return Boolean is
16558 return Is_Protected_Interface
(T
)
16559 or else Is_Synchronized_Interface
(T
)
16560 or else Is_Task_Interface
(T
);
16561 end Is_Concurrent_Interface
;
16563 ------------------------------------------------------
16564 -- Is_Conjunction_Of_Formal_Preelab_Init_Attributes --
16565 ------------------------------------------------------
16567 function Is_Conjunction_Of_Formal_Preelab_Init_Attributes
16568 (Expr
: Node_Id
) return Boolean
16571 function Is_Formal_Preelab_Init_Attribute
16572 (N
: Node_Id
) return Boolean;
16573 -- Returns True if N is a Preelaborable_Initialization attribute
16574 -- applied to a generic formal type, or N's Original_Node is such
16577 --------------------------------------
16578 -- Is_Formal_Preelab_Init_Attribute --
16579 --------------------------------------
16581 function Is_Formal_Preelab_Init_Attribute
16582 (N
: Node_Id
) return Boolean
16584 Orig_N
: constant Node_Id
:= Original_Node
(N
);
16587 return Nkind
(Orig_N
) = N_Attribute_Reference
16588 and then Attribute_Name
(Orig_N
) = Name_Preelaborable_Initialization
16589 and then Is_Entity_Name
(Prefix
(Orig_N
))
16590 and then Is_Generic_Type
(Entity
(Prefix
(Orig_N
)));
16591 end Is_Formal_Preelab_Init_Attribute
;
16593 -- Start of Is_Conjunction_Of_Formal_Preelab_Init_Attributes
16596 return Is_Formal_Preelab_Init_Attribute
(Expr
)
16597 or else (Nkind
(Expr
) = N_Op_And
16599 Is_Conjunction_Of_Formal_Preelab_Init_Attributes
16602 Is_Conjunction_Of_Formal_Preelab_Init_Attributes
16603 (Right_Opnd
(Expr
)));
16604 end Is_Conjunction_Of_Formal_Preelab_Init_Attributes
;
16606 -----------------------
16607 -- Is_Constant_Bound --
16608 -----------------------
16610 function Is_Constant_Bound
(Exp
: Node_Id
) return Boolean is
16612 if Compile_Time_Known_Value
(Exp
) then
16615 elsif Is_Entity_Name
(Exp
) and then Present
(Entity
(Exp
)) then
16616 return Is_Constant_Object
(Entity
(Exp
))
16617 or else Ekind
(Entity
(Exp
)) = E_Enumeration_Literal
;
16619 elsif Nkind
(Exp
) in N_Binary_Op
then
16620 return Is_Constant_Bound
(Left_Opnd
(Exp
))
16621 and then Is_Constant_Bound
(Right_Opnd
(Exp
))
16622 and then Scope
(Entity
(Exp
)) = Standard_Standard
;
16627 end Is_Constant_Bound
;
16629 ---------------------------
16630 -- Is_Container_Element --
16631 ---------------------------
16633 function Is_Container_Element
(Exp
: Node_Id
) return Boolean is
16634 Loc
: constant Source_Ptr
:= Sloc
(Exp
);
16635 Pref
: constant Node_Id
:= Prefix
(Exp
);
16638 -- Call to an indexing aspect
16640 Cont_Typ
: Entity_Id
;
16641 -- The type of the container being accessed
16643 Elem_Typ
: Entity_Id
;
16644 -- Its element type
16646 Indexing
: Entity_Id
;
16647 Is_Const
: Boolean;
16648 -- Indicates that constant indexing is used, and the element is thus
16651 Ref_Typ
: Entity_Id
;
16652 -- The reference type returned by the indexing operation
16655 -- If C is a container, in a context that imposes the element type of
16656 -- that container, the indexing notation C (X) is rewritten as:
16658 -- Indexing (C, X).Discr.all
16660 -- where Indexing is one of the indexing aspects of the container.
16661 -- If the context does not require a reference, the construct can be
16666 -- First, verify that the construct has the proper form
16668 if not Expander_Active
then
16671 elsif Nkind
(Pref
) /= N_Selected_Component
then
16674 elsif Nkind
(Prefix
(Pref
)) /= N_Function_Call
then
16678 Call
:= Prefix
(Pref
);
16679 Ref_Typ
:= Etype
(Call
);
16682 if not Has_Implicit_Dereference
(Ref_Typ
)
16683 or else No
(First
(Parameter_Associations
(Call
)))
16684 or else not Is_Entity_Name
(Name
(Call
))
16689 -- Retrieve type of container object, and its iterator aspects
16691 Cont_Typ
:= Etype
(First
(Parameter_Associations
(Call
)));
16692 Indexing
:= Find_Value_Of_Aspect
(Cont_Typ
, Aspect_Constant_Indexing
);
16695 if No
(Indexing
) then
16697 -- Container should have at least one indexing operation
16701 elsif Entity
(Name
(Call
)) /= Entity
(Indexing
) then
16703 -- This may be a variable indexing operation
16705 Indexing
:= Find_Value_Of_Aspect
(Cont_Typ
, Aspect_Variable_Indexing
);
16708 or else Entity
(Name
(Call
)) /= Entity
(Indexing
)
16717 Elem_Typ
:= Find_Value_Of_Aspect
(Cont_Typ
, Aspect_Iterator_Element
);
16719 if No
(Elem_Typ
) or else Entity
(Elem_Typ
) /= Etype
(Exp
) then
16723 -- Check that the expression is not the target of an assignment, in
16724 -- which case the rewriting is not possible.
16726 if not Is_Const
then
16732 while Present
(Par
)
16734 if Nkind
(Parent
(Par
)) = N_Assignment_Statement
16735 and then Par
= Name
(Parent
(Par
))
16739 -- A renaming produces a reference, and the transformation
16742 elsif Nkind
(Parent
(Par
)) = N_Object_Renaming_Declaration
then
16745 elsif Nkind
(Parent
(Par
)) in
16747 N_Procedure_Call_Statement |
16748 N_Entry_Call_Statement
16750 -- Check that the element is not part of an actual for an
16751 -- in-out parameter.
16758 F
:= First_Formal
(Entity
(Name
(Parent
(Par
))));
16759 A
:= First
(Parameter_Associations
(Parent
(Par
)));
16760 while Present
(F
) loop
16761 if A
= Par
and then Ekind
(F
) /= E_In_Parameter
then
16770 -- E_In_Parameter in a call: element is not modified.
16775 Par
:= Parent
(Par
);
16780 -- The expression has the proper form and the context requires the
16781 -- element type. Retrieve the Element function of the container and
16782 -- rewrite the construct as a call to it.
16788 Op
:= First_Elmt
(Primitive_Operations
(Cont_Typ
));
16789 while Present
(Op
) loop
16790 exit when Chars
(Node
(Op
)) = Name_Element
;
16799 Make_Function_Call
(Loc
,
16800 Name
=> New_Occurrence_Of
(Node
(Op
), Loc
),
16801 Parameter_Associations
=> Parameter_Associations
(Call
)));
16802 Analyze_And_Resolve
(Exp
, Entity
(Elem_Typ
));
16806 end Is_Container_Element
;
16808 ----------------------------
16809 -- Is_Contract_Annotation --
16810 ----------------------------
16812 function Is_Contract_Annotation
(Item
: Node_Id
) return Boolean is
16814 return Is_Package_Contract_Annotation
(Item
)
16816 Is_Subprogram_Contract_Annotation
(Item
);
16817 end Is_Contract_Annotation
;
16819 --------------------------------------
16820 -- Is_Controlling_Limited_Procedure --
16821 --------------------------------------
16823 function Is_Controlling_Limited_Procedure
16824 (Proc_Nam
: Entity_Id
) return Boolean
16827 Param_Typ
: Entity_Id
:= Empty
;
16830 if Ekind
(Proc_Nam
) = E_Procedure
16831 and then Present
(Parameter_Specifications
(Parent
(Proc_Nam
)))
16835 (First
(Parameter_Specifications
(Parent
(Proc_Nam
))));
16837 -- The formal may be an anonymous access type
16839 if Nkind
(Param
) = N_Access_Definition
then
16840 Param_Typ
:= Entity
(Subtype_Mark
(Param
));
16842 Param_Typ
:= Etype
(Param
);
16845 -- In the case where an Itype was created for a dispatchin call, the
16846 -- procedure call has been rewritten. The actual may be an access to
16847 -- interface type in which case it is the designated type that is the
16848 -- controlling type.
16850 elsif Present
(Associated_Node_For_Itype
(Proc_Nam
))
16851 and then Present
(Original_Node
(Associated_Node_For_Itype
(Proc_Nam
)))
16853 Present
(Parameter_Associations
16854 (Associated_Node_For_Itype
(Proc_Nam
)))
16857 Etype
(First
(Parameter_Associations
16858 (Associated_Node_For_Itype
(Proc_Nam
))));
16860 if Ekind
(Param_Typ
) = E_Anonymous_Access_Type
then
16861 Param_Typ
:= Directly_Designated_Type
(Param_Typ
);
16865 if Present
(Param_Typ
) then
16867 Is_Interface
(Param_Typ
)
16868 and then Is_Limited_Record
(Param_Typ
);
16872 end Is_Controlling_Limited_Procedure
;
16874 -----------------------------
16875 -- Is_CPP_Constructor_Call --
16876 -----------------------------
16878 function Is_CPP_Constructor_Call
(N
: Node_Id
) return Boolean is
16880 return Nkind
(N
) = N_Function_Call
16881 and then Is_CPP_Class
(Etype
(Etype
(N
)))
16882 and then Is_Constructor
(Entity
(Name
(N
)))
16883 and then Is_Imported
(Entity
(Name
(N
)));
16884 end Is_CPP_Constructor_Call
;
16886 -------------------------
16887 -- Is_Current_Instance --
16888 -------------------------
16890 function Is_Current_Instance
(N
: Node_Id
) return Boolean is
16891 Typ
: constant Entity_Id
:= Entity
(N
);
16895 -- Simplest case: entity is a concurrent type and we are currently
16896 -- inside the body. This will eventually be expanded into a call to
16897 -- Self (for tasks) or _object (for protected objects).
16899 if Is_Concurrent_Type
(Typ
) and then In_Open_Scopes
(Typ
) then
16903 -- Check whether the context is a (sub)type declaration for the
16907 while Present
(P
) loop
16908 if Nkind
(P
) in N_Full_Type_Declaration
16909 | N_Private_Type_Declaration
16910 | N_Subtype_Declaration
16911 and then Comes_From_Source
(P
)
16913 -- If the type has a previous incomplete declaration, the
16914 -- reference in the type definition may have the incomplete
16915 -- view. So, here we detect if this incomplete view is a current
16916 -- instance by checking if its full view is the entity of the
16917 -- full declaration begin analyzed.
16920 (Defining_Entity
(P
) = Typ
16922 (Ekind
(Typ
) = E_Incomplete_Type
16923 and then Full_View
(Typ
) = Defining_Entity
(P
)))
16927 -- A subtype name may appear in an aspect specification for a
16928 -- Predicate_Failure aspect, for which we do not construct a
16929 -- wrapper procedure. The subtype will be replaced by the
16930 -- expression being tested when the corresponding predicate
16931 -- check is expanded. It may also appear in the pragma Predicate
16932 -- expression during legality checking.
16934 elsif Nkind
(P
) = N_Aspect_Specification
16935 and then Nkind
(Parent
(P
)) = N_Subtype_Declaration
16936 and then Underlying_Type
(Defining_Identifier
(Parent
(P
))) =
16937 Underlying_Type
(Typ
)
16941 elsif Nkind
(P
) = N_Pragma
16942 and then Get_Pragma_Id
(P
) in Pragma_Predicate
16943 | Pragma_Predicate_Failure
16946 Arg
: constant Entity_Id
:=
16947 Entity
(Expression
(Get_Argument
(P
)));
16949 if Underlying_Type
(Arg
) = Underlying_Type
(Typ
) then
16959 -- In any other context this is not a current occurrence
16962 end Is_Current_Instance
;
16964 --------------------------------------------------
16965 -- Is_Current_Instance_Reference_In_Type_Aspect --
16966 --------------------------------------------------
16968 function Is_Current_Instance_Reference_In_Type_Aspect
16969 (N
: Node_Id
) return Boolean
16972 -- When a current_instance is referenced within an aspect_specification
16973 -- of a type or subtype, it will show up as a reference to the formal
16974 -- parameter of the aspect's associated subprogram rather than as a
16975 -- reference to the type or subtype itself (in fact, the original name
16976 -- is never even analyzed). We check for predicate, invariant, and
16977 -- Default_Initial_Condition subprograms (in theory there could be
16978 -- other cases added, in which case this function will need updating).
16980 if Is_Entity_Name
(N
) then
16981 return Present
(Entity
(N
))
16982 and then Ekind
(Entity
(N
)) = E_In_Parameter
16983 and then Ekind
(Scope
(Entity
(N
))) in E_Function | E_Procedure
16985 (Is_Predicate_Function
(Scope
(Entity
(N
)))
16986 or else Is_Invariant_Procedure
(Scope
(Entity
(N
)))
16987 or else Is_Partial_Invariant_Procedure
(Scope
(Entity
(N
)))
16988 or else Is_DIC_Procedure
(Scope
(Entity
(N
))));
16992 when N_Indexed_Component
16996 Is_Current_Instance_Reference_In_Type_Aspect
(Prefix
(N
));
16998 when N_Selected_Component
=>
17000 Is_Current_Instance_Reference_In_Type_Aspect
(Prefix
(N
));
17002 when N_Type_Conversion
=>
17003 return Is_Current_Instance_Reference_In_Type_Aspect
17006 when N_Qualified_Expression
=>
17007 return Is_Current_Instance_Reference_In_Type_Aspect
17014 end Is_Current_Instance_Reference_In_Type_Aspect
;
17016 --------------------
17017 -- Is_Declaration --
17018 --------------------
17020 function Is_Declaration
17022 Body_OK
: Boolean := True;
17023 Concurrent_OK
: Boolean := True;
17024 Formal_OK
: Boolean := True;
17025 Generic_OK
: Boolean := True;
17026 Instantiation_OK
: Boolean := True;
17027 Renaming_OK
: Boolean := True;
17028 Stub_OK
: Boolean := True;
17029 Subprogram_OK
: Boolean := True;
17030 Type_OK
: Boolean := True) return Boolean
17035 -- Body declarations
17037 when N_Proper_Body
=>
17040 -- Concurrent type declarations
17042 when N_Protected_Type_Declaration
17043 | N_Single_Protected_Declaration
17044 | N_Single_Task_Declaration
17045 | N_Task_Type_Declaration
17047 return Concurrent_OK
or Type_OK
;
17049 -- Formal declarations
17051 when N_Formal_Abstract_Subprogram_Declaration
17052 | N_Formal_Concrete_Subprogram_Declaration
17053 | N_Formal_Object_Declaration
17054 | N_Formal_Package_Declaration
17055 | N_Formal_Type_Declaration
17059 -- Generic declarations
17061 when N_Generic_Package_Declaration
17062 | N_Generic_Subprogram_Declaration
17066 -- Generic instantiations
17068 when N_Function_Instantiation
17069 | N_Package_Instantiation
17070 | N_Procedure_Instantiation
17072 return Instantiation_OK
;
17074 -- Generic renaming declarations
17076 when N_Generic_Renaming_Declaration
=>
17077 return Generic_OK
or Renaming_OK
;
17079 -- Renaming declarations
17081 when N_Exception_Renaming_Declaration
17082 | N_Object_Renaming_Declaration
17083 | N_Package_Renaming_Declaration
17084 | N_Subprogram_Renaming_Declaration
17086 return Renaming_OK
;
17088 -- Stub declarations
17090 when N_Body_Stub
=>
17093 -- Subprogram declarations
17095 when N_Abstract_Subprogram_Declaration
17096 | N_Entry_Declaration
17097 | N_Expression_Function
17098 | N_Subprogram_Declaration
17100 return Subprogram_OK
;
17102 -- Type declarations
17104 when N_Full_Type_Declaration
17105 | N_Incomplete_Type_Declaration
17106 | N_Private_Extension_Declaration
17107 | N_Private_Type_Declaration
17108 | N_Subtype_Declaration
17114 when N_Component_Declaration
17115 | N_Exception_Declaration
17116 | N_Implicit_Label_Declaration
17117 | N_Number_Declaration
17118 | N_Object_Declaration
17119 | N_Package_Declaration
17126 end Is_Declaration
;
17128 --------------------------------
17129 -- Is_Declared_Within_Variant --
17130 --------------------------------
17132 function Is_Declared_Within_Variant
(Comp
: Entity_Id
) return Boolean is
17133 Comp_Decl
: constant Node_Id
:= Parent
(Comp
);
17134 Comp_List
: constant Node_Id
:= Parent
(Comp_Decl
);
17136 return Nkind
(Parent
(Comp_List
)) = N_Variant
;
17137 end Is_Declared_Within_Variant
;
17139 ----------------------------------------------
17140 -- Is_Dependent_Component_Of_Mutable_Object --
17141 ----------------------------------------------
17143 function Is_Dependent_Component_Of_Mutable_Object
17144 (Object
: Node_Id
) return Boolean
17147 Prefix_Type
: Entity_Id
;
17148 P_Aliased
: Boolean := False;
17151 Deref
: Node_Id
:= Original_Node
(Object
);
17152 -- Dereference node, in something like X.all.Y(2)
17154 -- Start of processing for Is_Dependent_Component_Of_Mutable_Object
17157 -- Find the dereference node if any
17159 while Nkind
(Deref
) in
17160 N_Indexed_Component | N_Selected_Component | N_Slice
17162 Deref
:= Original_Node
(Prefix
(Deref
));
17165 -- If the prefix is a qualified expression of a variable, then function
17166 -- Is_Variable will return False for that because a qualified expression
17167 -- denotes a constant view, so we need to get the name being qualified
17168 -- so we can test below whether that's a variable (or a dereference).
17170 if Nkind
(Deref
) = N_Qualified_Expression
then
17171 Deref
:= Expression
(Deref
);
17174 -- Ada 2005: If we have a component or slice of a dereference, something
17175 -- like X.all.Y (2) and the type of X is access-to-constant, Is_Variable
17176 -- will return False, because it is indeed a constant view. But it might
17177 -- be a view of a variable object, so we want the following condition to
17178 -- be True in that case.
17180 if Is_Variable
(Object
)
17181 or else Is_Variable
(Deref
)
17183 (Ada_Version
>= Ada_2005
17184 and then (Nkind
(Deref
) = N_Explicit_Dereference
17185 or else (Present
(Etype
(Deref
))
17186 and then Is_Access_Type
(Etype
(Deref
)))))
17188 if Nkind
(Object
) = N_Selected_Component
then
17190 -- If the selector is not a component, then we definitely return
17191 -- False (it could be a function selector in a prefix form call
17192 -- occurring in an iterator specification).
17194 if Ekind
(Entity
(Selector_Name
(Object
))) not in
17195 E_Component | E_Discriminant
17200 -- Get the original node of the prefix in case it has been
17201 -- rewritten, which can occur, for example, in qualified
17202 -- expression cases. Also, a discriminant check on a selected
17203 -- component may be expanded into a dereference when removing
17204 -- side effects, and the subtype of the original node may be
17207 P
:= Original_Node
(Prefix
(Object
));
17208 Prefix_Type
:= Etype
(P
);
17210 -- If the prefix is a qualified expression, we want to look at its
17213 if Nkind
(P
) = N_Qualified_Expression
then
17214 P
:= Expression
(P
);
17215 Prefix_Type
:= Etype
(P
);
17218 if Is_Entity_Name
(P
) then
17219 -- The Etype may not be set on P (which is wrong) in certain
17220 -- corner cases involving the deprecated front-end inlining of
17221 -- subprograms (via -gnatN), so use the Etype set on the
17222 -- the entity for these instances since we know it is present.
17224 if No
(Prefix_Type
) then
17225 Prefix_Type
:= Etype
(Entity
(P
));
17228 if Ekind
(Entity
(P
)) = E_Generic_In_Out_Parameter
then
17229 Prefix_Type
:= Base_Type
(Prefix_Type
);
17232 if Is_Aliased
(Entity
(P
)) then
17236 -- For explicit dereferences we get the access prefix so we can
17237 -- treat this similarly to implicit dereferences and examine the
17238 -- kind of the access type and its designated subtype further
17241 elsif Nkind
(P
) = N_Explicit_Dereference
then
17243 Prefix_Type
:= Etype
(P
);
17246 -- Check for prefix being an aliased component???
17251 -- A heap object is constrained by its initial value
17253 -- Ada 2005 (AI-363): Always assume the object could be mutable in
17254 -- the dereferenced case, since the access value might denote an
17255 -- unconstrained aliased object, whereas in Ada 95 the designated
17256 -- object is guaranteed to be constrained. A worst-case assumption
17257 -- has to apply in Ada 2005 because we can't tell at compile
17258 -- time whether the object is "constrained by its initial value",
17259 -- despite the fact that 3.10.2(26/2) and 8.5.1(5/2) are semantic
17260 -- rules (these rules are acknowledged to need fixing). We don't
17261 -- impose this more stringent checking for earlier Ada versions or
17262 -- when Relaxed_RM_Semantics applies (the latter for CodePeer's
17263 -- benefit, though it's unclear on why using -gnat95 would not be
17266 if Ada_Version
< Ada_2005
or else Relaxed_RM_Semantics
then
17267 if Is_Access_Type
(Prefix_Type
)
17268 or else Nkind
(P
) = N_Explicit_Dereference
17273 else pragma Assert
(Ada_Version
>= Ada_2005
);
17274 if Is_Access_Type
(Prefix_Type
) then
17275 -- We need to make sure we have the base subtype, in case
17276 -- this is actually an access subtype (whose Ekind will be
17277 -- E_Access_Subtype).
17279 Prefix_Type
:= Etype
(Prefix_Type
);
17281 -- If the access type is pool-specific, and there is no
17282 -- constrained partial view of the designated type, then the
17283 -- designated object is known to be constrained. If it's a
17284 -- formal access type and the renaming is in the generic
17285 -- spec, we also treat it as pool-specific (known to be
17286 -- constrained), but assume the worst if in the generic body
17287 -- (see RM 3.3(23.3/3)).
17289 if Ekind
(Prefix_Type
) = E_Access_Type
17290 and then (not Is_Generic_Type
(Prefix_Type
)
17291 or else not In_Generic_Body
(Current_Scope
))
17292 and then not Object_Type_Has_Constrained_Partial_View
17293 (Typ
=> Designated_Type
(Prefix_Type
),
17294 Scop
=> Current_Scope
)
17298 -- Otherwise (general access type, or there is a constrained
17299 -- partial view of the designated type), we need to check
17300 -- based on the designated type.
17303 Prefix_Type
:= Designated_Type
(Prefix_Type
);
17309 Original_Record_Component
(Entity
(Selector_Name
(Object
)));
17311 -- As per AI-0017, the renaming is illegal in a generic body, even
17312 -- if the subtype is indefinite (only applies to prefixes of an
17313 -- untagged formal type, see RM 3.3 (23.11/3)).
17315 -- Ada 2005 (AI-363): In Ada 2005 an aliased object can be mutable
17317 if not Is_Constrained
(Prefix_Type
)
17318 and then (Is_Definite_Subtype
(Prefix_Type
)
17320 (not Is_Tagged_Type
(Prefix_Type
)
17321 and then Is_Generic_Type
(Prefix_Type
)
17322 and then In_Generic_Body
(Current_Scope
)))
17324 and then (Is_Declared_Within_Variant
(Comp
)
17325 or else Has_Discriminant_Dependent_Constraint
(Comp
))
17326 and then (not P_Aliased
or else Ada_Version
>= Ada_2005
)
17330 -- If the prefix is of an access type at this point, then we want
17331 -- to return False, rather than calling this function recursively
17332 -- on the access object (which itself might be a discriminant-
17333 -- dependent component of some other object, but that isn't
17334 -- relevant to checking the object passed to us). This avoids
17335 -- issuing wrong errors when compiling with -gnatc, where there
17336 -- can be implicit dereferences that have not been expanded.
17338 elsif Is_Access_Type
(Etype
(Prefix
(Object
))) then
17343 Is_Dependent_Component_Of_Mutable_Object
(Prefix
(Object
));
17346 elsif Nkind
(Object
) = N_Indexed_Component
17347 or else Nkind
(Object
) = N_Slice
17349 return Is_Dependent_Component_Of_Mutable_Object
17350 (Original_Node
(Prefix
(Object
)));
17352 -- A type conversion that Is_Variable is a view conversion:
17353 -- go back to the denoted object.
17355 elsif Nkind
(Object
) = N_Type_Conversion
then
17357 Is_Dependent_Component_Of_Mutable_Object
17358 (Original_Node
(Expression
(Object
)));
17363 end Is_Dependent_Component_Of_Mutable_Object
;
17365 ---------------------
17366 -- Is_Dereferenced --
17367 ---------------------
17369 function Is_Dereferenced
(N
: Node_Id
) return Boolean is
17370 P
: constant Node_Id
:= Parent
(N
);
17372 return Nkind
(P
) in N_Selected_Component
17373 | N_Explicit_Dereference
17374 | N_Indexed_Component
17376 and then Prefix
(P
) = N
;
17377 end Is_Dereferenced
;
17379 ----------------------
17380 -- Is_Descendant_Of --
17381 ----------------------
17383 function Is_Descendant_Of
(T1
: Entity_Id
; T2
: Entity_Id
) return Boolean is
17388 pragma Assert
(Nkind
(T1
) in N_Entity
);
17389 pragma Assert
(Nkind
(T2
) in N_Entity
);
17391 T
:= Base_Type
(T1
);
17393 -- Immediate return if the types match
17398 -- Comment needed here ???
17400 elsif Ekind
(T
) = E_Class_Wide_Type
then
17401 return Etype
(T
) = T2
;
17409 -- Done if we found the type we are looking for
17414 -- Done if no more derivations to check
17421 -- Following test catches error cases resulting from prev errors
17423 elsif No
(Etyp
) then
17426 elsif Is_Private_Type
(T
) and then Etyp
= Full_View
(T
) then
17429 elsif Is_Private_Type
(Etyp
) and then Full_View
(Etyp
) = T
then
17433 T
:= Base_Type
(Etyp
);
17436 end Is_Descendant_Of
;
17438 ----------------------------------------
17439 -- Is_Descendant_Of_Suspension_Object --
17440 ----------------------------------------
17442 function Is_Descendant_Of_Suspension_Object
17443 (Typ
: Entity_Id
) return Boolean
17445 Cur_Typ
: Entity_Id
;
17446 Par_Typ
: Entity_Id
;
17449 -- Climb the type derivation chain checking each parent type against
17450 -- Suspension_Object.
17452 Cur_Typ
:= Base_Type
(Typ
);
17453 while Present
(Cur_Typ
) loop
17454 Par_Typ
:= Etype
(Cur_Typ
);
17456 -- The current type is a match
17458 if Is_RTE
(Cur_Typ
, RE_Suspension_Object
) then
17461 -- Stop the traversal once the root of the derivation chain has been
17462 -- reached. In that case the current type is its own base type.
17464 elsif Cur_Typ
= Par_Typ
then
17468 Cur_Typ
:= Base_Type
(Par_Typ
);
17472 end Is_Descendant_Of_Suspension_Object
;
17474 ---------------------------------------------
17475 -- Is_Double_Precision_Floating_Point_Type --
17476 ---------------------------------------------
17478 function Is_Double_Precision_Floating_Point_Type
17479 (E
: Entity_Id
) return Boolean is
17481 return Is_Floating_Point_Type
(E
)
17482 and then Machine_Radix_Value
(E
) = Uint_2
17483 and then Machine_Mantissa_Value
(E
) = UI_From_Int
(53)
17484 and then Machine_Emax_Value
(E
) = Uint_2
** Uint_10
17485 and then Machine_Emin_Value
(E
) = Uint_3
- (Uint_2
** Uint_10
);
17486 end Is_Double_Precision_Floating_Point_Type
;
17488 -----------------------------
17489 -- Is_Effectively_Volatile --
17490 -----------------------------
17492 function Is_Effectively_Volatile
17494 Ignore_Protected
: Boolean := False) return Boolean is
17496 if Is_Type
(Id
) then
17498 -- An arbitrary type is effectively volatile when it is subject to
17499 -- pragma Atomic or Volatile.
17501 if Is_Volatile
(Id
) then
17504 -- An array type is effectively volatile when it is subject to pragma
17505 -- Atomic_Components or Volatile_Components or its component type is
17506 -- effectively volatile.
17508 elsif Is_Array_Type
(Id
) then
17509 if Has_Volatile_Components
(Id
) then
17513 Anc
: Entity_Id
:= Base_Type
(Id
);
17515 if Is_Private_Type
(Anc
) then
17516 Anc
:= Full_View
(Anc
);
17519 -- Test for presence of ancestor, as the full view of a
17520 -- private type may be missing in case of error.
17522 return Present
(Anc
)
17523 and then Is_Effectively_Volatile
17524 (Component_Type
(Anc
), Ignore_Protected
);
17528 -- A protected type is always volatile unless Ignore_Protected is
17531 elsif Is_Protected_Type
(Id
) and then not Ignore_Protected
then
17534 -- A descendant of Ada.Synchronous_Task_Control.Suspension_Object is
17535 -- automatically volatile.
17537 elsif Is_Descendant_Of_Suspension_Object
(Id
) then
17540 -- Otherwise the type is not effectively volatile
17546 -- Otherwise Id denotes an object
17548 else pragma Assert
(Is_Object
(Id
));
17549 -- A volatile object for which No_Caching is enabled is not
17550 -- effectively volatile.
17555 (Ekind
(Id
) = E_Variable
and then No_Caching_Enabled
(Id
)))
17556 or else Has_Volatile_Components
(Id
)
17557 or else Is_Effectively_Volatile
(Etype
(Id
), Ignore_Protected
);
17559 end Is_Effectively_Volatile
;
17561 -----------------------------------------
17562 -- Is_Effectively_Volatile_For_Reading --
17563 -----------------------------------------
17565 function Is_Effectively_Volatile_For_Reading
17567 Ignore_Protected
: Boolean := False) return Boolean
17570 -- A concurrent type is effectively volatile for reading, except for a
17571 -- protected type when Ignore_Protected is True.
17573 if Is_Task_Type
(Id
)
17574 or else (Is_Protected_Type
(Id
) and then not Ignore_Protected
)
17578 elsif Is_Effectively_Volatile
(Id
, Ignore_Protected
) then
17580 -- Other volatile types and objects are effectively volatile for
17581 -- reading when they have property Async_Writers or Effective_Reads
17582 -- set to True. This includes the case of an array type whose
17583 -- Volatile_Components aspect is True (hence it is effectively
17584 -- volatile) which does not have the properties Async_Writers
17585 -- and Effective_Reads set to False.
17587 if Async_Writers_Enabled
(Id
)
17588 or else Effective_Reads_Enabled
(Id
)
17592 -- In addition, an array type is effectively volatile for reading
17593 -- when its component type is effectively volatile for reading.
17595 elsif Is_Array_Type
(Id
) then
17597 Anc
: Entity_Id
:= Base_Type
(Id
);
17599 if Is_Private_Type
(Anc
) then
17600 Anc
:= Full_View
(Anc
);
17603 -- Test for presence of ancestor, as the full view of a
17604 -- private type may be missing in case of error.
17606 return Present
(Anc
)
17607 and then Is_Effectively_Volatile_For_Reading
17608 (Component_Type
(Anc
), Ignore_Protected
);
17615 end Is_Effectively_Volatile_For_Reading
;
17617 ------------------------------------
17618 -- Is_Effectively_Volatile_Object --
17619 ------------------------------------
17621 function Is_Effectively_Volatile_Object
(N
: Node_Id
) return Boolean is
17622 function Is_Effectively_Volatile
(E
: Entity_Id
) return Boolean is
17623 (Is_Effectively_Volatile
(E
, Ignore_Protected
=> False));
17625 function Is_Effectively_Volatile_Object_Inst
17626 is new Is_Effectively_Volatile_Object_Shared
(Is_Effectively_Volatile
);
17628 return Is_Effectively_Volatile_Object_Inst
(N
);
17629 end Is_Effectively_Volatile_Object
;
17631 ------------------------------------------------
17632 -- Is_Effectively_Volatile_Object_For_Reading --
17633 ------------------------------------------------
17635 function Is_Effectively_Volatile_Object_For_Reading
17636 (N
: Node_Id
) return Boolean
17638 function Is_Effectively_Volatile_For_Reading
17639 (E
: Entity_Id
) return Boolean
17640 is (Is_Effectively_Volatile_For_Reading
(E
, Ignore_Protected
=> False));
17642 function Is_Effectively_Volatile_Object_For_Reading_Inst
17643 is new Is_Effectively_Volatile_Object_Shared
17644 (Is_Effectively_Volatile_For_Reading
);
17646 return Is_Effectively_Volatile_Object_For_Reading_Inst
(N
);
17647 end Is_Effectively_Volatile_Object_For_Reading
;
17649 -------------------------------------------
17650 -- Is_Effectively_Volatile_Object_Shared --
17651 -------------------------------------------
17653 function Is_Effectively_Volatile_Object_Shared
17654 (N
: Node_Id
) return Boolean
17657 if Is_Entity_Name
(N
) then
17658 return Is_Object
(Entity
(N
))
17659 and then Is_Effectively_Volatile_Entity
(Entity
(N
));
17661 elsif Nkind
(N
) in N_Indexed_Component | N_Slice
then
17662 return Is_Effectively_Volatile_Object_Shared
(Prefix
(N
));
17664 elsif Nkind
(N
) = N_Selected_Component
then
17666 Is_Effectively_Volatile_Object_Shared
(Prefix
(N
))
17668 Is_Effectively_Volatile_Object_Shared
(Selector_Name
(N
));
17670 elsif Nkind
(N
) in N_Qualified_Expression
17671 | N_Unchecked_Type_Conversion
17672 | N_Type_Conversion
17674 return Is_Effectively_Volatile_Object_Shared
(Expression
(N
));
17679 end Is_Effectively_Volatile_Object_Shared
;
17681 ----------------------------------------
17682 -- Is_Entity_Of_Quantified_Expression --
17683 ----------------------------------------
17685 function Is_Entity_Of_Quantified_Expression
(Id
: Entity_Id
) return Boolean
17687 Par
: constant Node_Id
:= Parent
(Id
);
17690 return (Nkind
(Par
) = N_Loop_Parameter_Specification
17691 or else Nkind
(Par
) = N_Iterator_Specification
)
17692 and then Defining_Identifier
(Par
) = Id
17693 and then Nkind
(Parent
(Par
)) = N_Quantified_Expression
;
17694 end Is_Entity_Of_Quantified_Expression
;
17696 -------------------
17697 -- Is_Entry_Body --
17698 -------------------
17700 function Is_Entry_Body
(Id
: Entity_Id
) return Boolean is
17704 and then Nkind
(Unit_Declaration_Node
(Id
)) = N_Entry_Body
;
17707 --------------------------
17708 -- Is_Entry_Declaration --
17709 --------------------------
17711 function Is_Entry_Declaration
(Id
: Entity_Id
) return Boolean is
17715 and then Nkind
(Unit_Declaration_Node
(Id
)) = N_Entry_Declaration
;
17716 end Is_Entry_Declaration
;
17718 ------------------------------------
17719 -- Is_Expanded_Priority_Attribute --
17720 ------------------------------------
17722 function Is_Expanded_Priority_Attribute
(E
: Entity_Id
) return Boolean is
17725 Nkind
(E
) = N_Function_Call
17726 and then not Configurable_Run_Time_Mode
17727 and then Nkind
(Original_Node
(E
)) = N_Attribute_Reference
17728 and then (Is_RTE
(Entity
(Name
(E
)), RE_Get_Ceiling
)
17729 or else Is_RTE
(Entity
(Name
(E
)), RO_PE_Get_Ceiling
));
17730 end Is_Expanded_Priority_Attribute
;
17732 ----------------------------
17733 -- Is_Expression_Function --
17734 ----------------------------
17736 function Is_Expression_Function
(Subp
: Entity_Id
) return Boolean is
17738 if Ekind
(Subp
) in E_Function | E_Subprogram_Body
then
17740 Nkind
(Original_Node
(Unit_Declaration_Node
(Subp
))) =
17741 N_Expression_Function
;
17745 end Is_Expression_Function
;
17747 ------------------------------------------
17748 -- Is_Expression_Function_Or_Completion --
17749 ------------------------------------------
17751 function Is_Expression_Function_Or_Completion
17752 (Subp
: Entity_Id
) return Boolean
17754 Subp_Decl
: Node_Id
;
17757 if Ekind
(Subp
) = E_Function
then
17758 Subp_Decl
:= Unit_Declaration_Node
(Subp
);
17760 -- The function declaration is either an expression function or is
17761 -- completed by an expression function body.
17764 Is_Expression_Function
(Subp
)
17765 or else (Nkind
(Subp_Decl
) = N_Subprogram_Declaration
17766 and then Present
(Corresponding_Body
(Subp_Decl
))
17767 and then Is_Expression_Function
17768 (Corresponding_Body
(Subp_Decl
)));
17770 elsif Ekind
(Subp
) = E_Subprogram_Body
then
17771 return Is_Expression_Function
(Subp
);
17776 end Is_Expression_Function_Or_Completion
;
17778 -----------------------------------------------
17779 -- Is_Extended_Precision_Floating_Point_Type --
17780 -----------------------------------------------
17782 function Is_Extended_Precision_Floating_Point_Type
17783 (E
: Entity_Id
) return Boolean is
17785 return Is_Floating_Point_Type
(E
)
17786 and then Machine_Radix_Value
(E
) = Uint_2
17787 and then Machine_Mantissa_Value
(E
) = Uint_64
17788 and then Machine_Emax_Value
(E
) = Uint_2
** Uint_14
17789 and then Machine_Emin_Value
(E
) = Uint_3
- (Uint_2
** Uint_14
);
17790 end Is_Extended_Precision_Floating_Point_Type
;
17792 -----------------------
17793 -- Is_EVF_Expression --
17794 -----------------------
17796 function Is_EVF_Expression
(N
: Node_Id
) return Boolean is
17797 Orig_N
: constant Node_Id
:= Original_Node
(N
);
17803 -- Detect a reference to a formal parameter of a specific tagged type
17804 -- whose related subprogram is subject to pragma Expresions_Visible with
17807 if Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
17812 and then Is_Specific_Tagged_Type
(Etype
(Id
))
17813 and then Extensions_Visible_Status
(Id
) =
17814 Extensions_Visible_False
;
17816 -- A case expression is an EVF expression when it contains at least one
17817 -- EVF dependent_expression. Note that a case expression may have been
17818 -- expanded, hence the use of Original_Node.
17820 elsif Nkind
(Orig_N
) = N_Case_Expression
then
17821 Alt
:= First
(Alternatives
(Orig_N
));
17822 while Present
(Alt
) loop
17823 if Is_EVF_Expression
(Expression
(Alt
)) then
17830 -- An if expression is an EVF expression when it contains at least one
17831 -- EVF dependent_expression. Note that an if expression may have been
17832 -- expanded, hence the use of Original_Node.
17834 elsif Nkind
(Orig_N
) = N_If_Expression
then
17835 Expr
:= Next
(First
(Expressions
(Orig_N
)));
17836 while Present
(Expr
) loop
17837 if Is_EVF_Expression
(Expr
) then
17844 -- A qualified expression or a type conversion is an EVF expression when
17845 -- its operand is an EVF expression.
17847 elsif Nkind
(N
) in N_Qualified_Expression
17848 | N_Unchecked_Type_Conversion
17849 | N_Type_Conversion
17851 return Is_EVF_Expression
(Expression
(N
));
17853 -- Attributes 'Loop_Entry, 'Old, and 'Update are EVF expressions when
17854 -- their prefix denotes an EVF expression.
17856 elsif Nkind
(N
) = N_Attribute_Reference
17857 and then Attribute_Name
(N
) in Name_Loop_Entry
17861 return Is_EVF_Expression
(Prefix
(N
));
17865 end Is_EVF_Expression
;
17871 function Is_False
(U
: Opt_Ubool
) return Boolean is
17873 return not Is_True
(U
);
17876 ---------------------------
17877 -- Is_Fixed_Model_Number --
17878 ---------------------------
17880 function Is_Fixed_Model_Number
(U
: Ureal
; T
: Entity_Id
) return Boolean is
17881 S
: constant Ureal
:= Small_Value
(T
);
17882 M
: Urealp
.Save_Mark
;
17887 R
:= (U
= UR_Trunc
(U
/ S
) * S
);
17888 Urealp
.Release
(M
);
17890 end Is_Fixed_Model_Number
;
17892 -----------------------------
17893 -- Is_Full_Access_Object --
17894 -----------------------------
17896 function Is_Full_Access_Object
(N
: Node_Id
) return Boolean is
17898 return Is_Atomic_Object
(N
)
17899 or else Is_Volatile_Full_Access_Object_Ref
(N
);
17900 end Is_Full_Access_Object
;
17902 -------------------------------
17903 -- Is_Fully_Initialized_Type --
17904 -------------------------------
17906 function Is_Fully_Initialized_Type
(Typ
: Entity_Id
) return Boolean is
17910 if Is_Scalar_Type
(Typ
) then
17912 -- A scalar type with an aspect Default_Value is fully initialized
17914 -- Note: Iniitalize/Normalize_Scalars also ensure full initialization
17915 -- of a scalar type, but we don't take that into account here, since
17916 -- we don't want these to affect warnings.
17918 return Has_Default_Aspect
(Typ
);
17920 elsif Is_Access_Type
(Typ
) then
17923 elsif Is_Array_Type
(Typ
) then
17924 if Is_Fully_Initialized_Type
(Component_Type
(Typ
))
17925 or else (Ada_Version
>= Ada_2012
and then Has_Default_Aspect
(Typ
))
17930 -- An interesting case, if we have a constrained type one of whose
17931 -- bounds is known to be null, then there are no elements to be
17932 -- initialized, so all the elements are initialized.
17934 if Is_Constrained
(Typ
) then
17937 Indx_Typ
: Entity_Id
;
17938 Lbd
, Hbd
: Node_Id
;
17941 Indx
:= First_Index
(Typ
);
17942 while Present
(Indx
) loop
17943 if Etype
(Indx
) = Any_Type
then
17946 -- If index is a range, use directly
17948 elsif Nkind
(Indx
) = N_Range
then
17949 Lbd
:= Low_Bound
(Indx
);
17950 Hbd
:= High_Bound
(Indx
);
17953 Indx_Typ
:= Etype
(Indx
);
17955 if Is_Private_Type
(Indx_Typ
) then
17956 Indx_Typ
:= Full_View
(Indx_Typ
);
17959 if No
(Indx_Typ
) or else Etype
(Indx_Typ
) = Any_Type
then
17962 Lbd
:= Type_Low_Bound
(Indx_Typ
);
17963 Hbd
:= Type_High_Bound
(Indx_Typ
);
17967 if Compile_Time_Known_Value
(Lbd
)
17969 Compile_Time_Known_Value
(Hbd
)
17971 if Expr_Value
(Hbd
) < Expr_Value
(Lbd
) then
17981 -- If no null indexes, then type is not fully initialized
17987 elsif Is_Record_Type
(Typ
) then
17988 if Has_Defaulted_Discriminants
(Typ
)
17989 and then Is_Fully_Initialized_Variant
(Typ
)
17994 -- We consider bounded string types to be fully initialized, because
17995 -- otherwise we get false alarms when the Data component is not
17996 -- default-initialized.
17998 if Is_Bounded_String
(Typ
) then
18002 -- Controlled records are considered to be fully initialized if
18003 -- there is a user defined Initialize routine. This may not be
18004 -- entirely correct, but as the spec notes, we are guessing here
18005 -- what is best from the point of view of issuing warnings.
18007 if Is_Controlled
(Typ
) then
18009 Utyp
: constant Entity_Id
:= Underlying_Type
(Typ
);
18012 if Present
(Utyp
) then
18014 Init
: constant Entity_Id
:=
18015 (Find_Optional_Prim_Op
18016 (Underlying_Type
(Typ
), Name_Initialize
));
18020 and then Comes_From_Source
(Init
)
18021 and then not In_Predefined_Unit
(Init
)
18025 elsif Has_Null_Extension
(Typ
)
18027 Is_Fully_Initialized_Type
18028 (Etype
(Base_Type
(Typ
)))
18037 -- Otherwise see if all record components are initialized
18043 Comp
:= First_Component
(Typ
);
18044 while Present
(Comp
) loop
18045 if (No
(Parent
(Comp
))
18046 or else No
(Expression
(Parent
(Comp
))))
18047 and then not Is_Fully_Initialized_Type
(Etype
(Comp
))
18049 -- Special VM case for tag components, which need to be
18050 -- defined in this case, but are never initialized as VMs
18051 -- are using other dispatching mechanisms. Ignore this
18052 -- uninitialized case. Note that this applies both to the
18053 -- uTag entry and the main vtable pointer (CPP_Class case).
18055 and then (Tagged_Type_Expansion
or else not Is_Tag
(Comp
))
18060 Next_Component
(Comp
);
18064 -- No uninitialized components, so type is fully initialized.
18065 -- Note that this catches the case of no components as well.
18069 elsif Is_Concurrent_Type
(Typ
) then
18072 elsif Is_Private_Type
(Typ
) then
18074 U
: constant Entity_Id
:= Underlying_Type
(Typ
);
18080 return Is_Fully_Initialized_Type
(U
);
18087 end Is_Fully_Initialized_Type
;
18089 ----------------------------------
18090 -- Is_Fully_Initialized_Variant --
18091 ----------------------------------
18093 function Is_Fully_Initialized_Variant
(Typ
: Entity_Id
) return Boolean is
18094 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
18095 Constraints
: constant List_Id
:= New_List
;
18096 Components
: constant Elist_Id
:= New_Elmt_List
;
18097 Comp_Elmt
: Elmt_Id
;
18099 Comp_List
: Node_Id
;
18101 Discr_Val
: Node_Id
;
18103 Report_Errors
: Boolean;
18104 pragma Warnings
(Off
, Report_Errors
);
18107 if Serious_Errors_Detected
> 0 then
18111 if Is_Record_Type
(Typ
)
18112 and then Nkind
(Parent
(Typ
)) = N_Full_Type_Declaration
18113 and then Nkind
(Type_Definition
(Parent
(Typ
))) = N_Record_Definition
18115 Comp_List
:= Component_List
(Type_Definition
(Parent
(Typ
)));
18117 Discr
:= First_Discriminant
(Typ
);
18118 while Present
(Discr
) loop
18119 if Nkind
(Parent
(Discr
)) = N_Discriminant_Specification
then
18120 Discr_Val
:= Expression
(Parent
(Discr
));
18122 if Present
(Discr_Val
)
18123 and then Is_OK_Static_Expression
(Discr_Val
)
18125 Append_To
(Constraints
,
18126 Make_Component_Association
(Loc
,
18127 Choices
=> New_List
(New_Occurrence_Of
(Discr
, Loc
)),
18128 Expression
=> New_Copy
(Discr_Val
)));
18136 Next_Discriminant
(Discr
);
18141 Comp_List
=> Comp_List
,
18142 Governed_By
=> Constraints
,
18143 Into
=> Components
,
18144 Report_Errors
=> Report_Errors
);
18146 -- Check that each component present is fully initialized
18148 Comp_Elmt
:= First_Elmt
(Components
);
18149 while Present
(Comp_Elmt
) loop
18150 Comp_Id
:= Node
(Comp_Elmt
);
18152 if Ekind
(Comp_Id
) = E_Component
18153 and then (No
(Parent
(Comp_Id
))
18154 or else No
(Expression
(Parent
(Comp_Id
))))
18155 and then not Is_Fully_Initialized_Type
(Etype
(Comp_Id
))
18160 Next_Elmt
(Comp_Elmt
);
18165 elsif Is_Private_Type
(Typ
) then
18167 U
: constant Entity_Id
:= Underlying_Type
(Typ
);
18173 return Is_Fully_Initialized_Variant
(U
);
18180 end Is_Fully_Initialized_Variant
;
18182 ------------------------------------
18183 -- Is_Generic_Declaration_Or_Body --
18184 ------------------------------------
18186 function Is_Generic_Declaration_Or_Body
(Decl
: Node_Id
) return Boolean is
18187 Spec_Decl
: Node_Id
;
18190 -- Package/subprogram body
18192 if Nkind
(Decl
) in N_Package_Body | N_Subprogram_Body
18193 and then Present
(Corresponding_Spec
(Decl
))
18195 Spec_Decl
:= Unit_Declaration_Node
(Corresponding_Spec
(Decl
));
18197 -- Package/subprogram body stub
18199 elsif Nkind
(Decl
) in N_Package_Body_Stub | N_Subprogram_Body_Stub
18200 and then Present
(Corresponding_Spec_Of_Stub
(Decl
))
18203 Unit_Declaration_Node
(Corresponding_Spec_Of_Stub
(Decl
));
18211 -- Rather than inspecting the defining entity of the spec declaration,
18212 -- look at its Nkind. This takes care of the case where the analysis of
18213 -- a generic body modifies the Ekind of its spec to allow for recursive
18216 return Nkind
(Spec_Decl
) in N_Generic_Declaration
;
18217 end Is_Generic_Declaration_Or_Body
;
18219 ---------------------------
18220 -- Is_Independent_Object --
18221 ---------------------------
18223 function Is_Independent_Object
(N
: Node_Id
) return Boolean is
18224 function Is_Independent_Object_Entity
(Id
: Entity_Id
) return Boolean;
18225 -- Determine whether arbitrary entity Id denotes an object that is
18228 function Prefix_Has_Independent_Components
(P
: Node_Id
) return Boolean;
18229 -- Determine whether prefix P has independent components. This requires
18230 -- the presence of an Independent_Components aspect/pragma.
18232 ------------------------------------
18233 -- Is_Independent_Object_Entity --
18234 ------------------------------------
18236 function Is_Independent_Object_Entity
(Id
: Entity_Id
) return Boolean is
18240 and then (Is_Independent
(Id
)
18242 Is_Independent
(Etype
(Id
)));
18243 end Is_Independent_Object_Entity
;
18245 -------------------------------------
18246 -- Prefix_Has_Independent_Components --
18247 -------------------------------------
18249 function Prefix_Has_Independent_Components
(P
: Node_Id
) return Boolean
18251 Typ
: constant Entity_Id
:= Etype
(P
);
18254 if Is_Access_Type
(Typ
) then
18255 return Has_Independent_Components
(Designated_Type
(Typ
));
18257 elsif Has_Independent_Components
(Typ
) then
18260 elsif Is_Entity_Name
(P
)
18261 and then Has_Independent_Components
(Entity
(P
))
18268 end Prefix_Has_Independent_Components
;
18270 -- Start of processing for Is_Independent_Object
18273 if Is_Entity_Name
(N
) then
18274 return Is_Independent_Object_Entity
(Entity
(N
));
18276 elsif Is_Independent
(Etype
(N
)) then
18279 elsif Nkind
(N
) = N_Indexed_Component
then
18280 return Prefix_Has_Independent_Components
(Prefix
(N
));
18282 elsif Nkind
(N
) = N_Selected_Component
then
18283 return Prefix_Has_Independent_Components
(Prefix
(N
))
18284 or else Is_Independent
(Entity
(Selector_Name
(N
)));
18289 end Is_Independent_Object
;
18291 ----------------------------
18292 -- Is_Inherited_Operation --
18293 ----------------------------
18295 function Is_Inherited_Operation
(E
: Entity_Id
) return Boolean is
18296 pragma Assert
(Is_Overloadable
(E
));
18297 Kind
: constant Node_Kind
:= Nkind
(Parent
(E
));
18299 return Kind
= N_Full_Type_Declaration
18300 or else Kind
= N_Private_Extension_Declaration
18301 or else Kind
= N_Subtype_Declaration
18302 or else (Ekind
(E
) = E_Enumeration_Literal
18303 and then Is_Derived_Type
(Etype
(E
)));
18304 end Is_Inherited_Operation
;
18306 -------------------------------------
18307 -- Is_Inherited_Operation_For_Type --
18308 -------------------------------------
18310 function Is_Inherited_Operation_For_Type
18312 Typ
: Entity_Id
) return Boolean
18315 -- Check that the operation has been created by the type declaration
18317 return Is_Inherited_Operation
(E
)
18318 and then Defining_Identifier
(Parent
(E
)) = Typ
;
18319 end Is_Inherited_Operation_For_Type
;
18321 --------------------------------------
18322 -- Is_Inlinable_Expression_Function --
18323 --------------------------------------
18325 function Is_Inlinable_Expression_Function
18326 (Subp
: Entity_Id
) return Boolean
18328 Return_Expr
: Node_Id
;
18331 if Is_Expression_Function_Or_Completion
(Subp
)
18332 and then Has_Pragma_Inline_Always
(Subp
)
18333 and then Needs_No_Actuals
(Subp
)
18334 and then No
(Contract
(Subp
))
18335 and then not Is_Dispatching_Operation
(Subp
)
18336 and then Needs_Finalization
(Etype
(Subp
))
18337 and then not Is_Class_Wide_Type
(Etype
(Subp
))
18338 and then not Has_Invariants
(Etype
(Subp
))
18339 and then Present
(Subprogram_Body
(Subp
))
18340 and then Was_Expression_Function
(Subprogram_Body
(Subp
))
18342 Return_Expr
:= Expression_Of_Expression_Function
(Subp
);
18344 -- The returned object must not have a qualified expression and its
18345 -- nominal subtype must be statically compatible with the result
18346 -- subtype of the expression function.
18349 Nkind
(Return_Expr
) = N_Identifier
18350 and then Etype
(Return_Expr
) = Etype
(Subp
);
18354 end Is_Inlinable_Expression_Function
;
18360 function Is_Iterator
(Typ
: Entity_Id
) return Boolean is
18361 function Denotes_Iterator
(Iter_Typ
: Entity_Id
) return Boolean;
18362 -- Determine whether type Iter_Typ is a predefined forward or reversible
18365 ----------------------
18366 -- Denotes_Iterator --
18367 ----------------------
18369 function Denotes_Iterator
(Iter_Typ
: Entity_Id
) return Boolean is
18371 -- Check that the name matches, and that the ultimate ancestor is in
18372 -- a predefined unit, i.e the one that declares iterator interfaces.
18375 Chars
(Iter_Typ
) in Name_Forward_Iterator | Name_Reversible_Iterator
18376 and then In_Predefined_Unit
(Root_Type
(Iter_Typ
));
18377 end Denotes_Iterator
;
18381 Iface_Elmt
: Elmt_Id
;
18384 -- Start of processing for Is_Iterator
18387 -- The type may be a subtype of a descendant of the proper instance of
18388 -- the predefined interface type, so we must use the root type of the
18389 -- given type. The same is done for Is_Reversible_Iterator.
18391 if Is_Class_Wide_Type
(Typ
)
18392 and then Denotes_Iterator
(Root_Type
(Typ
))
18396 elsif not Is_Tagged_Type
(Typ
) or else not Is_Derived_Type
(Typ
) then
18399 elsif Present
(Find_Value_Of_Aspect
(Typ
, Aspect_Iterable
)) then
18403 Collect_Interfaces
(Typ
, Ifaces
);
18405 Iface_Elmt
:= First_Elmt
(Ifaces
);
18406 while Present
(Iface_Elmt
) loop
18407 if Denotes_Iterator
(Node
(Iface_Elmt
)) then
18411 Next_Elmt
(Iface_Elmt
);
18418 ----------------------------
18419 -- Is_Iterator_Over_Array --
18420 ----------------------------
18422 function Is_Iterator_Over_Array
(N
: Node_Id
) return Boolean is
18423 Container
: constant Node_Id
:= Name
(N
);
18424 Container_Typ
: constant Entity_Id
:= Base_Type
(Etype
(Container
));
18426 return Is_Array_Type
(Container_Typ
);
18427 end Is_Iterator_Over_Array
;
18429 --------------------------
18430 -- Known_To_Be_Assigned --
18431 --------------------------
18433 function Known_To_Be_Assigned
18435 Only_LHS
: Boolean := False) return Boolean
18437 function Known_Assn
(N
: Node_Id
) return Boolean is
18438 (Known_To_Be_Assigned
(N
, Only_LHS
));
18439 -- Local function to simplify the passing of parameters for recursive
18442 P
: constant Node_Id
:= Parent
(N
);
18443 Form
: Entity_Id
:= Empty
;
18444 Call
: Node_Id
:= Empty
;
18446 -- Start of processing for Known_To_Be_Assigned
18449 -- Check for out parameters
18451 Find_Actual
(N
, Form
, Call
);
18453 if Present
(Form
) then
18454 return Ekind
(Form
) /= E_In_Parameter
and then not Only_LHS
;
18457 -- Otherwise look at the parent
18461 -- Test left side of assignment
18463 when N_Assignment_Statement
=>
18464 return N
= Name
(P
);
18466 -- Test prefix of component or attribute. Note that the prefix of an
18467 -- explicit or implicit dereference cannot be an l-value. In the case
18468 -- of a 'Read attribute, the reference can be an actual in the
18469 -- argument list of the attribute.
18471 when N_Attribute_Reference
=>
18473 not Only_LHS
and then
18475 and then Name_Implies_Lvalue_Prefix
(Attribute_Name
(P
)))
18477 Attribute_Name
(P
) = Name_Read
);
18479 -- For an expanded name, the name is an lvalue if the expanded name
18480 -- is an lvalue, but the prefix is never an lvalue, since it is just
18481 -- the scope where the name is found.
18483 when N_Expanded_Name
=>
18484 if N
= Prefix
(P
) then
18485 return Known_Assn
(P
);
18490 -- For a selected component A.B, A is certainly an lvalue if A.B is.
18491 -- B is a little interesting, if we have A.B := 3, there is some
18492 -- discussion as to whether B is an lvalue or not, we choose to say
18493 -- it is. Note however that A is not an lvalue if it is of an access
18494 -- type since this is an implicit dereference.
18496 when N_Selected_Component
=>
18498 and then Present
(Etype
(N
))
18499 and then Is_Access_Type
(Etype
(N
))
18503 return Known_Assn
(P
);
18506 -- For an indexed component or slice, the index or slice bounds is
18507 -- never an lvalue. The prefix is an lvalue if the indexed component
18508 -- or slice is an lvalue, except if it is an access type, where we
18509 -- have an implicit dereference.
18511 when N_Indexed_Component | N_Slice
=>
18513 or else (Present
(Etype
(N
)) and then Is_Access_Type
(Etype
(N
)))
18517 return Known_Assn
(P
);
18520 -- Prefix of a reference is an lvalue if the reference is an lvalue
18522 when N_Reference
=>
18523 return Known_Assn
(P
);
18525 -- Prefix of explicit dereference is never an lvalue
18527 when N_Explicit_Dereference
=>
18530 -- Test for appearing in a conversion that itself appears in an
18531 -- lvalue context, since this should be an lvalue.
18533 when N_Type_Conversion
=>
18534 return Known_Assn
(P
);
18536 -- Test for appearance in object renaming declaration
18538 when N_Object_Renaming_Declaration
=>
18539 return not Only_LHS
;
18541 -- All other references are definitely not lvalues
18546 end Known_To_Be_Assigned
;
18548 -----------------------------
18549 -- Is_Library_Level_Entity --
18550 -----------------------------
18552 function Is_Library_Level_Entity
(E
: Entity_Id
) return Boolean is
18554 -- The following is a small optimization, and it also properly handles
18555 -- discriminals, which in task bodies might appear in expressions before
18556 -- the corresponding procedure has been created, and which therefore do
18557 -- not have an assigned scope.
18559 if Is_Formal
(E
) then
18562 -- If we somehow got an empty value for Scope, the tree must be
18563 -- malformed. Rather than blow up we return True in this case.
18565 elsif No
(Scope
(E
)) then
18568 -- Handle loops since Enclosing_Dynamic_Scope skips them; required to
18569 -- properly handle entities local to quantified expressions in library
18570 -- level specifications.
18572 elsif Ekind
(Scope
(E
)) = E_Loop
then
18576 -- Normal test is simply that the enclosing dynamic scope is Standard
18578 return Enclosing_Dynamic_Scope
(E
) = Standard_Standard
;
18579 end Is_Library_Level_Entity
;
18581 --------------------------------
18582 -- Is_Limited_Class_Wide_Type --
18583 --------------------------------
18585 function Is_Limited_Class_Wide_Type
(Typ
: Entity_Id
) return Boolean is
18588 Is_Class_Wide_Type
(Typ
)
18589 and then (Is_Limited_Type
(Typ
) or else From_Limited_With
(Typ
));
18590 end Is_Limited_Class_Wide_Type
;
18592 ---------------------------------
18593 -- Is_Local_Variable_Reference --
18594 ---------------------------------
18596 function Is_Local_Variable_Reference
(Expr
: Node_Id
) return Boolean is
18598 if not Is_Entity_Name
(Expr
) then
18603 Ent
: constant Entity_Id
:= Entity
(Expr
);
18604 Sub
: constant Entity_Id
:= Enclosing_Subprogram
(Ent
);
18607 not in E_Variable | E_In_Out_Parameter | E_Out_Parameter
18611 return Present
(Sub
) and then Sub
= Current_Subprogram
;
18615 end Is_Local_Variable_Reference
;
18621 function Is_Master
(N
: Node_Id
) return Boolean is
18622 Disable_Subexpression_Masters
: constant Boolean := True;
18625 if Nkind
(N
) in N_Subprogram_Body | N_Task_Body | N_Entry_Body
18626 or else Is_Statement
(N
)
18631 -- We avoid returning True when the master is a subexpression described
18632 -- in RM 7.6.1(3/2) for the proposes of accessibility level calculation
18633 -- in Accessibility_Level_Helper.Innermost_Master_Scope_Depth ???
18635 if not Disable_Subexpression_Masters
18636 and then Nkind
(N
) in N_Subexpr
18639 Par
: Node_Id
:= N
;
18641 subtype N_Simple_Statement_Other_Than_Simple_Return
18642 is Node_Kind
with Static_Predicate
=>
18643 N_Simple_Statement_Other_Than_Simple_Return
18644 in N_Abort_Statement
18645 | N_Assignment_Statement
18647 | N_Delay_Statement
18648 | N_Entry_Call_Statement
18652 | N_Raise_Statement
18653 | N_Requeue_Statement
18655 | N_Procedure_Call_Statement
;
18657 while Present
(Par
) loop
18658 Par
:= Parent
(Par
);
18659 if Nkind
(Par
) in N_Subexpr |
18660 N_Simple_Statement_Other_Than_Simple_Return
18673 -----------------------
18674 -- Is_Name_Reference --
18675 -----------------------
18677 function Is_Name_Reference
(N
: Node_Id
) return Boolean is
18679 if Is_Entity_Name
(N
) then
18680 return Present
(Entity
(N
)) and then Is_Object
(Entity
(N
));
18684 when N_Indexed_Component
18688 Is_Name_Reference
(Prefix
(N
))
18689 or else Is_Access_Type
(Etype
(Prefix
(N
)));
18691 -- Attributes 'Input, 'Old and 'Result produce objects
18693 when N_Attribute_Reference
=>
18694 return Attribute_Name
(N
) in Name_Input | Name_Old | Name_Result
;
18696 when N_Selected_Component
=>
18698 Is_Name_Reference
(Selector_Name
(N
))
18700 (Is_Name_Reference
(Prefix
(N
))
18701 or else Is_Access_Type
(Etype
(Prefix
(N
))));
18703 when N_Explicit_Dereference
=>
18706 -- A view conversion of a tagged name is a name reference
18708 when N_Type_Conversion
=>
18710 Is_Tagged_Type
(Etype
(Subtype_Mark
(N
)))
18711 and then Is_Tagged_Type
(Etype
(Expression
(N
)))
18712 and then Is_Name_Reference
(Expression
(N
));
18714 -- An unchecked type conversion is considered to be a name if the
18715 -- operand is a name (this construction arises only as a result of
18716 -- expansion activities).
18718 when N_Unchecked_Type_Conversion
=>
18719 return Is_Name_Reference
(Expression
(N
));
18724 end Is_Name_Reference
;
18726 --------------------------
18727 -- Is_Newly_Constructed --
18728 --------------------------
18730 function Is_Newly_Constructed
18731 (Exp
: Node_Id
; Context_Requires_NC
: Boolean) return Boolean
18733 Original_Exp
: constant Node_Id
:= Original_Node
(Exp
);
18735 function Is_NC
(Exp
: Node_Id
) return Boolean is
18736 (Is_Newly_Constructed
(Exp
, Context_Requires_NC
));
18738 -- If the context requires that the expression shall be newly
18739 -- constructed, then "True" is a good result in the sense that the
18740 -- expression satisfies the requirements of the context (and "False"
18741 -- is analogously a bad result). If the context requires that the
18742 -- expression shall *not* be newly constructed, then things are
18743 -- reversed: "False" is the good value and "True" is the bad value.
18745 Good_Result
: constant Boolean := Context_Requires_NC
;
18746 Bad_Result
: constant Boolean := not Good_Result
;
18748 case Nkind
(Original_Exp
) is
18750 | N_Extension_Aggregate
18756 when N_Identifier
=>
18757 return Present
(Entity
(Original_Exp
))
18758 and then Ekind
(Entity
(Original_Exp
)) = E_Function
;
18760 when N_Qualified_Expression
=>
18761 return Is_NC
(Expression
(Original_Exp
));
18763 when N_Type_Conversion
18764 | N_Unchecked_Type_Conversion
18766 if Is_View_Conversion
(Original_Exp
) then
18767 return Is_NC
(Expression
(Original_Exp
));
18768 elsif not Comes_From_Source
(Exp
) then
18769 if Exp
/= Original_Exp
then
18770 return Is_NC
(Original_Exp
);
18772 return Is_NC
(Expression
(Original_Exp
));
18778 when N_Explicit_Dereference
18779 | N_Indexed_Component
18780 | N_Selected_Component
18782 return Nkind
(Exp
) = N_Function_Call
;
18784 -- A use of 'Input is a function call, hence allowed. Normally the
18785 -- attribute will be changed to a call, but the attribute by itself
18786 -- can occur with -gnatc.
18788 when N_Attribute_Reference
=>
18789 return Attribute_Name
(Original_Exp
) = Name_Input
;
18791 -- "return raise ..." is OK
18793 when N_Raise_Expression
=>
18794 return Good_Result
;
18796 -- For a case expression, all dependent expressions must be legal
18798 when N_Case_Expression
=>
18803 Alt
:= First
(Alternatives
(Original_Exp
));
18804 while Present
(Alt
) loop
18805 if Is_NC
(Expression
(Alt
)) = Bad_Result
then
18812 return Good_Result
;
18815 -- For an if expression, all dependent expressions must be legal
18817 when N_If_Expression
=>
18819 Then_Expr
: constant Node_Id
:=
18820 Next
(First
(Expressions
(Original_Exp
)));
18821 Else_Expr
: constant Node_Id
:= Next
(Then_Expr
);
18823 if (Is_NC
(Then_Expr
) = Bad_Result
)
18824 or else (Is_NC
(Else_Expr
) = Bad_Result
)
18828 return Good_Result
;
18835 end Is_Newly_Constructed
;
18837 ------------------------------------
18838 -- Is_Non_Preelaborable_Construct --
18839 ------------------------------------
18841 function Is_Non_Preelaborable_Construct
(N
: Node_Id
) return Boolean is
18843 -- NOTE: the routines within Is_Non_Preelaborable_Construct are
18844 -- intentionally unnested to avoid deep indentation of code.
18846 Non_Preelaborable
: exception;
18847 -- This exception is raised when the construct violates preelaborability
18848 -- to terminate the recursion.
18850 procedure Visit
(Nod
: Node_Id
);
18851 -- Semantically inspect construct Nod to determine whether it violates
18852 -- preelaborability. This routine raises Non_Preelaborable.
18854 procedure Visit_List
(List
: List_Id
);
18855 pragma Inline
(Visit_List
);
18856 -- Invoke Visit on each element of list List. This routine raises
18857 -- Non_Preelaborable.
18859 procedure Visit_Pragma
(Prag
: Node_Id
);
18860 pragma Inline
(Visit_Pragma
);
18861 -- Semantically inspect pragma Prag to determine whether it violates
18862 -- preelaborability. This routine raises Non_Preelaborable.
18864 procedure Visit_Subexpression
(Expr
: Node_Id
);
18865 pragma Inline
(Visit_Subexpression
);
18866 -- Semantically inspect expression Expr to determine whether it violates
18867 -- preelaborability. This routine raises Non_Preelaborable.
18873 procedure Visit
(Nod
: Node_Id
) is
18875 case Nkind
(Nod
) is
18879 when N_Component_Declaration
=>
18881 -- Defining_Identifier is left out because it is not relevant
18882 -- for preelaborability.
18884 Visit
(Component_Definition
(Nod
));
18885 Visit
(Expression
(Nod
));
18887 when N_Derived_Type_Definition
=>
18889 -- Interface_List is left out because it is not relevant for
18890 -- preelaborability.
18892 Visit
(Record_Extension_Part
(Nod
));
18893 Visit
(Subtype_Indication
(Nod
));
18895 when N_Entry_Declaration
=>
18897 -- A protected type with at leat one entry is not preelaborable
18898 -- while task types are never preelaborable. This renders entry
18899 -- declarations non-preelaborable.
18901 raise Non_Preelaborable
;
18903 when N_Full_Type_Declaration
=>
18905 -- Defining_Identifier and Discriminant_Specifications are left
18906 -- out because they are not relevant for preelaborability.
18908 Visit
(Type_Definition
(Nod
));
18910 when N_Function_Instantiation
18911 | N_Package_Instantiation
18912 | N_Procedure_Instantiation
18914 -- Defining_Unit_Name and Name are left out because they are
18915 -- not relevant for preelaborability.
18917 Visit_List
(Generic_Associations
(Nod
));
18919 when N_Object_Declaration
=>
18921 -- Defining_Identifier is left out because it is not relevant
18922 -- for preelaborability.
18924 Visit
(Object_Definition
(Nod
));
18926 if Has_Init_Expression
(Nod
) then
18927 Visit
(Expression
(Nod
));
18929 elsif not Has_Preelaborable_Initialization
18930 (Etype
(Defining_Entity
(Nod
)))
18932 raise Non_Preelaborable
;
18935 when N_Private_Extension_Declaration
18936 | N_Subtype_Declaration
18938 -- Defining_Identifier, Discriminant_Specifications, and
18939 -- Interface_List are left out because they are not relevant
18940 -- for preelaborability.
18942 Visit
(Subtype_Indication
(Nod
));
18944 when N_Protected_Type_Declaration
18945 | N_Single_Protected_Declaration
18947 -- Defining_Identifier, Discriminant_Specifications, and
18948 -- Interface_List are left out because they are not relevant
18949 -- for preelaborability.
18951 Visit
(Protected_Definition
(Nod
));
18953 -- A [single] task type is never preelaborable
18955 when N_Single_Task_Declaration
18956 | N_Task_Type_Declaration
18958 raise Non_Preelaborable
;
18963 Visit_Pragma
(Nod
);
18967 when N_Statement_Other_Than_Procedure_Call
=>
18968 if Nkind
(Nod
) /= N_Null_Statement
then
18969 raise Non_Preelaborable
;
18975 Visit_Subexpression
(Nod
);
18979 when N_Access_To_Object_Definition
=>
18980 Visit
(Subtype_Indication
(Nod
));
18982 when N_Case_Expression_Alternative
=>
18983 Visit
(Expression
(Nod
));
18984 Visit_List
(Discrete_Choices
(Nod
));
18986 when N_Component_Definition
=>
18987 Visit
(Access_Definition
(Nod
));
18988 Visit
(Subtype_Indication
(Nod
));
18990 when N_Component_List
=>
18991 Visit_List
(Component_Items
(Nod
));
18992 Visit
(Variant_Part
(Nod
));
18994 when N_Constrained_Array_Definition
=>
18995 Visit_List
(Discrete_Subtype_Definitions
(Nod
));
18996 Visit
(Component_Definition
(Nod
));
18998 when N_Delta_Constraint
18999 | N_Digits_Constraint
19001 -- Delta_Expression and Digits_Expression are left out because
19002 -- they are not relevant for preelaborability.
19004 Visit
(Range_Constraint
(Nod
));
19006 when N_Discriminant_Specification
=>
19008 -- Defining_Identifier and Expression are left out because they
19009 -- are not relevant for preelaborability.
19011 Visit
(Discriminant_Type
(Nod
));
19013 when N_Generic_Association
=>
19015 -- Selector_Name is left out because it is not relevant for
19016 -- preelaborability.
19018 Visit
(Explicit_Generic_Actual_Parameter
(Nod
));
19020 when N_Index_Or_Discriminant_Constraint
=>
19021 Visit_List
(Constraints
(Nod
));
19023 when N_Iterator_Specification
=>
19025 -- Defining_Identifier is left out because it is not relevant
19026 -- for preelaborability.
19028 Visit
(Name
(Nod
));
19029 Visit
(Subtype_Indication
(Nod
));
19031 when N_Loop_Parameter_Specification
=>
19033 -- Defining_Identifier is left out because it is not relevant
19034 -- for preelaborability.
19036 Visit
(Discrete_Subtype_Definition
(Nod
));
19038 when N_Parameter_Association
=>
19039 Visit
(Explicit_Actual_Parameter
(N
));
19041 when N_Protected_Definition
=>
19043 -- End_Label is left out because it is not relevant for
19044 -- preelaborability.
19046 Visit_List
(Private_Declarations
(Nod
));
19047 Visit_List
(Visible_Declarations
(Nod
));
19049 when N_Range_Constraint
=>
19050 Visit
(Range_Expression
(Nod
));
19052 when N_Record_Definition
19055 -- End_Label, Discrete_Choices, and Interface_List are left out
19056 -- because they are not relevant for preelaborability.
19058 Visit
(Component_List
(Nod
));
19060 when N_Subtype_Indication
=>
19062 -- Subtype_Mark is left out because it is not relevant for
19063 -- preelaborability.
19065 Visit
(Constraint
(Nod
));
19067 when N_Unconstrained_Array_Definition
=>
19069 -- Subtype_Marks is left out because it is not relevant for
19070 -- preelaborability.
19072 Visit
(Component_Definition
(Nod
));
19074 when N_Variant_Part
=>
19076 -- Name is left out because it is not relevant for
19077 -- preelaborability.
19079 Visit_List
(Variants
(Nod
));
19092 procedure Visit_List
(List
: List_Id
) is
19096 Nod
:= First
(List
);
19097 while Present
(Nod
) loop
19107 procedure Visit_Pragma
(Prag
: Node_Id
) is
19109 case Get_Pragma_Id
(Prag
) is
19111 | Pragma_Assert_And_Cut
19113 | Pragma_Async_Readers
19114 | Pragma_Async_Writers
19115 | Pragma_Attribute_Definition
19117 | Pragma_Constant_After_Elaboration
19119 | Pragma_Deadline_Floor
19120 | Pragma_Dispatching_Domain
19121 | Pragma_Effective_Reads
19122 | Pragma_Effective_Writes
19123 | Pragma_Extensions_Visible
19125 | Pragma_Secondary_Stack_Size
19127 | Pragma_Volatile_Function
19129 Visit_List
(Pragma_Argument_Associations
(Prag
));
19138 -------------------------
19139 -- Visit_Subexpression --
19140 -------------------------
19142 procedure Visit_Subexpression
(Expr
: Node_Id
) is
19143 procedure Visit_Aggregate
(Aggr
: Node_Id
);
19144 pragma Inline
(Visit_Aggregate
);
19145 -- Semantically inspect aggregate Aggr to determine whether it
19146 -- violates preelaborability.
19148 ---------------------
19149 -- Visit_Aggregate --
19150 ---------------------
19152 procedure Visit_Aggregate
(Aggr
: Node_Id
) is
19154 if not Is_Preelaborable_Aggregate
(Aggr
) then
19155 raise Non_Preelaborable
;
19157 end Visit_Aggregate
;
19159 -- Start of processing for Visit_Subexpression
19162 case Nkind
(Expr
) is
19164 | N_Qualified_Expression
19165 | N_Type_Conversion
19166 | N_Unchecked_Expression
19167 | N_Unchecked_Type_Conversion
19169 -- Subpool_Handle_Name and Subtype_Mark are left out because
19170 -- they are not relevant for preelaborability.
19172 Visit
(Expression
(Expr
));
19175 | N_Extension_Aggregate
19177 Visit_Aggregate
(Expr
);
19179 when N_Attribute_Reference
19180 | N_Explicit_Dereference
19183 -- Attribute_Name and Expressions are left out because they are
19184 -- not relevant for preelaborability.
19186 Visit
(Prefix
(Expr
));
19188 when N_Case_Expression
=>
19190 -- End_Span is left out because it is not relevant for
19191 -- preelaborability.
19193 Visit_List
(Alternatives
(Expr
));
19194 Visit
(Expression
(Expr
));
19196 when N_Delta_Aggregate
=>
19197 Visit_Aggregate
(Expr
);
19198 Visit
(Expression
(Expr
));
19200 when N_Expression_With_Actions
=>
19201 Visit_List
(Actions
(Expr
));
19202 Visit
(Expression
(Expr
));
19204 when N_Function_Call
=>
19206 -- Ada 2022 (AI12-0175): Calls to certain functions that are
19207 -- essentially unchecked conversions are preelaborable.
19209 if Ada_Version
>= Ada_2022
19210 and then Nkind
(Expr
) = N_Function_Call
19211 and then Is_Entity_Name
(Name
(Expr
))
19212 and then Is_Preelaborable_Function
(Entity
(Name
(Expr
)))
19214 Visit_List
(Parameter_Associations
(Expr
));
19216 raise Non_Preelaborable
;
19219 when N_If_Expression
=>
19220 Visit_List
(Expressions
(Expr
));
19222 when N_Quantified_Expression
=>
19223 Visit
(Condition
(Expr
));
19224 Visit
(Iterator_Specification
(Expr
));
19225 Visit
(Loop_Parameter_Specification
(Expr
));
19228 Visit
(High_Bound
(Expr
));
19229 Visit
(Low_Bound
(Expr
));
19232 Visit
(Discrete_Range
(Expr
));
19233 Visit
(Prefix
(Expr
));
19239 -- The evaluation of an object name is not preelaborable,
19240 -- unless the name is a static expression (checked further
19241 -- below), or statically denotes a discriminant.
19243 if Is_Entity_Name
(Expr
) then
19244 Object_Name
: declare
19245 Id
: constant Entity_Id
:= Entity
(Expr
);
19248 if Is_Object
(Id
) then
19249 if Ekind
(Id
) = E_Discriminant
then
19252 elsif Ekind
(Id
) in E_Constant | E_In_Parameter
19253 and then Present
(Discriminal_Link
(Id
))
19258 raise Non_Preelaborable
;
19263 -- A non-static expression is not preelaborable
19265 elsif not Is_OK_Static_Expression
(Expr
) then
19266 raise Non_Preelaborable
;
19269 end Visit_Subexpression
;
19271 -- Start of processing for Is_Non_Preelaborable_Construct
19276 -- At this point it is known that the construct is preelaborable
19282 -- The elaboration of the construct performs an action which violates
19283 -- preelaborability.
19285 when Non_Preelaborable
=>
19287 end Is_Non_Preelaborable_Construct
;
19289 ---------------------------------
19290 -- Is_Nontrivial_DIC_Procedure --
19291 ---------------------------------
19293 function Is_Nontrivial_DIC_Procedure
(Id
: Entity_Id
) return Boolean is
19294 Body_Decl
: Node_Id
;
19298 if Ekind
(Id
) = E_Procedure
and then Is_DIC_Procedure
(Id
) then
19300 Unit_Declaration_Node
19301 (Corresponding_Body
(Unit_Declaration_Node
(Id
)));
19303 -- The body of the Default_Initial_Condition procedure must contain
19304 -- at least one statement, otherwise the generation of the subprogram
19307 pragma Assert
(Present
(Handled_Statement_Sequence
(Body_Decl
)));
19309 -- To qualify as nontrivial, the first statement of the procedure
19310 -- must be a check in the form of an if statement. If the original
19311 -- Default_Initial_Condition expression was folded, then the first
19312 -- statement is not a check.
19314 Stmt
:= First
(Statements
(Handled_Statement_Sequence
(Body_Decl
)));
19317 Nkind
(Stmt
) = N_If_Statement
19318 and then Nkind
(Original_Node
(Stmt
)) = N_Pragma
;
19322 end Is_Nontrivial_DIC_Procedure
;
19324 -----------------------
19325 -- Is_Null_Extension --
19326 -----------------------
19328 function Is_Null_Extension
19329 (T
: Entity_Id
; Ignore_Privacy
: Boolean := False) return Boolean
19331 Type_Decl
: Node_Id
;
19332 Type_Def
: Node_Id
;
19334 pragma Assert
(not Is_Class_Wide_Type
(T
));
19336 if Ignore_Privacy
then
19337 Type_Decl
:= Parent
(Underlying_Type
(Base_Type
(T
)));
19339 Type_Decl
:= Parent
(Base_Type
(T
));
19340 if Nkind
(Type_Decl
) /= N_Full_Type_Declaration
then
19344 pragma Assert
(Nkind
(Type_Decl
) = N_Full_Type_Declaration
);
19345 Type_Def
:= Type_Definition
(Type_Decl
);
19346 if Present
(Discriminant_Specifications
(Type_Decl
))
19347 or else Nkind
(Type_Def
) /= N_Derived_Type_Definition
19348 or else not Is_Tagged_Type
(T
)
19349 or else No
(Record_Extension_Part
(Type_Def
))
19354 return Is_Null_Record_Definition
(Record_Extension_Part
(Type_Def
));
19355 end Is_Null_Extension
;
19357 --------------------------
19358 -- Is_Null_Extension_Of --
19359 --------------------------
19361 function Is_Null_Extension_Of
19362 (Descendant
, Ancestor
: Entity_Id
) return Boolean
19364 Ancestor_Type
: constant Entity_Id
19365 := Underlying_Type
(Base_Type
(Ancestor
));
19366 Descendant_Type
: Entity_Id
:= Underlying_Type
(Base_Type
(Descendant
));
19368 pragma Assert
(not Is_Class_Wide_Type
(Descendant
));
19369 pragma Assert
(not Is_Class_Wide_Type
(Ancestor
));
19370 pragma Assert
(Descendant_Type
/= Ancestor_Type
);
19372 while Descendant_Type
/= Ancestor_Type
loop
19373 if not Is_Null_Extension
19374 (Descendant_Type
, Ignore_Privacy
=> True)
19378 Descendant_Type
:= Etype
(Subtype_Indication
19379 (Type_Definition
(Parent
(Descendant_Type
))));
19380 Descendant_Type
:= Underlying_Type
(Base_Type
(Descendant_Type
));
19383 end Is_Null_Extension_Of
;
19385 -------------------------------
19386 -- Is_Null_Record_Definition --
19387 -------------------------------
19389 function Is_Null_Record_Definition
(Record_Def
: Node_Id
) return Boolean is
19392 -- Testing Null_Present is just an optimization, not required.
19394 if Null_Present
(Record_Def
) then
19396 elsif Present
(Variant_Part
(Component_List
(Record_Def
))) then
19398 elsif not Present
(Component_List
(Record_Def
)) then
19402 Item
:= First
(Component_Items
(Component_List
(Record_Def
)));
19404 while Present
(Item
) loop
19405 if Nkind
(Item
) = N_Component_Declaration
19406 and then Is_Internal_Name
(Chars
(Defining_Identifier
(Item
)))
19409 elsif Nkind
(Item
) = N_Pragma
then
19414 Item
:= Next
(Item
);
19418 end Is_Null_Record_Definition
;
19420 -------------------------
19421 -- Is_Null_Record_Type --
19422 -------------------------
19424 function Is_Null_Record_Type
19425 (T
: Entity_Id
; Ignore_Privacy
: Boolean := False) return Boolean
19428 Type_Def
: Node_Id
;
19430 if not Is_Record_Type
(T
) then
19434 if Ignore_Privacy
then
19435 Decl
:= Parent
(Underlying_Type
(Base_Type
(T
)));
19437 Decl
:= Parent
(Base_Type
(T
));
19438 if Nkind
(Decl
) /= N_Full_Type_Declaration
then
19442 pragma Assert
(Nkind
(Decl
) = N_Full_Type_Declaration
);
19443 Type_Def
:= Type_Definition
(Decl
);
19445 if Has_Discriminants
(Defining_Identifier
(Decl
)) then
19449 case Nkind
(Type_Def
) is
19450 when N_Record_Definition
=>
19451 return Is_Null_Record_Definition
(Type_Def
);
19452 when N_Derived_Type_Definition
=>
19453 if not Is_Null_Record_Type
19454 (Etype
(Subtype_Indication
(Type_Def
)),
19455 Ignore_Privacy
=> Ignore_Privacy
)
19458 elsif not Is_Tagged_Type
(T
) then
19461 return Is_Null_Extension
(T
, Ignore_Privacy
=> Ignore_Privacy
);
19466 end Is_Null_Record_Type
;
19468 ---------------------
19469 -- Is_Object_Image --
19470 ---------------------
19472 function Is_Object_Image
(Prefix
: Node_Id
) return Boolean is
19474 -- Here we test for the case that the prefix is not a type and assume
19475 -- if it is not then it must be a named value or an object reference.
19476 -- This is because the parser always checks that prefixes of attributes
19479 return not (Is_Entity_Name
(Prefix
)
19480 and then Is_Type
(Entity
(Prefix
))
19481 and then not Is_Current_Instance
(Prefix
));
19482 end Is_Object_Image
;
19484 -------------------------
19485 -- Is_Object_Reference --
19486 -------------------------
19488 function Is_Object_Reference
(N
: Node_Id
) return Boolean is
19489 function Safe_Prefix
(N
: Node_Id
) return Node_Id
;
19490 -- Return Prefix (N) unless it has been rewritten as an
19491 -- N_Raise_xxx_Error node, in which case return its original node.
19497 function Safe_Prefix
(N
: Node_Id
) return Node_Id
is
19499 if Nkind
(Prefix
(N
)) in N_Raise_xxx_Error
then
19500 return Original_Node
(Prefix
(N
));
19507 -- AI12-0068: Note that a current instance reference in a type or
19508 -- subtype's aspect_specification is considered a value, not an object
19509 -- (see RM 8.6(18/5)).
19511 if Is_Entity_Name
(N
) then
19512 return Present
(Entity
(N
)) and then Is_Object
(Entity
(N
))
19513 and then not Is_Current_Instance_Reference_In_Type_Aspect
(N
);
19517 when N_Indexed_Component
19521 Is_Object_Reference
(Safe_Prefix
(N
))
19522 or else Is_Access_Type
(Etype
(Safe_Prefix
(N
)));
19524 -- In Ada 95, a function call is a constant object; a procedure
19527 -- Note that predefined operators are functions as well, and so
19528 -- are attributes that are (can be renamed as) functions.
19530 when N_Function_Call
19533 return Etype
(N
) /= Standard_Void_Type
;
19535 -- Attributes references 'Loop_Entry, 'Old, 'Priority and 'Result
19536 -- yield objects, even though they are not functions.
19538 when N_Attribute_Reference
=>
19540 Attribute_Name
(N
) in Name_Loop_Entry
19544 or else Is_Function_Attribute_Name
(Attribute_Name
(N
));
19546 when N_Selected_Component
=>
19548 Is_Object_Reference
(Selector_Name
(N
))
19550 (Is_Object_Reference
(Safe_Prefix
(N
))
19551 or else Is_Access_Type
(Etype
(Safe_Prefix
(N
))));
19553 -- An explicit dereference denotes an object, except that a
19554 -- conditional expression gets turned into an explicit dereference
19555 -- in some cases, and conditional expressions are not object
19558 when N_Explicit_Dereference
=>
19559 return Nkind
(Original_Node
(N
)) not in
19560 N_Case_Expression | N_If_Expression
;
19562 -- A view conversion of a tagged object is an object reference
19564 when N_Type_Conversion
=>
19565 if Ada_Version
<= Ada_2012
then
19566 -- A view conversion of a tagged object is an object
19568 return Is_Tagged_Type
(Etype
(Subtype_Mark
(N
)))
19569 and then Is_Tagged_Type
(Etype
(Expression
(N
)))
19570 and then Is_Object_Reference
(Expression
(N
));
19573 -- AI12-0226: In Ada 2022 a value conversion of an object is
19576 return Is_Object_Reference
(Expression
(N
));
19579 -- An unchecked type conversion is considered to be an object if
19580 -- the operand is an object (this construction arises only as a
19581 -- result of expansion activities).
19583 when N_Unchecked_Type_Conversion
=>
19586 -- AI05-0003: In Ada 2012 a qualified expression is a name.
19587 -- This allows disambiguation of function calls and the use
19588 -- of aggregates in more contexts.
19590 when N_Qualified_Expression
=>
19591 return Ada_Version
>= Ada_2012
19592 and then Is_Object_Reference
(Expression
(N
));
19594 -- In Ada 95 an aggregate is an object reference
19597 | N_Delta_Aggregate
19598 | N_Extension_Aggregate
19600 return Ada_Version
>= Ada_95
;
19602 -- A string literal is not an object reference, but it might come
19603 -- from rewriting of an object reference, e.g. from folding of an
19606 when N_String_Literal
=>
19607 return Is_Rewrite_Substitution
(N
)
19608 and then Is_Object_Reference
(Original_Node
(N
));
19610 -- AI12-0125: Target name represents a constant object
19612 when N_Target_Name
=>
19619 end Is_Object_Reference
;
19621 -----------------------------------
19622 -- Is_OK_Variable_For_Out_Formal --
19623 -----------------------------------
19625 function Is_OK_Variable_For_Out_Formal
(AV
: Node_Id
) return Boolean is
19627 Note_Possible_Modification
(AV
, Sure
=> True);
19629 -- We must reject parenthesized variable names. Comes_From_Source is
19630 -- checked because there are currently cases where the compiler violates
19631 -- this rule (e.g. passing a task object to its controlled Initialize
19632 -- routine). This should be properly documented in sinfo???
19634 if Paren_Count
(AV
) > 0 and then Comes_From_Source
(AV
) then
19637 -- A variable is always allowed
19639 elsif Is_Variable
(AV
) then
19642 -- Generalized indexing operations are rewritten as explicit
19643 -- dereferences, and it is only during resolution that we can
19644 -- check whether the context requires an access_to_variable type.
19646 elsif Nkind
(AV
) = N_Explicit_Dereference
19647 and then Present
(Etype
(Original_Node
(AV
)))
19648 and then Has_Implicit_Dereference
(Etype
(Original_Node
(AV
)))
19649 and then Ada_Version
>= Ada_2012
19651 return not Is_Access_Constant
(Etype
(Prefix
(AV
)));
19653 -- Unchecked conversions are allowed only if they come from the
19654 -- generated code, which sometimes uses unchecked conversions for out
19655 -- parameters in cases where code generation is unaffected. We tell
19656 -- source unchecked conversions by seeing if they are rewrites of
19657 -- an original Unchecked_Conversion function call, or of an explicit
19658 -- conversion of a function call or an aggregate (as may happen in the
19659 -- expansion of a packed array aggregate).
19661 elsif Nkind
(AV
) = N_Unchecked_Type_Conversion
then
19662 if Nkind
(Original_Node
(AV
)) in N_Function_Call | N_Aggregate
then
19665 elsif Nkind
(Original_Node
(Expression
(AV
))) = N_Function_Call
then
19668 elsif Nkind
(Original_Node
(AV
)) = N_Type_Conversion
then
19669 return Is_OK_Variable_For_Out_Formal
(Expression
(AV
));
19675 -- Normal type conversions are allowed if argument is a variable
19677 elsif Nkind
(AV
) = N_Type_Conversion
then
19678 if Is_Variable
(Expression
(AV
))
19679 and then Paren_Count
(Expression
(AV
)) = 0
19681 Note_Possible_Modification
(Expression
(AV
), Sure
=> True);
19684 -- We also allow a non-parenthesized expression that raises
19685 -- constraint error if it rewrites what used to be a variable
19687 elsif Raises_Constraint_Error
(Expression
(AV
))
19688 and then Paren_Count
(Expression
(AV
)) = 0
19689 and then Is_Variable
(Original_Node
(Expression
(AV
)))
19693 -- Type conversion of something other than a variable
19699 -- If this node is rewritten, then test the original form, if that is
19700 -- OK, then we consider the rewritten node OK (for example, if the
19701 -- original node is a conversion, then Is_Variable will not be true
19702 -- but we still want to allow the conversion if it converts a variable).
19704 elsif Is_Rewrite_Substitution
(AV
) then
19705 return Is_OK_Variable_For_Out_Formal
(Original_Node
(AV
));
19707 -- All other non-variables are rejected
19712 end Is_OK_Variable_For_Out_Formal
;
19714 ----------------------------
19715 -- Is_OK_Volatile_Context --
19716 ----------------------------
19718 function Is_OK_Volatile_Context
19719 (Context
: Node_Id
;
19721 Check_Actuals
: Boolean) return Boolean
19723 function Is_Protected_Operation_Call
(Nod
: Node_Id
) return Boolean;
19724 -- Determine whether an arbitrary node denotes a call to a protected
19725 -- entry, function, or procedure in prefixed form where the prefix is
19728 function Within_Check
(Nod
: Node_Id
) return Boolean;
19729 -- Determine whether an arbitrary node appears in a check node
19731 function Within_Volatile_Function
(Id
: Entity_Id
) return Boolean;
19732 -- Determine whether an arbitrary entity appears in a volatile function
19734 ---------------------------------
19735 -- Is_Protected_Operation_Call --
19736 ---------------------------------
19738 function Is_Protected_Operation_Call
(Nod
: Node_Id
) return Boolean is
19743 -- A call to a protected operations retains its selected component
19744 -- form as opposed to other prefixed calls that are transformed in
19747 if Nkind
(Nod
) = N_Selected_Component
then
19748 Pref
:= Prefix
(Nod
);
19749 Subp
:= Selector_Name
(Nod
);
19753 and then Present
(Etype
(Pref
))
19754 and then Is_Protected_Type
(Etype
(Pref
))
19755 and then Is_Entity_Name
(Subp
)
19756 and then Present
(Entity
(Subp
))
19757 and then Ekind
(Entity
(Subp
)) in
19758 E_Entry | E_Entry_Family | E_Function | E_Procedure
;
19762 end Is_Protected_Operation_Call
;
19768 function Within_Check
(Nod
: Node_Id
) return Boolean is
19772 -- Climb the parent chain looking for a check node
19775 while Present
(Par
) loop
19776 if Nkind
(Par
) in N_Raise_xxx_Error
then
19779 -- Prevent the search from going too far
19781 elsif Is_Body_Or_Package_Declaration
(Par
) then
19785 Par
:= Parent
(Par
);
19791 ------------------------------
19792 -- Within_Volatile_Function --
19793 ------------------------------
19795 function Within_Volatile_Function
(Id
: Entity_Id
) return Boolean is
19796 pragma Assert
(Ekind
(Id
) = E_Return_Statement
);
19798 Func_Id
: constant Entity_Id
:= Return_Applies_To
(Id
);
19801 pragma Assert
(Ekind
(Func_Id
) in E_Function | E_Generic_Function
);
19803 return Is_Volatile_Function
(Func_Id
);
19804 end Within_Volatile_Function
;
19808 Obj_Id
: Entity_Id
;
19810 -- Start of processing for Is_OK_Volatile_Context
19813 -- Ignore context restriction when doing preanalysis, e.g. on a copy of
19814 -- an expression function, because this copy is not fully decorated and
19815 -- it is not possible to reliably decide the legality of the context.
19816 -- Any violations will be reported anyway when doing the full analysis.
19818 if not Full_Analysis
then
19822 -- For actual parameters within explicit parameter associations switch
19823 -- the context to the corresponding subprogram call.
19825 if Nkind
(Context
) = N_Parameter_Association
then
19826 return Is_OK_Volatile_Context
(Context
=> Parent
(Context
),
19827 Obj_Ref
=> Obj_Ref
,
19828 Check_Actuals
=> Check_Actuals
);
19830 -- The volatile object appears on either side of an assignment
19832 elsif Nkind
(Context
) = N_Assignment_Statement
then
19835 -- The volatile object is part of the initialization expression of
19838 elsif Nkind
(Context
) = N_Object_Declaration
19839 and then Present
(Expression
(Context
))
19840 and then Expression
(Context
) = Obj_Ref
19841 and then Nkind
(Parent
(Context
)) /= N_Expression_With_Actions
19843 Obj_Id
:= Defining_Entity
(Context
);
19845 -- The volatile object acts as the initialization expression of an
19846 -- extended return statement. This is valid context as long as the
19847 -- function is volatile.
19849 if Is_Return_Object
(Obj_Id
) then
19850 return Within_Volatile_Function
(Scope
(Obj_Id
));
19852 -- Otherwise this is a normal object initialization
19858 -- The volatile object acts as the name of a renaming declaration
19860 elsif Nkind
(Context
) = N_Object_Renaming_Declaration
19861 and then Name
(Context
) = Obj_Ref
19865 -- The volatile object appears as an actual parameter in a call to an
19866 -- instance of Unchecked_Conversion whose result is renamed.
19868 elsif Nkind
(Context
) = N_Function_Call
19869 and then Is_Entity_Name
(Name
(Context
))
19870 and then Is_Unchecked_Conversion_Instance
(Entity
(Name
(Context
)))
19871 and then Nkind
(Parent
(Context
)) = N_Object_Renaming_Declaration
19875 -- The volatile object is actually the prefix in a protected entry,
19876 -- function, or procedure call.
19878 elsif Is_Protected_Operation_Call
(Context
) then
19881 -- The volatile object appears as the expression of a simple return
19882 -- statement that applies to a volatile function.
19884 elsif Nkind
(Context
) = N_Simple_Return_Statement
19885 and then Expression
(Context
) = Obj_Ref
19888 Within_Volatile_Function
(Return_Statement_Entity
(Context
));
19890 -- The volatile object appears as the prefix of a name occurring in a
19891 -- non-interfering context.
19893 elsif Nkind
(Context
) in
19894 N_Attribute_Reference |
19895 N_Explicit_Dereference |
19896 N_Indexed_Component |
19897 N_Selected_Component |
19899 and then Prefix
(Context
) = Obj_Ref
19900 and then Is_OK_Volatile_Context
19901 (Context
=> Parent
(Context
),
19902 Obj_Ref
=> Context
,
19903 Check_Actuals
=> Check_Actuals
)
19907 -- The volatile object appears as the prefix of attributes Address,
19908 -- Alignment, Component_Size, First, First_Bit, Last, Last_Bit, Length,
19909 -- Position, Size, Storage_Size.
19911 elsif Nkind
(Context
) = N_Attribute_Reference
19912 and then Prefix
(Context
) = Obj_Ref
19913 and then Attribute_Name
(Context
) in Name_Address
19915 | Name_Component_Size
19923 | Name_Storage_Size
19927 -- The volatile object appears as the expression of a type conversion
19928 -- occurring in a non-interfering context.
19930 elsif Nkind
(Context
) in N_Qualified_Expression
19931 | N_Type_Conversion
19932 | N_Unchecked_Type_Conversion
19933 and then Expression
(Context
) = Obj_Ref
19934 and then Is_OK_Volatile_Context
19935 (Context
=> Parent
(Context
),
19936 Obj_Ref
=> Context
,
19937 Check_Actuals
=> Check_Actuals
)
19941 -- The volatile object appears as the expression in a delay statement
19943 elsif Nkind
(Context
) in N_Delay_Statement
then
19946 -- Allow references to volatile objects in various checks. This is not a
19947 -- direct SPARK 2014 requirement.
19949 elsif Within_Check
(Context
) then
19952 -- References to effectively volatile objects that appear as actual
19953 -- parameters in subprogram calls can be examined only after call itself
19954 -- has been resolved. Before that, assume such references to be legal.
19956 elsif Nkind
(Context
) in N_Subprogram_Call | N_Entry_Call_Statement
then
19957 if Check_Actuals
then
19960 Formal
: Entity_Id
;
19961 Subp
: constant Entity_Id
:= Get_Called_Entity
(Context
);
19963 Find_Actual
(Obj_Ref
, Formal
, Call
);
19964 pragma Assert
(Call
= Context
);
19966 -- An effectively volatile object may act as an actual when the
19967 -- corresponding formal is of a non-scalar effectively volatile
19968 -- type (SPARK RM 7.1.3(10)).
19970 if not Is_Scalar_Type
(Etype
(Formal
))
19971 and then Is_Effectively_Volatile_For_Reading
(Etype
(Formal
))
19975 -- An effectively volatile object may act as an actual in a
19976 -- call to an instance of Unchecked_Conversion. (SPARK RM
19979 elsif Is_Unchecked_Conversion_Instance
(Subp
) then
19992 end Is_OK_Volatile_Context
;
19994 ------------------------------------
19995 -- Is_Package_Contract_Annotation --
19996 ------------------------------------
19998 function Is_Package_Contract_Annotation
(Item
: Node_Id
) return Boolean is
20002 if Nkind
(Item
) = N_Aspect_Specification
then
20003 Nam
:= Chars
(Identifier
(Item
));
20005 else pragma Assert
(Nkind
(Item
) = N_Pragma
);
20006 Nam
:= Pragma_Name
(Item
);
20009 return Nam
= Name_Abstract_State
20010 or else Nam
= Name_Initial_Condition
20011 or else Nam
= Name_Initializes
20012 or else Nam
= Name_Refined_State
;
20013 end Is_Package_Contract_Annotation
;
20015 -----------------------------------
20016 -- Is_Partially_Initialized_Type --
20017 -----------------------------------
20019 function Is_Partially_Initialized_Type
20021 Include_Implicit
: Boolean := True) return Boolean
20024 if Is_Scalar_Type
(Typ
) then
20025 return Has_Default_Aspect
(Base_Type
(Typ
));
20027 elsif Is_Access_Type
(Typ
) then
20028 return Include_Implicit
;
20030 elsif Is_Array_Type
(Typ
) then
20032 -- If component type is partially initialized, so is array type
20034 if Has_Default_Aspect
(Base_Type
(Typ
))
20035 or else Is_Partially_Initialized_Type
20036 (Component_Type
(Typ
), Include_Implicit
)
20040 -- Otherwise we are only partially initialized if we are fully
20041 -- initialized (this is the empty array case, no point in us
20042 -- duplicating that code here).
20045 return Is_Fully_Initialized_Type
(Typ
);
20048 elsif Is_Record_Type
(Typ
) then
20050 -- A discriminated type is always partially initialized if in
20053 if Has_Discriminants
(Typ
) and then Include_Implicit
then
20056 -- A tagged type is always partially initialized
20058 elsif Is_Tagged_Type
(Typ
) then
20061 -- Case of nondiscriminated record
20067 Component_Present
: Boolean := False;
20068 -- Set True if at least one component is present. If no
20069 -- components are present, then record type is fully
20070 -- initialized (another odd case, like the null array).
20073 -- Loop through components
20075 Comp
:= First_Component
(Typ
);
20076 while Present
(Comp
) loop
20077 Component_Present
:= True;
20079 -- If a component has an initialization expression then the
20080 -- enclosing record type is partially initialized
20082 if Present
(Parent
(Comp
))
20083 and then Present
(Expression
(Parent
(Comp
)))
20087 -- If a component is of a type which is itself partially
20088 -- initialized, then the enclosing record type is also.
20090 elsif Is_Partially_Initialized_Type
20091 (Etype
(Comp
), Include_Implicit
)
20096 Next_Component
(Comp
);
20099 -- No initialized components found. If we found any components
20100 -- they were all uninitialized so the result is false.
20102 if Component_Present
then
20105 -- But if we found no components, then all the components are
20106 -- initialized so we consider the type to be initialized.
20114 -- Concurrent types are always fully initialized
20116 elsif Is_Concurrent_Type
(Typ
) then
20119 -- For a private type, go to underlying type. If there is no underlying
20120 -- type then just assume this partially initialized. Not clear if this
20121 -- can happen in a non-error case, but no harm in testing for this.
20123 elsif Is_Private_Type
(Typ
) then
20125 U
: constant Entity_Id
:= Underlying_Type
(Typ
);
20130 return Is_Partially_Initialized_Type
(U
, Include_Implicit
);
20134 -- For any other type (are there any?) assume partially initialized
20139 end Is_Partially_Initialized_Type
;
20141 ------------------------------------
20142 -- Is_Potentially_Persistent_Type --
20143 ------------------------------------
20145 function Is_Potentially_Persistent_Type
(T
: Entity_Id
) return Boolean is
20150 -- For private type, test corresponding full type
20152 if Is_Private_Type
(T
) then
20153 return Is_Potentially_Persistent_Type
(Full_View
(T
));
20155 -- Scalar types are potentially persistent
20157 elsif Is_Scalar_Type
(T
) then
20160 -- Record type is potentially persistent if not tagged and the types of
20161 -- all it components are potentially persistent, and no component has
20162 -- an initialization expression.
20164 elsif Is_Record_Type
(T
)
20165 and then not Is_Tagged_Type
(T
)
20166 and then not Is_Partially_Initialized_Type
(T
)
20168 Comp
:= First_Component
(T
);
20169 while Present
(Comp
) loop
20170 if not Is_Potentially_Persistent_Type
(Etype
(Comp
)) then
20173 Next_Entity
(Comp
);
20179 -- Array type is potentially persistent if its component type is
20180 -- potentially persistent and if all its constraints are static.
20182 elsif Is_Array_Type
(T
) then
20183 if not Is_Potentially_Persistent_Type
(Component_Type
(T
)) then
20187 Indx
:= First_Index
(T
);
20188 while Present
(Indx
) loop
20189 if not Is_OK_Static_Subtype
(Etype
(Indx
)) then
20198 -- All other types are not potentially persistent
20203 end Is_Potentially_Persistent_Type
;
20205 --------------------------------
20206 -- Is_Potentially_Unevaluated --
20207 --------------------------------
20209 function Is_Potentially_Unevaluated
(N
: Node_Id
) return Boolean is
20210 function Has_Null_Others_Choice
(Aggr
: Node_Id
) return Boolean;
20211 -- Aggr is an array aggregate with static bounds and an others clause;
20212 -- return True if the others choice of the given array aggregate does
20213 -- not cover any component (i.e. is null).
20215 function Immediate_Context_Implies_Is_Potentially_Unevaluated
20216 (Expr
: Node_Id
) return Boolean;
20217 -- Return True if the *immediate* context of this expression tells us
20218 -- that it is potentially unevaluated; return False if the *immediate*
20219 -- context doesn't provide an answer to this question and we need to
20222 function Non_Static_Or_Null_Range
(N
: Node_Id
) return Boolean;
20223 -- Return True if the given range is nonstatic or null
20225 ----------------------------
20226 -- Has_Null_Others_Choice --
20227 ----------------------------
20229 function Has_Null_Others_Choice
(Aggr
: Node_Id
) return Boolean is
20230 Idx
: constant Node_Id
:= First_Index
(Etype
(Aggr
));
20231 Hiv
: constant Uint
:= Expr_Value
(Type_High_Bound
(Etype
(Idx
)));
20232 Lov
: constant Uint
:= Expr_Value
(Type_Low_Bound
(Etype
(Idx
)));
20236 Intervals
: constant Interval_Lists
.Discrete_Interval_List
:=
20237 Interval_Lists
.Aggregate_Intervals
(Aggr
);
20240 -- The others choice is null if, after normalization, we
20241 -- have a single interval covering the whole aggregate.
20243 return Intervals
'Length = 1
20245 Intervals
(Intervals
'First).Low
= Lov
20247 Intervals
(Intervals
'First).High
= Hiv
;
20250 -- If the aggregate is malformed (that is, indexes are not disjoint)
20251 -- then no action is needed at this stage; the error will be reported
20252 -- later by the frontend.
20255 when Interval_Lists
.Intervals_Error
=>
20257 end Has_Null_Others_Choice
;
20259 ----------------------------------------------------------
20260 -- Immediate_Context_Implies_Is_Potentially_Unevaluated --
20261 ----------------------------------------------------------
20263 function Immediate_Context_Implies_Is_Potentially_Unevaluated
20264 (Expr
: Node_Id
) return Boolean
20266 Par
: constant Node_Id
:= Parent
(Expr
);
20268 function Aggregate_Type
return Node_Id
is (Etype
(Parent
(Par
)));
20270 if Nkind
(Par
) = N_If_Expression
then
20271 return Is_Elsif
(Par
) or else Expr
/= First
(Expressions
(Par
));
20273 elsif Nkind
(Par
) = N_Case_Expression
then
20274 return Expr
/= Expression
(Par
);
20276 elsif Nkind
(Par
) in N_And_Then | N_Or_Else
then
20277 return Expr
= Right_Opnd
(Par
);
20279 elsif Nkind
(Par
) in N_In | N_Not_In
then
20281 -- If the membership includes several alternatives, only the first
20282 -- is definitely evaluated.
20284 if Present
(Alternatives
(Par
)) then
20285 return Expr
/= First
(Alternatives
(Par
));
20287 -- If this is a range membership both bounds are evaluated
20293 elsif Nkind
(Par
) = N_Quantified_Expression
then
20294 return Expr
= Condition
(Par
);
20296 elsif Nkind
(Par
) = N_Component_Association
20297 and then Expr
= Expression
(Par
)
20298 and then Nkind
(Parent
(Par
))
20299 in N_Aggregate | N_Delta_Aggregate | N_Extension_Aggregate
20300 and then Present
(Aggregate_Type
)
20301 and then Aggregate_Type
/= Any_Composite
20303 if Is_Array_Type
(Aggregate_Type
) then
20304 if Ada_Version
>= Ada_2022
then
20305 -- For Ada 2022, this predicate returns True for
20306 -- any "repeatedly evaluated" expression.
20312 In_Others_Choice
: Boolean := False;
20313 Array_Agg
: constant Node_Id
:= Parent
(Par
);
20315 -- The expression of an array_component_association is
20316 -- potentially unevaluated if the associated choice is a
20317 -- subtype_indication or range that defines a nonstatic or
20320 Choice
:= First
(Choices
(Par
));
20321 while Present
(Choice
) loop
20322 if Nkind
(Choice
) = N_Range
20323 and then Non_Static_Or_Null_Range
(Choice
)
20327 elsif Nkind
(Choice
) = N_Identifier
20328 and then Present
(Scalar_Range
(Etype
(Choice
)))
20330 Non_Static_Or_Null_Range
20331 (Scalar_Range
(Etype
(Choice
)))
20335 elsif Nkind
(Choice
) = N_Others_Choice
then
20336 In_Others_Choice
:= True;
20342 -- It is also potentially unevaluated if the associated
20343 -- choice is an others choice and the applicable index
20344 -- constraint is nonstatic or null.
20346 if In_Others_Choice
then
20347 if not Compile_Time_Known_Bounds
(Aggregate_Type
) then
20350 return Has_Null_Others_Choice
(Array_Agg
);
20355 elsif Is_Container_Aggregate
(Parent
(Par
)) then
20356 -- a component of a container aggregate
20365 end Immediate_Context_Implies_Is_Potentially_Unevaluated
;
20367 ------------------------------
20368 -- Non_Static_Or_Null_Range --
20369 ------------------------------
20371 function Non_Static_Or_Null_Range
(N
: Node_Id
) return Boolean is
20372 Low
, High
: Node_Id
;
20375 Get_Index_Bounds
(N
, Low
, High
);
20377 -- Check static bounds
20379 if not Compile_Time_Known_Value
(Low
)
20380 or else not Compile_Time_Known_Value
(High
)
20384 -- Check null range
20386 elsif Expr_Value
(High
) < Expr_Value
(Low
) then
20391 end Non_Static_Or_Null_Range
;
20398 -- Start of processing for Is_Potentially_Unevaluated
20404 -- A postcondition whose expression is a short-circuit is broken down
20405 -- into individual aspects for better exception reporting. The original
20406 -- short-circuit expression is rewritten as the second operand, and an
20407 -- occurrence of 'Old in that operand is potentially unevaluated.
20408 -- See sem_ch13.adb for details of this transformation. The reference
20409 -- to 'Old may appear within an expression, so we must look for the
20410 -- enclosing pragma argument in the tree that contains the reference.
20412 while Present
(Par
)
20413 and then Nkind
(Par
) /= N_Pragma_Argument_Association
20415 if Is_Rewrite_Substitution
(Par
)
20416 and then Nkind
(Original_Node
(Par
)) = N_And_Then
20421 Par
:= Parent
(Par
);
20424 -- Other cases; 'Old appears within other expression (not the top-level
20425 -- conjunct in a postcondition) with a potentially unevaluated operand.
20427 Par
:= Parent
(Expr
);
20429 while Present
(Par
)
20430 and then Nkind
(Par
) /= N_Pragma_Argument_Association
20432 if Comes_From_Source
(Par
)
20434 Immediate_Context_Implies_Is_Potentially_Unevaluated
(Expr
)
20438 -- For component associations continue climbing; it may be part of
20439 -- an array aggregate.
20441 elsif Nkind
(Par
) = N_Component_Association
then
20444 -- If the context is not an expression, or if is the result of
20445 -- expansion of an enclosing construct (such as another attribute)
20446 -- the predicate does not apply.
20448 elsif Nkind
(Par
) = N_Case_Expression_Alternative
then
20451 elsif Nkind
(Par
) not in N_Subexpr
20452 or else not Comes_From_Source
(Par
)
20458 Par
:= Parent
(Par
);
20462 end Is_Potentially_Unevaluated
;
20464 -----------------------------------------
20465 -- Is_Predefined_Dispatching_Operation --
20466 -----------------------------------------
20468 function Is_Predefined_Dispatching_Operation
20469 (E
: Entity_Id
) return Boolean
20471 TSS_Name
: TSS_Name_Type
;
20474 if not Is_Dispatching_Operation
(E
) then
20478 Get_Name_String
(Chars
(E
));
20480 -- Most predefined primitives have internally generated names. Equality
20481 -- must be treated differently; the predefined operation is recognized
20482 -- as a homogeneous binary operator that returns Boolean.
20484 if Name_Len
> TSS_Name_Type
'Last then
20487 (Name_Buffer
(Name_Len
- TSS_Name
'Length + 1 .. Name_Len
));
20489 if Chars
(E
) in Name_uAssign | Name_uSize
20491 (Chars
(E
) = Name_Op_Eq
20492 and then Etype
(First_Formal
(E
)) = Etype
(Last_Formal
(E
)))
20493 or else TSS_Name
= TSS_Deep_Adjust
20494 or else TSS_Name
= TSS_Deep_Finalize
20495 or else TSS_Name
= TSS_Stream_Input
20496 or else TSS_Name
= TSS_Stream_Output
20497 or else TSS_Name
= TSS_Stream_Read
20498 or else TSS_Name
= TSS_Stream_Write
20499 or else TSS_Name
= TSS_Put_Image
20500 or else Is_Predefined_Interface_Primitive
(E
)
20507 end Is_Predefined_Dispatching_Operation
;
20509 ---------------------------------------
20510 -- Is_Predefined_Interface_Primitive --
20511 ---------------------------------------
20513 function Is_Predefined_Interface_Primitive
(E
: Entity_Id
) return Boolean is
20515 -- In VM targets we don't restrict the functionality of this test to
20516 -- compiling in Ada 2005 mode since in VM targets any tagged type has
20517 -- these primitives.
20519 return (Ada_Version
>= Ada_2005
or else not Tagged_Type_Expansion
)
20520 and then Chars
(E
) in Name_uDisp_Asynchronous_Select
20521 | Name_uDisp_Conditional_Select
20522 | Name_uDisp_Get_Prim_Op_Kind
20523 | Name_uDisp_Get_Task_Id
20524 | Name_uDisp_Requeue
20525 | Name_uDisp_Timed_Select
;
20526 end Is_Predefined_Interface_Primitive
;
20528 ---------------------------------------
20529 -- Is_Predefined_Internal_Operation --
20530 ---------------------------------------
20532 function Is_Predefined_Internal_Operation
20533 (E
: Entity_Id
) return Boolean
20535 TSS_Name
: TSS_Name_Type
;
20538 if not Is_Dispatching_Operation
(E
) then
20542 Get_Name_String
(Chars
(E
));
20544 -- Most predefined primitives have internally generated names. Equality
20545 -- must be treated differently; the predefined operation is recognized
20546 -- as a homogeneous binary operator that returns Boolean.
20548 if Name_Len
> TSS_Name_Type
'Last then
20551 (Name_Buffer
(Name_Len
- TSS_Name
'Length + 1 .. Name_Len
));
20553 if Chars
(E
) in Name_uSize | Name_uAssign
20555 (Chars
(E
) = Name_Op_Eq
20556 and then Etype
(First_Formal
(E
)) = Etype
(Last_Formal
(E
)))
20557 or else TSS_Name
= TSS_Deep_Adjust
20558 or else TSS_Name
= TSS_Deep_Finalize
20559 or else Is_Predefined_Interface_Primitive
(E
)
20566 end Is_Predefined_Internal_Operation
;
20568 --------------------------------
20569 -- Is_Preelaborable_Aggregate --
20570 --------------------------------
20572 function Is_Preelaborable_Aggregate
(Aggr
: Node_Id
) return Boolean is
20573 Aggr_Typ
: constant Entity_Id
:= Etype
(Aggr
);
20574 Array_Aggr
: constant Boolean := Is_Array_Type
(Aggr_Typ
);
20576 Anc_Part
: Node_Id
;
20579 Comp_Typ
: Entity_Id
:= Empty
; -- init to avoid warning
20584 Comp_Typ
:= Component_Type
(Aggr_Typ
);
20587 -- Inspect the ancestor part
20589 if Nkind
(Aggr
) = N_Extension_Aggregate
then
20590 Anc_Part
:= Ancestor_Part
(Aggr
);
20592 -- The ancestor denotes a subtype mark
20594 if Is_Entity_Name
(Anc_Part
)
20595 and then Is_Type
(Entity
(Anc_Part
))
20597 if not Has_Preelaborable_Initialization
(Entity
(Anc_Part
)) then
20601 -- Otherwise the ancestor denotes an expression
20603 elsif not Is_Preelaborable_Construct
(Anc_Part
) then
20608 -- Inspect the positional associations
20610 Expr
:= First
(Expressions
(Aggr
));
20611 while Present
(Expr
) loop
20612 if not Is_Preelaborable_Construct
(Expr
) then
20619 -- Inspect the named associations
20621 Assoc
:= First
(Component_Associations
(Aggr
));
20622 while Present
(Assoc
) loop
20624 -- Inspect the choices of the current named association
20626 Choice
:= First
(Choices
(Assoc
));
20627 while Present
(Choice
) loop
20630 -- For a choice to be preelaborable, it must denote either a
20631 -- static range or a static expression.
20633 if Nkind
(Choice
) = N_Others_Choice
then
20636 elsif Nkind
(Choice
) = N_Range
then
20637 if not Is_OK_Static_Range
(Choice
) then
20641 elsif not Is_OK_Static_Expression
(Choice
) then
20646 Comp_Typ
:= Etype
(Choice
);
20652 -- The type of the choice must have preelaborable initialization if
20653 -- the association carries a <>.
20655 pragma Assert
(Present
(Comp_Typ
));
20656 if Box_Present
(Assoc
) then
20657 if not Has_Preelaborable_Initialization
(Comp_Typ
) then
20661 -- The type of the expression must have preelaborable initialization
20663 elsif not Is_Preelaborable_Construct
(Expression
(Assoc
)) then
20670 -- At this point the aggregate is preelaborable
20673 end Is_Preelaborable_Aggregate
;
20675 --------------------------------
20676 -- Is_Preelaborable_Construct --
20677 --------------------------------
20679 function Is_Preelaborable_Construct
(N
: Node_Id
) return Boolean is
20683 if Nkind
(N
) in N_Aggregate | N_Extension_Aggregate
then
20684 return Is_Preelaborable_Aggregate
(N
);
20686 -- Attributes are allowed in general, even if their prefix is a formal
20687 -- type. It seems that certain attributes known not to be static might
20688 -- not be allowed, but there are no rules to prevent them.
20690 elsif Nkind
(N
) = N_Attribute_Reference
then
20695 elsif Nkind
(N
) in N_Subexpr
and then Is_OK_Static_Expression
(N
) then
20698 elsif Nkind
(N
) = N_Qualified_Expression
then
20699 return Is_Preelaborable_Construct
(Expression
(N
));
20701 -- Names are preelaborable when they denote a discriminant of an
20702 -- enclosing type. Discriminals are also considered for this check.
20704 elsif Is_Entity_Name
(N
)
20705 and then Present
(Entity
(N
))
20707 (Ekind
(Entity
(N
)) = E_Discriminant
20708 or else (Ekind
(Entity
(N
)) in E_Constant | E_In_Parameter
20709 and then Present
(Discriminal_Link
(Entity
(N
)))))
20715 elsif Nkind
(N
) = N_Null
then
20718 -- Ada 2022 (AI12-0175): Calls to certain functions that are essentially
20719 -- unchecked conversions are preelaborable.
20721 elsif Ada_Version
>= Ada_2022
20722 and then Nkind
(N
) = N_Function_Call
20723 and then Is_Entity_Name
(Name
(N
))
20724 and then Is_Preelaborable_Function
(Entity
(Name
(N
)))
20729 A
:= First_Actual
(N
);
20731 while Present
(A
) loop
20732 if not Is_Preelaborable_Construct
(A
) then
20742 -- Otherwise the construct is not preelaborable
20747 end Is_Preelaborable_Construct
;
20749 -------------------------------
20750 -- Is_Preelaborable_Function --
20751 -------------------------------
20753 function Is_Preelaborable_Function
(Id
: Entity_Id
) return Boolean is
20754 SATAC
: constant Rtsfind
.RTU_Id
:= System_Address_To_Access_Conversions
;
20755 Scop
: constant Entity_Id
:= Scope
(Id
);
20758 -- Small optimization: every allowed function has convention Intrinsic
20759 -- (see Analyze_Subprogram_Instantiation for the subtlety in the test).
20761 if not Is_Intrinsic_Subprogram
(Id
)
20762 and then Convention
(Id
) /= Convention_Intrinsic
20767 -- An instance of Unchecked_Conversion
20769 if Is_Unchecked_Conversion_Instance
(Id
) then
20773 -- A function declared in System.Storage_Elements
20775 if Is_RTU
(Scop
, System_Storage_Elements
) then
20779 -- The functions To_Pointer and To_Address declared in an instance of
20780 -- System.Address_To_Access_Conversions (they are the only ones).
20782 if Ekind
(Scop
) = E_Package
20783 and then Nkind
(Parent
(Scop
)) = N_Package_Specification
20784 and then Present
(Generic_Parent
(Parent
(Scop
)))
20785 and then Is_RTU
(Generic_Parent
(Parent
(Scop
)), SATAC
)
20791 end Is_Preelaborable_Function
;
20793 -----------------------------
20794 -- Is_Private_Library_Unit --
20795 -----------------------------
20797 function Is_Private_Library_Unit
(Unit
: Entity_Id
) return Boolean is
20798 Comp_Unit
: constant Node_Id
:= Parent
(Unit_Declaration_Node
(Unit
));
20800 return Nkind
(Comp_Unit
) = N_Compilation_Unit
20801 and then Private_Present
(Comp_Unit
);
20802 end Is_Private_Library_Unit
;
20804 ---------------------------------
20805 -- Is_Protected_Self_Reference --
20806 ---------------------------------
20808 function Is_Protected_Self_Reference
(N
: Node_Id
) return Boolean is
20810 function In_Access_Definition
(N
: Node_Id
) return Boolean;
20811 -- Returns true if N belongs to an access definition
20813 --------------------------
20814 -- In_Access_Definition --
20815 --------------------------
20817 function In_Access_Definition
(N
: Node_Id
) return Boolean is
20822 while Present
(P
) loop
20823 if Nkind
(P
) = N_Access_Definition
then
20831 end In_Access_Definition
;
20833 -- Start of processing for Is_Protected_Self_Reference
20836 -- Verify that prefix is analyzed and has the proper form. Note that
20837 -- the attributes Elab_Spec, Elab_Body, and Elab_Subp_Body, which also
20838 -- produce the address of an entity, do not analyze their prefix
20839 -- because they denote entities that are not necessarily visible.
20840 -- Neither of them can apply to a protected type.
20842 return Ada_Version
>= Ada_2005
20843 and then Is_Entity_Name
(N
)
20844 and then Present
(Entity
(N
))
20845 and then Is_Protected_Type
(Entity
(N
))
20846 and then In_Open_Scopes
(Entity
(N
))
20847 and then not In_Access_Definition
(N
);
20848 end Is_Protected_Self_Reference
;
20850 -----------------------------
20851 -- Is_RCI_Pkg_Spec_Or_Body --
20852 -----------------------------
20854 function Is_RCI_Pkg_Spec_Or_Body
(Cunit
: Node_Id
) return Boolean is
20856 function Is_RCI_Pkg_Decl_Cunit
(Cunit
: Node_Id
) return Boolean;
20857 -- Return True if the unit of Cunit is an RCI package declaration
20859 ---------------------------
20860 -- Is_RCI_Pkg_Decl_Cunit --
20861 ---------------------------
20863 function Is_RCI_Pkg_Decl_Cunit
(Cunit
: Node_Id
) return Boolean is
20864 The_Unit
: constant Node_Id
:= Unit
(Cunit
);
20867 if Nkind
(The_Unit
) /= N_Package_Declaration
then
20871 return Is_Remote_Call_Interface
(Defining_Entity
(The_Unit
));
20872 end Is_RCI_Pkg_Decl_Cunit
;
20874 -- Start of processing for Is_RCI_Pkg_Spec_Or_Body
20877 return Is_RCI_Pkg_Decl_Cunit
(Cunit
)
20879 (Nkind
(Unit
(Cunit
)) = N_Package_Body
20880 and then Is_RCI_Pkg_Decl_Cunit
(Library_Unit
(Cunit
)));
20881 end Is_RCI_Pkg_Spec_Or_Body
;
20883 -----------------------------------------
20884 -- Is_Remote_Access_To_Class_Wide_Type --
20885 -----------------------------------------
20887 function Is_Remote_Access_To_Class_Wide_Type
20888 (E
: Entity_Id
) return Boolean
20891 -- A remote access to class-wide type is a general access to object type
20892 -- declared in the visible part of a Remote_Types or Remote_Call_
20895 return Ekind
(E
) = E_General_Access_Type
20896 and then (Is_Remote_Call_Interface
(E
) or else Is_Remote_Types
(E
));
20897 end Is_Remote_Access_To_Class_Wide_Type
;
20899 -----------------------------------------
20900 -- Is_Remote_Access_To_Subprogram_Type --
20901 -----------------------------------------
20903 function Is_Remote_Access_To_Subprogram_Type
20904 (E
: Entity_Id
) return Boolean
20907 return (Ekind
(E
) = E_Access_Subprogram_Type
20908 or else (Ekind
(E
) = E_Record_Type
20909 and then Present
(Corresponding_Remote_Type
(E
))))
20910 and then (Is_Remote_Call_Interface
(E
) or else Is_Remote_Types
(E
));
20911 end Is_Remote_Access_To_Subprogram_Type
;
20913 --------------------
20914 -- Is_Remote_Call --
20915 --------------------
20917 function Is_Remote_Call
(N
: Node_Id
) return Boolean is
20919 if Nkind
(N
) not in N_Subprogram_Call
then
20921 -- An entry call cannot be remote
20925 elsif Nkind
(Name
(N
)) in N_Has_Entity
20926 and then Is_Remote_Call_Interface
(Entity
(Name
(N
)))
20928 -- A subprogram declared in the spec of a RCI package is remote
20932 elsif Nkind
(Name
(N
)) = N_Explicit_Dereference
20933 and then Is_Remote_Access_To_Subprogram_Type
20934 (Etype
(Prefix
(Name
(N
))))
20936 -- The dereference of a RAS is a remote call
20940 elsif Present
(Controlling_Argument
(N
))
20941 and then Is_Remote_Access_To_Class_Wide_Type
20942 (Etype
(Controlling_Argument
(N
)))
20944 -- Any primitive operation call with a controlling argument of
20945 -- a RACW type is a remote call.
20950 -- All other calls are local calls
20953 end Is_Remote_Call
;
20955 ----------------------
20956 -- Is_Renamed_Entry --
20957 ----------------------
20959 function Is_Renamed_Entry
(Proc_Nam
: Entity_Id
) return Boolean is
20960 Orig_Node
: Node_Id
:= Empty
;
20961 Subp_Decl
: Node_Id
:=
20962 (if No
(Parent
(Proc_Nam
)) then Empty
else Parent
(Parent
(Proc_Nam
)));
20964 function Is_Entry
(Nam
: Node_Id
) return Boolean;
20965 -- Determine whether Nam is an entry. Traverse selectors if there are
20966 -- nested selected components.
20972 function Is_Entry
(Nam
: Node_Id
) return Boolean is
20974 if Nkind
(Nam
) = N_Selected_Component
then
20975 return Is_Entry
(Selector_Name
(Nam
));
20978 return Ekind
(Entity
(Nam
)) = E_Entry
;
20981 -- Start of processing for Is_Renamed_Entry
20984 if Present
(Alias
(Proc_Nam
)) then
20985 Subp_Decl
:= Parent
(Parent
(Alias
(Proc_Nam
)));
20988 -- Look for a rewritten subprogram renaming declaration
20990 if Nkind
(Subp_Decl
) = N_Subprogram_Declaration
20991 and then Present
(Original_Node
(Subp_Decl
))
20993 Orig_Node
:= Original_Node
(Subp_Decl
);
20996 -- The rewritten subprogram is actually an entry
20998 if Present
(Orig_Node
)
20999 and then Nkind
(Orig_Node
) = N_Subprogram_Renaming_Declaration
21000 and then Is_Entry
(Name
(Orig_Node
))
21006 end Is_Renamed_Entry
;
21008 ----------------------------
21009 -- Is_Reversible_Iterator --
21010 ----------------------------
21012 function Is_Reversible_Iterator
(Typ
: Entity_Id
) return Boolean is
21013 Ifaces_List
: Elist_Id
;
21014 Iface_Elmt
: Elmt_Id
;
21018 if Is_Class_Wide_Type
(Typ
)
21019 and then Chars
(Root_Type
(Typ
)) = Name_Reversible_Iterator
21020 and then In_Predefined_Unit
(Root_Type
(Typ
))
21024 elsif not Is_Tagged_Type
(Typ
) or else not Is_Derived_Type
(Typ
) then
21028 Collect_Interfaces
(Typ
, Ifaces_List
);
21030 Iface_Elmt
:= First_Elmt
(Ifaces_List
);
21031 while Present
(Iface_Elmt
) loop
21032 Iface
:= Node
(Iface_Elmt
);
21033 if Chars
(Iface
) = Name_Reversible_Iterator
21034 and then In_Predefined_Unit
(Iface
)
21039 Next_Elmt
(Iface_Elmt
);
21044 end Is_Reversible_Iterator
;
21046 ---------------------------------
21047 -- Is_Single_Concurrent_Object --
21048 ---------------------------------
21050 function Is_Single_Concurrent_Object
(Id
: Entity_Id
) return Boolean is
21053 Is_Single_Protected_Object
(Id
) or else Is_Single_Task_Object
(Id
);
21054 end Is_Single_Concurrent_Object
;
21056 -------------------------------
21057 -- Is_Single_Concurrent_Type --
21058 -------------------------------
21060 function Is_Single_Concurrent_Type
(Id
: Entity_Id
) return Boolean is
21063 Ekind
(Id
) in E_Protected_Type | E_Task_Type
21064 and then Is_Single_Concurrent_Type_Declaration
21065 (Declaration_Node
(Id
));
21066 end Is_Single_Concurrent_Type
;
21068 -------------------------------------------
21069 -- Is_Single_Concurrent_Type_Declaration --
21070 -------------------------------------------
21072 function Is_Single_Concurrent_Type_Declaration
21073 (N
: Node_Id
) return Boolean
21076 return Nkind
(Original_Node
(N
)) in
21077 N_Single_Protected_Declaration | N_Single_Task_Declaration
;
21078 end Is_Single_Concurrent_Type_Declaration
;
21080 ---------------------------------------------
21081 -- Is_Single_Precision_Floating_Point_Type --
21082 ---------------------------------------------
21084 function Is_Single_Precision_Floating_Point_Type
21085 (E
: Entity_Id
) return Boolean is
21087 return Is_Floating_Point_Type
(E
)
21088 and then Machine_Radix_Value
(E
) = Uint_2
21089 and then Machine_Mantissa_Value
(E
) = Uint_24
21090 and then Machine_Emax_Value
(E
) = Uint_2
** Uint_7
21091 and then Machine_Emin_Value
(E
) = Uint_3
- (Uint_2
** Uint_7
);
21092 end Is_Single_Precision_Floating_Point_Type
;
21094 --------------------------------
21095 -- Is_Single_Protected_Object --
21096 --------------------------------
21098 function Is_Single_Protected_Object
(Id
: Entity_Id
) return Boolean is
21101 Ekind
(Id
) = E_Variable
21102 and then Ekind
(Etype
(Id
)) = E_Protected_Type
21103 and then Is_Single_Concurrent_Type
(Etype
(Id
));
21104 end Is_Single_Protected_Object
;
21106 ---------------------------
21107 -- Is_Single_Task_Object --
21108 ---------------------------
21110 function Is_Single_Task_Object
(Id
: Entity_Id
) return Boolean is
21113 Ekind
(Id
) = E_Variable
21114 and then Ekind
(Etype
(Id
)) = E_Task_Type
21115 and then Is_Single_Concurrent_Type
(Etype
(Id
));
21116 end Is_Single_Task_Object
;
21118 --------------------------------------
21119 -- Is_Special_Aliased_Formal_Access --
21120 --------------------------------------
21122 function Is_Special_Aliased_Formal_Access
21124 In_Return_Context
: Boolean := False) return Boolean
21126 Scop
: constant Entity_Id
:= Current_Subprogram
;
21128 -- Verify the expression is an access reference to 'Access within a
21129 -- return statement as this is the only time an explicitly aliased
21130 -- formal has different semantics.
21132 if Nkind
(Exp
) /= N_Attribute_Reference
21133 or else Get_Attribute_Id
(Attribute_Name
(Exp
)) /= Attribute_Access
21134 or else not (In_Return_Value
(Exp
)
21135 or else In_Return_Context
)
21136 or else not Needs_Result_Accessibility_Level
(Scop
)
21141 -- Check if the prefix of the reference is indeed an explicitly aliased
21142 -- formal parameter for the function Scop. Additionally, we must check
21143 -- that Scop returns an anonymous access type, otherwise the special
21144 -- rules dictating a need for a dynamic check are not in effect.
21146 return Is_Entity_Name
(Prefix
(Exp
))
21147 and then Is_Explicitly_Aliased
(Entity
(Prefix
(Exp
)));
21148 end Is_Special_Aliased_Formal_Access
;
21150 -----------------------------
21151 -- Is_Specific_Tagged_Type --
21152 -----------------------------
21154 function Is_Specific_Tagged_Type
(Typ
: Entity_Id
) return Boolean is
21155 Full_Typ
: Entity_Id
;
21158 -- Handle private types
21160 if Is_Private_Type
(Typ
) and then Present
(Full_View
(Typ
)) then
21161 Full_Typ
:= Full_View
(Typ
);
21166 -- A specific tagged type is a non-class-wide tagged type
21168 return Is_Tagged_Type
(Full_Typ
) and not Is_Class_Wide_Type
(Full_Typ
);
21169 end Is_Specific_Tagged_Type
;
21175 function Is_Statement
(N
: Node_Id
) return Boolean is
21178 Nkind
(N
) in N_Statement_Other_Than_Procedure_Call
21179 or else Nkind
(N
) = N_Procedure_Call_Statement
;
21182 --------------------------------------
21183 -- Is_Static_Discriminant_Component --
21184 --------------------------------------
21186 function Is_Static_Discriminant_Component
(N
: Node_Id
) return Boolean is
21188 return Nkind
(N
) = N_Selected_Component
21189 and then not Is_In_Discriminant_Check
(N
)
21190 and then Present
(Etype
(Prefix
(N
)))
21191 and then Ekind
(Etype
(Prefix
(N
))) = E_Record_Subtype
21192 and then Has_Static_Discriminants
(Etype
(Prefix
(N
)))
21193 and then Present
(Entity
(Selector_Name
(N
)))
21194 and then Ekind
(Entity
(Selector_Name
(N
))) = E_Discriminant
21195 and then not In_Check_Node
(N
);
21196 end Is_Static_Discriminant_Component
;
21198 ------------------------
21199 -- Is_Static_Function --
21200 ------------------------
21202 function Is_Static_Function
(Subp
: Entity_Id
) return Boolean is
21204 -- Always return False for pre Ada 2022 to e.g. ignore the Static
21205 -- aspect in package Interfaces for Ada_Version < 2022 and also
21208 return Ada_Version
>= Ada_2022
21209 and then Has_Aspect
(Subp
, Aspect_Static
)
21211 (No
(Find_Value_Of_Aspect
(Subp
, Aspect_Static
))
21212 or else Is_True
(Static_Boolean
21213 (Find_Value_Of_Aspect
(Subp
, Aspect_Static
))));
21214 end Is_Static_Function
;
21216 -----------------------------
21217 -- Is_Static_Function_Call --
21218 -----------------------------
21220 function Is_Static_Function_Call
(Call
: Node_Id
) return Boolean is
21221 function Has_All_Static_Actuals
(Call
: Node_Id
) return Boolean;
21222 -- Return whether all actual parameters of Call are static expressions
21224 ----------------------------
21225 -- Has_All_Static_Actuals --
21226 ----------------------------
21228 function Has_All_Static_Actuals
(Call
: Node_Id
) return Boolean is
21229 Actual
: Node_Id
:= First_Actual
(Call
);
21230 String_Result
: constant Boolean :=
21231 Is_String_Type
(Etype
(Entity
(Name
(Call
))));
21234 while Present
(Actual
) loop
21235 if not Is_Static_Expression
(Actual
) then
21237 -- ??? In the string-returning case we want to avoid a call
21238 -- being made to Establish_Transient_Scope in Resolve_Call,
21239 -- but at the point where that's tested for (which now includes
21240 -- a call to test Is_Static_Function_Call), the actuals of the
21241 -- call haven't been resolved, so expressions of the actuals
21242 -- may not have been marked Is_Static_Expression yet, so we
21243 -- force them to be resolved here, so we can tell if they're
21244 -- static. Calling Resolve here is admittedly a kludge, and we
21245 -- limit this call to string-returning cases.
21247 if String_Result
then
21251 -- Test flag again in case it's now True due to above Resolve
21253 if not Is_Static_Expression
(Actual
) then
21258 Next_Actual
(Actual
);
21262 end Has_All_Static_Actuals
;
21265 return Nkind
(Call
) = N_Function_Call
21266 and then Is_Entity_Name
(Name
(Call
))
21267 and then Is_Static_Function
(Entity
(Name
(Call
)))
21268 and then Has_All_Static_Actuals
(Call
);
21269 end Is_Static_Function_Call
;
21271 -------------------------------------------
21272 -- Is_Subcomponent_Of_Full_Access_Object --
21273 -------------------------------------------
21275 function Is_Subcomponent_Of_Full_Access_Object
(N
: Node_Id
) return Boolean
21280 R
:= Get_Referenced_Object
(N
);
21282 while Nkind
(R
) in N_Indexed_Component | N_Selected_Component | N_Slice
21284 R
:= Get_Referenced_Object
(Prefix
(R
));
21286 -- If the prefix is an access value, only the designated type matters
21288 if Is_Access_Type
(Etype
(R
)) then
21289 if Is_Full_Access
(Designated_Type
(Etype
(R
))) then
21294 if Is_Full_Access_Object
(R
) then
21301 end Is_Subcomponent_Of_Full_Access_Object
;
21303 ---------------------------------------
21304 -- Is_Subprogram_Contract_Annotation --
21305 ---------------------------------------
21307 function Is_Subprogram_Contract_Annotation
21308 (Item
: Node_Id
) return Boolean
21313 if Nkind
(Item
) = N_Aspect_Specification
then
21314 Nam
:= Chars
(Identifier
(Item
));
21316 else pragma Assert
(Nkind
(Item
) = N_Pragma
);
21317 Nam
:= Pragma_Name
(Item
);
21320 return Nam
= Name_Contract_Cases
21321 or else Nam
= Name_Depends
21322 or else Nam
= Name_Extensions_Visible
21323 or else Nam
= Name_Global
21324 or else Nam
= Name_Post
21325 or else Nam
= Name_Post_Class
21326 or else Nam
= Name_Postcondition
21327 or else Nam
= Name_Pre
21328 or else Nam
= Name_Pre_Class
21329 or else Nam
= Name_Precondition
21330 or else Nam
= Name_Refined_Depends
21331 or else Nam
= Name_Refined_Global
21332 or else Nam
= Name_Refined_Post
21333 or else Nam
= Name_Subprogram_Variant
21334 or else Nam
= Name_Test_Case
;
21335 end Is_Subprogram_Contract_Annotation
;
21337 --------------------------------------------------
21338 -- Is_Subprogram_Stub_Without_Prior_Declaration --
21339 --------------------------------------------------
21341 function Is_Subprogram_Stub_Without_Prior_Declaration
21342 (N
: Node_Id
) return Boolean
21345 pragma Assert
(Nkind
(N
) = N_Subprogram_Body_Stub
);
21347 case Ekind
(Defining_Entity
(N
)) is
21349 -- A subprogram stub without prior declaration serves as declaration
21350 -- for the actual subprogram body. As such, it has an attached
21351 -- defining entity of E_Function or E_Procedure.
21358 -- Otherwise, it is completes a [generic] subprogram declaration
21360 when E_Generic_Function
21361 | E_Generic_Procedure
21362 | E_Subprogram_Body
21367 raise Program_Error
;
21369 end Is_Subprogram_Stub_Without_Prior_Declaration
;
21371 ---------------------------
21372 -- Is_Suitable_Primitive --
21373 ---------------------------
21375 function Is_Suitable_Primitive
(Subp_Id
: Entity_Id
) return Boolean is
21377 -- The Default_Initial_Condition and invariant procedures must not be
21378 -- treated as primitive operations even when they apply to a tagged
21379 -- type. These routines must not act as targets of dispatching calls
21380 -- because they already utilize class-wide-precondition semantics to
21381 -- handle inheritance and overriding.
21383 if Ekind
(Subp_Id
) = E_Procedure
21384 and then (Is_DIC_Procedure
(Subp_Id
)
21386 Is_Invariant_Procedure
(Subp_Id
))
21392 end Is_Suitable_Primitive
;
21394 ----------------------------
21395 -- Is_Synchronized_Object --
21396 ----------------------------
21398 function Is_Synchronized_Object
(Id
: Entity_Id
) return Boolean is
21402 if Is_Object
(Id
) then
21404 -- The object is synchronized if it is of a type that yields a
21405 -- synchronized object.
21407 if Yields_Synchronized_Object
(Etype
(Id
)) then
21410 -- The object is synchronized if it is atomic and Async_Writers is
21413 elsif Is_Atomic_Object_Entity
(Id
)
21414 and then Async_Writers_Enabled
(Id
)
21418 -- A constant is a synchronized object by default, unless its type is
21419 -- access-to-variable type.
21421 elsif Ekind
(Id
) = E_Constant
21422 and then not Is_Access_Variable
(Etype
(Id
))
21426 -- A variable is a synchronized object if it is subject to pragma
21427 -- Constant_After_Elaboration.
21429 elsif Ekind
(Id
) = E_Variable
then
21430 Prag
:= Get_Pragma
(Id
, Pragma_Constant_After_Elaboration
);
21432 return Present
(Prag
) and then Is_Enabled_Pragma
(Prag
);
21436 -- Otherwise the input is not an object or it does not qualify as a
21437 -- synchronized object.
21440 end Is_Synchronized_Object
;
21442 ---------------------------------
21443 -- Is_Synchronized_Tagged_Type --
21444 ---------------------------------
21446 function Is_Synchronized_Tagged_Type
(E
: Entity_Id
) return Boolean is
21447 Kind
: constant Entity_Kind
:= Ekind
(Base_Type
(E
));
21450 -- A task or protected type derived from an interface is a tagged type.
21451 -- Such a tagged type is called a synchronized tagged type, as are
21452 -- synchronized interfaces and private extensions whose declaration
21453 -- includes the reserved word synchronized.
21455 return (Is_Tagged_Type
(E
)
21456 and then (Kind
= E_Task_Type
21458 Kind
= E_Protected_Type
))
21461 and then Is_Synchronized_Interface
(E
))
21463 (Ekind
(E
) = E_Record_Type_With_Private
21464 and then Nkind
(Parent
(E
)) = N_Private_Extension_Declaration
21465 and then (Synchronized_Present
(Parent
(E
))
21466 or else Is_Synchronized_Interface
(Etype
(E
))));
21467 end Is_Synchronized_Tagged_Type
;
21473 function Is_Transfer
(N
: Node_Id
) return Boolean is
21474 Kind
: constant Node_Kind
:= Nkind
(N
);
21477 if Kind
= N_Simple_Return_Statement
21479 Kind
= N_Extended_Return_Statement
21481 Kind
= N_Goto_Statement
21483 Kind
= N_Raise_Statement
21485 Kind
= N_Requeue_Statement
21489 elsif (Kind
= N_Exit_Statement
or else Kind
in N_Raise_xxx_Error
)
21490 and then No
(Condition
(N
))
21494 elsif Kind
= N_Procedure_Call_Statement
21495 and then Is_Entity_Name
(Name
(N
))
21496 and then Present
(Entity
(Name
(N
)))
21497 and then No_Return
(Entity
(Name
(N
)))
21501 elsif Nkind
(Original_Node
(N
)) = N_Raise_Statement
then
21513 function Is_True
(U
: Opt_Ubool
) return Boolean is
21515 return No
(U
) or else U
= Uint_1
;
21518 --------------------------------------
21519 -- Is_Unchecked_Conversion_Instance --
21520 --------------------------------------
21522 function Is_Unchecked_Conversion_Instance
(Id
: Entity_Id
) return Boolean is
21526 -- Look for a function whose generic parent is the predefined intrinsic
21527 -- function Unchecked_Conversion, or for one that renames such an
21530 if Ekind
(Id
) = E_Function
then
21531 Par
:= Parent
(Id
);
21533 if Nkind
(Par
) = N_Function_Specification
then
21534 Par
:= Generic_Parent
(Par
);
21536 if Present
(Par
) then
21538 Chars
(Par
) = Name_Unchecked_Conversion
21539 and then Is_Intrinsic_Subprogram
(Par
)
21540 and then In_Predefined_Unit
(Par
);
21543 Present
(Alias
(Id
))
21544 and then Is_Unchecked_Conversion_Instance
(Alias
(Id
));
21550 end Is_Unchecked_Conversion_Instance
;
21552 -------------------------------
21553 -- Is_Universal_Numeric_Type --
21554 -------------------------------
21556 function Is_Universal_Numeric_Type
(T
: Entity_Id
) return Boolean is
21558 return T
= Universal_Integer
or else T
= Universal_Real
;
21559 end Is_Universal_Numeric_Type
;
21561 ------------------------------
21562 -- Is_User_Defined_Equality --
21563 ------------------------------
21565 function Is_User_Defined_Equality
(Id
: Entity_Id
) return Boolean is
21566 F1
, F2
: Entity_Id
;
21569 -- An equality operator is a function that carries the name "=", returns
21570 -- Boolean, and has exactly two formal parameters of an identical type.
21572 if Ekind
(Id
) = E_Function
21573 and then Chars
(Id
) = Name_Op_Eq
21574 and then Base_Type
(Etype
(Id
)) = Standard_Boolean
21576 F1
:= First_Formal
(Id
);
21582 F2
:= Next_Formal
(F1
);
21584 return Present
(F2
)
21585 and then No
(Next_Formal
(F2
))
21586 and then Base_Type
(Etype
(F1
)) = Base_Type
(Etype
(F2
));
21591 end Is_User_Defined_Equality
;
21593 -----------------------------
21594 -- Is_User_Defined_Literal --
21595 -----------------------------
21597 function Is_User_Defined_Literal
21599 Typ
: Entity_Id
) return Boolean
21601 Literal_Aspect_Map
:
21602 constant array (N_Numeric_Or_String_Literal
) of Aspect_Id
:=
21603 (N_Integer_Literal
=> Aspect_Integer_Literal
,
21604 N_Real_Literal
=> Aspect_Real_Literal
,
21605 N_String_Literal
=> Aspect_String_Literal
);
21608 return Nkind
(N
) in N_Numeric_Or_String_Literal
21609 and then Present
(Find_Aspect
(Typ
, Literal_Aspect_Map
(Nkind
(N
))));
21610 end Is_User_Defined_Literal
;
21612 --------------------------------------
21613 -- Is_Validation_Variable_Reference --
21614 --------------------------------------
21616 function Is_Validation_Variable_Reference
(N
: Node_Id
) return Boolean is
21617 Var
: constant Node_Id
:= Unqual_Conv
(N
);
21618 Var_Id
: Entity_Id
;
21623 if Is_Entity_Name
(Var
) then
21624 Var_Id
:= Entity
(Var
);
21629 and then Ekind
(Var_Id
) = E_Variable
21630 and then Present
(Validated_Object
(Var_Id
));
21631 end Is_Validation_Variable_Reference
;
21633 ----------------------------
21634 -- Is_Variable_Size_Array --
21635 ----------------------------
21637 function Is_Variable_Size_Array
(E
: Entity_Id
) return Boolean is
21641 pragma Assert
(Is_Array_Type
(E
));
21643 -- Check if some index is initialized with a non-constant value
21645 Idx
:= First_Index
(E
);
21646 while Present
(Idx
) loop
21647 if Nkind
(Idx
) = N_Range
then
21648 if not Is_Constant_Bound
(Low_Bound
(Idx
))
21649 or else not Is_Constant_Bound
(High_Bound
(Idx
))
21659 end Is_Variable_Size_Array
;
21661 -----------------------------
21662 -- Is_Variable_Size_Record --
21663 -----------------------------
21665 function Is_Variable_Size_Record
(E
: Entity_Id
) return Boolean is
21667 Comp_Typ
: Entity_Id
;
21670 pragma Assert
(Is_Record_Type
(E
));
21672 Comp
:= First_Component
(E
);
21673 while Present
(Comp
) loop
21674 Comp_Typ
:= Underlying_Type
(Etype
(Comp
));
21676 -- Recursive call if the record type has discriminants
21678 if Is_Record_Type
(Comp_Typ
)
21679 and then Has_Discriminants
(Comp_Typ
)
21680 and then Is_Variable_Size_Record
(Comp_Typ
)
21684 elsif Is_Array_Type
(Comp_Typ
)
21685 and then Is_Variable_Size_Array
(Comp_Typ
)
21690 Next_Component
(Comp
);
21694 end Is_Variable_Size_Record
;
21700 -- Should Is_Variable be refactored to better handle dereferences and
21701 -- technical debt ???
21703 function Is_Variable
21705 Use_Original_Node
: Boolean := True) return Boolean
21707 Orig_Node
: Node_Id
;
21709 function In_Protected_Function
(E
: Entity_Id
) return Boolean;
21710 -- Within a protected function, the private components of the enclosing
21711 -- protected type are constants. A function nested within a (protected)
21712 -- procedure is not itself protected. Within the body of a protected
21713 -- function the current instance of the protected type is a constant.
21715 function Is_Variable_Prefix
(P
: Node_Id
) return Boolean;
21716 -- Prefixes can involve implicit dereferences, in which case we must
21717 -- test for the case of a reference of a constant access type, which can
21718 -- can never be a variable.
21720 ---------------------------
21721 -- In_Protected_Function --
21722 ---------------------------
21724 function In_Protected_Function
(E
: Entity_Id
) return Boolean is
21729 -- E is the current instance of a type
21731 if Is_Type
(E
) then
21740 if not Is_Protected_Type
(Prot
) then
21744 S
:= Current_Scope
;
21745 while Present
(S
) and then S
/= Prot
loop
21746 if Ekind
(S
) = E_Function
and then Scope
(S
) = Prot
then
21755 end In_Protected_Function
;
21757 ------------------------
21758 -- Is_Variable_Prefix --
21759 ------------------------
21761 function Is_Variable_Prefix
(P
: Node_Id
) return Boolean is
21763 if Is_Access_Type
(Etype
(P
)) then
21764 return not Is_Access_Constant
(Root_Type
(Etype
(P
)));
21766 -- For the case of an indexed component whose prefix has a packed
21767 -- array type, the prefix has been rewritten into a type conversion.
21768 -- Determine variable-ness from the converted expression.
21770 elsif Nkind
(P
) = N_Type_Conversion
21771 and then not Comes_From_Source
(P
)
21772 and then Is_Packed_Array
(Etype
(P
))
21774 return Is_Variable
(Expression
(P
));
21777 return Is_Variable
(P
);
21779 end Is_Variable_Prefix
;
21781 -- Start of processing for Is_Variable
21784 -- Special check, allow x'Deref(expr) as a variable
21786 if Nkind
(N
) = N_Attribute_Reference
21787 and then Attribute_Name
(N
) = Name_Deref
21792 -- Check if we perform the test on the original node since this may be a
21793 -- test of syntactic categories which must not be disturbed by whatever
21794 -- rewriting might have occurred. For example, an aggregate, which is
21795 -- certainly NOT a variable, could be turned into a variable by
21798 if Use_Original_Node
then
21799 Orig_Node
:= Original_Node
(N
);
21804 -- Definitely OK if Assignment_OK is set. Since this is something that
21805 -- only gets set for expanded nodes, the test is on N, not Orig_Node.
21807 if Nkind
(N
) in N_Subexpr
and then Assignment_OK
(N
) then
21810 -- Normally we go to the original node, but there is one exception where
21811 -- we use the rewritten node, namely when it is an explicit dereference.
21812 -- The generated code may rewrite a prefix which is an access type with
21813 -- an explicit dereference. The dereference is a variable, even though
21814 -- the original node may not be (since it could be a constant of the
21817 -- In Ada 2005 we have a further case to consider: the prefix may be a
21818 -- function call given in prefix notation. The original node appears to
21819 -- be a selected component, but we need to examine the call.
21821 elsif Nkind
(N
) = N_Explicit_Dereference
21822 and then Nkind
(Orig_Node
) /= N_Explicit_Dereference
21823 and then Present
(Etype
(Orig_Node
))
21824 and then Is_Access_Type
(Etype
(Orig_Node
))
21826 -- Note that if the prefix is an explicit dereference that does not
21827 -- come from source, we must check for a rewritten function call in
21828 -- prefixed notation before other forms of rewriting, to prevent a
21832 (Nkind
(Orig_Node
) = N_Function_Call
21833 and then not Is_Access_Constant
(Etype
(Prefix
(N
))))
21835 Is_Variable_Prefix
(Original_Node
(Prefix
(N
)));
21837 -- Generalized indexing operations are rewritten as explicit
21838 -- dereferences, and it is only during resolution that we can
21839 -- check whether the context requires an access_to_variable type.
21841 elsif Nkind
(N
) = N_Explicit_Dereference
21842 and then Present
(Etype
(Orig_Node
))
21843 and then Has_Implicit_Dereference
(Etype
(Orig_Node
))
21844 and then Ada_Version
>= Ada_2012
21846 return not Is_Access_Constant
(Etype
(Prefix
(N
)));
21848 -- A function call is never a variable
21850 elsif Nkind
(N
) = N_Function_Call
then
21853 -- All remaining checks use the original node
21855 elsif Is_Entity_Name
(Orig_Node
)
21856 and then Present
(Entity
(Orig_Node
))
21859 E
: constant Entity_Id
:= Entity
(Orig_Node
);
21860 K
: constant Entity_Kind
:= Ekind
(E
);
21863 if Is_Loop_Parameter
(E
) then
21867 return (K
= E_Variable
21868 and then Nkind
(Parent
(E
)) /= N_Exception_Handler
)
21869 or else (K
= E_Component
21870 and then not In_Protected_Function
(E
))
21871 or else (Present
(Etype
(E
))
21872 and then Is_Access_Object_Type
(Etype
(E
))
21873 and then Is_Access_Variable
(Etype
(E
))
21874 and then Is_Dereferenced
(N
))
21875 or else K
= E_Out_Parameter
21876 or else K
= E_In_Out_Parameter
21877 or else K
= E_Generic_In_Out_Parameter
21879 -- Current instance of type. If this is a protected type, check
21880 -- we are not within the body of one of its protected functions.
21882 or else (Is_Type
(E
)
21883 and then In_Open_Scopes
(E
)
21884 and then not In_Protected_Function
(E
))
21886 or else (Is_Incomplete_Or_Private_Type
(E
)
21887 and then In_Open_Scopes
(Full_View
(E
)));
21891 case Nkind
(Orig_Node
) is
21892 when N_Indexed_Component
21895 return Is_Variable_Prefix
(Prefix
(Orig_Node
));
21897 when N_Selected_Component
=>
21898 return (Is_Variable
(Selector_Name
(Orig_Node
))
21899 and then Is_Variable_Prefix
(Prefix
(Orig_Node
)))
21901 (Nkind
(N
) = N_Expanded_Name
21902 and then Scope
(Entity
(N
)) = Entity
(Prefix
(N
)));
21904 -- For an explicit dereference, the type of the prefix cannot
21905 -- be an access to constant or an access to subprogram.
21907 when N_Explicit_Dereference
=>
21909 Typ
: constant Entity_Id
:= Etype
(Prefix
(Orig_Node
));
21911 return Is_Access_Type
(Typ
)
21912 and then not Is_Access_Constant
(Root_Type
(Typ
))
21913 and then Ekind
(Typ
) /= E_Access_Subprogram_Type
;
21916 -- The type conversion is the case where we do not deal with the
21917 -- context dependent special case of an actual parameter. Thus
21918 -- the type conversion is only considered a variable for the
21919 -- purposes of this routine if the target type is tagged. However,
21920 -- a type conversion is considered to be a variable if it does not
21921 -- come from source (this deals for example with the conversions
21922 -- of expressions to their actual subtypes).
21924 when N_Type_Conversion
=>
21925 return Is_Variable
(Expression
(Orig_Node
))
21927 (not Comes_From_Source
(Orig_Node
)
21929 (Is_Tagged_Type
(Etype
(Subtype_Mark
(Orig_Node
)))
21931 Is_Tagged_Type
(Etype
(Expression
(Orig_Node
)))));
21933 -- GNAT allows an unchecked type conversion as a variable. This
21934 -- only affects the generation of internal expanded code, since
21935 -- calls to instantiations of Unchecked_Conversion are never
21936 -- considered variables (since they are function calls).
21938 when N_Unchecked_Type_Conversion
=>
21939 return Is_Variable
(Expression
(Orig_Node
));
21947 ------------------------
21948 -- Is_View_Conversion --
21949 ------------------------
21951 function Is_View_Conversion
(N
: Node_Id
) return Boolean is
21953 if Nkind
(N
) = N_Type_Conversion
21954 and then Nkind
(Unqual_Conv
(N
)) in N_Has_Etype
21956 if Is_Tagged_Type
(Etype
(N
))
21957 and then Is_Tagged_Type
(Etype
(Unqual_Conv
(N
)))
21961 elsif Is_Actual_Parameter
(N
)
21962 and then (Is_Actual_Out_Parameter
(N
)
21963 or else Is_Actual_In_Out_Parameter
(N
))
21970 end Is_View_Conversion
;
21972 ---------------------------
21973 -- Is_Visibly_Controlled --
21974 ---------------------------
21976 function Is_Visibly_Controlled
(T
: Entity_Id
) return Boolean is
21977 Root
: constant Entity_Id
:= Root_Type
(T
);
21979 return Chars
(Scope
(Root
)) = Name_Finalization
21980 and then Chars
(Scope
(Scope
(Root
))) = Name_Ada
21981 and then Scope
(Scope
(Scope
(Root
))) = Standard_Standard
;
21982 end Is_Visibly_Controlled
;
21984 ----------------------------------------
21985 -- Is_Volatile_Full_Access_Object_Ref --
21986 ----------------------------------------
21988 function Is_Volatile_Full_Access_Object_Ref
(N
: Node_Id
) return Boolean is
21989 function Is_VFA_Object_Entity
(Id
: Entity_Id
) return Boolean;
21990 -- Determine whether arbitrary entity Id denotes an object that is
21991 -- Volatile_Full_Access.
21993 ----------------------------
21994 -- Is_VFA_Object_Entity --
21995 ----------------------------
21997 function Is_VFA_Object_Entity
(Id
: Entity_Id
) return Boolean is
22001 and then (Is_Volatile_Full_Access
(Id
)
22003 Is_Volatile_Full_Access
(Etype
(Id
)));
22004 end Is_VFA_Object_Entity
;
22006 -- Start of processing for Is_Volatile_Full_Access_Object_Ref
22009 if Is_Entity_Name
(N
) then
22010 return Is_VFA_Object_Entity
(Entity
(N
));
22012 elsif Is_Volatile_Full_Access
(Etype
(N
)) then
22015 elsif Nkind
(N
) = N_Selected_Component
then
22016 return Is_Volatile_Full_Access
(Entity
(Selector_Name
(N
)));
22021 end Is_Volatile_Full_Access_Object_Ref
;
22023 --------------------------
22024 -- Is_Volatile_Function --
22025 --------------------------
22027 function Is_Volatile_Function
(Func_Id
: Entity_Id
) return Boolean is
22029 pragma Assert
(Ekind
(Func_Id
) in E_Function | E_Generic_Function
);
22031 -- A protected function is volatile
22033 if Nkind
(Parent
(Unit_Declaration_Node
(Func_Id
))) =
22034 N_Protected_Definition
22038 -- An instance of Ada.Unchecked_Conversion is a volatile function if
22039 -- either the source or the target are effectively volatile.
22041 elsif Is_Unchecked_Conversion_Instance
(Func_Id
)
22042 and then Has_Effectively_Volatile_Profile
(Func_Id
)
22046 -- Otherwise the function is treated as volatile if it is subject to
22047 -- enabled pragma Volatile_Function.
22051 Is_Enabled_Pragma
(Get_Pragma
(Func_Id
, Pragma_Volatile_Function
));
22053 end Is_Volatile_Function
;
22055 ----------------------------
22056 -- Is_Volatile_Object_Ref --
22057 ----------------------------
22059 function Is_Volatile_Object_Ref
(N
: Node_Id
) return Boolean is
22060 function Is_Volatile_Object_Entity
(Id
: Entity_Id
) return Boolean;
22061 -- Determine whether arbitrary entity Id denotes an object that is
22064 function Prefix_Has_Volatile_Components
(P
: Node_Id
) return Boolean;
22065 -- Determine whether prefix P has volatile components. This requires
22066 -- the presence of a Volatile_Components aspect/pragma or that P be
22067 -- itself a volatile object as per RM C.6(8).
22069 ---------------------------------
22070 -- Is_Volatile_Object_Entity --
22071 ---------------------------------
22073 function Is_Volatile_Object_Entity
(Id
: Entity_Id
) return Boolean is
22077 and then (Is_Volatile
(Id
) or else Is_Volatile
(Etype
(Id
)));
22078 end Is_Volatile_Object_Entity
;
22080 ------------------------------------
22081 -- Prefix_Has_Volatile_Components --
22082 ------------------------------------
22084 function Prefix_Has_Volatile_Components
(P
: Node_Id
) return Boolean is
22085 Typ
: constant Entity_Id
:= Etype
(P
);
22088 if Is_Access_Type
(Typ
) then
22090 Dtyp
: constant Entity_Id
:= Designated_Type
(Typ
);
22093 return Has_Volatile_Components
(Dtyp
)
22094 or else Is_Volatile
(Dtyp
);
22097 elsif Has_Volatile_Components
(Typ
) then
22100 elsif Is_Entity_Name
(P
)
22101 and then Has_Volatile_Component
(Entity
(P
))
22105 elsif Is_Volatile_Object_Ref
(P
) then
22111 end Prefix_Has_Volatile_Components
;
22113 -- Start of processing for Is_Volatile_Object_Ref
22116 if Is_Entity_Name
(N
) then
22117 return Is_Volatile_Object_Entity
(Entity
(N
));
22119 elsif Is_Volatile
(Etype
(N
)) then
22122 elsif Nkind
(N
) = N_Indexed_Component
then
22123 return Prefix_Has_Volatile_Components
(Prefix
(N
));
22125 elsif Nkind
(N
) = N_Selected_Component
then
22126 return Prefix_Has_Volatile_Components
(Prefix
(N
))
22127 or else Is_Volatile
(Entity
(Selector_Name
(N
)));
22132 end Is_Volatile_Object_Ref
;
22134 -----------------------------
22135 -- Iterate_Call_Parameters --
22136 -----------------------------
22138 procedure Iterate_Call_Parameters
(Call
: Node_Id
) is
22139 Actual
: Node_Id
:= First_Actual
(Call
);
22140 Formal
: Entity_Id
:= First_Formal
(Get_Called_Entity
(Call
));
22143 while Present
(Formal
) and then Present
(Actual
) loop
22144 Handle_Parameter
(Formal
, Actual
);
22146 Next_Formal
(Formal
);
22147 Next_Actual
(Actual
);
22150 pragma Assert
(No
(Formal
));
22151 pragma Assert
(No
(Actual
));
22152 end Iterate_Call_Parameters
;
22154 ---------------------------
22155 -- Itype_Has_Declaration --
22156 ---------------------------
22158 function Itype_Has_Declaration
(Id
: Entity_Id
) return Boolean is
22160 pragma Assert
(Is_Itype
(Id
));
22161 return Present
(Parent
(Id
))
22162 and then Nkind
(Parent
(Id
)) in
22163 N_Full_Type_Declaration | N_Subtype_Declaration
22164 and then Defining_Entity
(Parent
(Id
)) = Id
;
22165 end Itype_Has_Declaration
;
22167 -------------------------
22168 -- Kill_Current_Values --
22169 -------------------------
22171 procedure Kill_Current_Values
22173 Last_Assignment_Only
: Boolean := False)
22176 if Is_Assignable
(Ent
) then
22177 Set_Last_Assignment
(Ent
, Empty
);
22180 if Is_Object
(Ent
) then
22181 if not Last_Assignment_Only
then
22183 Set_Current_Value
(Ent
, Empty
);
22185 -- Do not reset the Is_Known_[Non_]Null and Is_Known_Valid flags
22186 -- for a constant. Once the constant is elaborated, its value is
22187 -- not changed, therefore the associated flags that describe the
22188 -- value should not be modified either.
22190 if Ekind
(Ent
) = E_Constant
then
22193 -- Non-constant entities
22196 if not Can_Never_Be_Null
(Ent
) then
22197 Set_Is_Known_Non_Null
(Ent
, False);
22200 Set_Is_Known_Null
(Ent
, False);
22202 -- Reset the Is_Known_Valid flag unless the type is always
22203 -- valid. This does not apply to a loop parameter because its
22204 -- bounds are defined by the loop header and therefore always
22207 if not Is_Known_Valid
(Etype
(Ent
))
22208 and then Ekind
(Ent
) /= E_Loop_Parameter
22210 Set_Is_Known_Valid
(Ent
, False);
22215 end Kill_Current_Values
;
22217 procedure Kill_Current_Values
(Last_Assignment_Only
: Boolean := False) is
22220 procedure Kill_Current_Values_For_Entity_Chain
(E
: Entity_Id
);
22221 -- Clear current value for entity E and all entities chained to E
22223 ------------------------------------------
22224 -- Kill_Current_Values_For_Entity_Chain --
22225 ------------------------------------------
22227 procedure Kill_Current_Values_For_Entity_Chain
(E
: Entity_Id
) is
22231 while Present
(Ent
) loop
22232 Kill_Current_Values
(Ent
, Last_Assignment_Only
);
22235 end Kill_Current_Values_For_Entity_Chain
;
22237 -- Start of processing for Kill_Current_Values
22240 -- Kill all saved checks, a special case of killing saved values
22242 if not Last_Assignment_Only
then
22246 -- Loop through relevant scopes, which includes the current scope and
22247 -- any parent scopes if the current scope is a block or a package.
22249 S
:= Current_Scope
;
22252 -- Clear current values of all entities in current scope
22254 Kill_Current_Values_For_Entity_Chain
(First_Entity
(S
));
22256 -- If scope is a package, also clear current values of all private
22257 -- entities in the scope.
22259 if Is_Package_Or_Generic_Package
(S
)
22260 or else Is_Concurrent_Type
(S
)
22262 Kill_Current_Values_For_Entity_Chain
(First_Private_Entity
(S
));
22265 -- If this is a not a subprogram, deal with parents
22267 if not Is_Subprogram
(S
) then
22269 exit Scope_Loop
when S
= Standard_Standard
;
22273 end loop Scope_Loop
;
22274 end Kill_Current_Values
;
22276 --------------------------
22277 -- Kill_Size_Check_Code --
22278 --------------------------
22280 procedure Kill_Size_Check_Code
(E
: Entity_Id
) is
22282 if (Ekind
(E
) = E_Constant
or else Ekind
(E
) = E_Variable
)
22283 and then Present
(Size_Check_Code
(E
))
22285 Remove
(Size_Check_Code
(E
));
22286 Set_Size_Check_Code
(E
, Empty
);
22288 end Kill_Size_Check_Code
;
22290 --------------------
22291 -- Known_Non_Null --
22292 --------------------
22294 function Known_Non_Null
(N
: Node_Id
) return Boolean is
22295 Status
: constant Null_Status_Kind
:= Null_Status
(N
);
22302 -- The expression yields a non-null value ignoring simple flow analysis
22304 if Status
= Is_Non_Null
then
22307 -- Otherwise check whether N is a reference to an entity that appears
22308 -- within a conditional construct.
22310 elsif Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
22312 -- First check if we are in decisive conditional
22314 Get_Current_Value_Condition
(N
, Op
, Val
);
22316 if Known_Null
(Val
) then
22317 if Op
= N_Op_Eq
then
22319 elsif Op
= N_Op_Ne
then
22324 -- If OK to do replacement, test Is_Known_Non_Null flag
22328 if OK_To_Do_Constant_Replacement
(Id
) then
22329 return Is_Known_Non_Null
(Id
);
22333 -- Otherwise it is not possible to determine whether N yields a non-null
22337 end Known_Non_Null
;
22343 function Known_Null
(N
: Node_Id
) return Boolean is
22344 Status
: constant Null_Status_Kind
:= Null_Status
(N
);
22351 -- The expression yields a null value ignoring simple flow analysis
22353 if Status
= Is_Null
then
22356 -- Otherwise check whether N is a reference to an entity that appears
22357 -- within a conditional construct.
22359 elsif Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
22361 -- First check if we are in decisive conditional
22363 Get_Current_Value_Condition
(N
, Op
, Val
);
22365 -- If Get_Current_Value_Condition were to return Val = N, then the
22366 -- recursion below could be infinite.
22369 raise Program_Error
;
22372 if Known_Null
(Val
) then
22373 if Op
= N_Op_Eq
then
22375 elsif Op
= N_Op_Ne
then
22380 -- If OK to do replacement, test Is_Known_Null flag
22384 if OK_To_Do_Constant_Replacement
(Id
) then
22385 return Is_Known_Null
(Id
);
22389 -- Otherwise it is not possible to determine whether N yields a null
22395 ---------------------------
22396 -- Last_Source_Statement --
22397 ---------------------------
22399 function Last_Source_Statement
(HSS
: Node_Id
) return Node_Id
is
22403 N
:= Last
(Statements
(HSS
));
22404 while Present
(N
) loop
22405 exit when Comes_From_Source
(N
);
22410 end Last_Source_Statement
;
22412 -----------------------
22413 -- Mark_Coextensions --
22414 -----------------------
22416 procedure Mark_Coextensions
(Context_Nod
: Node_Id
; Root_Nod
: Node_Id
) is
22417 Is_Dynamic
: Boolean;
22418 -- Indicates whether the context causes nested coextensions to be
22419 -- dynamic or static
22421 function Mark_Allocator
(N
: Node_Id
) return Traverse_Result
;
22422 -- Recognize an allocator node and label it as a dynamic coextension
22424 --------------------
22425 -- Mark_Allocator --
22426 --------------------
22428 function Mark_Allocator
(N
: Node_Id
) return Traverse_Result
is
22430 if Nkind
(N
) = N_Allocator
then
22432 Set_Is_Static_Coextension
(N
, False);
22433 Set_Is_Dynamic_Coextension
(N
);
22435 -- If the allocator expression is potentially dynamic, it may
22436 -- be expanded out of order and require dynamic allocation
22437 -- anyway, so we treat the coextension itself as dynamic.
22438 -- Potential optimization ???
22440 elsif Nkind
(Expression
(N
)) = N_Qualified_Expression
22441 and then Nkind
(Expression
(Expression
(N
))) = N_Op_Concat
22443 Set_Is_Static_Coextension
(N
, False);
22444 Set_Is_Dynamic_Coextension
(N
);
22446 Set_Is_Dynamic_Coextension
(N
, False);
22447 Set_Is_Static_Coextension
(N
);
22452 end Mark_Allocator
;
22454 procedure Mark_Allocators
is new Traverse_Proc
(Mark_Allocator
);
22456 -- Start of processing for Mark_Coextensions
22459 -- An allocator that appears on the right-hand side of an assignment is
22460 -- treated as a potentially dynamic coextension when the right-hand side
22461 -- is an allocator or a qualified expression.
22463 -- Obj := new ...'(new Coextension ...);
22465 if Nkind
(Context_Nod
) = N_Assignment_Statement
then
22466 Is_Dynamic
:= Nkind
(Expression
(Context_Nod
)) in
22467 N_Allocator | N_Qualified_Expression
;
22469 -- An allocator that appears within the expression of a simple return
22470 -- statement is treated as a potentially dynamic coextension when the
22471 -- expression is either aggregate, allocator, or qualified expression.
22473 -- return (new Coextension ...);
22474 -- return new ...'(new Coextension ...);
22476 elsif Nkind
(Context_Nod
) = N_Simple_Return_Statement
then
22477 Is_Dynamic
:= Nkind
(Expression
(Context_Nod
)) in
22478 N_Aggregate | N_Allocator | N_Qualified_Expression
;
22480 -- An alloctor that appears within the initialization expression of an
22481 -- object declaration is considered a potentially dynamic coextension
22482 -- when the initialization expression is an allocator or a qualified
22485 -- Obj : ... := new ...'(new Coextension ...);
22487 -- A similar case arises when the object declaration is part of an
22488 -- extended return statement.
22490 -- return Obj : ... := new ...'(new Coextension ...);
22491 -- return Obj : ... := (new Coextension ...);
22493 elsif Nkind
(Context_Nod
) = N_Object_Declaration
then
22494 Is_Dynamic
:= Nkind
(Root_Nod
) in N_Allocator | N_Qualified_Expression
22495 or else Nkind
(Parent
(Context_Nod
)) = N_Extended_Return_Statement
;
22497 -- This routine should not be called with constructs that cannot contain
22501 raise Program_Error
;
22504 Mark_Allocators
(Root_Nod
);
22505 end Mark_Coextensions
;
22507 ---------------------------------
22508 -- Mark_Elaboration_Attributes --
22509 ---------------------------------
22511 procedure Mark_Elaboration_Attributes
22512 (N_Id
: Node_Or_Entity_Id
;
22513 Checks
: Boolean := False;
22514 Level
: Boolean := False;
22515 Modes
: Boolean := False;
22516 Warnings
: Boolean := False)
22518 function Elaboration_Checks_OK
22519 (Target_Id
: Entity_Id
;
22520 Context_Id
: Entity_Id
) return Boolean;
22521 -- Determine whether elaboration checks are enabled for target Target_Id
22522 -- which resides within context Context_Id.
22524 procedure Mark_Elaboration_Attributes_Id
(Id
: Entity_Id
);
22525 -- Preserve relevant attributes of the context in arbitrary entity Id
22527 procedure Mark_Elaboration_Attributes_Node
(N
: Node_Id
);
22528 -- Preserve relevant attributes of the context in arbitrary node N
22530 ---------------------------
22531 -- Elaboration_Checks_OK --
22532 ---------------------------
22534 function Elaboration_Checks_OK
22535 (Target_Id
: Entity_Id
;
22536 Context_Id
: Entity_Id
) return Boolean
22538 Encl_Scop
: Entity_Id
;
22541 -- Elaboration checks are suppressed for the target
22543 if Elaboration_Checks_Suppressed
(Target_Id
) then
22547 -- Otherwise elaboration checks are OK for the target, but may be
22548 -- suppressed for the context where the target is declared.
22550 Encl_Scop
:= Context_Id
;
22551 while Present
(Encl_Scop
) and then Encl_Scop
/= Standard_Standard
loop
22552 if Elaboration_Checks_Suppressed
(Encl_Scop
) then
22556 Encl_Scop
:= Scope
(Encl_Scop
);
22559 -- Neither the target nor its declarative context have elaboration
22560 -- checks suppressed.
22563 end Elaboration_Checks_OK
;
22565 ------------------------------------
22566 -- Mark_Elaboration_Attributes_Id --
22567 ------------------------------------
22569 procedure Mark_Elaboration_Attributes_Id
(Id
: Entity_Id
) is
22571 -- Mark the status of elaboration checks in effect. Do not reset the
22572 -- status in case the entity is reanalyzed with checks suppressed.
22574 if Checks
and then not Is_Elaboration_Checks_OK_Id
(Id
) then
22575 Set_Is_Elaboration_Checks_OK_Id
(Id
,
22576 Elaboration_Checks_OK
22578 Context_Id
=> Scope
(Id
)));
22581 -- Mark the status of elaboration warnings in effect. Do not reset
22582 -- the status in case the entity is reanalyzed with warnings off.
22584 if Warnings
and then not Is_Elaboration_Warnings_OK_Id
(Id
) then
22585 Set_Is_Elaboration_Warnings_OK_Id
(Id
, Elab_Warnings
);
22587 end Mark_Elaboration_Attributes_Id
;
22589 --------------------------------------
22590 -- Mark_Elaboration_Attributes_Node --
22591 --------------------------------------
22593 procedure Mark_Elaboration_Attributes_Node
(N
: Node_Id
) is
22594 function Extract_Name
(N
: Node_Id
) return Node_Id
;
22595 -- Obtain the Name attribute of call or instantiation N
22601 function Extract_Name
(N
: Node_Id
) return Node_Id
is
22607 -- A call to an entry family appears in indexed form
22609 if Nkind
(Nam
) = N_Indexed_Component
then
22610 Nam
:= Prefix
(Nam
);
22613 -- The name may also appear in qualified form
22615 if Nkind
(Nam
) = N_Selected_Component
then
22616 Nam
:= Selector_Name
(Nam
);
22624 Context_Id
: Entity_Id
;
22627 -- Start of processing for Mark_Elaboration_Attributes_Node
22630 -- Mark the status of elaboration checks in effect. Do not reset the
22631 -- status in case the node is reanalyzed with checks suppressed.
22633 if Checks
and then not Is_Elaboration_Checks_OK_Node
(N
) then
22635 -- Assignments, attribute references, and variable references do
22636 -- not have a "declarative" context.
22638 Context_Id
:= Empty
;
22640 -- The status of elaboration checks for calls and instantiations
22641 -- depends on the most recent pragma Suppress/Unsuppress, as well
22642 -- as the suppression status of the context where the target is
22646 -- function Func ...;
22650 -- procedure Main is
22651 -- pragma Suppress (Elaboration_Checks, Pack);
22652 -- X : ... := Pack.Func;
22655 -- In the example above, the call to Func has elaboration checks
22656 -- enabled because there is no active general purpose suppression
22657 -- pragma, however the elaboration checks of Pack are explicitly
22658 -- suppressed. As a result the elaboration checks of the call must
22659 -- be disabled in order to preserve this dependency.
22661 if Nkind
(N
) in N_Entry_Call_Statement
22663 | N_Function_Instantiation
22664 | N_Package_Instantiation
22665 | N_Procedure_Call_Statement
22666 | N_Procedure_Instantiation
22668 Nam
:= Extract_Name
(N
);
22670 if Is_Entity_Name
(Nam
) and then Present
(Entity
(Nam
)) then
22671 Context_Id
:= Scope
(Entity
(Nam
));
22675 Set_Is_Elaboration_Checks_OK_Node
(N
,
22676 Elaboration_Checks_OK
22677 (Target_Id
=> Empty
,
22678 Context_Id
=> Context_Id
));
22681 -- Mark the enclosing level of the node. Do not reset the status in
22682 -- case the node is relocated and reanalyzed.
22684 if Level
and then not Is_Declaration_Level_Node
(N
) then
22685 Set_Is_Declaration_Level_Node
(N
,
22686 Find_Enclosing_Level
(N
) = Declaration_Level
);
22689 -- Mark the Ghost and SPARK mode in effect
22692 if Ghost_Mode
= Ignore
then
22693 Set_Is_Ignored_Ghost_Node
(N
);
22696 if SPARK_Mode
= On
then
22697 Set_Is_SPARK_Mode_On_Node
(N
);
22701 -- Mark the status of elaboration warnings in effect. Do not reset
22702 -- the status in case the node is reanalyzed with warnings off.
22704 if Warnings
and then not Is_Elaboration_Warnings_OK_Node
(N
) then
22705 Set_Is_Elaboration_Warnings_OK_Node
(N
, Elab_Warnings
);
22707 end Mark_Elaboration_Attributes_Node
;
22709 -- Start of processing for Mark_Elaboration_Attributes
22712 -- Do not capture any elaboration-related attributes when switch -gnatH
22713 -- (legacy elaboration checking mode enabled) is in effect because the
22714 -- attributes are useless to the legacy model.
22716 if Legacy_Elaboration_Checks
then
22720 if Nkind
(N_Id
) in N_Entity
then
22721 Mark_Elaboration_Attributes_Id
(N_Id
);
22723 Mark_Elaboration_Attributes_Node
(N_Id
);
22725 end Mark_Elaboration_Attributes
;
22727 ----------------------------------------
22728 -- Mark_Save_Invocation_Graph_Of_Body --
22729 ----------------------------------------
22731 procedure Mark_Save_Invocation_Graph_Of_Body
is
22732 Main
: constant Node_Id
:= Cunit
(Main_Unit
);
22733 Main_Unit
: constant Node_Id
:= Unit
(Main
);
22734 Aux_Id
: Entity_Id
;
22737 Set_Save_Invocation_Graph_Of_Body
(Main
);
22739 -- Assume that the main unit does not have a complimentary unit
22743 -- Obtain the complimentary unit of the main unit
22745 if Nkind
(Main_Unit
) in N_Generic_Package_Declaration
22746 | N_Generic_Subprogram_Declaration
22747 | N_Package_Declaration
22748 | N_Subprogram_Declaration
22750 Aux_Id
:= Corresponding_Body
(Main_Unit
);
22752 elsif Nkind
(Main_Unit
) in N_Package_Body
22753 | N_Subprogram_Body
22754 | N_Subprogram_Renaming_Declaration
22756 Aux_Id
:= Corresponding_Spec
(Main_Unit
);
22759 if Present
(Aux_Id
) then
22760 Set_Save_Invocation_Graph_Of_Body
22761 (Parent
(Unit_Declaration_Node
(Aux_Id
)));
22763 end Mark_Save_Invocation_Graph_Of_Body
;
22765 ----------------------------------
22766 -- Matching_Static_Array_Bounds --
22767 ----------------------------------
22769 function Matching_Static_Array_Bounds
22771 R_Typ
: Node_Id
) return Boolean
22773 L_Ndims
: constant Nat
:= Number_Dimensions
(L_Typ
);
22774 R_Ndims
: constant Nat
:= Number_Dimensions
(R_Typ
);
22776 L_Index
: Node_Id
:= Empty
; -- init to ...
22777 R_Index
: Node_Id
:= Empty
; -- ...avoid warnings
22786 if L_Ndims
/= R_Ndims
then
22790 -- Unconstrained types do not have static bounds
22792 if not Is_Constrained
(L_Typ
) or else not Is_Constrained
(R_Typ
) then
22796 -- First treat specially the first dimension, as the lower bound and
22797 -- length of string literals are not stored like those of arrays.
22799 if Ekind
(L_Typ
) = E_String_Literal_Subtype
then
22800 L_Low
:= String_Literal_Low_Bound
(L_Typ
);
22801 L_Len
:= String_Literal_Length
(L_Typ
);
22803 L_Index
:= First_Index
(L_Typ
);
22804 Get_Index_Bounds
(L_Index
, L_Low
, L_High
);
22806 if Is_OK_Static_Expression
(L_Low
)
22808 Is_OK_Static_Expression
(L_High
)
22810 if Expr_Value
(L_High
) < Expr_Value
(L_Low
) then
22813 L_Len
:= (Expr_Value
(L_High
) - Expr_Value
(L_Low
)) + 1;
22820 if Ekind
(R_Typ
) = E_String_Literal_Subtype
then
22821 R_Low
:= String_Literal_Low_Bound
(R_Typ
);
22822 R_Len
:= String_Literal_Length
(R_Typ
);
22824 R_Index
:= First_Index
(R_Typ
);
22825 Get_Index_Bounds
(R_Index
, R_Low
, R_High
);
22827 if Is_OK_Static_Expression
(R_Low
)
22829 Is_OK_Static_Expression
(R_High
)
22831 if Expr_Value
(R_High
) < Expr_Value
(R_Low
) then
22834 R_Len
:= (Expr_Value
(R_High
) - Expr_Value
(R_Low
)) + 1;
22841 if (Is_OK_Static_Expression
(L_Low
)
22843 Is_OK_Static_Expression
(R_Low
))
22844 and then Expr_Value
(L_Low
) = Expr_Value
(R_Low
)
22845 and then L_Len
= R_Len
22852 -- Then treat all other dimensions
22854 for Indx
in 2 .. L_Ndims
loop
22858 Get_Index_Bounds
(L_Index
, L_Low
, L_High
);
22859 Get_Index_Bounds
(R_Index
, R_Low
, R_High
);
22861 if (Is_OK_Static_Expression
(L_Low
) and then
22862 Is_OK_Static_Expression
(L_High
) and then
22863 Is_OK_Static_Expression
(R_Low
) and then
22864 Is_OK_Static_Expression
(R_High
))
22865 and then (Expr_Value
(L_Low
) = Expr_Value
(R_Low
)
22867 Expr_Value
(L_High
) = Expr_Value
(R_High
))
22875 -- If we fall through the loop, all indexes matched
22878 end Matching_Static_Array_Bounds
;
22884 function Might_Raise
(N
: Node_Id
) return Boolean is
22885 Result
: Boolean := False;
22887 function Process
(N
: Node_Id
) return Traverse_Result
;
22888 -- Set Result to True if we find something that could raise an exception
22894 function Process
(N
: Node_Id
) return Traverse_Result
is
22896 if Nkind
(N
) in N_Procedure_Call_Statement
22898 | N_Raise_Statement
22899 | N_Raise_xxx_Error
22908 procedure Set_Result
is new Traverse_Proc
(Process
);
22910 -- Start of processing for Might_Raise
22913 -- False if exceptions can't be propagated
22915 if No_Exception_Handlers_Set
then
22919 -- If the checks handled by the back end are not disabled, we cannot
22920 -- ensure that no exception will be raised.
22922 if not Access_Checks_Suppressed
(Empty
)
22923 or else not Discriminant_Checks_Suppressed
(Empty
)
22924 or else not Range_Checks_Suppressed
(Empty
)
22925 or else not Index_Checks_Suppressed
(Empty
)
22926 or else Opt
.Stack_Checking_Enabled
22935 ----------------------------------------
22936 -- Nearest_Class_Condition_Subprogram --
22937 ----------------------------------------
22939 function Nearest_Class_Condition_Subprogram
22940 (Kind
: Condition_Kind
;
22941 Spec_Id
: Entity_Id
) return Entity_Id
22943 Subp_Id
: constant Entity_Id
:= Ultimate_Alias
(Spec_Id
);
22946 -- Prevent cascaded errors
22948 if not Is_Dispatching_Operation
(Subp_Id
) then
22951 -- No need to search if this subprogram has class-wide postconditions
22953 elsif Present
(Class_Condition
(Kind
, Subp_Id
)) then
22957 -- Process the contracts of inherited subprograms, looking for
22958 -- class-wide pre/postconditions.
22961 Subps
: constant Subprogram_List
:= Inherited_Subprograms
(Subp_Id
);
22962 Subp_Id
: Entity_Id
;
22965 for Index
in Subps
'Range loop
22966 Subp_Id
:= Subps
(Index
);
22968 if Present
(Alias
(Subp_Id
)) then
22969 Subp_Id
:= Ultimate_Alias
(Subp_Id
);
22972 -- Wrappers of class-wide pre/postconditions reference the
22973 -- parent primitive that has the inherited contract.
22975 if Is_Wrapper
(Subp_Id
)
22976 and then Present
(LSP_Subprogram
(Subp_Id
))
22978 Subp_Id
:= LSP_Subprogram
(Subp_Id
);
22981 if Present
(Class_Condition
(Kind
, Subp_Id
)) then
22988 end Nearest_Class_Condition_Subprogram
;
22990 --------------------------------
22991 -- Nearest_Enclosing_Instance --
22992 --------------------------------
22994 function Nearest_Enclosing_Instance
(E
: Entity_Id
) return Entity_Id
is
22999 while Present
(Inst
) and then Inst
/= Standard_Standard
loop
23000 if Is_Generic_Instance
(Inst
) then
23004 Inst
:= Scope
(Inst
);
23008 end Nearest_Enclosing_Instance
;
23010 ------------------------
23011 -- Needs_Finalization --
23012 ------------------------
23014 function Needs_Finalization
(Typ
: Entity_Id
) return Boolean is
23015 function Has_Some_Controlled_Component
23016 (Input_Typ
: Entity_Id
) return Boolean;
23017 -- Determine whether type Input_Typ has at least one controlled
23020 -----------------------------------
23021 -- Has_Some_Controlled_Component --
23022 -----------------------------------
23024 function Has_Some_Controlled_Component
23025 (Input_Typ
: Entity_Id
) return Boolean
23030 -- When a type is already frozen and has at least one controlled
23031 -- component, or is manually decorated, it is sufficient to inspect
23032 -- flag Has_Controlled_Component.
23034 if Has_Controlled_Component
(Input_Typ
) then
23037 -- Otherwise inspect the internals of the type
23039 elsif not Is_Frozen
(Input_Typ
) then
23040 if Is_Array_Type
(Input_Typ
) then
23041 return Needs_Finalization
(Component_Type
(Input_Typ
));
23043 elsif Is_Record_Type
(Input_Typ
) then
23044 Comp
:= First_Component
(Input_Typ
);
23045 while Present
(Comp
) loop
23046 if Needs_Finalization
(Etype
(Comp
)) then
23050 Next_Component
(Comp
);
23056 end Has_Some_Controlled_Component
;
23058 -- Start of processing for Needs_Finalization
23061 -- Certain run-time configurations and targets do not provide support
23062 -- for controlled types.
23064 if Restriction_Active
(No_Finalization
) then
23067 -- C++ types are not considered controlled. It is assumed that the non-
23068 -- Ada side will handle their clean up.
23070 elsif Convention
(Typ
) = Convention_CPP
then
23073 -- Class-wide types are treated as controlled because derivations from
23074 -- the root type may introduce controlled components.
23076 elsif Is_Class_Wide_Type
(Typ
) then
23079 -- Concurrent types are controlled as long as their corresponding record
23082 elsif Is_Concurrent_Type
(Typ
)
23083 and then Present
(Corresponding_Record_Type
(Typ
))
23084 and then Needs_Finalization
(Corresponding_Record_Type
(Typ
))
23088 -- Otherwise the type is controlled when it is either derived from type
23089 -- [Limited_]Controlled and not subject to aspect Disable_Controlled, or
23090 -- contains at least one controlled component.
23094 Is_Controlled
(Typ
) or else Has_Some_Controlled_Component
(Typ
);
23096 end Needs_Finalization
;
23098 ----------------------
23099 -- Needs_One_Actual --
23100 ----------------------
23102 function Needs_One_Actual
(E
: Entity_Id
) return Boolean is
23103 Formal
: Entity_Id
;
23106 -- Ada 2005 or later, and formals present. The first formal must be
23107 -- of a type that supports prefix notation: a controlling argument,
23108 -- a class-wide type, or an access to such.
23110 if Ada_Version
>= Ada_2005
23111 and then Present
(First_Formal
(E
))
23112 and then No
(Default_Value
(First_Formal
(E
)))
23114 (Is_Controlling_Formal
(First_Formal
(E
))
23115 or else Is_Class_Wide_Type
(Etype
(First_Formal
(E
)))
23116 or else Is_Anonymous_Access_Type
(Etype
(First_Formal
(E
))))
23118 Formal
:= Next_Formal
(First_Formal
(E
));
23119 while Present
(Formal
) loop
23120 if No
(Default_Value
(Formal
)) then
23124 Next_Formal
(Formal
);
23129 -- Ada 83/95 or no formals
23134 end Needs_One_Actual
;
23136 --------------------------------------
23137 -- Needs_Result_Accessibility_Level --
23138 --------------------------------------
23140 function Needs_Result_Accessibility_Level
23141 (Func_Id
: Entity_Id
) return Boolean
23143 Func_Typ
: constant Entity_Id
:= Underlying_Type
(Etype
(Func_Id
));
23145 function Has_Unconstrained_Access_Discriminant_Component
23146 (Comp_Typ
: Entity_Id
) return Boolean;
23147 -- Returns True if any component of the type has an unconstrained access
23150 -----------------------------------------------------
23151 -- Has_Unconstrained_Access_Discriminant_Component --
23152 -----------------------------------------------------
23154 function Has_Unconstrained_Access_Discriminant_Component
23155 (Comp_Typ
: Entity_Id
) return Boolean
23158 if not Is_Limited_Type
(Comp_Typ
) then
23161 -- Only limited types can have access discriminants with
23164 elsif Has_Unconstrained_Access_Discriminants
(Comp_Typ
) then
23167 elsif Is_Array_Type
(Comp_Typ
) then
23168 return Has_Unconstrained_Access_Discriminant_Component
23169 (Underlying_Type
(Component_Type
(Comp_Typ
)));
23171 elsif Is_Record_Type
(Comp_Typ
) then
23176 Comp
:= First_Component
(Comp_Typ
);
23177 while Present
(Comp
) loop
23178 if Has_Unconstrained_Access_Discriminant_Component
23179 (Underlying_Type
(Etype
(Comp
)))
23184 Next_Component
(Comp
);
23190 end Has_Unconstrained_Access_Discriminant_Component
;
23192 Disable_Tagged_Cases
: constant Boolean := True;
23193 -- Flag used to temporarily disable a "True" result for tagged types.
23194 -- See comments further below for details.
23196 -- Start of processing for Needs_Result_Accessibility_Level
23199 -- False if completion unavailable, which can happen when we are
23200 -- analyzing an abstract subprogram or if the subprogram has
23201 -- delayed freezing.
23203 if No
(Func_Typ
) then
23206 -- False if not a function, also handle enum-lit renames case
23208 elsif Func_Typ
= Standard_Void_Type
23209 or else Is_Scalar_Type
(Func_Typ
)
23213 -- Handle a corner case, a cross-dialect subp renaming. For example,
23214 -- an Ada 2012 renaming of an Ada 2005 subprogram. This can occur when
23215 -- an Ada 2005 (or earlier) unit references predefined run-time units.
23217 elsif Present
(Alias
(Func_Id
)) then
23219 -- Unimplemented: a cross-dialect subp renaming which does not set
23220 -- the Alias attribute (e.g., a rename of a dereference of an access
23221 -- to subprogram value). ???
23223 return Present
(Extra_Accessibility_Of_Result
(Alias
(Func_Id
)));
23225 -- Remaining cases require Ada 2012 mode
23227 elsif Ada_Version
< Ada_2012
then
23230 -- Handle the situation where a result is an anonymous access type
23231 -- RM 3.10.2 (10.3/3).
23233 elsif Ekind
(Func_Typ
) = E_Anonymous_Access_Type
then
23236 -- In the case of, say, a null tagged record result type, the need for
23237 -- this extra parameter might not be obvious so this function returns
23238 -- True for all tagged types for compatibility reasons.
23240 -- A function with, say, a tagged null controlling result type might
23241 -- be overridden by a primitive of an extension having an access
23242 -- discriminant and the overrider and overridden must have compatible
23243 -- calling conventions (including implicitly declared parameters).
23245 -- Similarly, values of one access-to-subprogram type might designate
23246 -- both a primitive subprogram of a given type and a function which is,
23247 -- for example, not a primitive subprogram of any type. Again, this
23248 -- requires calling convention compatibility. It might be possible to
23249 -- solve these issues by introducing wrappers, but that is not the
23250 -- approach that was chosen.
23252 -- Note: Despite the reasoning noted above, the extra accessibility
23253 -- parameter for tagged types is disabled for performance reasons.
23255 elsif Is_Tagged_Type
(Func_Typ
) then
23256 return not Disable_Tagged_Cases
;
23258 elsif Has_Unconstrained_Access_Discriminants
(Func_Typ
) then
23261 elsif Has_Unconstrained_Access_Discriminant_Component
(Func_Typ
) then
23264 -- False for all other cases
23269 end Needs_Result_Accessibility_Level
;
23271 ----------------------------
23272 -- Needs_Secondary_Stack --
23273 ----------------------------
23275 function Needs_Secondary_Stack
(Id
: Entity_Id
) return Boolean is
23276 pragma Assert
(if Present
(Id
) then Ekind
(Id
) in E_Void | Type_Kind
);
23278 function Caller_Known_Size_Record
(Typ
: Entity_Id
) return Boolean;
23279 -- Called for untagged record and protected types. Return True if the
23280 -- size of function results is known in the caller for Typ.
23282 function Large_Max_Size_Mutable
(Typ
: Entity_Id
) return Boolean;
23283 -- Returns True if Typ is a nonlimited record with defaulted
23284 -- discriminants whose max size makes it unsuitable for allocating on
23285 -- the primary stack.
23287 ------------------------------
23288 -- Caller_Known_Size_Record --
23289 ------------------------------
23291 function Caller_Known_Size_Record
(Typ
: Entity_Id
) return Boolean is
23292 pragma Assert
(Typ
= Underlying_Type
(Typ
));
23294 function Depends_On_Discriminant
(Typ
: Entity_Id
) return Boolean;
23295 -- Called for untagged record and protected types. Return True if Typ
23296 -- depends on discriminants, either directly when it is unconstrained
23297 -- or indirectly when it is constrained by uplevel discriminants.
23299 -----------------------------
23300 -- Depends_On_Discriminant --
23301 -----------------------------
23303 function Depends_On_Discriminant
(Typ
: Entity_Id
) return Boolean is
23307 if Has_Discriminants
(Typ
) then
23308 if not Is_Constrained
(Typ
) then
23312 Cons
:= First_Elmt
(Discriminant_Constraint
(Typ
));
23313 while Present
(Cons
) loop
23314 if Nkind
(Node
(Cons
)) = N_Identifier
23315 and then Ekind
(Entity
(Node
(Cons
))) = E_Discriminant
23326 end Depends_On_Discriminant
;
23329 -- First see if we have a variant part and return False if it depends
23330 -- on discriminants.
23332 if Has_Variant_Part
(Typ
) and then Depends_On_Discriminant
(Typ
) then
23336 -- Then loop over components and return False if their subtype has a
23337 -- caller-unknown size, possibly recursively.
23339 -- ??? This is overly conservative, an array could be nested inside
23340 -- some other record that is constrained by nondiscriminants. That
23341 -- is, the recursive calls are too conservative.
23347 Comp
:= First_Component
(Typ
);
23348 while Present
(Comp
) loop
23350 Comp_Type
: constant Entity_Id
:=
23351 Underlying_Type
(Etype
(Comp
));
23354 if Is_Record_Type
(Comp_Type
)
23356 Is_Protected_Type
(Comp_Type
)
23358 if not Caller_Known_Size_Record
(Comp_Type
) then
23362 elsif Is_Array_Type
(Comp_Type
) then
23363 if Size_Depends_On_Discriminant
(Comp_Type
) then
23369 Next_Component
(Comp
);
23374 end Caller_Known_Size_Record
;
23376 ------------------------------
23377 -- Large_Max_Size_Mutable --
23378 ------------------------------
23380 function Large_Max_Size_Mutable
(Typ
: Entity_Id
) return Boolean is
23381 pragma Assert
(Typ
= Underlying_Type
(Typ
));
23383 function Is_Large_Discrete_Type
(T
: Entity_Id
) return Boolean;
23384 -- Returns true if the discrete type T has a large range
23386 ----------------------------
23387 -- Is_Large_Discrete_Type --
23388 ----------------------------
23390 function Is_Large_Discrete_Type
(T
: Entity_Id
) return Boolean is
23391 Threshold
: constant Int
:= 16;
23392 -- Arbitrary threshold above which we consider it "large". We want
23393 -- a fairly large threshold, because these large types really
23394 -- shouldn't have default discriminants in the first place, in
23398 return UI_To_Int
(RM_Size
(T
)) > Threshold
;
23399 end Is_Large_Discrete_Type
;
23401 -- Start of processing for Large_Max_Size_Mutable
23404 if Is_Record_Type
(Typ
)
23405 and then not Is_Limited_View
(Typ
)
23406 and then Has_Defaulted_Discriminants
(Typ
)
23408 -- Loop through the components, looking for an array whose upper
23409 -- bound(s) depends on discriminants, where both the subtype of
23410 -- the discriminant and the index subtype are too large.
23416 Comp
:= First_Component
(Typ
);
23417 while Present
(Comp
) loop
23419 Comp_Type
: constant Entity_Id
:=
23420 Underlying_Type
(Etype
(Comp
));
23427 if Is_Array_Type
(Comp_Type
) then
23428 Indx
:= First_Index
(Comp_Type
);
23430 while Present
(Indx
) loop
23431 Ityp
:= Etype
(Indx
);
23432 Hi
:= Type_High_Bound
(Ityp
);
23434 if Nkind
(Hi
) = N_Identifier
23435 and then Ekind
(Entity
(Hi
)) = E_Discriminant
23436 and then Is_Large_Discrete_Type
(Ityp
)
23437 and then Is_Large_Discrete_Type
23438 (Etype
(Entity
(Hi
)))
23448 Next_Component
(Comp
);
23454 end Large_Max_Size_Mutable
;
23456 -- Local declarations
23458 Typ
: constant Entity_Id
:= Underlying_Type
(Id
);
23460 -- Start of processing for Needs_Secondary_Stack
23463 -- This is a private type which is not completed yet. This can only
23464 -- happen in a default expression (of a formal parameter or of a
23465 -- record component). Do not expand transient scope in this case.
23471 -- Do not expand transient scope for non-existent procedure return or
23472 -- string literal types.
23474 if Typ
= Standard_Void_Type
23475 or else Ekind
(Typ
) = E_String_Literal_Subtype
23479 -- If Typ is a generic formal incomplete type, then we want to look at
23480 -- the actual type.
23482 elsif Ekind
(Typ
) = E_Record_Subtype
23483 and then Present
(Cloned_Subtype
(Typ
))
23485 return Needs_Secondary_Stack
(Cloned_Subtype
(Typ
));
23487 -- Class-wide types obviously have an unknown size. For specific tagged
23488 -- types, if a call returning one of them is dispatching on result, and
23489 -- this type is not returned on the secondary stack, then the call goes
23490 -- through a thunk that only moves the result from the primary onto the
23491 -- secondary stack, because the computation of the size of the result is
23492 -- possible but complex from the outside.
23494 elsif Is_Class_Wide_Type
(Typ
) then
23497 -- If the return slot of the back end cannot be accessed, then there
23498 -- is no way to call Adjust at the right time for the return object if
23499 -- the type needs finalization, so the return object must be allocated
23500 -- on the secondary stack.
23502 elsif not Back_End_Return_Slot
and then Needs_Finalization
(Typ
) then
23505 -- Definite subtypes have a known size. This includes all elementary
23506 -- types. Tasks have a known size even if they have discriminants, so
23507 -- we return False here, with one exception:
23508 -- For a type like:
23509 -- type T (Last : Natural := 0) is
23510 -- X : String (1 .. Last);
23512 -- we return True. That's because for "P(F(...));", where F returns T,
23513 -- we don't know the size of the result at the call site, so if we
23514 -- allocated it on the primary stack, we would have to allocate the
23515 -- maximum size, which is way too big.
23517 elsif Is_Definite_Subtype
(Typ
) or else Is_Task_Type
(Typ
) then
23518 return Large_Max_Size_Mutable
(Typ
);
23520 -- Indefinite (discriminated) record or protected type
23522 elsif Is_Record_Type
(Typ
) or else Is_Protected_Type
(Typ
) then
23523 return not Caller_Known_Size_Record
(Typ
);
23525 -- Unconstrained array
23528 pragma Assert
(Is_Array_Type
(Typ
) and not Is_Definite_Subtype
(Typ
));
23531 end Needs_Secondary_Stack
;
23533 ---------------------------------
23534 -- Needs_Simple_Initialization --
23535 ---------------------------------
23537 function Needs_Simple_Initialization
23539 Consider_IS
: Boolean := True) return Boolean
23541 Consider_IS_NS
: constant Boolean :=
23542 Normalize_Scalars
or (Initialize_Scalars
and Consider_IS
);
23545 -- Never need initialization if it is suppressed
23547 if Initialization_Suppressed
(Typ
) then
23551 -- Check for private type, in which case test applies to the underlying
23552 -- type of the private type.
23554 if Is_Private_Type
(Typ
) then
23556 RT
: constant Entity_Id
:= Underlying_Type
(Typ
);
23558 if Present
(RT
) then
23559 return Needs_Simple_Initialization
(RT
);
23565 -- Scalar type with Default_Value aspect requires initialization
23567 elsif Is_Scalar_Type
(Typ
) and then Has_Default_Aspect
(Typ
) then
23570 -- Cases needing simple initialization are access types, and, if pragma
23571 -- Normalize_Scalars or Initialize_Scalars is in effect, then all scalar
23574 elsif Is_Access_Type
(Typ
)
23575 or else (Consider_IS_NS
and then Is_Scalar_Type
(Typ
))
23579 -- If Initialize/Normalize_Scalars is in effect, string objects also
23580 -- need initialization, unless they are created in the course of
23581 -- expanding an aggregate (since in the latter case they will be
23582 -- filled with appropriate initializing values before they are used).
23584 elsif Consider_IS_NS
23585 and then Is_Standard_String_Type
(Typ
)
23587 (not Is_Itype
(Typ
)
23588 or else Nkind
(Associated_Node_For_Itype
(Typ
)) /= N_Aggregate
)
23595 end Needs_Simple_Initialization
;
23597 -------------------------------------
23598 -- Needs_Variable_Reference_Marker --
23599 -------------------------------------
23601 function Needs_Variable_Reference_Marker
23603 Calls_OK
: Boolean) return Boolean
23605 function Within_Suitable_Context
(Ref
: Node_Id
) return Boolean;
23606 -- Deteremine whether variable reference Ref appears within a suitable
23607 -- context that allows the creation of a marker.
23609 -----------------------------
23610 -- Within_Suitable_Context --
23611 -----------------------------
23613 function Within_Suitable_Context
(Ref
: Node_Id
) return Boolean is
23618 while Present
(Par
) loop
23620 -- The context is not suitable when the reference appears within
23621 -- the formal part of an instantiation which acts as compilation
23622 -- unit because there is no proper list for the insertion of the
23625 if Nkind
(Par
) = N_Generic_Association
23626 and then Nkind
(Parent
(Par
)) in N_Generic_Instantiation
23627 and then Nkind
(Parent
(Parent
(Par
))) = N_Compilation_Unit
23631 -- The context is not suitable when the reference appears within
23632 -- a pragma. If the pragma has run-time semantics, the reference
23633 -- will be reconsidered once the pragma is expanded.
23635 elsif Nkind
(Par
) = N_Pragma
then
23638 -- The context is not suitable when the reference appears within a
23639 -- subprogram call, and the caller requests this behavior.
23642 and then Nkind
(Par
) in N_Entry_Call_Statement
23644 | N_Procedure_Call_Statement
23648 -- Prevent the search from going too far
23650 elsif Is_Body_Or_Package_Declaration
(Par
) then
23654 Par
:= Parent
(Par
);
23658 end Within_Suitable_Context
;
23663 Var_Id
: Entity_Id
;
23665 -- Start of processing for Needs_Variable_Reference_Marker
23668 -- No marker needs to be created when switch -gnatH (legacy elaboration
23669 -- checking mode enabled) is in effect because the legacy ABE mechanism
23670 -- does not use markers.
23672 if Legacy_Elaboration_Checks
then
23675 -- No marker needs to be created when the reference is preanalyzed
23676 -- because the marker will be inserted in the wrong place.
23678 elsif Preanalysis_Active
then
23681 -- Only references warrant a marker
23683 elsif Nkind
(N
) not in N_Expanded_Name | N_Identifier
then
23686 -- Only source references warrant a marker
23688 elsif not Comes_From_Source
(N
) then
23691 -- No marker needs to be created when the reference is erroneous, left
23692 -- in a bad state, or does not denote a variable.
23694 elsif not (Present
(Entity
(N
))
23695 and then Ekind
(Entity
(N
)) = E_Variable
23696 and then Entity
(N
) /= Any_Id
)
23701 Var_Id
:= Entity
(N
);
23702 Prag
:= SPARK_Pragma
(Var_Id
);
23704 -- Both the variable and reference must appear in SPARK_Mode On regions
23705 -- because this elaboration scenario falls under the SPARK rules.
23707 if not (Comes_From_Source
(Var_Id
)
23708 and then Present
(Prag
)
23709 and then Get_SPARK_Mode_From_Annotation
(Prag
) = On
23710 and then Is_SPARK_Mode_On_Node
(N
))
23714 -- No marker needs to be created when the reference does not appear
23715 -- within a suitable context (see body for details).
23717 -- Performance note: parent traversal
23719 elsif not Within_Suitable_Context
(N
) then
23723 -- At this point it is known that the variable reference will play a
23724 -- role in ABE diagnostics and requires a marker.
23727 end Needs_Variable_Reference_Marker
;
23729 ------------------------
23730 -- New_Copy_List_Tree --
23731 ------------------------
23733 function New_Copy_List_Tree
(List
: List_Id
) return List_Id
is
23738 if List
= No_List
then
23745 while Present
(E
) loop
23746 Append
(New_Copy_Tree
(E
), NL
);
23752 end New_Copy_List_Tree
;
23754 ----------------------------
23755 -- New_Copy_Separate_List --
23756 ----------------------------
23758 function New_Copy_Separate_List
(List
: List_Id
) return List_Id
is
23760 if List
= No_List
then
23765 List_Copy
: constant List_Id
:= New_List
;
23766 N
: Node_Id
:= First
(List
);
23769 while Present
(N
) loop
23770 Append
(New_Copy_Separate_Tree
(N
), List_Copy
);
23777 end New_Copy_Separate_List
;
23779 ----------------------------
23780 -- New_Copy_Separate_Tree --
23781 ----------------------------
23783 function New_Copy_Separate_Tree
(Source
: Node_Id
) return Node_Id
is
23784 function Search_Decl
(N
: Node_Id
) return Traverse_Result
;
23785 -- Subtree visitor which collects declarations
23787 procedure Search_Declarations
is new Traverse_Proc
(Search_Decl
);
23788 -- Subtree visitor instantiation
23796 function Search_Decl
(N
: Node_Id
) return Traverse_Result
is
23798 if Nkind
(N
) in N_Declaration
then
23799 Append_New_Elmt
(N
, Decls
);
23807 Source_Copy
: constant Node_Id
:= New_Copy_Tree
(Source
);
23809 -- Start of processing for New_Copy_Separate_Tree
23813 Search_Declarations
(Source_Copy
);
23815 -- Associate a new Entity with all the subtree declarations (keeping
23816 -- their original name).
23818 if Present
(Decls
) then
23825 Elmt
:= First_Elmt
(Decls
);
23826 while Present
(Elmt
) loop
23827 Decl
:= Node
(Elmt
);
23828 New_E
:= Make_Temporary
(Sloc
(Decl
), 'P');
23830 if Nkind
(Decl
) = N_Expression_Function
then
23831 Decl
:= Specification
(Decl
);
23834 if Nkind
(Decl
) in N_Function_Instantiation
23835 | N_Function_Specification
23836 | N_Generic_Function_Renaming_Declaration
23837 | N_Generic_Package_Renaming_Declaration
23838 | N_Generic_Procedure_Renaming_Declaration
23840 | N_Package_Instantiation
23841 | N_Package_Renaming_Declaration
23842 | N_Package_Specification
23843 | N_Procedure_Instantiation
23844 | N_Procedure_Specification
23846 Set_Chars
(New_E
, Chars
(Defining_Unit_Name
(Decl
)));
23847 Set_Defining_Unit_Name
(Decl
, New_E
);
23849 Set_Chars
(New_E
, Chars
(Defining_Identifier
(Decl
)));
23850 Set_Defining_Identifier
(Decl
, New_E
);
23858 return Source_Copy
;
23859 end New_Copy_Separate_Tree
;
23861 -------------------
23862 -- New_Copy_Tree --
23863 -------------------
23865 -- The following tables play a key role in replicating entities and Itypes.
23866 -- They are intentionally declared at the library level rather than within
23867 -- New_Copy_Tree to avoid elaborating them on each call. This performance
23868 -- optimization saves up to 2% of the entire compilation time spent in the
23869 -- front end. Care should be taken to reset the tables on each new call to
23872 NCT_Table_Max
: constant := 511;
23874 subtype NCT_Table_Index
is Nat
range 0 .. NCT_Table_Max
- 1;
23876 function NCT_Table_Hash
(Key
: Node_Or_Entity_Id
) return NCT_Table_Index
;
23877 -- Obtain the hash value of node or entity Key
23879 --------------------
23880 -- NCT_Table_Hash --
23881 --------------------
23883 function NCT_Table_Hash
(Key
: Node_Or_Entity_Id
) return NCT_Table_Index
is
23885 return NCT_Table_Index
(Key
mod NCT_Table_Max
);
23886 end NCT_Table_Hash
;
23888 ----------------------
23889 -- NCT_New_Entities --
23890 ----------------------
23892 -- The following table maps old entities and Itypes to their corresponding
23893 -- new entities and Itypes.
23897 package NCT_New_Entities
is new Simple_HTable
(
23898 Header_Num
=> NCT_Table_Index
,
23899 Element
=> Entity_Id
,
23900 No_Element
=> Empty
,
23902 Hash
=> NCT_Table_Hash
,
23905 ------------------------
23906 -- NCT_Pending_Itypes --
23907 ------------------------
23909 -- The following table maps old Associated_Node_For_Itype nodes to a set of
23910 -- new itypes. Given a set of old Itypes Aaa, Bbb, and Ccc, where all three
23911 -- have the same Associated_Node_For_Itype Ppp, and their corresponding new
23912 -- Itypes Xxx, Yyy, Zzz, the table contains the following mapping:
23914 -- Ppp -> (Xxx, Yyy, Zzz)
23916 -- The set is expressed as an Elist
23918 package NCT_Pending_Itypes
is new Simple_HTable
(
23919 Header_Num
=> NCT_Table_Index
,
23920 Element
=> Elist_Id
,
23921 No_Element
=> No_Elist
,
23923 Hash
=> NCT_Table_Hash
,
23926 NCT_Tables_In_Use
: Boolean := False;
23927 -- This flag keeps track of whether the two tables NCT_New_Entities and
23928 -- NCT_Pending_Itypes are in use. The flag is part of an optimization
23929 -- where certain operations are not performed if the tables are not in
23930 -- use. This saves up to 8% of the entire compilation time spent in the
23933 -------------------
23934 -- New_Copy_Tree --
23935 -------------------
23937 function New_Copy_Tree
23939 Map
: Elist_Id
:= No_Elist
;
23940 New_Sloc
: Source_Ptr
:= No_Location
;
23941 New_Scope
: Entity_Id
:= Empty
;
23942 Scopes_In_EWA_OK
: Boolean := False) return Node_Id
23944 -- This routine performs low-level tree manipulations and needs access
23945 -- to the internals of the tree.
23947 EWA_Level
: Nat
:= 0;
23948 -- This counter keeps track of how many N_Expression_With_Actions nodes
23949 -- are encountered during a depth-first traversal of the subtree. These
23950 -- nodes may define new entities in their Actions lists and thus require
23951 -- special processing.
23953 EWA_Inner_Scope_Level
: Nat
:= 0;
23954 -- This counter keeps track of how many scoping constructs appear within
23955 -- an N_Expression_With_Actions node.
23957 procedure Add_New_Entity
(Old_Id
: Entity_Id
; New_Id
: Entity_Id
);
23958 pragma Inline
(Add_New_Entity
);
23959 -- Add an entry in the NCT_New_Entities table which maps key Old_Id to
23960 -- value New_Id. Old_Id is an entity which appears within the Actions
23961 -- list of an N_Expression_With_Actions node, or within an entity map.
23962 -- New_Id is the corresponding new entity generated during Phase 1.
23964 procedure Add_Pending_Itype
(Assoc_Nod
: Node_Id
; Itype
: Entity_Id
);
23965 pragma Inline
(Add_Pending_Itype
);
23966 -- Add an entry in the NCT_Pending_Itypes which maps key Assoc_Nod to
23967 -- value Itype. Assoc_Nod is the associated node of an itype. Itype is
23970 procedure Build_NCT_Tables
(Entity_Map
: Elist_Id
);
23971 pragma Inline
(Build_NCT_Tables
);
23972 -- Populate tables NCT_New_Entities and NCT_Pending_Itypes with the
23973 -- information supplied in entity map Entity_Map. The format of the
23974 -- entity map must be as follows:
23976 -- Old_Id1, New_Id1, Old_Id2, New_Id2, .., Old_IdN, New_IdN
23978 function Copy_Any_Node_With_Replacement
23979 (N
: Node_Or_Entity_Id
) return Node_Or_Entity_Id
;
23980 pragma Inline
(Copy_Any_Node_With_Replacement
);
23981 -- Replicate entity or node N by invoking one of the following routines:
23983 -- Copy_Node_With_Replacement
23984 -- Corresponding_Entity
23986 function Copy_Elist_With_Replacement
(List
: Elist_Id
) return Elist_Id
;
23987 -- Replicate the elements of entity list List
23989 function Copy_Field_With_Replacement
23991 Old_Par
: Node_Id
:= Empty
;
23992 New_Par
: Node_Id
:= Empty
;
23993 Semantic
: Boolean := False) return Union_Id
;
23994 -- Replicate field Field by invoking one of the following routines:
23996 -- Copy_Elist_With_Replacement
23997 -- Copy_List_With_Replacement
23998 -- Copy_Node_With_Replacement
23999 -- Corresponding_Entity
24001 -- If the field is not an entity list, entity, itype, syntactic list,
24002 -- or node, then the field is returned unchanged. The routine always
24003 -- replicates entities, itypes, and valid syntactic fields. Old_Par is
24004 -- the expected parent of a syntactic field. New_Par is the new parent
24005 -- associated with a replicated syntactic field. Flag Semantic should
24006 -- be set when the input is a semantic field.
24008 function Copy_List_With_Replacement
(List
: List_Id
) return List_Id
;
24009 -- Replicate the elements of syntactic list List
24011 function Copy_Node_With_Replacement
(N
: Node_Id
) return Node_Id
;
24012 -- Replicate node N
24014 function Corresponding_Entity
(Id
: Entity_Id
) return Entity_Id
;
24015 pragma Inline
(Corresponding_Entity
);
24016 -- Return the corresponding new entity of Id generated during Phase 1.
24017 -- If there is no such entity, return Id.
24019 function In_Entity_Map
24021 Entity_Map
: Elist_Id
) return Boolean;
24022 pragma Inline
(In_Entity_Map
);
24023 -- Determine whether entity Id is one of the old ids specified in entity
24024 -- map Entity_Map. The format of the entity map must be as follows:
24026 -- Old_Id1, New_Id1, Old_Id2, New_Id2, .., Old_IdN, New_IdN
24028 procedure Update_CFS_Sloc
(N
: Node_Or_Entity_Id
);
24029 pragma Inline
(Update_CFS_Sloc
);
24030 -- Update the Comes_From_Source and Sloc attributes of node or entity N
24032 procedure Update_First_Real_Statement
24033 (Old_HSS
: Node_Id
;
24034 New_HSS
: Node_Id
);
24035 pragma Inline
(Update_First_Real_Statement
);
24036 -- Update semantic attribute First_Real_Statement of handled sequence of
24037 -- statements New_HSS based on handled sequence of statements Old_HSS.
24039 procedure Update_Named_Associations
24040 (Old_Call
: Node_Id
;
24041 New_Call
: Node_Id
);
24042 pragma Inline
(Update_Named_Associations
);
24043 -- Update semantic chain First/Next_Named_Association of call New_call
24044 -- based on call Old_Call.
24046 procedure Update_New_Entities
(Entity_Map
: Elist_Id
);
24047 pragma Inline
(Update_New_Entities
);
24048 -- Update the semantic attributes of all new entities generated during
24049 -- Phase 1 that do not appear in entity map Entity_Map. The format of
24050 -- the entity map must be as follows:
24052 -- Old_Id1, New_Id1, Old_Id2, New_Id2, .., Old_IdN, New_IdN
24054 procedure Update_Pending_Itypes
24055 (Old_Assoc
: Node_Id
;
24056 New_Assoc
: Node_Id
);
24057 pragma Inline
(Update_Pending_Itypes
);
24058 -- Update semantic attribute Associated_Node_For_Itype to refer to node
24059 -- New_Assoc for all itypes whose associated node is Old_Assoc.
24061 procedure Update_Semantic_Fields
(Id
: Entity_Id
);
24062 pragma Inline
(Update_Semantic_Fields
);
24063 -- Subsidiary to Update_New_Entities. Update semantic fields of entity
24066 procedure Visit_Any_Node
(N
: Node_Or_Entity_Id
);
24067 pragma Inline
(Visit_Any_Node
);
24068 -- Visit entity of node N by invoking one of the following routines:
24074 procedure Visit_Elist
(List
: Elist_Id
);
24075 -- Visit the elements of entity list List
24077 procedure Visit_Entity
(Id
: Entity_Id
);
24078 -- Visit entity Id. This action may create a new entity of Id and save
24079 -- it in table NCT_New_Entities.
24081 procedure Visit_Field
24083 Par_Nod
: Node_Id
:= Empty
;
24084 Semantic
: Boolean := False);
24085 -- Visit field Field by invoking one of the following routines:
24093 -- If the field is not an entity list, entity, itype, syntactic list,
24094 -- or node, then the field is not visited. The routine always visits
24095 -- valid syntactic fields. Par_Nod is the expected parent of the
24096 -- syntactic field. Flag Semantic should be set when the input is a
24099 procedure Visit_Itype
(Itype
: Entity_Id
);
24100 -- Visit itype Itype. This action may create a new entity for Itype and
24101 -- save it in table NCT_New_Entities. In addition, the routine may map
24102 -- the associated node of Itype to the new itype in NCT_Pending_Itypes.
24104 procedure Visit_List
(List
: List_Id
);
24105 -- Visit the elements of syntactic list List
24107 procedure Visit_Node
(N
: Node_Id
);
24110 procedure Visit_Semantic_Fields
(Id
: Entity_Id
);
24111 pragma Inline
(Visit_Semantic_Fields
);
24112 -- Subsidiary to Visit_Entity and Visit_Itype. Visit common semantic
24113 -- fields of entity or itype Id.
24115 --------------------
24116 -- Add_New_Entity --
24117 --------------------
24119 procedure Add_New_Entity
(Old_Id
: Entity_Id
; New_Id
: Entity_Id
) is
24121 pragma Assert
(Present
(Old_Id
));
24122 pragma Assert
(Present
(New_Id
));
24123 pragma Assert
(Nkind
(Old_Id
) in N_Entity
);
24124 pragma Assert
(Nkind
(New_Id
) in N_Entity
);
24126 NCT_Tables_In_Use
:= True;
24128 -- Sanity check the NCT_New_Entities table. No previous mapping with
24129 -- key Old_Id should exist.
24131 pragma Assert
(No
(NCT_New_Entities
.Get
(Old_Id
)));
24133 -- Establish the mapping
24135 -- Old_Id -> New_Id
24137 NCT_New_Entities
.Set
(Old_Id
, New_Id
);
24138 end Add_New_Entity
;
24140 -----------------------
24141 -- Add_Pending_Itype --
24142 -----------------------
24144 procedure Add_Pending_Itype
(Assoc_Nod
: Node_Id
; Itype
: Entity_Id
) is
24148 pragma Assert
(Present
(Assoc_Nod
));
24149 pragma Assert
(Present
(Itype
));
24150 pragma Assert
(Nkind
(Itype
) in N_Entity
);
24151 pragma Assert
(Is_Itype
(Itype
));
24153 NCT_Tables_In_Use
:= True;
24155 -- It is not possible to sanity check the NCT_Pendint_Itypes table
24156 -- directly because a single node may act as the associated node for
24157 -- multiple itypes.
24159 Itypes
:= NCT_Pending_Itypes
.Get
(Assoc_Nod
);
24161 if No
(Itypes
) then
24162 Itypes
:= New_Elmt_List
;
24163 NCT_Pending_Itypes
.Set
(Assoc_Nod
, Itypes
);
24166 -- Establish the mapping
24168 -- Assoc_Nod -> (Itype, ...)
24170 -- Avoid inserting the same itype multiple times. This involves a
24171 -- linear search, however the set of itypes with the same associated
24172 -- node is very small.
24174 Append_Unique_Elmt
(Itype
, Itypes
);
24175 end Add_Pending_Itype
;
24177 ----------------------
24178 -- Build_NCT_Tables --
24179 ----------------------
24181 procedure Build_NCT_Tables
(Entity_Map
: Elist_Id
) is
24183 Old_Id
: Entity_Id
;
24184 New_Id
: Entity_Id
;
24187 -- Nothing to do when there is no entity map
24189 if No
(Entity_Map
) then
24193 Elmt
:= First_Elmt
(Entity_Map
);
24194 while Present
(Elmt
) loop
24196 -- Extract the (Old_Id, New_Id) pair from the entity map
24198 Old_Id
:= Node
(Elmt
);
24201 New_Id
:= Node
(Elmt
);
24204 -- Establish the following mapping within table NCT_New_Entities
24206 -- Old_Id -> New_Id
24208 Add_New_Entity
(Old_Id
, New_Id
);
24210 -- Establish the following mapping within table NCT_Pending_Itypes
24211 -- when the new entity is an itype.
24213 -- Assoc_Nod -> (New_Id, ...)
24215 -- IMPORTANT: the associated node is that of the old itype because
24216 -- the node will be replicated in Phase 2.
24218 if Is_Itype
(Old_Id
) then
24220 (Assoc_Nod
=> Associated_Node_For_Itype
(Old_Id
),
24224 end Build_NCT_Tables
;
24226 ------------------------------------
24227 -- Copy_Any_Node_With_Replacement --
24228 ------------------------------------
24230 function Copy_Any_Node_With_Replacement
24231 (N
: Node_Or_Entity_Id
) return Node_Or_Entity_Id
24234 if Nkind
(N
) in N_Entity
then
24235 return Corresponding_Entity
(N
);
24237 return Copy_Node_With_Replacement
(N
);
24239 end Copy_Any_Node_With_Replacement
;
24241 ---------------------------------
24242 -- Copy_Elist_With_Replacement --
24243 ---------------------------------
24245 function Copy_Elist_With_Replacement
(List
: Elist_Id
) return Elist_Id
is
24250 -- Copy the contents of the old list. Note that the list itself may
24251 -- be empty, in which case the routine returns a new empty list. This
24252 -- avoids sharing lists between subtrees. The element of an entity
24253 -- list could be an entity or a node, hence the invocation of routine
24254 -- Copy_Any_Node_With_Replacement.
24256 if Present
(List
) then
24257 Result
:= New_Elmt_List
;
24259 Elmt
:= First_Elmt
(List
);
24260 while Present
(Elmt
) loop
24262 (Copy_Any_Node_With_Replacement
(Node
(Elmt
)), Result
);
24267 -- Otherwise the list does not exist
24270 Result
:= No_Elist
;
24274 end Copy_Elist_With_Replacement
;
24276 ---------------------------------
24277 -- Copy_Field_With_Replacement --
24278 ---------------------------------
24280 function Copy_Field_With_Replacement
24282 Old_Par
: Node_Id
:= Empty
;
24283 New_Par
: Node_Id
:= Empty
;
24284 Semantic
: Boolean := False) return Union_Id
24286 function Has_More_Ids
(N
: Node_Id
) return Boolean;
24287 -- Return True when N has attribute More_Ids set to True
24289 function Is_Syntactic_Node
return Boolean;
24290 -- Return True when Field is a syntactic node
24296 function Has_More_Ids
(N
: Node_Id
) return Boolean is
24298 if Nkind
(N
) in N_Component_Declaration
24299 | N_Discriminant_Specification
24300 | N_Exception_Declaration
24301 | N_Formal_Object_Declaration
24302 | N_Number_Declaration
24303 | N_Object_Declaration
24304 | N_Parameter_Specification
24305 | N_Use_Package_Clause
24306 | N_Use_Type_Clause
24308 return More_Ids
(N
);
24314 -----------------------
24315 -- Is_Syntactic_Node --
24316 -----------------------
24318 function Is_Syntactic_Node
return Boolean is
24319 Old_N
: constant Node_Id
:= Node_Id
(Field
);
24322 if Parent
(Old_N
) = Old_Par
then
24325 elsif not Has_More_Ids
(Old_Par
) then
24328 -- Perform the check using the last last id in the syntactic chain
24332 N
: Node_Id
:= Old_Par
;
24335 while Present
(N
) and then More_Ids
(N
) loop
24339 pragma Assert
(Prev_Ids
(N
));
24340 return Parent
(Old_N
) = N
;
24343 end Is_Syntactic_Node
;
24346 -- The field is empty
24348 if Field
= Union_Id
(Empty
) then
24351 -- The field is an entity/itype/node
24353 elsif Field
in Node_Range
then
24355 Old_N
: constant Node_Id
:= Node_Id
(Field
);
24356 Syntactic
: constant Boolean := Is_Syntactic_Node
;
24361 -- The field is an entity/itype
24363 if Nkind
(Old_N
) in N_Entity
then
24365 -- An entity/itype is always replicated
24367 New_N
:= Corresponding_Entity
(Old_N
);
24369 -- Update the parent pointer when the entity is a syntactic
24370 -- field. Note that itypes do not have parent pointers.
24372 if Syntactic
and then New_N
/= Old_N
then
24373 Set_Parent
(New_N
, New_Par
);
24376 -- The field is a node
24379 -- A node is replicated when it is either a syntactic field
24380 -- or when the caller treats it as a semantic attribute.
24382 if Syntactic
or else Semantic
then
24383 New_N
:= Copy_Node_With_Replacement
(Old_N
);
24385 -- Update the parent pointer when the node is a syntactic
24388 if Syntactic
and then New_N
/= Old_N
then
24389 Set_Parent
(New_N
, New_Par
);
24392 -- Otherwise the node is returned unchanged
24399 return Union_Id
(New_N
);
24402 -- The field is an entity list
24404 elsif Field
in Elist_Range
then
24405 return Union_Id
(Copy_Elist_With_Replacement
(Elist_Id
(Field
)));
24407 -- The field is a syntactic list
24409 elsif Field
in List_Range
then
24411 Old_List
: constant List_Id
:= List_Id
(Field
);
24412 Syntactic
: constant Boolean := Parent
(Old_List
) = Old_Par
;
24414 New_List
: List_Id
;
24417 -- A list is replicated when it is either a syntactic field or
24418 -- when the caller treats it as a semantic attribute.
24420 if Syntactic
or else Semantic
then
24421 New_List
:= Copy_List_With_Replacement
(Old_List
);
24423 -- Update the parent pointer when the list is a syntactic
24426 if Syntactic
and then New_List
/= Old_List
then
24427 Set_Parent
(New_List
, New_Par
);
24430 -- Otherwise the list is returned unchanged
24433 New_List
:= Old_List
;
24436 return Union_Id
(New_List
);
24439 -- Otherwise the field denotes an attribute that does not need to be
24440 -- replicated (Chars, literals, etc).
24445 end Copy_Field_With_Replacement
;
24447 --------------------------------
24448 -- Copy_List_With_Replacement --
24449 --------------------------------
24451 function Copy_List_With_Replacement
(List
: List_Id
) return List_Id
is
24456 -- Copy the contents of the old list. Note that the list itself may
24457 -- be empty, in which case the routine returns a new empty list. This
24458 -- avoids sharing lists between subtrees. The element of a syntactic
24459 -- list is always a node, never an entity or itype, hence the call to
24460 -- routine Copy_Node_With_Replacement.
24462 if Present
(List
) then
24463 Result
:= New_List
;
24465 Elmt
:= First
(List
);
24466 while Present
(Elmt
) loop
24467 Append
(Copy_Node_With_Replacement
(Elmt
), Result
);
24472 -- Otherwise the list does not exist
24479 end Copy_List_With_Replacement
;
24481 --------------------------------
24482 -- Copy_Node_With_Replacement --
24483 --------------------------------
24485 function Copy_Node_With_Replacement
(N
: Node_Id
) return Node_Id
is
24488 function Transform
(U
: Union_Id
) return Union_Id
;
24489 -- Copies one field, replacing N with Result
24495 function Transform
(U
: Union_Id
) return Union_Id
is
24497 return Copy_Field_With_Replacement
24500 New_Par
=> Result
);
24503 procedure Walk
is new Walk_Sinfo_Fields_Pairwise
(Transform
);
24505 -- Start of processing for Copy_Node_With_Replacement
24508 -- Assume that the node must be returned unchanged
24512 if N
> Empty_Or_Error
then
24513 pragma Assert
(Nkind
(N
) not in N_Entity
);
24515 Result
:= New_Copy
(N
);
24517 Walk
(Result
, Result
);
24519 -- Update the Comes_From_Source and Sloc attributes of the node
24520 -- in case the caller has supplied new values.
24522 Update_CFS_Sloc
(Result
);
24524 -- Update the Associated_Node_For_Itype attribute of all itypes
24525 -- created during Phase 1 whose associated node is N. As a result
24526 -- the Associated_Node_For_Itype refers to the replicated node.
24527 -- No action needs to be taken when the Associated_Node_For_Itype
24528 -- refers to an entity because this was already handled during
24529 -- Phase 1, in Visit_Itype.
24531 Update_Pending_Itypes
24533 New_Assoc
=> Result
);
24535 -- Update the First/Next_Named_Association chain for a replicated
24538 if Nkind
(N
) in N_Entry_Call_Statement
24540 | N_Procedure_Call_Statement
24542 Update_Named_Associations
24544 New_Call
=> Result
);
24546 -- Update the Renamed_Object attribute of a replicated object
24549 elsif Nkind
(N
) = N_Object_Renaming_Declaration
then
24550 Set_Renamed_Object_Of_Possibly_Void
24551 (Defining_Entity
(Result
), Name
(Result
));
24553 -- Update the First_Real_Statement attribute of a replicated
24554 -- handled sequence of statements.
24556 elsif Nkind
(N
) = N_Handled_Sequence_Of_Statements
then
24557 Update_First_Real_Statement
24559 New_HSS
=> Result
);
24561 -- Update the Chars attribute of identifiers
24563 elsif Nkind
(N
) = N_Identifier
then
24565 -- The Entity field of identifiers that denote aspects is used
24566 -- to store arbitrary expressions (and hence we must check that
24567 -- they reference an actual entity before copying their Chars
24570 if Present
(Entity
(Result
))
24571 and then Nkind
(Entity
(Result
)) in N_Entity
24573 Set_Chars
(Result
, Chars
(Entity
(Result
)));
24577 if Has_Aspects
(N
) then
24578 Set_Aspect_Specifications
(Result
,
24579 Copy_List_With_Replacement
(Aspect_Specifications
(N
)));
24584 end Copy_Node_With_Replacement
;
24586 --------------------------
24587 -- Corresponding_Entity --
24588 --------------------------
24590 function Corresponding_Entity
(Id
: Entity_Id
) return Entity_Id
is
24591 New_Id
: Entity_Id
;
24592 Result
: Entity_Id
;
24595 -- Assume that the entity must be returned unchanged
24599 if Id
> Empty_Or_Error
then
24600 pragma Assert
(Nkind
(Id
) in N_Entity
);
24602 -- Determine whether the entity has a corresponding new entity
24603 -- generated during Phase 1 and if it does, use it.
24605 if NCT_Tables_In_Use
then
24606 New_Id
:= NCT_New_Entities
.Get
(Id
);
24608 if Present
(New_Id
) then
24615 end Corresponding_Entity
;
24617 -------------------
24618 -- In_Entity_Map --
24619 -------------------
24621 function In_Entity_Map
24623 Entity_Map
: Elist_Id
) return Boolean
24626 Old_Id
: Entity_Id
;
24629 -- The entity map contains pairs (Old_Id, New_Id). The advancement
24630 -- step always skips the New_Id portion of the pair.
24632 if Present
(Entity_Map
) then
24633 Elmt
:= First_Elmt
(Entity_Map
);
24634 while Present
(Elmt
) loop
24635 Old_Id
:= Node
(Elmt
);
24637 if Old_Id
= Id
then
24649 ---------------------
24650 -- Update_CFS_Sloc --
24651 ---------------------
24653 procedure Update_CFS_Sloc
(N
: Node_Or_Entity_Id
) is
24655 -- A new source location defaults the Comes_From_Source attribute
24657 if New_Sloc
/= No_Location
then
24658 Set_Comes_From_Source
(N
, Get_Comes_From_Source_Default
);
24659 Set_Sloc
(N
, New_Sloc
);
24661 end Update_CFS_Sloc
;
24663 ---------------------------------
24664 -- Update_First_Real_Statement --
24665 ---------------------------------
24667 procedure Update_First_Real_Statement
24668 (Old_HSS
: Node_Id
;
24671 Old_First_Stmt
: constant Node_Id
:= First_Real_Statement
(Old_HSS
);
24673 New_Stmt
: Node_Id
;
24674 Old_Stmt
: Node_Id
;
24677 -- Recreate the First_Real_Statement attribute of a handled sequence
24678 -- of statements by traversing the statement lists of both sequences
24681 if Present
(Old_First_Stmt
) then
24682 New_Stmt
:= First
(Statements
(New_HSS
));
24683 Old_Stmt
:= First
(Statements
(Old_HSS
));
24684 while Present
(Old_Stmt
) and then Old_Stmt
/= Old_First_Stmt
loop
24689 pragma Assert
(Present
(New_Stmt
));
24690 pragma Assert
(Present
(Old_Stmt
));
24692 Set_First_Real_Statement
(New_HSS
, New_Stmt
);
24694 end Update_First_Real_Statement
;
24696 -------------------------------
24697 -- Update_Named_Associations --
24698 -------------------------------
24700 procedure Update_Named_Associations
24701 (Old_Call
: Node_Id
;
24702 New_Call
: Node_Id
)
24705 New_Next
: Node_Id
;
24707 Old_Next
: Node_Id
;
24710 if No
(First_Named_Actual
(Old_Call
)) then
24714 -- Recreate the First/Next_Named_Actual chain of a call by traversing
24715 -- the chains of both the old and new calls in parallel.
24717 New_Act
:= First
(Parameter_Associations
(New_Call
));
24718 Old_Act
:= First
(Parameter_Associations
(Old_Call
));
24719 while Present
(Old_Act
) loop
24720 if Nkind
(Old_Act
) = N_Parameter_Association
24721 and then Explicit_Actual_Parameter
(Old_Act
)
24722 = First_Named_Actual
(Old_Call
)
24724 Set_First_Named_Actual
(New_Call
,
24725 Explicit_Actual_Parameter
(New_Act
));
24728 if Nkind
(Old_Act
) = N_Parameter_Association
24729 and then Present
(Next_Named_Actual
(Old_Act
))
24731 -- Scan the actual parameter list to find the next suitable
24732 -- named actual. Note that the list may be out of order.
24734 New_Next
:= First
(Parameter_Associations
(New_Call
));
24735 Old_Next
:= First
(Parameter_Associations
(Old_Call
));
24736 while Nkind
(Old_Next
) /= N_Parameter_Association
24737 or else Explicit_Actual_Parameter
(Old_Next
) /=
24738 Next_Named_Actual
(Old_Act
)
24744 Set_Next_Named_Actual
(New_Act
,
24745 Explicit_Actual_Parameter
(New_Next
));
24751 end Update_Named_Associations
;
24753 -------------------------
24754 -- Update_New_Entities --
24755 -------------------------
24757 procedure Update_New_Entities
(Entity_Map
: Elist_Id
) is
24758 New_Id
: Entity_Id
:= Empty
;
24759 Old_Id
: Entity_Id
:= Empty
;
24762 if NCT_Tables_In_Use
then
24763 NCT_New_Entities
.Get_First
(Old_Id
, New_Id
);
24765 -- Update the semantic fields of all new entities created during
24766 -- Phase 1 which were not supplied via an entity map.
24767 -- ??? Is there a better way of distinguishing those?
24769 while Present
(Old_Id
) and then Present
(New_Id
) loop
24770 if not (Present
(Entity_Map
)
24771 and then In_Entity_Map
(Old_Id
, Entity_Map
))
24773 Update_Semantic_Fields
(New_Id
);
24776 NCT_New_Entities
.Get_Next
(Old_Id
, New_Id
);
24779 end Update_New_Entities
;
24781 ---------------------------
24782 -- Update_Pending_Itypes --
24783 ---------------------------
24785 procedure Update_Pending_Itypes
24786 (Old_Assoc
: Node_Id
;
24787 New_Assoc
: Node_Id
)
24793 if NCT_Tables_In_Use
then
24794 Itypes
:= NCT_Pending_Itypes
.Get
(Old_Assoc
);
24796 -- Update the Associated_Node_For_Itype attribute for all itypes
24797 -- which originally refer to Old_Assoc to designate New_Assoc.
24799 if Present
(Itypes
) then
24800 Item
:= First_Elmt
(Itypes
);
24801 while Present
(Item
) loop
24802 Set_Associated_Node_For_Itype
(Node
(Item
), New_Assoc
);
24808 end Update_Pending_Itypes
;
24810 ----------------------------
24811 -- Update_Semantic_Fields --
24812 ----------------------------
24814 procedure Update_Semantic_Fields
(Id
: Entity_Id
) is
24816 -- Discriminant_Constraint
24818 if Is_Type
(Id
) and then Has_Discriminants
(Base_Type
(Id
)) then
24819 Set_Discriminant_Constraint
(Id
, Elist_Id
(
24820 Copy_Field_With_Replacement
24821 (Field
=> Union_Id
(Discriminant_Constraint
(Id
)),
24822 Semantic
=> True)));
24827 Set_Etype
(Id
, Node_Id
(
24828 Copy_Field_With_Replacement
24829 (Field
=> Union_Id
(Etype
(Id
)),
24830 Semantic
=> True)));
24833 -- Packed_Array_Impl_Type
24835 if Is_Array_Type
(Id
) then
24836 if Present
(First_Index
(Id
)) then
24837 Set_First_Index
(Id
, First
(List_Id
(
24838 Copy_Field_With_Replacement
24839 (Field
=> Union_Id
(List_Containing
(First_Index
(Id
))),
24840 Semantic
=> True))));
24843 if Is_Packed
(Id
) then
24844 Set_Packed_Array_Impl_Type
(Id
, Node_Id
(
24845 Copy_Field_With_Replacement
24846 (Field
=> Union_Id
(Packed_Array_Impl_Type
(Id
)),
24847 Semantic
=> True)));
24853 Set_Prev_Entity
(Id
, Node_Id
(
24854 Copy_Field_With_Replacement
24855 (Field
=> Union_Id
(Prev_Entity
(Id
)),
24856 Semantic
=> True)));
24860 Set_Next_Entity
(Id
, Node_Id
(
24861 Copy_Field_With_Replacement
24862 (Field
=> Union_Id
(Next_Entity
(Id
)),
24863 Semantic
=> True)));
24867 if Is_Discrete_Type
(Id
) then
24868 Set_Scalar_Range
(Id
, Node_Id
(
24869 Copy_Field_With_Replacement
24870 (Field
=> Union_Id
(Scalar_Range
(Id
)),
24871 Semantic
=> True)));
24876 -- Update the scope when the caller specified an explicit one
24878 if Present
(New_Scope
) then
24879 Set_Scope
(Id
, New_Scope
);
24881 Set_Scope
(Id
, Node_Id
(
24882 Copy_Field_With_Replacement
24883 (Field
=> Union_Id
(Scope
(Id
)),
24884 Semantic
=> True)));
24886 end Update_Semantic_Fields
;
24888 --------------------
24889 -- Visit_Any_Node --
24890 --------------------
24892 procedure Visit_Any_Node
(N
: Node_Or_Entity_Id
) is
24894 if Nkind
(N
) in N_Entity
then
24895 if Is_Itype
(N
) then
24903 end Visit_Any_Node
;
24909 procedure Visit_Elist
(List
: Elist_Id
) is
24913 -- The element of an entity list could be an entity, itype, or a
24914 -- node, hence the call to Visit_Any_Node.
24916 if Present
(List
) then
24917 Elmt
:= First_Elmt
(List
);
24918 while Present
(Elmt
) loop
24919 Visit_Any_Node
(Node
(Elmt
));
24930 procedure Visit_Entity
(Id
: Entity_Id
) is
24931 New_Id
: Entity_Id
;
24934 pragma Assert
(Nkind
(Id
) in N_Entity
);
24935 pragma Assert
(not Is_Itype
(Id
));
24937 -- Nothing to do when the entity is not defined in the Actions list
24938 -- of an N_Expression_With_Actions node.
24940 if EWA_Level
= 0 then
24943 -- Nothing to do when the entity is defined in a scoping construct
24944 -- within an N_Expression_With_Actions node, unless the caller has
24945 -- requested their replication.
24947 -- ??? should this restriction be eliminated?
24949 elsif EWA_Inner_Scope_Level
> 0 and then not Scopes_In_EWA_OK
then
24952 -- Nothing to do when the entity does not denote a construct that
24953 -- may appear within an N_Expression_With_Actions node. Relaxing
24954 -- this restriction leads to a performance penalty.
24956 -- ??? this list is flaky, and may hide dormant bugs
24957 -- Should functions be included???
24959 -- Quantified expressions contain an entity declaration that must
24960 -- always be replaced when the expander is active, even if it has
24961 -- not been analyzed yet like e.g. in predicates.
24963 elsif Ekind
(Id
) not in E_Block
24968 and then not Is_Entity_Of_Quantified_Expression
(Id
)
24969 and then not Is_Type
(Id
)
24973 -- Nothing to do when the entity was already visited
24975 elsif NCT_Tables_In_Use
24976 and then Present
(NCT_New_Entities
.Get
(Id
))
24980 -- Nothing to do when the declaration node of the entity is not in
24981 -- the subtree being replicated.
24983 elsif not In_Subtree
24984 (N
=> Declaration_Node
(Id
),
24990 -- Create a new entity by directly copying the old entity. This
24991 -- action causes all attributes of the old entity to be inherited.
24993 New_Id
:= New_Copy
(Id
);
24995 -- Create a new name for the new entity because the back end needs
24996 -- distinct names for debugging purposes, provided that the entity
24997 -- has already been analyzed.
24999 if Ekind
(Id
) /= E_Void
then
25000 Set_Chars
(New_Id
, New_Internal_Name
('T'));
25003 -- Update the Comes_From_Source and Sloc attributes of the entity in
25004 -- case the caller has supplied new values.
25006 Update_CFS_Sloc
(New_Id
);
25008 -- Establish the following mapping within table NCT_New_Entities:
25012 Add_New_Entity
(Id
, New_Id
);
25014 -- Deal with the semantic fields of entities. The fields are visited
25015 -- because they may mention entities which reside within the subtree
25018 Visit_Semantic_Fields
(Id
);
25025 procedure Visit_Field
25027 Par_Nod
: Node_Id
:= Empty
;
25028 Semantic
: Boolean := False)
25031 -- The field is empty
25033 if Field
= Union_Id
(Empty
) then
25036 -- The field is an entity/itype/node
25038 elsif Field
in Node_Range
then
25040 N
: constant Node_Id
:= Node_Id
(Field
);
25043 -- The field is an entity/itype
25045 if Nkind
(N
) in N_Entity
then
25047 -- Itypes are always visited
25049 if Is_Itype
(N
) then
25052 -- An entity is visited when it is either a syntactic field
25053 -- or when the caller treats it as a semantic attribute.
25055 elsif Parent
(N
) = Par_Nod
or else Semantic
then
25059 -- The field is a node
25062 -- A node is visited when it is either a syntactic field or
25063 -- when the caller treats it as a semantic attribute.
25065 if Parent
(N
) = Par_Nod
or else Semantic
then
25071 -- The field is an entity list
25073 elsif Field
in Elist_Range
then
25074 Visit_Elist
(Elist_Id
(Field
));
25076 -- The field is a syntax list
25078 elsif Field
in List_Range
then
25080 List
: constant List_Id
:= List_Id
(Field
);
25083 -- A syntax list is visited when it is either a syntactic field
25084 -- or when the caller treats it as a semantic attribute.
25086 if Parent
(List
) = Par_Nod
or else Semantic
then
25091 -- Otherwise the field denotes information which does not need to be
25092 -- visited (chars, literals, etc.).
25103 procedure Visit_Itype
(Itype
: Entity_Id
) is
25104 New_Assoc
: Node_Id
;
25105 New_Itype
: Entity_Id
;
25106 Old_Assoc
: Node_Id
;
25109 pragma Assert
(Nkind
(Itype
) in N_Entity
);
25110 pragma Assert
(Is_Itype
(Itype
));
25112 -- Itypes that describe the designated type of access to subprograms
25113 -- have the structure of subprogram declarations, with signatures,
25114 -- etc. Either we duplicate the signatures completely, or choose to
25115 -- share such itypes, which is fine because their elaboration will
25116 -- have no side effects.
25118 if Ekind
(Itype
) = E_Subprogram_Type
then
25121 -- Nothing to do if the itype was already visited
25123 elsif NCT_Tables_In_Use
25124 and then Present
(NCT_New_Entities
.Get
(Itype
))
25128 -- Nothing to do if the associated node of the itype is not within
25129 -- the subtree being replicated.
25131 elsif not In_Subtree
25132 (N
=> Associated_Node_For_Itype
(Itype
),
25138 -- Create a new itype by directly copying the old itype. This action
25139 -- causes all attributes of the old itype to be inherited.
25141 New_Itype
:= New_Copy
(Itype
);
25143 -- Create a new name for the new itype because the back end requires
25144 -- distinct names for debugging purposes.
25146 Set_Chars
(New_Itype
, New_Internal_Name
('T'));
25148 -- Update the Comes_From_Source and Sloc attributes of the itype in
25149 -- case the caller has supplied new values.
25151 Update_CFS_Sloc
(New_Itype
);
25153 -- Establish the following mapping within table NCT_New_Entities:
25155 -- Itype -> New_Itype
25157 Add_New_Entity
(Itype
, New_Itype
);
25159 -- The new itype must be unfrozen because the resulting subtree may
25160 -- be inserted anywhere and cause an earlier or later freezing.
25162 if Present
(Freeze_Node
(New_Itype
)) then
25163 Set_Freeze_Node
(New_Itype
, Empty
);
25164 Set_Is_Frozen
(New_Itype
, False);
25167 -- If a record subtype is simply copied, the entity list will be
25168 -- shared. Thus cloned_Subtype must be set to indicate the sharing.
25169 -- ??? What does this do?
25171 if Ekind
(Itype
) in E_Class_Wide_Subtype | E_Record_Subtype
then
25172 Set_Cloned_Subtype
(New_Itype
, Itype
);
25175 -- The associated node may denote an entity, in which case it may
25176 -- already have a new corresponding entity created during a prior
25177 -- call to Visit_Entity or Visit_Itype for the same subtree.
25180 -- Old_Assoc ---------> New_Assoc
25182 -- Created by Visit_Itype
25183 -- Itype -------------> New_Itype
25184 -- ANFI = Old_Assoc ANFI = Old_Assoc < must be updated
25186 -- In the example above, Old_Assoc is an arbitrary entity that was
25187 -- already visited for the same subtree and has a corresponding new
25188 -- entity New_Assoc. Old_Assoc was inherited by New_Itype by virtue
25189 -- of copying entities, however it must be updated to New_Assoc.
25191 Old_Assoc
:= Associated_Node_For_Itype
(Itype
);
25193 if Nkind
(Old_Assoc
) in N_Entity
then
25194 if NCT_Tables_In_Use
then
25195 New_Assoc
:= NCT_New_Entities
.Get
(Old_Assoc
);
25197 if Present
(New_Assoc
) then
25198 Set_Associated_Node_For_Itype
(New_Itype
, New_Assoc
);
25202 -- Otherwise the associated node denotes a node. Postpone the update
25203 -- until Phase 2 when the node is replicated. Establish the following
25204 -- mapping within table NCT_Pending_Itypes:
25206 -- Old_Assoc -> (New_Type, ...)
25209 Add_Pending_Itype
(Old_Assoc
, New_Itype
);
25212 -- Deal with the semantic fields of itypes. The fields are visited
25213 -- because they may mention entities that reside within the subtree
25216 Visit_Semantic_Fields
(Itype
);
25223 procedure Visit_List
(List
: List_Id
) is
25227 -- Note that the element of a syntactic list is always a node, never
25228 -- an entity or itype, hence the call to Visit_Node.
25230 if Present
(List
) then
25231 Elmt
:= First
(List
);
25232 while Present
(Elmt
) loop
25244 procedure Visit_Node
(N
: Node_Id
) is
25246 pragma Assert
(Nkind
(N
) not in N_Entity
);
25248 -- If the node is a quantified expression and expander is active,
25249 -- it contains an implicit declaration that may require a new entity
25250 -- when the condition has already been (pre)analyzed.
25252 if Nkind
(N
) = N_Expression_With_Actions
25254 (Nkind
(N
) = N_Quantified_Expression
and then Expander_Active
)
25256 EWA_Level
:= EWA_Level
+ 1;
25258 elsif EWA_Level
> 0
25259 and then Nkind
(N
) in N_Block_Statement
25260 | N_Subprogram_Body
25261 | N_Subprogram_Declaration
25263 EWA_Inner_Scope_Level
:= EWA_Inner_Scope_Level
+ 1;
25266 -- If the node is a block, we need to process all declarations
25267 -- in the block and make new entities for each.
25269 if Nkind
(N
) = N_Block_Statement
and then Present
(Declarations
(N
))
25272 Decl
: Node_Id
:= First
(Declarations
(N
));
25275 while Present
(Decl
) loop
25276 if Nkind
(Decl
) = N_Object_Declaration
then
25277 Add_New_Entity
(Defining_Identifier
(Decl
),
25278 New_Copy
(Defining_Identifier
(Decl
)));
25287 procedure Action
(U
: Union_Id
);
25288 procedure Action
(U
: Union_Id
) is
25290 Visit_Field
(Field
=> U
, Par_Nod
=> N
);
25293 procedure Walk
is new Walk_Sinfo_Fields
(Action
);
25299 and then Nkind
(N
) in N_Block_Statement
25300 | N_Subprogram_Body
25301 | N_Subprogram_Declaration
25303 EWA_Inner_Scope_Level
:= EWA_Inner_Scope_Level
- 1;
25305 elsif Nkind
(N
) = N_Expression_With_Actions
then
25306 EWA_Level
:= EWA_Level
- 1;
25310 ---------------------------
25311 -- Visit_Semantic_Fields --
25312 ---------------------------
25314 procedure Visit_Semantic_Fields
(Id
: Entity_Id
) is
25316 pragma Assert
(Nkind
(Id
) in N_Entity
);
25318 -- Discriminant_Constraint
25320 if Is_Type
(Id
) and then Has_Discriminants
(Base_Type
(Id
)) then
25322 (Field
=> Union_Id
(Discriminant_Constraint
(Id
)),
25329 (Field
=> Union_Id
(Etype
(Id
)),
25333 -- Packed_Array_Impl_Type
25335 if Is_Array_Type
(Id
) then
25336 if Present
(First_Index
(Id
)) then
25338 (Field
=> Union_Id
(List_Containing
(First_Index
(Id
))),
25342 if Is_Packed
(Id
) then
25344 (Field
=> Union_Id
(Packed_Array_Impl_Type
(Id
)),
25351 if Is_Discrete_Type
(Id
) then
25353 (Field
=> Union_Id
(Scalar_Range
(Id
)),
25356 end Visit_Semantic_Fields
;
25358 -- Start of processing for New_Copy_Tree
25361 -- Routine New_Copy_Tree performs a deep copy of a subtree by creating
25362 -- shallow copies for each node within, and then updating the child and
25363 -- parent pointers accordingly. This process is straightforward, however
25364 -- the routine must deal with the following complications:
25366 -- * Entities defined within N_Expression_With_Actions nodes must be
25367 -- replicated rather than shared to avoid introducing two identical
25368 -- symbols within the same scope. Note that no other expression can
25369 -- currently define entities.
25372 -- Source_Low : ...;
25373 -- Source_High : ...;
25375 -- <reference to Source_Low>
25376 -- <reference to Source_High>
25379 -- New_Copy_Tree handles this case by first creating new entities
25380 -- and then updating all existing references to point to these new
25387 -- <reference to New_Low>
25388 -- <reference to New_High>
25391 -- * Itypes defined within the subtree must be replicated to avoid any
25392 -- dependencies on invalid or inaccessible data.
25394 -- subtype Source_Itype is ... range Source_Low .. Source_High;
25396 -- New_Copy_Tree handles this case by first creating a new itype in
25397 -- the same fashion as entities, and then updating various relevant
25400 -- subtype New_Itype is ... range New_Low .. New_High;
25402 -- * The Associated_Node_For_Itype field of itypes must be updated to
25403 -- reference the proper replicated entity or node.
25405 -- * Semantic fields of entities such as Etype and Scope must be
25406 -- updated to reference the proper replicated entities.
25408 -- * Semantic fields of nodes such as First_Real_Statement must be
25409 -- updated to reference the proper replicated nodes.
25411 -- Finally, quantified expressions contain an implicit declaration for
25412 -- the bound variable. Given that quantified expressions appearing
25413 -- in contracts are copied to create pragmas and eventually checking
25414 -- procedures, a new bound variable must be created for each copy, to
25415 -- prevent multiple declarations of the same symbol.
25417 -- To meet all these demands, routine New_Copy_Tree is split into two
25420 -- Phase 1 traverses the tree in order to locate entities and itypes
25421 -- defined within the subtree. New entities are generated and saved in
25422 -- table NCT_New_Entities. The semantic fields of all new entities and
25423 -- itypes are then updated accordingly.
25425 -- Phase 2 traverses the tree in order to replicate each node. Various
25426 -- semantic fields of nodes and entities are updated accordingly.
25428 -- Preparatory phase. Clear the contents of tables NCT_New_Entities and
25429 -- NCT_Pending_Itypes in case a previous call to New_Copy_Tree left some
25432 if NCT_Tables_In_Use
then
25433 NCT_Tables_In_Use
:= False;
25435 NCT_New_Entities
.Reset
;
25436 NCT_Pending_Itypes
.Reset
;
25439 -- Populate tables NCT_New_Entities and NCT_Pending_Itypes with data
25440 -- supplied by a linear entity map. The tables offer faster access to
25443 Build_NCT_Tables
(Map
);
25445 -- Execute Phase 1. Traverse the subtree and generate new entities for
25446 -- the following cases:
25448 -- * An entity defined within an N_Expression_With_Actions node
25450 -- * An itype referenced within the subtree where the associated node
25451 -- is also in the subtree.
25453 -- All new entities are accessible via table NCT_New_Entities, which
25454 -- contains mappings of the form:
25456 -- Old_Entity -> New_Entity
25457 -- Old_Itype -> New_Itype
25459 -- In addition, the associated nodes of all new itypes are mapped in
25460 -- table NCT_Pending_Itypes:
25462 -- Assoc_Nod -> (New_Itype1, New_Itype2, .., New_ItypeN)
25464 Visit_Any_Node
(Source
);
25466 -- Update the semantic attributes of all new entities generated during
25467 -- Phase 1 before starting Phase 2. The updates could be performed in
25468 -- routine Corresponding_Entity, however this may cause the same entity
25469 -- to be updated multiple times, effectively generating useless nodes.
25470 -- Keeping the updates separates from Phase 2 ensures that only one set
25471 -- of attributes is generated for an entity at any one time.
25473 Update_New_Entities
(Map
);
25475 -- Execute Phase 2. Replicate the source subtree one node at a time.
25476 -- The following transformations take place:
25478 -- * References to entities and itypes are updated to refer to the
25479 -- new entities and itypes generated during Phase 1.
25481 -- * All Associated_Node_For_Itype attributes of itypes are updated
25482 -- to refer to the new replicated Associated_Node_For_Itype.
25484 return Copy_Node_With_Replacement
(Source
);
25487 -------------------------
25488 -- New_External_Entity --
25489 -------------------------
25491 function New_External_Entity
25492 (Kind
: Entity_Kind
;
25493 Scope_Id
: Entity_Id
;
25494 Sloc_Value
: Source_Ptr
;
25495 Related_Id
: Entity_Id
;
25496 Suffix
: Character;
25497 Suffix_Index
: Int
:= 0;
25498 Prefix
: Character := ' ') return Entity_Id
25500 N
: constant Entity_Id
:=
25501 Make_Defining_Identifier
(Sloc_Value
,
25503 (Chars
(Related_Id
), Suffix
, Suffix_Index
, Prefix
));
25506 Mutate_Ekind
(N
, Kind
);
25507 Set_Is_Internal
(N
, True);
25508 Append_Entity
(N
, Scope_Id
);
25509 Set_Public_Status
(N
);
25511 if Kind
in Type_Kind
then
25512 Reinit_Size_Align
(N
);
25516 end New_External_Entity
;
25518 -------------------------
25519 -- New_Internal_Entity --
25520 -------------------------
25522 function New_Internal_Entity
25523 (Kind
: Entity_Kind
;
25524 Scope_Id
: Entity_Id
;
25525 Sloc_Value
: Source_Ptr
;
25526 Id_Char
: Character) return Entity_Id
25528 N
: constant Entity_Id
:= Make_Temporary
(Sloc_Value
, Id_Char
);
25531 Mutate_Ekind
(N
, Kind
);
25532 Set_Is_Internal
(N
, True);
25533 Append_Entity
(N
, Scope_Id
);
25535 if Kind
in Type_Kind
then
25536 Reinit_Size_Align
(N
);
25540 end New_Internal_Entity
;
25546 function Next_Actual
(Actual_Id
: Node_Id
) return Node_Id
is
25547 Par
: constant Node_Id
:= Parent
(Actual_Id
);
25551 -- If we are pointing at a positional parameter, it is a member of a
25552 -- node list (the list of parameters), and the next parameter is the
25553 -- next node on the list, unless we hit a parameter association, then
25554 -- we shift to using the chain whose head is the First_Named_Actual in
25555 -- the parent, and then is threaded using the Next_Named_Actual of the
25556 -- Parameter_Association. All this fiddling is because the original node
25557 -- list is in the textual call order, and what we need is the
25558 -- declaration order.
25560 if Is_List_Member
(Actual_Id
) then
25561 N
:= Next
(Actual_Id
);
25563 if Nkind
(N
) = N_Parameter_Association
then
25565 -- In case of a build-in-place call, the call will no longer be a
25566 -- call; it will have been rewritten.
25568 if Nkind
(Par
) in N_Entry_Call_Statement
25570 | N_Procedure_Call_Statement
25572 return First_Named_Actual
(Par
);
25574 -- In case of a call rewritten in GNATprove mode while "inlining
25575 -- for proof" go to the original call.
25577 elsif Nkind
(Par
) = N_Null_Statement
then
25581 Nkind
(Original_Node
(Par
)) in N_Subprogram_Call
);
25583 return First_Named_Actual
(Original_Node
(Par
));
25592 return Next_Named_Actual
(Parent
(Actual_Id
));
25596 procedure Next_Actual
(Actual_Id
: in out Node_Id
) is
25598 Actual_Id
:= Next_Actual
(Actual_Id
);
25605 function Next_Global
(Node
: Node_Id
) return Node_Id
is
25607 -- The global item may either be in a list, or by itself, in which case
25608 -- there is no next global item with the same mode.
25610 if Is_List_Member
(Node
) then
25611 return Next
(Node
);
25617 procedure Next_Global
(Node
: in out Node_Id
) is
25619 Node
:= Next_Global
(Node
);
25622 ------------------------
25623 -- No_Caching_Enabled --
25624 ------------------------
25626 function No_Caching_Enabled
(Id
: Entity_Id
) return Boolean is
25627 pragma Assert
(Ekind
(Id
) = E_Variable
);
25628 Prag
: constant Node_Id
:= Get_Pragma
(Id
, Pragma_No_Caching
);
25632 if Present
(Prag
) then
25633 Arg1
:= First
(Pragma_Argument_Associations
(Prag
));
25635 -- The pragma has an optional Boolean expression, the related
25636 -- property is enabled only when the expression evaluates to True.
25638 if Present
(Arg1
) then
25639 return Is_True
(Expr_Value
(Get_Pragma_Arg
(Arg1
)));
25641 -- Otherwise the lack of expression enables the property by
25648 -- The property was never set in the first place
25653 end No_Caching_Enabled
;
25655 --------------------------
25656 -- No_Heap_Finalization --
25657 --------------------------
25659 function No_Heap_Finalization
(Typ
: Entity_Id
) return Boolean is
25661 if Ekind
(Typ
) in E_Access_Type | E_General_Access_Type
25662 and then Is_Library_Level_Entity
(Typ
)
25664 -- A global No_Heap_Finalization pragma applies to all library-level
25665 -- named access-to-object types.
25667 if Present
(No_Heap_Finalization_Pragma
) then
25670 -- The library-level named access-to-object type itself is subject to
25671 -- pragma No_Heap_Finalization.
25673 elsif Present
(Get_Pragma
(Typ
, Pragma_No_Heap_Finalization
)) then
25679 end No_Heap_Finalization
;
25681 -----------------------
25682 -- Normalize_Actuals --
25683 -----------------------
25685 -- Chain actuals according to formals of subprogram. If there are no named
25686 -- associations, the chain is simply the list of Parameter Associations,
25687 -- since the order is the same as the declaration order. If there are named
25688 -- associations, then the First_Named_Actual field in the N_Function_Call
25689 -- or N_Procedure_Call_Statement node points to the Parameter_Association
25690 -- node for the parameter that comes first in declaration order. The
25691 -- remaining named parameters are then chained in declaration order using
25692 -- Next_Named_Actual.
25694 -- This routine also verifies that the number of actuals is compatible with
25695 -- the number and default values of formals, but performs no type checking
25696 -- (type checking is done by the caller).
25698 -- If the matching succeeds, Success is set to True and the caller proceeds
25699 -- with type-checking. If the match is unsuccessful, then Success is set to
25700 -- False, and the caller attempts a different interpretation, if there is
25703 -- If the flag Report is on, the call is not overloaded, and a failure to
25704 -- match can be reported here, rather than in the caller.
25706 procedure Normalize_Actuals
25710 Success
: out Boolean)
25712 Actuals
: constant List_Id
:= Parameter_Associations
(N
);
25713 Actual
: Node_Id
:= Empty
;
25714 Formal
: Entity_Id
;
25715 Last
: Node_Id
:= Empty
;
25716 First_Named
: Node_Id
:= Empty
;
25719 Formals_To_Match
: Integer := 0;
25720 Actuals_To_Match
: Integer := 0;
25722 procedure Chain
(A
: Node_Id
);
25723 -- Add named actual at the proper place in the list, using the
25724 -- Next_Named_Actual link.
25726 function Reporting
return Boolean;
25727 -- Determines if an error is to be reported. To report an error, we
25728 -- need Report to be True, and also we do not report errors caused
25729 -- by calls to init procs that occur within other init procs. Such
25730 -- errors must always be cascaded errors, since if all the types are
25731 -- declared correctly, the compiler will certainly build decent calls.
25737 procedure Chain
(A
: Node_Id
) is
25741 -- Call node points to first actual in list
25743 Set_First_Named_Actual
(N
, Explicit_Actual_Parameter
(A
));
25746 Set_Next_Named_Actual
(Last
, Explicit_Actual_Parameter
(A
));
25750 Set_Next_Named_Actual
(Last
, Empty
);
25757 function Reporting
return Boolean is
25762 elsif not Within_Init_Proc
then
25765 elsif Is_Init_Proc
(Entity
(Name
(N
))) then
25773 -- Start of processing for Normalize_Actuals
25776 if Is_Access_Type
(S
) then
25778 -- The name in the call is a function call that returns an access
25779 -- to subprogram. The designated type has the list of formals.
25781 Formal
:= First_Formal
(Designated_Type
(S
));
25783 Formal
:= First_Formal
(S
);
25786 while Present
(Formal
) loop
25787 Formals_To_Match
:= Formals_To_Match
+ 1;
25788 Next_Formal
(Formal
);
25791 -- Find if there is a named association, and verify that no positional
25792 -- associations appear after named ones.
25794 if Present
(Actuals
) then
25795 Actual
:= First
(Actuals
);
25798 while Present
(Actual
)
25799 and then Nkind
(Actual
) /= N_Parameter_Association
25801 Actuals_To_Match
:= Actuals_To_Match
+ 1;
25805 if No
(Actual
) and Actuals_To_Match
= Formals_To_Match
then
25807 -- Most common case: positional notation, no defaults
25812 elsif Actuals_To_Match
> Formals_To_Match
then
25814 -- Too many actuals: will not work
25817 if Is_Entity_Name
(Name
(N
)) then
25818 Error_Msg_N
("too many arguments in call to&", Name
(N
));
25820 Error_Msg_N
("too many arguments in call", N
);
25828 First_Named
:= Actual
;
25830 while Present
(Actual
) loop
25831 if Nkind
(Actual
) /= N_Parameter_Association
then
25833 ("positional parameters not allowed after named ones", Actual
);
25838 Actuals_To_Match
:= Actuals_To_Match
+ 1;
25844 if Present
(Actuals
) then
25845 Actual
:= First
(Actuals
);
25848 Formal
:= First_Formal
(S
);
25849 while Present
(Formal
) loop
25851 -- Match the formals in order. If the corresponding actual is
25852 -- positional, nothing to do. Else scan the list of named actuals
25853 -- to find the one with the right name.
25855 if Present
(Actual
)
25856 and then Nkind
(Actual
) /= N_Parameter_Association
25859 Actuals_To_Match
:= Actuals_To_Match
- 1;
25860 Formals_To_Match
:= Formals_To_Match
- 1;
25863 -- For named parameters, search the list of actuals to find
25864 -- one that matches the next formal name.
25866 Actual
:= First_Named
;
25868 while Present
(Actual
) loop
25869 if Chars
(Selector_Name
(Actual
)) = Chars
(Formal
) then
25872 Actuals_To_Match
:= Actuals_To_Match
- 1;
25873 Formals_To_Match
:= Formals_To_Match
- 1;
25881 if Ekind
(Formal
) /= E_In_Parameter
25882 or else No
(Default_Value
(Formal
))
25885 if (Comes_From_Source
(S
)
25886 or else Sloc
(S
) = Standard_Location
)
25887 and then Is_Overloadable
(S
)
25891 Nkind
(Parent
(N
)) in N_Procedure_Call_Statement
25893 | N_Parameter_Association
25894 and then Ekind
(S
) /= E_Function
25896 Set_Etype
(N
, Etype
(S
));
25899 Error_Msg_Name_1
:= Chars
(S
);
25900 Error_Msg_Sloc
:= Sloc
(S
);
25902 ("missing argument for parameter & "
25903 & "in call to % declared #", N
, Formal
);
25906 elsif Is_Overloadable
(S
) then
25907 Error_Msg_Name_1
:= Chars
(S
);
25909 -- Point to type derivation that generated the
25912 Error_Msg_Sloc
:= Sloc
(Parent
(S
));
25915 ("missing argument for parameter & "
25916 & "in call to % (inherited) #", N
, Formal
);
25920 ("missing argument for parameter &", N
, Formal
);
25928 Formals_To_Match
:= Formals_To_Match
- 1;
25933 Next_Formal
(Formal
);
25936 if Formals_To_Match
= 0 and then Actuals_To_Match
= 0 then
25943 -- Find some superfluous named actual that did not get
25944 -- attached to the list of associations.
25946 Actual
:= First
(Actuals
);
25947 while Present
(Actual
) loop
25948 if Nkind
(Actual
) = N_Parameter_Association
25949 and then Actual
/= Last
25950 and then No
(Next_Named_Actual
(Actual
))
25952 -- A validity check may introduce a copy of a call that
25953 -- includes an extra actual (for example for an unrelated
25954 -- accessibility check). Check that the extra actual matches
25955 -- some extra formal, which must exist already because
25956 -- subprogram must be frozen at this point.
25958 if Present
(Extra_Formals
(S
))
25959 and then not Comes_From_Source
(Actual
)
25960 and then Nkind
(Actual
) = N_Parameter_Association
25961 and then Chars
(Extra_Formals
(S
)) =
25962 Chars
(Selector_Name
(Actual
))
25967 ("unmatched actual & in call", Selector_Name
(Actual
));
25979 end Normalize_Actuals
;
25981 --------------------------------
25982 -- Note_Possible_Modification --
25983 --------------------------------
25985 procedure Note_Possible_Modification
(N
: Node_Id
; Sure
: Boolean) is
25986 Modification_Comes_From_Source
: constant Boolean :=
25987 Comes_From_Source
(Parent
(N
));
25993 -- Loop to find referenced entity, if there is one
25999 if Is_Entity_Name
(Exp
) then
26000 Ent
:= Entity
(Exp
);
26002 -- If the entity is missing, it is an undeclared identifier,
26003 -- and there is nothing to annotate.
26009 elsif Nkind
(Exp
) = N_Explicit_Dereference
then
26011 P
: constant Node_Id
:= Prefix
(Exp
);
26014 -- In formal verification mode, keep track of all reads and
26015 -- writes through explicit dereferences.
26017 if GNATprove_Mode
then
26018 SPARK_Specific
.Generate_Dereference
(N
, 'm');
26021 if Nkind
(P
) = N_Selected_Component
26022 and then Present
(Entry_Formal
(Entity
(Selector_Name
(P
))))
26024 -- Case of a reference to an entry formal
26026 Ent
:= Entry_Formal
(Entity
(Selector_Name
(P
)));
26028 elsif Nkind
(P
) = N_Identifier
26029 and then Nkind
(Parent
(Entity
(P
))) = N_Object_Declaration
26030 and then Present
(Expression
(Parent
(Entity
(P
))))
26031 and then Nkind
(Expression
(Parent
(Entity
(P
)))) =
26034 -- Case of a reference to a value on which side effects have
26037 Exp
:= Prefix
(Expression
(Parent
(Entity
(P
))));
26045 elsif Nkind
(Exp
) in N_Type_Conversion | N_Unchecked_Type_Conversion
26047 Exp
:= Expression
(Exp
);
26050 elsif Nkind
(Exp
) in
26051 N_Slice | N_Indexed_Component | N_Selected_Component
26053 -- Special check, if the prefix is an access type, then return
26054 -- since we are modifying the thing pointed to, not the prefix.
26055 -- When we are expanding, most usually the prefix is replaced
26056 -- by an explicit dereference, and this test is not needed, but
26057 -- in some cases (notably -gnatc mode and generics) when we do
26058 -- not do full expansion, we need this special test.
26060 if Is_Access_Type
(Etype
(Prefix
(Exp
))) then
26063 -- Otherwise go to prefix and keep going
26066 Exp
:= Prefix
(Exp
);
26070 -- All other cases, not a modification
26076 -- Now look for entity being referenced
26078 if Present
(Ent
) then
26079 if Is_Object
(Ent
) then
26080 if Comes_From_Source
(Exp
)
26081 or else Modification_Comes_From_Source
26083 -- Give warning if pragma unmodified is given and we are
26084 -- sure this is a modification.
26086 if Has_Pragma_Unmodified
(Ent
) and then Sure
then
26088 -- Note that the entity may be present only as a result
26089 -- of pragma Unused.
26091 if Has_Pragma_Unused
(Ent
) then
26093 ("??aspect Unused specified for &!", N
, Ent
);
26096 ("??aspect Unmodified specified for &!", N
, Ent
);
26100 Set_Never_Set_In_Source
(Ent
, False);
26103 Set_Is_True_Constant
(Ent
, False);
26104 Set_Current_Value
(Ent
, Empty
);
26105 Set_Is_Known_Null
(Ent
, False);
26107 if not Can_Never_Be_Null
(Ent
) then
26108 Set_Is_Known_Non_Null
(Ent
, False);
26111 -- Follow renaming chain
26113 if Ekind
(Ent
) in E_Variable | E_Constant
26114 and then Present
(Renamed_Object
(Ent
))
26116 Exp
:= Renamed_Object
(Ent
);
26118 -- If the entity is the loop variable in an iteration over
26119 -- a container, retrieve container expression to indicate
26120 -- possible modification.
26122 if Present
(Related_Expression
(Ent
))
26123 and then Nkind
(Parent
(Related_Expression
(Ent
))) =
26124 N_Iterator_Specification
26126 Exp
:= Original_Node
(Related_Expression
(Ent
));
26131 -- The expression may be the renaming of a subcomponent of an
26132 -- array or container. The assignment to the subcomponent is
26133 -- a modification of the container.
26135 elsif Comes_From_Source
(Original_Node
(Exp
))
26136 and then Nkind
(Original_Node
(Exp
)) in
26137 N_Selected_Component | N_Indexed_Component
26139 Exp
:= Prefix
(Original_Node
(Exp
));
26143 -- Generate a reference only if the assignment comes from
26144 -- source. This excludes, for example, calls to a dispatching
26145 -- assignment operation when the left-hand side is tagged. In
26146 -- GNATprove mode, we need those references also on generated
26147 -- code, as these are used to compute the local effects of
26150 if Modification_Comes_From_Source
or GNATprove_Mode
then
26151 Generate_Reference
(Ent
, Exp
, 'm');
26153 -- If the target of the assignment is the bound variable
26154 -- in an iterator, indicate that the corresponding array
26155 -- or container is also modified.
26157 if Ada_Version
>= Ada_2012
26158 and then Nkind
(Parent
(Ent
)) = N_Iterator_Specification
26161 Domain
: constant Node_Id
:= Name
(Parent
(Ent
));
26164 -- ??? In the full version of the construct, the
26165 -- domain of iteration can be given by an expression.
26167 if Is_Entity_Name
(Domain
) then
26168 Generate_Reference
(Entity
(Domain
), Exp
, 'm');
26169 Set_Is_True_Constant
(Entity
(Domain
), False);
26170 Set_Never_Set_In_Source
(Entity
(Domain
), False);
26179 -- If we are sure this is a modification from source, and we know
26180 -- this modifies a constant, then give an appropriate warning.
26183 and then Modification_Comes_From_Source
26184 and then Overlays_Constant
(Ent
)
26185 and then Address_Clause_Overlay_Warnings
26188 Addr
: constant Node_Id
:= Address_Clause
(Ent
);
26193 Find_Overlaid_Entity
(Addr
, O_Ent
, Off
);
26195 Error_Msg_Sloc
:= Sloc
(Addr
);
26197 ("?o?constant& may be modified via address clause#",
26208 end Note_Possible_Modification
;
26214 function Null_Status
(N
: Node_Id
) return Null_Status_Kind
is
26215 function Is_Null_Excluding_Def
(Def
: Node_Id
) return Boolean;
26216 -- Determine whether definition Def carries a null exclusion
26218 function Null_Status_Of_Entity
(Id
: Entity_Id
) return Null_Status_Kind
;
26219 -- Determine the null status of arbitrary entity Id
26221 function Null_Status_Of_Type
(Typ
: Entity_Id
) return Null_Status_Kind
;
26222 -- Determine the null status of type Typ
26224 ---------------------------
26225 -- Is_Null_Excluding_Def --
26226 ---------------------------
26228 function Is_Null_Excluding_Def
(Def
: Node_Id
) return Boolean is
26230 return Nkind
(Def
) in N_Access_Definition
26231 | N_Access_Function_Definition
26232 | N_Access_Procedure_Definition
26233 | N_Access_To_Object_Definition
26234 | N_Component_Definition
26235 | N_Derived_Type_Definition
26236 and then Null_Exclusion_Present
(Def
);
26237 end Is_Null_Excluding_Def
;
26239 ---------------------------
26240 -- Null_Status_Of_Entity --
26241 ---------------------------
26243 function Null_Status_Of_Entity
26244 (Id
: Entity_Id
) return Null_Status_Kind
26246 Decl
: constant Node_Id
:= Declaration_Node
(Id
);
26250 -- The value of an imported or exported entity may be set externally
26251 -- regardless of a null exclusion. As a result, the value cannot be
26252 -- determined statically.
26254 if Is_Imported
(Id
) or else Is_Exported
(Id
) then
26257 elsif Nkind
(Decl
) in N_Component_Declaration
26258 | N_Discriminant_Specification
26259 | N_Formal_Object_Declaration
26260 | N_Object_Declaration
26261 | N_Object_Renaming_Declaration
26262 | N_Parameter_Specification
26264 -- A component declaration yields a non-null value when either
26265 -- its component definition or access definition carries a null
26268 if Nkind
(Decl
) = N_Component_Declaration
then
26269 Def
:= Component_Definition
(Decl
);
26271 if Is_Null_Excluding_Def
(Def
) then
26272 return Is_Non_Null
;
26275 Def
:= Access_Definition
(Def
);
26277 if Present
(Def
) and then Is_Null_Excluding_Def
(Def
) then
26278 return Is_Non_Null
;
26281 -- A formal object declaration yields a non-null value if its
26282 -- access definition carries a null exclusion. If the object is
26283 -- default initialized, then the value depends on the expression.
26285 elsif Nkind
(Decl
) = N_Formal_Object_Declaration
then
26286 Def
:= Access_Definition
(Decl
);
26288 if Present
(Def
) and then Is_Null_Excluding_Def
(Def
) then
26289 return Is_Non_Null
;
26292 -- A constant may yield a null or non-null value depending on its
26293 -- initialization expression.
26295 elsif Ekind
(Id
) = E_Constant
then
26296 return Null_Status
(Constant_Value
(Id
));
26298 -- The construct yields a non-null value when it has a null
26301 elsif Null_Exclusion_Present
(Decl
) then
26302 return Is_Non_Null
;
26304 -- An object renaming declaration yields a non-null value if its
26305 -- access definition carries a null exclusion. Otherwise the value
26306 -- depends on the renamed name.
26308 elsif Nkind
(Decl
) = N_Object_Renaming_Declaration
then
26309 Def
:= Access_Definition
(Decl
);
26311 if Present
(Def
) and then Is_Null_Excluding_Def
(Def
) then
26312 return Is_Non_Null
;
26315 return Null_Status
(Name
(Decl
));
26320 -- At this point the declaration of the entity does not carry a null
26321 -- exclusion and lacks an initialization expression. Check the status
26324 return Null_Status_Of_Type
(Etype
(Id
));
26325 end Null_Status_Of_Entity
;
26327 -------------------------
26328 -- Null_Status_Of_Type --
26329 -------------------------
26331 function Null_Status_Of_Type
(Typ
: Entity_Id
) return Null_Status_Kind
is
26336 -- Traverse the type chain looking for types with null exclusion
26339 while Present
(Curr
) and then Etype
(Curr
) /= Curr
loop
26340 Decl
:= Parent
(Curr
);
26342 -- Guard against itypes which do not always have declarations. A
26343 -- type yields a non-null value if it carries a null exclusion.
26345 if Present
(Decl
) then
26346 if Nkind
(Decl
) = N_Full_Type_Declaration
26347 and then Is_Null_Excluding_Def
(Type_Definition
(Decl
))
26349 return Is_Non_Null
;
26351 elsif Nkind
(Decl
) = N_Subtype_Declaration
26352 and then Null_Exclusion_Present
(Decl
)
26354 return Is_Non_Null
;
26358 Curr
:= Etype
(Curr
);
26361 -- The type chain does not contain any null excluding types
26364 end Null_Status_Of_Type
;
26366 -- Start of processing for Null_Status
26369 -- Prevent cascaded errors or infinite loops when trying to determine
26370 -- the null status of an erroneous construct.
26372 if Error_Posted
(N
) then
26375 -- An allocator always creates a non-null value
26377 elsif Nkind
(N
) = N_Allocator
then
26378 return Is_Non_Null
;
26380 -- Taking the 'Access of something yields a non-null value
26382 elsif Nkind
(N
) = N_Attribute_Reference
26383 and then Attribute_Name
(N
) in Name_Access
26384 | Name_Unchecked_Access
26385 | Name_Unrestricted_Access
26387 return Is_Non_Null
;
26389 -- "null" yields null
26391 elsif Nkind
(N
) = N_Null
then
26394 -- Check the status of the operand of a type conversion
26396 elsif Nkind
(N
) = N_Type_Conversion
then
26397 return Null_Status
(Expression
(N
));
26399 -- The input denotes a reference to an entity. Determine whether the
26400 -- entity or its type yields a null or non-null value.
26402 elsif Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
26403 return Null_Status_Of_Entity
(Entity
(N
));
26406 -- Otherwise it is not possible to determine the null status of the
26407 -- subexpression at compile time without resorting to simple flow
26413 --------------------------------------
26414 -- Null_To_Null_Address_Convert_OK --
26415 --------------------------------------
26417 function Null_To_Null_Address_Convert_OK
26419 Typ
: Entity_Id
:= Empty
) return Boolean
26422 if not Relaxed_RM_Semantics
then
26426 if Nkind
(N
) = N_Null
then
26427 return Present
(Typ
) and then Is_Descendant_Of_Address
(Typ
);
26429 elsif Nkind
(N
) in N_Op_Compare
then
26431 L
: constant Node_Id
:= Left_Opnd
(N
);
26432 R
: constant Node_Id
:= Right_Opnd
(N
);
26435 -- We check the Etype of the complementary operand since the
26436 -- N_Null node is not decorated at this stage.
26439 ((Nkind
(L
) = N_Null
26440 and then Is_Descendant_Of_Address
(Etype
(R
)))
26442 (Nkind
(R
) = N_Null
26443 and then Is_Descendant_Of_Address
(Etype
(L
))));
26448 end Null_To_Null_Address_Convert_OK
;
26450 ---------------------------------
26451 -- Number_Of_Elements_In_Array --
26452 ---------------------------------
26454 function Number_Of_Elements_In_Array
(T
: Entity_Id
) return Int
is
26462 pragma Assert
(Is_Array_Type
(T
));
26464 Indx
:= First_Index
(T
);
26465 while Present
(Indx
) loop
26466 Typ
:= Underlying_Type
(Etype
(Indx
));
26468 -- Never look at junk bounds of a generic type
26470 if Is_Generic_Type
(Typ
) then
26474 -- Check the array bounds are known at compile time and return zero
26475 -- if they are not.
26477 Low
:= Type_Low_Bound
(Typ
);
26478 High
:= Type_High_Bound
(Typ
);
26480 if not Compile_Time_Known_Value
(Low
) then
26482 elsif not Compile_Time_Known_Value
(High
) then
26486 Num
* UI_To_Int
((Expr_Value
(High
) - Expr_Value
(Low
) + 1));
26493 end Number_Of_Elements_In_Array
;
26495 ---------------------------------
26496 -- Original_Aspect_Pragma_Name --
26497 ---------------------------------
26499 function Original_Aspect_Pragma_Name
(N
: Node_Id
) return Name_Id
is
26501 Item_Nam
: Name_Id
;
26504 pragma Assert
(Nkind
(N
) in N_Aspect_Specification | N_Pragma
);
26508 -- The pragma was generated to emulate an aspect, use the original
26509 -- aspect specification.
26511 if Nkind
(Item
) = N_Pragma
and then From_Aspect_Specification
(Item
) then
26512 Item
:= Corresponding_Aspect
(Item
);
26515 -- Retrieve the name of the aspect/pragma. As assertion pragmas from
26516 -- a generic instantiation might have been rewritten into pragma Check,
26517 -- we look at the original node for Item. Note also that Pre, Pre_Class,
26518 -- Post and Post_Class rewrite their pragma identifier to preserve the
26519 -- original name, so we look at the original node for the identifier.
26520 -- ??? this is kludgey
26522 if Nkind
(Item
) = N_Pragma
then
26524 Chars
(Original_Node
(Pragma_Identifier
(Original_Node
(Item
))));
26527 pragma Assert
(Nkind
(Item
) = N_Aspect_Specification
);
26528 Item_Nam
:= Chars
(Identifier
(Item
));
26531 -- Deal with 'Class by converting the name to its _XXX form
26533 if Class_Present
(Item
) then
26534 if Item_Nam
= Name_Invariant
then
26535 Item_Nam
:= Name_uInvariant
;
26537 elsif Item_Nam
= Name_Post
then
26538 Item_Nam
:= Name_uPost
;
26540 elsif Item_Nam
= Name_Pre
then
26541 Item_Nam
:= Name_uPre
;
26543 elsif Item_Nam
in Name_Type_Invariant | Name_Type_Invariant_Class
26545 Item_Nam
:= Name_uType_Invariant
;
26547 -- Nothing to do for other cases (e.g. a Check that derived from
26548 -- Pre_Class and has the flag set). Also we do nothing if the name
26549 -- is already in special _xxx form.
26555 end Original_Aspect_Pragma_Name
;
26557 --------------------------------------
26558 -- Original_Corresponding_Operation --
26559 --------------------------------------
26561 function Original_Corresponding_Operation
(S
: Entity_Id
) return Entity_Id
26563 Typ
: constant Entity_Id
:= Find_Dispatching_Type
(S
);
26566 -- If S is an inherited primitive S2 the original corresponding
26567 -- operation of S is the original corresponding operation of S2
26569 if Present
(Alias
(S
))
26570 and then Find_Dispatching_Type
(Alias
(S
)) /= Typ
26572 return Original_Corresponding_Operation
(Alias
(S
));
26574 -- If S overrides an inherited subprogram S2 the original corresponding
26575 -- operation of S is the original corresponding operation of S2
26577 elsif Present
(Overridden_Operation
(S
)) then
26578 return Original_Corresponding_Operation
(Overridden_Operation
(S
));
26580 -- otherwise it is S itself
26585 end Original_Corresponding_Operation
;
26587 -----------------------------------
26588 -- Original_View_In_Visible_Part --
26589 -----------------------------------
26591 function Original_View_In_Visible_Part
26592 (Typ
: Entity_Id
) return Boolean
26594 Scop
: constant Entity_Id
:= Scope
(Typ
);
26597 -- The scope must be a package
26599 if not Is_Package_Or_Generic_Package
(Scop
) then
26603 -- A type with a private declaration has a private view declared in
26604 -- the visible part.
26606 if Has_Private_Declaration
(Typ
) then
26610 return List_Containing
(Parent
(Typ
)) =
26611 Visible_Declarations
(Package_Specification
(Scop
));
26612 end Original_View_In_Visible_Part
;
26614 -------------------
26615 -- Output_Entity --
26616 -------------------
26618 procedure Output_Entity
(Id
: Entity_Id
) is
26622 Scop
:= Scope
(Id
);
26624 -- The entity may lack a scope when it is in the process of being
26625 -- analyzed. Use the current scope as an approximation.
26628 Scop
:= Current_Scope
;
26631 Output_Name
(Chars
(Id
), Scop
);
26638 procedure Output_Name
(Nam
: Name_Id
; Scop
: Entity_Id
:= Current_Scope
) is
26642 (Get_Qualified_Name
26653 -- This would be trivial, simply a test for an identifier that was a
26654 -- reference to a formal, if it were not for the fact that a previous call
26655 -- to Expand_Entry_Parameter will have modified the reference to the
26656 -- identifier. A formal of a protected entity is rewritten as
26658 -- typ!(recobj).rec.all'Constrained
26660 -- where rec is a selector whose Entry_Formal link points to the formal
26662 -- If the type of the entry parameter has a representation clause, then an
26663 -- extra temp is involved (see below).
26665 -- For a formal of a task entity, the formal is rewritten as a local
26668 -- In addition, a formal that is marked volatile because it is aliased
26669 -- through an address clause is rewritten as dereference as well.
26671 function Param_Entity
(N
: Node_Id
) return Entity_Id
is
26672 Renamed_Obj
: Node_Id
;
26675 -- Simple reference case
26677 if Nkind
(N
) in N_Identifier | N_Expanded_Name
then
26678 if Is_Formal
(Entity
(N
)) then
26681 -- Handle renamings of formal parameters and formals of tasks that
26682 -- are rewritten as renamings.
26684 elsif Nkind
(Parent
(Entity
(N
))) = N_Object_Renaming_Declaration
then
26685 Renamed_Obj
:= Get_Referenced_Object
(Renamed_Object
(Entity
(N
)));
26687 if Is_Entity_Name
(Renamed_Obj
)
26688 and then Is_Formal
(Entity
(Renamed_Obj
))
26690 return Entity
(Renamed_Obj
);
26693 Nkind
(Parent
(Parent
(Entity
(N
)))) = N_Accept_Statement
26700 if Nkind
(N
) = N_Explicit_Dereference
then
26702 P
: Node_Id
:= Prefix
(N
);
26708 -- If the type of an entry parameter has a representation
26709 -- clause, then the prefix is not a selected component, but
26710 -- instead a reference to a temp pointing at the selected
26711 -- component. In this case, set P to be the initial value of
26714 if Nkind
(P
) = N_Identifier
then
26717 if Ekind
(E
) = E_Constant
then
26718 Decl
:= Parent
(E
);
26720 if Nkind
(Decl
) = N_Object_Declaration
then
26721 P
:= Expression
(Decl
);
26726 if Nkind
(P
) = N_Selected_Component
then
26727 S
:= Selector_Name
(P
);
26729 if Present
(Entry_Formal
(Entity
(S
))) then
26730 return Entry_Formal
(Entity
(S
));
26733 elsif Nkind
(Original_Node
(N
)) = N_Identifier
then
26734 return Param_Entity
(Original_Node
(N
));
26743 ----------------------
26744 -- Policy_In_Effect --
26745 ----------------------
26747 function Policy_In_Effect
(Policy
: Name_Id
) return Name_Id
is
26748 function Policy_In_List
(List
: Node_Id
) return Name_Id
;
26749 -- Determine the mode of a policy in a N_Pragma list
26751 --------------------
26752 -- Policy_In_List --
26753 --------------------
26755 function Policy_In_List
(List
: Node_Id
) return Name_Id
is
26762 while Present
(Prag
) loop
26763 Arg1
:= First
(Pragma_Argument_Associations
(Prag
));
26764 Arg2
:= Next
(Arg1
);
26766 Arg1
:= Get_Pragma_Arg
(Arg1
);
26767 Arg2
:= Get_Pragma_Arg
(Arg2
);
26769 -- The current Check_Policy pragma matches the requested policy or
26770 -- appears in the single argument form (Assertion, policy_id).
26772 if Chars
(Arg1
) in Name_Assertion | Policy
then
26773 return Chars
(Arg2
);
26776 Prag
:= Next_Pragma
(Prag
);
26780 end Policy_In_List
;
26786 -- Start of processing for Policy_In_Effect
26789 if not Is_Valid_Assertion_Kind
(Policy
) then
26790 raise Program_Error
;
26793 -- Inspect all policy pragmas that appear within scopes (if any)
26795 Kind
:= Policy_In_List
(Check_Policy_List
);
26797 -- Inspect all configuration policy pragmas (if any)
26799 if Kind
= No_Name
then
26800 Kind
:= Policy_In_List
(Check_Policy_List_Config
);
26803 -- The context lacks policy pragmas, determine the mode based on whether
26804 -- assertions are enabled at the configuration level. This ensures that
26805 -- the policy is preserved when analyzing generics.
26807 if Kind
= No_Name
then
26808 if Assertions_Enabled_Config
then
26809 Kind
:= Name_Check
;
26811 Kind
:= Name_Ignore
;
26815 -- In CodePeer mode and GNATprove mode, we need to consider all
26816 -- assertions, unless they are disabled. Force Name_Check on
26817 -- ignored assertions.
26819 if Kind
in Name_Ignore | Name_Off
26820 and then (CodePeer_Mode
or GNATprove_Mode
)
26822 Kind
:= Name_Check
;
26826 end Policy_In_Effect
;
26828 -------------------------------
26829 -- Preanalyze_Without_Errors --
26830 -------------------------------
26832 procedure Preanalyze_Without_Errors
(N
: Node_Id
) is
26833 Status
: constant Boolean := Get_Ignore_Errors
;
26835 Set_Ignore_Errors
(True);
26837 Set_Ignore_Errors
(Status
);
26838 end Preanalyze_Without_Errors
;
26840 -----------------------
26841 -- Predicate_Enabled --
26842 -----------------------
26844 function Predicate_Enabled
(Typ
: Entity_Id
) return Boolean is
26846 return Present
(Predicate_Function
(Typ
))
26847 and then not Predicates_Ignored
(Typ
)
26848 and then not Predicate_Checks_Suppressed
(Empty
);
26849 end Predicate_Enabled
;
26851 ----------------------------------
26852 -- Predicate_Failure_Expression --
26853 ----------------------------------
26855 function Predicate_Failure_Expression
26856 (Typ
: Entity_Id
; Inherited_OK
: Boolean) return Node_Id
26858 PF_Aspect
: constant Node_Id
:=
26859 Find_Aspect
(Typ
, Aspect_Predicate_Failure
);
26861 -- Check for Predicate_Failure aspect specification via an
26862 -- aspect_specification (as opposed to via a pragma).
26864 if Present
(PF_Aspect
) then
26865 if Inherited_OK
or else Entity
(PF_Aspect
) = Typ
then
26866 return Expression
(PF_Aspect
);
26872 -- Check for Predicate_Failure aspect specification via a pragma.
26875 Rep_Item
: Node_Id
:= First_Rep_Item
(Typ
);
26877 while Present
(Rep_Item
) loop
26878 if Nkind
(Rep_Item
) = N_Pragma
26879 and then Get_Pragma_Id
(Rep_Item
) = Pragma_Predicate_Failure
26882 Arg1
: constant Node_Id
:=
26884 (First
(Pragma_Argument_Associations
(Rep_Item
)));
26885 Arg2
: constant Node_Id
:=
26887 (Next
(First
(Pragma_Argument_Associations
(Rep_Item
))));
26889 if Inherited_OK
or else
26890 (Nkind
(Arg1
) in N_Has_Entity
26891 and then Entity
(Arg1
) = Typ
)
26898 Next_Rep_Item
(Rep_Item
);
26902 -- If we are interested in an inherited Predicate_Failure aspect
26903 -- and we have an ancestor to inherit from, then recursively check
26906 if Inherited_OK
and then Present
(Nearest_Ancestor
(Typ
)) then
26907 return Predicate_Failure_Expression
(Nearest_Ancestor
(Typ
),
26908 Inherited_OK
=> True);
26912 end Predicate_Failure_Expression
;
26914 ----------------------------------
26915 -- Predicate_Tests_On_Arguments --
26916 ----------------------------------
26918 function Predicate_Tests_On_Arguments
(Subp
: Entity_Id
) return Boolean is
26920 -- Always test predicates on indirect call
26922 if Ekind
(Subp
) = E_Subprogram_Type
then
26925 -- Do not test predicates on call to generated default Finalize, since
26926 -- we are not interested in whether something we are finalizing (and
26927 -- typically destroying) satisfies its predicates.
26929 elsif Chars
(Subp
) = Name_Finalize
26930 and then not Comes_From_Source
(Subp
)
26934 -- Do not test predicates on any internally generated routines
26936 elsif Is_Internal_Name
(Chars
(Subp
)) then
26939 -- Do not test predicates on call to Init_Proc, since if needed the
26940 -- predicate test will occur at some other point.
26942 elsif Is_Init_Proc
(Subp
) then
26945 -- Do not test predicates on call to predicate function, since this
26946 -- would cause infinite recursion.
26948 elsif Ekind
(Subp
) = E_Function
26949 and then Is_Predicate_Function
(Subp
)
26953 -- For now, no other exceptions
26958 end Predicate_Tests_On_Arguments
;
26960 -----------------------
26961 -- Private_Component --
26962 -----------------------
26964 function Private_Component
(Type_Id
: Entity_Id
) return Entity_Id
is
26965 Ancestor
: constant Entity_Id
:= Base_Type
(Type_Id
);
26967 function Trace_Components
26969 Check
: Boolean) return Entity_Id
;
26970 -- Recursive function that does the work, and checks against circular
26971 -- definition for each subcomponent type.
26973 ----------------------
26974 -- Trace_Components --
26975 ----------------------
26977 function Trace_Components
26979 Check
: Boolean) return Entity_Id
26981 Btype
: constant Entity_Id
:= Base_Type
(T
);
26982 Component
: Entity_Id
;
26984 Candidate
: Entity_Id
:= Empty
;
26987 if Check
and then Btype
= Ancestor
then
26988 Error_Msg_N
("circular type definition", Type_Id
);
26992 if Is_Private_Type
(Btype
) and then not Is_Generic_Type
(Btype
) then
26993 if Present
(Full_View
(Btype
))
26994 and then Is_Record_Type
(Full_View
(Btype
))
26995 and then not Is_Frozen
(Btype
)
26997 -- To indicate that the ancestor depends on a private type, the
26998 -- current Btype is sufficient. However, to check for circular
26999 -- definition we must recurse on the full view.
27001 Candidate
:= Trace_Components
(Full_View
(Btype
), True);
27003 if Candidate
= Any_Type
then
27013 elsif Is_Array_Type
(Btype
) then
27014 return Trace_Components
(Component_Type
(Btype
), True);
27016 elsif Is_Record_Type
(Btype
) then
27017 Component
:= First_Entity
(Btype
);
27018 while Present
(Component
)
27019 and then Comes_From_Source
(Component
)
27021 -- Skip anonymous types generated by constrained components
27023 if not Is_Type
(Component
) then
27024 P
:= Trace_Components
(Etype
(Component
), True);
27026 if Present
(P
) then
27027 if P
= Any_Type
then
27035 Next_Entity
(Component
);
27043 end Trace_Components
;
27045 -- Start of processing for Private_Component
27048 return Trace_Components
(Type_Id
, False);
27049 end Private_Component
;
27051 ---------------------------
27052 -- Primitive_Names_Match --
27053 ---------------------------
27055 function Primitive_Names_Match
(E1
, E2
: Entity_Id
) return Boolean is
27056 function Non_Internal_Name
(E
: Entity_Id
) return Name_Id
;
27057 -- Given an internal name, returns the corresponding non-internal name
27059 ------------------------
27060 -- Non_Internal_Name --
27061 ------------------------
27063 function Non_Internal_Name
(E
: Entity_Id
) return Name_Id
is
27065 Get_Name_String
(Chars
(E
));
27066 Name_Len
:= Name_Len
- 1;
27068 end Non_Internal_Name
;
27070 -- Start of processing for Primitive_Names_Match
27073 pragma Assert
(Present
(E1
) and then Present
(E2
));
27075 return Chars
(E1
) = Chars
(E2
)
27077 (not Is_Internal_Name
(Chars
(E1
))
27078 and then Is_Internal_Name
(Chars
(E2
))
27079 and then Non_Internal_Name
(E2
) = Chars
(E1
))
27081 (not Is_Internal_Name
(Chars
(E2
))
27082 and then Is_Internal_Name
(Chars
(E1
))
27083 and then Non_Internal_Name
(E1
) = Chars
(E2
))
27085 (Is_Predefined_Dispatching_Operation
(E1
)
27086 and then Is_Predefined_Dispatching_Operation
(E2
)
27087 and then Same_TSS
(E1
, E2
))
27089 (Is_Init_Proc
(E1
) and then Is_Init_Proc
(E2
));
27090 end Primitive_Names_Match
;
27092 -----------------------
27093 -- Process_End_Label --
27094 -----------------------
27096 procedure Process_End_Label
27105 Label_Ref
: Boolean;
27106 -- Set True if reference to end label itself is required
27109 -- Gets set to the operator symbol or identifier that references the
27110 -- entity Ent. For the child unit case, this is the identifier from the
27111 -- designator. For other cases, this is simply Endl.
27113 procedure Generate_Parent_Ref
(N
: Node_Id
; E
: Entity_Id
);
27114 -- N is an identifier node that appears as a parent unit reference in
27115 -- the case where Ent is a child unit. This procedure generates an
27116 -- appropriate cross-reference entry. E is the corresponding entity.
27118 -------------------------
27119 -- Generate_Parent_Ref --
27120 -------------------------
27122 procedure Generate_Parent_Ref
(N
: Node_Id
; E
: Entity_Id
) is
27124 -- If names do not match, something weird, skip reference
27126 if Chars
(E
) = Chars
(N
) then
27128 -- Generate the reference. We do NOT consider this as a reference
27129 -- for unreferenced symbol purposes.
27131 Generate_Reference
(E
, N
, 'r', Set_Ref
=> False, Force
=> True);
27133 if Style_Check
then
27134 Style
.Check_Identifier
(N
, E
);
27137 end Generate_Parent_Ref
;
27139 -- Start of processing for Process_End_Label
27142 -- If no node, ignore. This happens in some error situations, and
27143 -- also for some internally generated structures where no end label
27144 -- references are required in any case.
27150 -- Nothing to do if no End_Label, happens for internally generated
27151 -- constructs where we don't want an end label reference anyway. Also
27152 -- nothing to do if Endl is a string literal, which means there was
27153 -- some prior error (bad operator symbol)
27155 Endl
:= End_Label
(N
);
27157 if No
(Endl
) or else Nkind
(Endl
) = N_String_Literal
then
27161 -- Reference node is not in extended main source unit
27163 if not In_Extended_Main_Source_Unit
(N
) then
27165 -- Generally we do not collect references except for the extended
27166 -- main source unit. The one exception is the 'e' entry for a
27167 -- package spec, where it is useful for a client to have the
27168 -- ending information to define scopes.
27174 Label_Ref
:= False;
27176 -- For this case, we can ignore any parent references, but we
27177 -- need the package name itself for the 'e' entry.
27179 if Nkind
(Endl
) = N_Designator
then
27180 Endl
:= Identifier
(Endl
);
27184 -- Reference is in extended main source unit
27189 -- For designator, generate references for the parent entries
27191 if Nkind
(Endl
) = N_Designator
then
27193 -- Generate references for the prefix if the END line comes from
27194 -- source (otherwise we do not need these references) We climb the
27195 -- scope stack to find the expected entities.
27197 if Comes_From_Source
(Endl
) then
27198 Nam
:= Name
(Endl
);
27199 Scop
:= Current_Scope
;
27200 while Nkind
(Nam
) = N_Selected_Component
loop
27201 Scop
:= Scope
(Scop
);
27202 exit when No
(Scop
);
27203 Generate_Parent_Ref
(Selector_Name
(Nam
), Scop
);
27204 Nam
:= Prefix
(Nam
);
27207 if Present
(Scop
) then
27208 Generate_Parent_Ref
(Nam
, Scope
(Scop
));
27212 Endl
:= Identifier
(Endl
);
27216 -- If the end label is not for the given entity, then either we have
27217 -- some previous error, or this is a generic instantiation for which
27218 -- we do not need to make a cross-reference in this case anyway. In
27219 -- either case we simply ignore the call.
27221 if Chars
(Ent
) /= Chars
(Endl
) then
27225 -- If label was really there, then generate a normal reference and then
27226 -- adjust the location in the end label to point past the name (which
27227 -- should almost always be the semicolon).
27229 Loc
:= Sloc
(Endl
);
27231 if Comes_From_Source
(Endl
) then
27233 -- If a label reference is required, then do the style check and
27234 -- generate an l-type cross-reference entry for the label
27237 if Style_Check
then
27238 Style
.Check_Identifier
(Endl
, Ent
);
27241 Generate_Reference
(Ent
, Endl
, 'l', Set_Ref
=> False);
27244 -- Set the location to point past the label (normally this will
27245 -- mean the semicolon immediately following the label). This is
27246 -- done for the sake of the 'e' or 't' entry generated below.
27248 Get_Decoded_Name_String
(Chars
(Endl
));
27249 Set_Sloc
(Endl
, Sloc
(Endl
) + Source_Ptr
(Name_Len
));
27252 -- Now generate the e/t reference
27254 Generate_Reference
(Ent
, Endl
, Typ
, Set_Ref
=> False, Force
=> True);
27256 -- Restore Sloc, in case modified above, since we have an identifier
27257 -- and the normal Sloc should be left set in the tree.
27259 Set_Sloc
(Endl
, Loc
);
27260 end Process_End_Label
;
27262 --------------------------------
27263 -- Propagate_Concurrent_Flags --
27264 --------------------------------
27266 procedure Propagate_Concurrent_Flags
27268 Comp_Typ
: Entity_Id
)
27271 if Has_Task
(Comp_Typ
) then
27272 Set_Has_Task
(Typ
);
27275 if Has_Protected
(Comp_Typ
) then
27276 Set_Has_Protected
(Typ
);
27279 if Has_Timing_Event
(Comp_Typ
) then
27280 Set_Has_Timing_Event
(Typ
);
27282 end Propagate_Concurrent_Flags
;
27284 ------------------------------
27285 -- Propagate_DIC_Attributes --
27286 ------------------------------
27288 procedure Propagate_DIC_Attributes
27290 From_Typ
: Entity_Id
)
27292 DIC_Proc
: Entity_Id
;
27293 Partial_DIC_Proc
: Entity_Id
;
27296 if Present
(Typ
) and then Present
(From_Typ
) then
27297 pragma Assert
(Is_Type
(Typ
) and then Is_Type
(From_Typ
));
27299 -- Nothing to do if both the source and the destination denote the
27302 if From_Typ
= Typ
then
27305 -- Nothing to do when the destination denotes an incomplete type
27306 -- because the DIC is associated with the current instance of a
27307 -- private type, thus it can never apply to an incomplete type.
27309 elsif Is_Incomplete_Type
(Typ
) then
27313 DIC_Proc
:= DIC_Procedure
(From_Typ
);
27314 Partial_DIC_Proc
:= Partial_DIC_Procedure
(From_Typ
);
27316 -- The setting of the attributes is intentionally conservative. This
27317 -- prevents accidental clobbering of enabled attributes. We need to
27318 -- call Base_Type twice, because it is sometimes not set to an actual
27321 if Has_Inherited_DIC
(From_Typ
) then
27322 Set_Has_Inherited_DIC
(Base_Type
(Base_Type
(Typ
)));
27325 if Has_Own_DIC
(From_Typ
) then
27326 Set_Has_Own_DIC
(Base_Type
(Base_Type
(Typ
)));
27329 if Present
(DIC_Proc
) and then No
(DIC_Procedure
(Typ
)) then
27330 Set_DIC_Procedure
(Typ
, DIC_Proc
);
27333 if Present
(Partial_DIC_Proc
)
27334 and then No
(Partial_DIC_Procedure
(Typ
))
27336 Set_Partial_DIC_Procedure
(Typ
, Partial_DIC_Proc
);
27339 end Propagate_DIC_Attributes
;
27341 ------------------------------------
27342 -- Propagate_Invariant_Attributes --
27343 ------------------------------------
27345 procedure Propagate_Invariant_Attributes
27347 From_Typ
: Entity_Id
)
27349 Full_IP
: Entity_Id
;
27350 Part_IP
: Entity_Id
;
27353 if Present
(Typ
) and then Present
(From_Typ
) then
27354 pragma Assert
(Is_Type
(Typ
) and then Is_Type
(From_Typ
));
27356 -- Nothing to do if both the source and the destination denote the
27359 if From_Typ
= Typ
then
27363 Full_IP
:= Invariant_Procedure
(From_Typ
);
27364 Part_IP
:= Partial_Invariant_Procedure
(From_Typ
);
27366 -- The setting of the attributes is intentionally conservative. This
27367 -- prevents accidental clobbering of enabled attributes. We need to
27368 -- call Base_Type twice, because it is sometimes not set to an actual
27371 if Has_Inheritable_Invariants
(From_Typ
) then
27372 Set_Has_Inheritable_Invariants
(Base_Type
(Base_Type
(Typ
)));
27375 if Has_Inherited_Invariants
(From_Typ
) then
27376 Set_Has_Inherited_Invariants
(Base_Type
(Base_Type
(Typ
)));
27379 if Has_Own_Invariants
(From_Typ
) then
27380 Set_Has_Own_Invariants
(Base_Type
(Base_Type
(Typ
)));
27383 if Present
(Full_IP
) and then No
(Invariant_Procedure
(Typ
)) then
27384 Set_Invariant_Procedure
(Typ
, Full_IP
);
27387 if Present
(Part_IP
) and then No
(Partial_Invariant_Procedure
(Typ
))
27389 Set_Partial_Invariant_Procedure
(Typ
, Part_IP
);
27392 end Propagate_Invariant_Attributes
;
27394 ------------------------------------
27395 -- Propagate_Predicate_Attributes --
27396 ------------------------------------
27398 procedure Propagate_Predicate_Attributes
27400 From_Typ
: Entity_Id
)
27402 Pred_Func
: Entity_Id
;
27404 if Present
(Typ
) and then Present
(From_Typ
) then
27405 pragma Assert
(Is_Type
(Typ
) and then Is_Type
(From_Typ
));
27407 -- Nothing to do if both the source and the destination denote the
27410 if From_Typ
= Typ
then
27414 Pred_Func
:= Predicate_Function
(From_Typ
);
27416 -- The setting of the attributes is intentionally conservative. This
27417 -- prevents accidental clobbering of enabled attributes.
27419 if Has_Predicates
(From_Typ
) then
27420 Set_Has_Predicates
(Typ
);
27423 if Present
(Pred_Func
) and then No
(Predicate_Function
(Typ
)) then
27424 Set_Predicate_Function
(Typ
, Pred_Func
);
27427 end Propagate_Predicate_Attributes
;
27429 ---------------------------------------
27430 -- Record_Possible_Part_Of_Reference --
27431 ---------------------------------------
27433 procedure Record_Possible_Part_Of_Reference
27434 (Var_Id
: Entity_Id
;
27437 Encap
: constant Entity_Id
:= Encapsulating_State
(Var_Id
);
27441 -- The variable is a constituent of a single protected/task type. Such
27442 -- a variable acts as a component of the type and must appear within a
27443 -- specific region (SPARK RM 9(3)). Instead of recording the reference,
27444 -- verify its legality now.
27446 if Present
(Encap
) and then Is_Single_Concurrent_Object
(Encap
) then
27447 Check_Part_Of_Reference
(Var_Id
, Ref
);
27449 -- The variable is subject to pragma Part_Of and may eventually become a
27450 -- constituent of a single protected/task type. Record the reference to
27451 -- verify its placement when the contract of the variable is analyzed.
27453 elsif Present
(Get_Pragma
(Var_Id
, Pragma_Part_Of
)) then
27454 Refs
:= Part_Of_References
(Var_Id
);
27457 Refs
:= New_Elmt_List
;
27458 Set_Part_Of_References
(Var_Id
, Refs
);
27461 Append_Elmt
(Ref
, Refs
);
27463 end Record_Possible_Part_Of_Reference
;
27469 function Referenced
(Id
: Entity_Id
; Expr
: Node_Id
) return Boolean is
27470 Seen
: Boolean := False;
27472 function Is_Reference
(N
: Node_Id
) return Traverse_Result
;
27473 -- Determine whether node N denotes a reference to Id. If this is the
27474 -- case, set global flag Seen to True and stop the traversal.
27480 function Is_Reference
(N
: Node_Id
) return Traverse_Result
is
27482 if Is_Entity_Name
(N
)
27483 and then Present
(Entity
(N
))
27484 and then Entity
(N
) = Id
27493 procedure Inspect_Expression
is new Traverse_Proc
(Is_Reference
);
27495 -- Start of processing for Referenced
27498 Inspect_Expression
(Expr
);
27502 ------------------------------------
27503 -- References_Generic_Formal_Type --
27504 ------------------------------------
27506 function References_Generic_Formal_Type
(N
: Node_Id
) return Boolean is
27508 function Process
(N
: Node_Id
) return Traverse_Result
;
27509 -- Process one node in search for generic formal type
27515 function Process
(N
: Node_Id
) return Traverse_Result
is
27517 if Nkind
(N
) in N_Has_Entity
then
27519 E
: constant Entity_Id
:= Entity
(N
);
27521 if Present
(E
) then
27522 if Is_Generic_Type
(E
) then
27524 elsif Present
(Etype
(E
))
27525 and then Is_Generic_Type
(Etype
(E
))
27536 function Traverse
is new Traverse_Func
(Process
);
27537 -- Traverse tree to look for generic type
27540 if Inside_A_Generic
then
27541 return Traverse
(N
) = Abandon
;
27545 end References_Generic_Formal_Type
;
27547 -------------------------------
27548 -- Remove_Entity_And_Homonym --
27549 -------------------------------
27551 procedure Remove_Entity_And_Homonym
(Id
: Entity_Id
) is
27553 Remove_Entity
(Id
);
27554 Remove_Homonym
(Id
);
27555 end Remove_Entity_And_Homonym
;
27557 --------------------
27558 -- Remove_Homonym --
27559 --------------------
27561 procedure Remove_Homonym
(Id
: Entity_Id
) is
27563 Prev
: Entity_Id
:= Empty
;
27566 if Id
= Current_Entity
(Id
) then
27567 if Present
(Homonym
(Id
)) then
27568 Set_Current_Entity
(Homonym
(Id
));
27570 Set_Name_Entity_Id
(Chars
(Id
), Empty
);
27574 Hom
:= Current_Entity
(Id
);
27575 while Present
(Hom
) and then Hom
/= Id
loop
27577 Hom
:= Homonym
(Hom
);
27580 -- If Id is not on the homonym chain, nothing to do
27582 if Present
(Hom
) then
27583 Set_Homonym
(Prev
, Homonym
(Id
));
27586 end Remove_Homonym
;
27588 ------------------------------
27589 -- Remove_Overloaded_Entity --
27590 ------------------------------
27592 procedure Remove_Overloaded_Entity
(Id
: Entity_Id
) is
27593 procedure Remove_Primitive_Of
(Typ
: Entity_Id
);
27594 -- Remove primitive subprogram Id from the list of primitives that
27595 -- belong to type Typ.
27597 -------------------------
27598 -- Remove_Primitive_Of --
27599 -------------------------
27601 procedure Remove_Primitive_Of
(Typ
: Entity_Id
) is
27605 if Is_Tagged_Type
(Typ
) then
27606 Prims
:= Direct_Primitive_Operations
(Typ
);
27608 if Present
(Prims
) then
27609 Remove
(Prims
, Id
);
27612 end Remove_Primitive_Of
;
27616 Formal
: Entity_Id
;
27618 -- Start of processing for Remove_Overloaded_Entity
27621 Remove_Entity_And_Homonym
(Id
);
27623 -- The entity denotes a primitive subprogram. Remove it from the list of
27624 -- primitives of the associated controlling type.
27626 if Ekind
(Id
) in E_Function | E_Procedure
and then Is_Primitive
(Id
) then
27627 Formal
:= First_Formal
(Id
);
27628 while Present
(Formal
) loop
27629 if Is_Controlling_Formal
(Formal
) then
27630 Remove_Primitive_Of
(Etype
(Formal
));
27634 Next_Formal
(Formal
);
27637 if Ekind
(Id
) = E_Function
and then Has_Controlling_Result
(Id
) then
27638 Remove_Primitive_Of
(Etype
(Id
));
27641 end Remove_Overloaded_Entity
;
27643 ---------------------
27644 -- Rep_To_Pos_Flag --
27645 ---------------------
27647 function Rep_To_Pos_Flag
(E
: Entity_Id
; Loc
: Source_Ptr
) return Node_Id
is
27649 return New_Occurrence_Of
27650 (Boolean_Literals
(not Range_Checks_Suppressed
(E
)), Loc
);
27651 end Rep_To_Pos_Flag
;
27653 --------------------
27654 -- Require_Entity --
27655 --------------------
27657 procedure Require_Entity
(N
: Node_Id
) is
27659 if Is_Entity_Name
(N
) and then No
(Entity
(N
)) then
27660 if Total_Errors_Detected
/= 0 then
27661 Set_Entity
(N
, Any_Id
);
27663 raise Program_Error
;
27666 end Require_Entity
;
27668 ------------------------------
27669 -- Requires_Transient_Scope --
27670 ------------------------------
27672 function Requires_Transient_Scope
(Typ
: Entity_Id
) return Boolean is
27674 return Needs_Secondary_Stack
(Typ
) or else Needs_Finalization
(Typ
);
27675 end Requires_Transient_Scope
;
27677 --------------------------
27678 -- Reset_Analyzed_Flags --
27679 --------------------------
27681 procedure Reset_Analyzed_Flags
(N
: Node_Id
) is
27682 function Clear_Analyzed
(N
: Node_Id
) return Traverse_Result
;
27683 -- Function used to reset Analyzed flags in tree. Note that we do
27684 -- not reset Analyzed flags in entities, since there is no need to
27685 -- reanalyze entities, and indeed, it is wrong to do so, since it
27686 -- can result in generating auxiliary stuff more than once.
27688 --------------------
27689 -- Clear_Analyzed --
27690 --------------------
27692 function Clear_Analyzed
(N
: Node_Id
) return Traverse_Result
is
27694 if Nkind
(N
) not in N_Entity
then
27695 Set_Analyzed
(N
, False);
27699 end Clear_Analyzed
;
27701 procedure Reset_Analyzed
is new Traverse_Proc
(Clear_Analyzed
);
27703 -- Start of processing for Reset_Analyzed_Flags
27706 Reset_Analyzed
(N
);
27707 end Reset_Analyzed_Flags
;
27709 ------------------------
27710 -- Restore_SPARK_Mode --
27711 ------------------------
27713 procedure Restore_SPARK_Mode
27714 (Mode
: SPARK_Mode_Type
;
27718 SPARK_Mode
:= Mode
;
27719 SPARK_Mode_Pragma
:= Prag
;
27720 end Restore_SPARK_Mode
;
27722 --------------------------------
27723 -- Returns_Unconstrained_Type --
27724 --------------------------------
27726 function Returns_Unconstrained_Type
(Subp
: Entity_Id
) return Boolean is
27728 return Ekind
(Subp
) = E_Function
27729 and then not Is_Scalar_Type
(Etype
(Subp
))
27730 and then not Is_Access_Type
(Etype
(Subp
))
27731 and then not Is_Constrained
(Etype
(Subp
));
27732 end Returns_Unconstrained_Type
;
27734 ----------------------------
27735 -- Root_Type_Of_Full_View --
27736 ----------------------------
27738 function Root_Type_Of_Full_View
(T
: Entity_Id
) return Entity_Id
is
27739 Rtyp
: constant Entity_Id
:= Root_Type
(T
);
27742 -- The root type of the full view may itself be a private type. Keep
27743 -- looking for the ultimate derivation parent.
27745 if Is_Private_Type
(Rtyp
) and then Present
(Full_View
(Rtyp
)) then
27746 return Root_Type_Of_Full_View
(Full_View
(Rtyp
));
27750 end Root_Type_Of_Full_View
;
27752 ---------------------------
27753 -- Safe_To_Capture_Value --
27754 ---------------------------
27756 function Safe_To_Capture_Value
27759 Cond
: Boolean := False) return Boolean
27762 -- The only entities for which we track constant values are variables
27763 -- that are not renamings, constants and formal parameters, so check
27764 -- if we have this case.
27766 -- Note: it may seem odd to track constant values for constants, but in
27767 -- fact this routine is used for other purposes than simply capturing
27768 -- the value. In particular, the setting of Known[_Non]_Null and
27771 if (Ekind
(Ent
) = E_Variable
and then No
(Renamed_Object
(Ent
)))
27773 Ekind
(Ent
) = E_Constant
27779 -- For conditionals, we also allow loop parameters
27781 elsif Cond
and then Ekind
(Ent
) = E_Loop_Parameter
then
27784 -- For all other cases, not just unsafe, but impossible to capture
27785 -- Current_Value, since the above are the only entities which have
27786 -- Current_Value fields.
27792 -- Skip if volatile or aliased, since funny things might be going on in
27793 -- these cases which we cannot necessarily track. Also skip any variable
27794 -- for which an address clause is given, or whose address is taken. Also
27795 -- never capture value of library level variables (an attempt to do so
27796 -- can occur in the case of package elaboration code).
27798 if Treat_As_Volatile
(Ent
)
27799 or else Is_Aliased
(Ent
)
27800 or else Present
(Address_Clause
(Ent
))
27801 or else Address_Taken
(Ent
)
27802 or else (Is_Library_Level_Entity
(Ent
)
27803 and then Ekind
(Ent
) = E_Variable
)
27808 -- OK, all above conditions are met. We also require that the scope of
27809 -- the reference be the same as the scope of the entity, not counting
27810 -- packages and blocks and loops.
27813 E_Scope
: constant Entity_Id
:= Scope
(Ent
);
27814 R_Scope
: Entity_Id
;
27817 R_Scope
:= Current_Scope
;
27818 while R_Scope
/= Standard_Standard
loop
27819 exit when R_Scope
= E_Scope
;
27821 if Ekind
(R_Scope
) not in E_Package | E_Block | E_Loop
then
27824 R_Scope
:= Scope
(R_Scope
);
27829 -- We also require that the reference does not appear in a context
27830 -- where it is not sure to be executed (i.e. a conditional context
27831 -- or an exception handler). We skip this if Cond is True, since the
27832 -- capturing of values from conditional tests handles this ok.
27834 if Cond
or else No
(N
) then
27845 -- Seems dubious that case expressions are not handled here ???
27848 while Present
(P
) loop
27849 if Nkind
(P
) = N_If_Statement
27850 or else Nkind
(P
) = N_Case_Statement
27851 or else (Nkind
(P
) in N_Short_Circuit
27852 and then Desc
= Right_Opnd
(P
))
27853 or else (Nkind
(P
) = N_If_Expression
27854 and then Desc
/= First
(Expressions
(P
)))
27855 or else Nkind
(P
) = N_Exception_Handler
27856 or else Nkind
(P
) = N_Selective_Accept
27857 or else Nkind
(P
) = N_Conditional_Entry_Call
27858 or else Nkind
(P
) = N_Timed_Entry_Call
27859 or else Nkind
(P
) = N_Asynchronous_Select
27867 -- A special Ada 2012 case: the original node may be part
27868 -- of the else_actions of a conditional expression, in which
27869 -- case it might not have been expanded yet, and appears in
27870 -- a non-syntactic list of actions. In that case it is clearly
27871 -- not safe to save a value.
27874 and then Is_List_Member
(Desc
)
27875 and then No
(Parent
(List_Containing
(Desc
)))
27883 -- OK, looks safe to set value
27886 end Safe_To_Capture_Value
;
27892 function Same_Name
(N1
, N2
: Node_Id
) return Boolean is
27893 K1
: constant Node_Kind
:= Nkind
(N1
);
27894 K2
: constant Node_Kind
:= Nkind
(N2
);
27897 if (K1
= N_Identifier
or else K1
= N_Defining_Identifier
)
27898 and then (K2
= N_Identifier
or else K2
= N_Defining_Identifier
)
27900 return Chars
(N1
) = Chars
(N2
);
27902 elsif (K1
= N_Selected_Component
or else K1
= N_Expanded_Name
)
27903 and then (K2
= N_Selected_Component
or else K2
= N_Expanded_Name
)
27905 return Same_Name
(Selector_Name
(N1
), Selector_Name
(N2
))
27906 and then Same_Name
(Prefix
(N1
), Prefix
(N2
));
27917 function Same_Object
(Node1
, Node2
: Node_Id
) return Boolean is
27918 N1
: constant Node_Id
:= Original_Node
(Node1
);
27919 N2
: constant Node_Id
:= Original_Node
(Node2
);
27920 -- We do the tests on original nodes, since we are most interested
27921 -- in the original source, not any expansion that got in the way.
27923 K1
: constant Node_Kind
:= Nkind
(N1
);
27924 K2
: constant Node_Kind
:= Nkind
(N2
);
27927 -- First case, both are entities with same entity
27929 if K1
in N_Has_Entity
and then K2
in N_Has_Entity
then
27931 EN1
: constant Entity_Id
:= Entity
(N1
);
27932 EN2
: constant Entity_Id
:= Entity
(N2
);
27934 if Present
(EN1
) and then Present
(EN2
)
27935 and then (Ekind
(EN1
) in E_Variable | E_Constant
27936 or else Is_Formal
(EN1
))
27944 -- Second case, selected component with same selector, same record
27946 if K1
= N_Selected_Component
27947 and then K2
= N_Selected_Component
27948 and then Chars
(Selector_Name
(N1
)) = Chars
(Selector_Name
(N2
))
27950 return Same_Object
(Prefix
(N1
), Prefix
(N2
));
27952 -- Third case, indexed component with same subscripts, same array
27954 elsif K1
= N_Indexed_Component
27955 and then K2
= N_Indexed_Component
27956 and then Same_Object
(Prefix
(N1
), Prefix
(N2
))
27961 E1
:= First
(Expressions
(N1
));
27962 E2
:= First
(Expressions
(N2
));
27963 while Present
(E1
) loop
27964 if not Same_Value
(E1
, E2
) then
27975 -- Fourth case, slice of same array with same bounds
27978 and then K2
= N_Slice
27979 and then Nkind
(Discrete_Range
(N1
)) = N_Range
27980 and then Nkind
(Discrete_Range
(N2
)) = N_Range
27981 and then Same_Value
(Low_Bound
(Discrete_Range
(N1
)),
27982 Low_Bound
(Discrete_Range
(N2
)))
27983 and then Same_Value
(High_Bound
(Discrete_Range
(N1
)),
27984 High_Bound
(Discrete_Range
(N2
)))
27986 return Same_Name
(Prefix
(N1
), Prefix
(N2
));
27988 -- All other cases, not clearly the same object
27995 ---------------------------------
27996 -- Same_Or_Aliased_Subprograms --
27997 ---------------------------------
27999 function Same_Or_Aliased_Subprograms
28001 E
: Entity_Id
) return Boolean
28003 Subp_Alias
: constant Entity_Id
:= Alias
(S
);
28005 return S
= E
or else (Present
(Subp_Alias
) and then Subp_Alias
= E
);
28006 end Same_Or_Aliased_Subprograms
;
28012 function Same_Type
(T1
, T2
: Entity_Id
) return Boolean is
28017 elsif not Is_Constrained
(T1
)
28018 and then not Is_Constrained
(T2
)
28019 and then Base_Type
(T1
) = Base_Type
(T2
)
28023 -- For now don't bother with case of identical constraints, to be
28024 -- fiddled with later on perhaps (this is only used for optimization
28025 -- purposes, so it is not critical to do a best possible job)
28036 function Same_Value
(Node1
, Node2
: Node_Id
) return Boolean is
28038 if Compile_Time_Known_Value
(Node1
)
28039 and then Compile_Time_Known_Value
(Node2
)
28041 -- Handle properly compile-time expressions that are not
28044 if Is_String_Type
(Etype
(Node1
)) then
28045 return Expr_Value_S
(Node1
) = Expr_Value_S
(Node2
);
28048 return Expr_Value
(Node1
) = Expr_Value
(Node2
);
28051 elsif Same_Object
(Node1
, Node2
) then
28058 --------------------
28059 -- Set_SPARK_Mode --
28060 --------------------
28062 procedure Set_SPARK_Mode
(Context
: Entity_Id
) is
28064 -- Do not consider illegal or partially decorated constructs
28066 if Ekind
(Context
) = E_Void
or else Error_Posted
(Context
) then
28069 elsif Present
(SPARK_Pragma
(Context
)) then
28071 (Mode
=> Get_SPARK_Mode_From_Annotation
(SPARK_Pragma
(Context
)),
28072 Prag
=> SPARK_Pragma
(Context
));
28074 end Set_SPARK_Mode
;
28076 -------------------------
28077 -- Scalar_Part_Present --
28078 -------------------------
28080 function Scalar_Part_Present
(Typ
: Entity_Id
) return Boolean is
28081 Val_Typ
: constant Entity_Id
:= Validated_View
(Typ
);
28085 if Is_Scalar_Type
(Val_Typ
) then
28088 elsif Is_Array_Type
(Val_Typ
) then
28089 return Scalar_Part_Present
(Component_Type
(Val_Typ
));
28091 elsif Is_Record_Type
(Val_Typ
) then
28092 Field
:= First_Component_Or_Discriminant
(Val_Typ
);
28093 while Present
(Field
) loop
28094 if Scalar_Part_Present
(Etype
(Field
)) then
28098 Next_Component_Or_Discriminant
(Field
);
28103 end Scalar_Part_Present
;
28105 ------------------------
28106 -- Scope_Is_Transient --
28107 ------------------------
28109 function Scope_Is_Transient
return Boolean is
28111 return Scope_Stack
.Table
(Scope_Stack
.Last
).Is_Transient
;
28112 end Scope_Is_Transient
;
28118 function Scope_Within
28119 (Inner
: Entity_Id
;
28120 Outer
: Entity_Id
) return Boolean
28126 while Present
(Curr
) and then Curr
/= Standard_Standard
loop
28127 Curr
:= Scope
(Curr
);
28129 if Curr
= Outer
then
28132 -- A selective accept body appears within a task type, but the
28133 -- enclosing subprogram is the procedure of the task body.
28135 elsif Ekind
(Implementation_Base_Type
(Curr
)) = E_Task_Type
28137 Outer
= Task_Body_Procedure
(Implementation_Base_Type
(Curr
))
28141 -- Ditto for the body of a protected operation
28143 elsif Is_Subprogram
(Curr
)
28144 and then Outer
= Protected_Body_Subprogram
(Curr
)
28148 -- Outside of its scope, a synchronized type may just be private
28150 elsif Is_Private_Type
(Curr
)
28151 and then Present
(Full_View
(Curr
))
28152 and then Is_Concurrent_Type
(Full_View
(Curr
))
28154 return Scope_Within
(Full_View
(Curr
), Outer
);
28161 --------------------------
28162 -- Scope_Within_Or_Same --
28163 --------------------------
28165 function Scope_Within_Or_Same
28166 (Inner
: Entity_Id
;
28167 Outer
: Entity_Id
) return Boolean
28169 Curr
: Entity_Id
:= Inner
;
28172 -- Similar to the above, but check for scope identity first
28174 while Present
(Curr
) and then Curr
/= Standard_Standard
loop
28175 if Curr
= Outer
then
28178 elsif Ekind
(Implementation_Base_Type
(Curr
)) = E_Task_Type
28180 Outer
= Task_Body_Procedure
(Implementation_Base_Type
(Curr
))
28184 elsif Is_Subprogram
(Curr
)
28185 and then Outer
= Protected_Body_Subprogram
(Curr
)
28189 elsif Is_Private_Type
(Curr
)
28190 and then Present
(Full_View
(Curr
))
28192 if Full_View
(Curr
) = Outer
then
28195 return Scope_Within
(Full_View
(Curr
), Outer
);
28199 Curr
:= Scope
(Curr
);
28203 end Scope_Within_Or_Same
;
28205 ------------------------
28206 -- Set_Current_Entity --
28207 ------------------------
28209 -- The given entity is to be set as the currently visible definition of its
28210 -- associated name (i.e. the Node_Id associated with its name). All we have
28211 -- to do is to get the name from the identifier, and then set the
28212 -- associated Node_Id to point to the given entity.
28214 procedure Set_Current_Entity
(E
: Entity_Id
) is
28216 Set_Name_Entity_Id
(Chars
(E
), E
);
28217 end Set_Current_Entity
;
28219 ---------------------------
28220 -- Set_Debug_Info_Needed --
28221 ---------------------------
28223 procedure Set_Debug_Info_Needed
(T
: Entity_Id
) is
28225 procedure Set_Debug_Info_Needed_If_Not_Set
(E
: Entity_Id
);
28226 pragma Inline
(Set_Debug_Info_Needed_If_Not_Set
);
28227 -- Used to set debug info in a related node if not set already
28229 --------------------------------------
28230 -- Set_Debug_Info_Needed_If_Not_Set --
28231 --------------------------------------
28233 procedure Set_Debug_Info_Needed_If_Not_Set
(E
: Entity_Id
) is
28235 if Present
(E
) and then not Needs_Debug_Info
(E
) then
28236 Set_Debug_Info_Needed
(E
);
28238 -- For a private type, indicate that the full view also needs
28239 -- debug information.
28242 and then Is_Private_Type
(E
)
28243 and then Present
(Full_View
(E
))
28245 Set_Debug_Info_Needed
(Full_View
(E
));
28248 end Set_Debug_Info_Needed_If_Not_Set
;
28250 -- Start of processing for Set_Debug_Info_Needed
28253 -- Nothing to do if there is no available entity
28258 -- Nothing to do for an entity with suppressed debug information
28260 elsif Debug_Info_Off
(T
) then
28263 -- Nothing to do for an ignored Ghost entity because the entity will be
28264 -- eliminated from the tree.
28266 elsif Is_Ignored_Ghost_Entity
(T
) then
28269 -- Nothing to do if entity comes from a predefined file. Library files
28270 -- are compiled without debug information, but inlined bodies of these
28271 -- routines may appear in user code, and debug information on them ends
28272 -- up complicating debugging the user code.
28274 elsif In_Inlined_Body
and then In_Predefined_Unit
(T
) then
28275 Set_Needs_Debug_Info
(T
, False);
28278 -- Set flag in entity itself. Note that we will go through the following
28279 -- circuitry even if the flag is already set on T. That's intentional,
28280 -- it makes sure that the flag will be set in subsidiary entities.
28282 Set_Needs_Debug_Info
(T
);
28284 -- Set flag on subsidiary entities if not set already
28286 if Is_Object
(T
) then
28287 Set_Debug_Info_Needed_If_Not_Set
(Etype
(T
));
28289 elsif Is_Type
(T
) then
28290 Set_Debug_Info_Needed_If_Not_Set
(Etype
(T
));
28292 if Is_Record_Type
(T
) then
28294 Ent
: Entity_Id
:= First_Entity
(T
);
28296 while Present
(Ent
) loop
28297 Set_Debug_Info_Needed_If_Not_Set
(Ent
);
28302 -- For a class wide subtype, we also need debug information
28303 -- for the equivalent type.
28305 if Ekind
(T
) = E_Class_Wide_Subtype
then
28306 Set_Debug_Info_Needed_If_Not_Set
(Equivalent_Type
(T
));
28309 elsif Is_Array_Type
(T
) then
28310 Set_Debug_Info_Needed_If_Not_Set
(Component_Type
(T
));
28313 Indx
: Node_Id
:= First_Index
(T
);
28315 while Present
(Indx
) loop
28316 Set_Debug_Info_Needed_If_Not_Set
(Etype
(Indx
));
28321 -- For a packed array type, we also need debug information for
28322 -- the type used to represent the packed array. Conversely, we
28323 -- also need it for the former if we need it for the latter.
28325 if Is_Packed
(T
) then
28326 Set_Debug_Info_Needed_If_Not_Set
(Packed_Array_Impl_Type
(T
));
28329 if Is_Packed_Array_Impl_Type
(T
) then
28330 Set_Debug_Info_Needed_If_Not_Set
(Original_Array_Type
(T
));
28333 elsif Is_Access_Type
(T
) then
28334 Set_Debug_Info_Needed_If_Not_Set
(Directly_Designated_Type
(T
));
28336 elsif Is_Private_Type
(T
) then
28338 FV
: constant Entity_Id
:= Full_View
(T
);
28341 Set_Debug_Info_Needed_If_Not_Set
(FV
);
28343 -- If the full view is itself a derived private type, we need
28344 -- debug information on its underlying type.
28347 and then Is_Private_Type
(FV
)
28348 and then Present
(Underlying_Full_View
(FV
))
28350 Set_Needs_Debug_Info
(Underlying_Full_View
(FV
));
28354 elsif Is_Protected_Type
(T
) then
28355 Set_Debug_Info_Needed_If_Not_Set
(Corresponding_Record_Type
(T
));
28357 elsif Is_Scalar_Type
(T
) then
28359 -- If the subrange bounds are materialized by dedicated constant
28360 -- objects, also include them in the debug info to make sure the
28361 -- debugger can properly use them.
28363 if Present
(Scalar_Range
(T
))
28364 and then Nkind
(Scalar_Range
(T
)) = N_Range
28367 Low_Bnd
: constant Node_Id
:= Type_Low_Bound
(T
);
28368 High_Bnd
: constant Node_Id
:= Type_High_Bound
(T
);
28371 if Is_Entity_Name
(Low_Bnd
) then
28372 Set_Debug_Info_Needed_If_Not_Set
(Entity
(Low_Bnd
));
28375 if Is_Entity_Name
(High_Bnd
) then
28376 Set_Debug_Info_Needed_If_Not_Set
(Entity
(High_Bnd
));
28382 end Set_Debug_Info_Needed
;
28384 --------------------------------
28385 -- Set_Debug_Info_Defining_Id --
28386 --------------------------------
28388 procedure Set_Debug_Info_Defining_Id
(N
: Node_Id
) is
28390 if Comes_From_Source
(Defining_Identifier
(N
)) then
28391 Set_Debug_Info_Needed
(Defining_Identifier
(N
));
28393 end Set_Debug_Info_Defining_Id
;
28395 ----------------------------
28396 -- Set_Entity_With_Checks --
28397 ----------------------------
28399 procedure Set_Entity_With_Checks
(N
: Node_Id
; Val
: Entity_Id
) is
28400 Val_Actual
: Entity_Id
;
28402 Post_Node
: Node_Id
;
28405 -- Unconditionally set the entity
28407 Set_Entity
(N
, Val
);
28409 -- The node to post on is the selector in the case of an expanded name,
28410 -- and otherwise the node itself.
28412 if Nkind
(N
) = N_Expanded_Name
then
28413 Post_Node
:= Selector_Name
(N
);
28418 -- Check for violation of No_Fixed_IO
28420 if Restriction_Check_Required
(No_Fixed_IO
)
28422 ((RTU_Loaded
(Ada_Text_IO
)
28423 and then (Is_RTE
(Val
, RE_Decimal_IO
)
28425 Is_RTE
(Val
, RE_Fixed_IO
)))
28428 (RTU_Loaded
(Ada_Wide_Text_IO
)
28429 and then (Is_RTE
(Val
, RO_WT_Decimal_IO
)
28431 Is_RTE
(Val
, RO_WT_Fixed_IO
)))
28434 (RTU_Loaded
(Ada_Wide_Wide_Text_IO
)
28435 and then (Is_RTE
(Val
, RO_WW_Decimal_IO
)
28437 Is_RTE
(Val
, RO_WW_Fixed_IO
))))
28439 -- A special extra check, don't complain about a reference from within
28440 -- the Ada.Interrupts package itself!
28442 and then not In_Same_Extended_Unit
(N
, Val
)
28444 Check_Restriction
(No_Fixed_IO
, Post_Node
);
28447 -- Remaining checks are only done on source nodes. Note that we test
28448 -- for violation of No_Fixed_IO even on non-source nodes, because the
28449 -- cases for checking violations of this restriction are instantiations
28450 -- where the reference in the instance has Comes_From_Source False.
28452 if not Comes_From_Source
(N
) then
28456 -- Check for violation of No_Abort_Statements, which is triggered by
28457 -- call to Ada.Task_Identification.Abort_Task.
28459 if Restriction_Check_Required
(No_Abort_Statements
)
28460 and then (Is_RTE
(Val
, RE_Abort_Task
))
28462 -- A special extra check, don't complain about a reference from within
28463 -- the Ada.Task_Identification package itself!
28465 and then not In_Same_Extended_Unit
(N
, Val
)
28467 Check_Restriction
(No_Abort_Statements
, Post_Node
);
28470 if Val
= Standard_Long_Long_Integer
then
28471 Check_Restriction
(No_Long_Long_Integers
, Post_Node
);
28474 -- Check for violation of No_Dynamic_Attachment
28476 if Restriction_Check_Required
(No_Dynamic_Attachment
)
28477 and then RTU_Loaded
(Ada_Interrupts
)
28478 and then (Is_RTE
(Val
, RE_Is_Reserved
) or else
28479 Is_RTE
(Val
, RE_Is_Attached
) or else
28480 Is_RTE
(Val
, RE_Current_Handler
) or else
28481 Is_RTE
(Val
, RE_Attach_Handler
) or else
28482 Is_RTE
(Val
, RE_Exchange_Handler
) or else
28483 Is_RTE
(Val
, RE_Detach_Handler
) or else
28484 Is_RTE
(Val
, RE_Reference
))
28486 -- A special extra check, don't complain about a reference from within
28487 -- the Ada.Interrupts package itself!
28489 and then not In_Same_Extended_Unit
(N
, Val
)
28491 Check_Restriction
(No_Dynamic_Attachment
, Post_Node
);
28494 -- Check for No_Implementation_Identifiers
28496 if Restriction_Check_Required
(No_Implementation_Identifiers
) then
28498 -- We have an implementation defined entity if it is marked as
28499 -- implementation defined, or is defined in a package marked as
28500 -- implementation defined. However, library packages themselves
28501 -- are excluded (we don't want to flag Interfaces itself, just
28502 -- the entities within it).
28504 if (Is_Implementation_Defined
(Val
)
28506 (Present
(Scope
(Val
))
28507 and then Is_Implementation_Defined
(Scope
(Val
))))
28508 and then not (Is_Package_Or_Generic_Package
(Val
)
28509 and then Is_Library_Level_Entity
(Val
))
28511 Check_Restriction
(No_Implementation_Identifiers
, Post_Node
);
28515 -- Do the style check
28518 and then not Suppress_Style_Checks
(Val
)
28519 and then not In_Instance
28521 if Nkind
(N
) = N_Identifier
then
28523 elsif Nkind
(N
) = N_Expanded_Name
then
28524 Nod
:= Selector_Name
(N
);
28529 -- A special situation arises for derived operations, where we want
28530 -- to do the check against the parent (since the Sloc of the derived
28531 -- operation points to the derived type declaration itself).
28534 while not Comes_From_Source
(Val_Actual
)
28535 and then Nkind
(Val_Actual
) in N_Entity
28536 and then (Ekind
(Val_Actual
) = E_Enumeration_Literal
28537 or else Is_Subprogram_Or_Generic_Subprogram
(Val_Actual
))
28538 and then Present
(Alias
(Val_Actual
))
28540 Val_Actual
:= Alias
(Val_Actual
);
28543 -- Renaming declarations for generic actuals do not come from source,
28544 -- and have a different name from that of the entity they rename, so
28545 -- there is no style check to perform here.
28547 if Chars
(Nod
) = Chars
(Val_Actual
) then
28548 Style
.Check_Identifier
(Nod
, Val_Actual
);
28551 end Set_Entity_With_Checks
;
28553 ------------------------------
28554 -- Set_Invalid_Scalar_Value --
28555 ------------------------------
28557 procedure Set_Invalid_Scalar_Value
28558 (Scal_Typ
: Float_Scalar_Id
;
28561 Slot
: Ureal
renames Invalid_Floats
(Scal_Typ
);
28564 -- Detect an attempt to set a different value for the same scalar type
28566 pragma Assert
(Slot
= No_Ureal
);
28568 end Set_Invalid_Scalar_Value
;
28570 ------------------------------
28571 -- Set_Invalid_Scalar_Value --
28572 ------------------------------
28574 procedure Set_Invalid_Scalar_Value
28575 (Scal_Typ
: Integer_Scalar_Id
;
28578 Slot
: Uint
renames Invalid_Integers
(Scal_Typ
);
28581 -- Detect an attempt to set a different value for the same scalar type
28583 pragma Assert
(No
(Slot
));
28585 end Set_Invalid_Scalar_Value
;
28587 ------------------------
28588 -- Set_Name_Entity_Id --
28589 ------------------------
28591 procedure Set_Name_Entity_Id
(Id
: Name_Id
; Val
: Entity_Id
) is
28593 Set_Name_Table_Int
(Id
, Int
(Val
));
28594 end Set_Name_Entity_Id
;
28596 ---------------------
28597 -- Set_Next_Actual --
28598 ---------------------
28600 procedure Set_Next_Actual
(Ass1_Id
: Node_Id
; Ass2_Id
: Node_Id
) is
28602 if Nkind
(Parent
(Ass1_Id
)) = N_Parameter_Association
then
28603 Set_First_Named_Actual
(Parent
(Ass1_Id
), Ass2_Id
);
28605 end Set_Next_Actual
;
28607 ----------------------------------
28608 -- Set_Optimize_Alignment_Flags --
28609 ----------------------------------
28611 procedure Set_Optimize_Alignment_Flags
(E
: Entity_Id
) is
28613 if Optimize_Alignment
= 'S' then
28614 Set_Optimize_Alignment_Space
(E
);
28615 elsif Optimize_Alignment
= 'T' then
28616 Set_Optimize_Alignment_Time
(E
);
28618 end Set_Optimize_Alignment_Flags
;
28620 -----------------------
28621 -- Set_Public_Status --
28622 -----------------------
28624 procedure Set_Public_Status
(Id
: Entity_Id
) is
28625 S
: constant Entity_Id
:= Current_Scope
;
28627 function Within_HSS_Or_If
(E
: Entity_Id
) return Boolean;
28628 -- Determines if E is defined within handled statement sequence or
28629 -- an if statement, returns True if so, False otherwise.
28631 ----------------------
28632 -- Within_HSS_Or_If --
28633 ----------------------
28635 function Within_HSS_Or_If
(E
: Entity_Id
) return Boolean is
28638 N
:= Declaration_Node
(E
);
28646 N_Handled_Sequence_Of_Statements | N_If_Statement
28651 end Within_HSS_Or_If
;
28653 -- Start of processing for Set_Public_Status
28656 -- Everything in the scope of Standard is public
28658 if S
= Standard_Standard
then
28659 Set_Is_Public
(Id
);
28661 -- Entity is definitely not public if enclosing scope is not public
28663 elsif not Is_Public
(S
) then
28666 -- An object or function declaration that occurs in a handled sequence
28667 -- of statements or within an if statement is the declaration for a
28668 -- temporary object or local subprogram generated by the expander. It
28669 -- never needs to be made public and furthermore, making it public can
28670 -- cause back end problems.
28672 elsif Nkind
(Parent
(Id
)) in
28673 N_Object_Declaration | N_Function_Specification
28674 and then Within_HSS_Or_If
(Id
)
28678 -- Entities in public packages or records are public
28680 elsif Ekind
(S
) = E_Package
or Is_Record_Type
(S
) then
28681 Set_Is_Public
(Id
);
28683 -- The bounds of an entry family declaration can generate object
28684 -- declarations that are visible to the back-end, e.g. in the
28685 -- the declaration of a composite type that contains tasks.
28687 elsif Is_Concurrent_Type
(S
)
28688 and then not Has_Completion
(S
)
28689 and then Nkind
(Parent
(Id
)) = N_Object_Declaration
28691 Set_Is_Public
(Id
);
28693 end Set_Public_Status
;
28695 -----------------------------
28696 -- Set_Referenced_Modified --
28697 -----------------------------
28699 procedure Set_Referenced_Modified
(N
: Node_Id
; Out_Param
: Boolean) is
28703 -- Deal with indexed or selected component where prefix is modified
28705 if Nkind
(N
) in N_Indexed_Component | N_Selected_Component
then
28706 Pref
:= Prefix
(N
);
28708 -- If prefix is access type, then it is the designated object that is
28709 -- being modified, which means we have no entity to set the flag on.
28711 if No
(Etype
(Pref
)) or else Is_Access_Type
(Etype
(Pref
)) then
28714 -- Otherwise chase the prefix
28717 Set_Referenced_Modified
(Pref
, Out_Param
);
28720 -- Otherwise see if we have an entity name (only other case to process)
28722 elsif Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
28723 Set_Referenced_As_LHS
(Entity
(N
), not Out_Param
);
28724 Set_Referenced_As_Out_Parameter
(Entity
(N
), Out_Param
);
28726 end Set_Referenced_Modified
;
28732 procedure Set_Rep_Info
(T1
: Entity_Id
; T2
: Entity_Id
) is
28734 Set_Is_Atomic
(T1
, Is_Atomic
(T2
));
28735 Set_Is_Independent
(T1
, Is_Independent
(T2
));
28736 Set_Is_Volatile_Full_Access
(T1
, Is_Volatile_Full_Access
(T2
));
28738 if Is_Base_Type
(T1
) then
28739 Set_Is_Volatile
(T1
, Is_Volatile
(T2
));
28743 ----------------------------
28744 -- Set_Scope_Is_Transient --
28745 ----------------------------
28747 procedure Set_Scope_Is_Transient
(V
: Boolean := True) is
28749 Scope_Stack
.Table
(Scope_Stack
.Last
).Is_Transient
:= V
;
28750 end Set_Scope_Is_Transient
;
28752 -------------------
28753 -- Set_Size_Info --
28754 -------------------
28756 procedure Set_Size_Info
(T1
, T2
: Entity_Id
) is
28758 -- We copy Esize, but not RM_Size, since in general RM_Size is
28759 -- subtype specific and does not get inherited by all subtypes.
28761 Copy_Esize
(To
=> T1
, From
=> T2
);
28762 Set_Has_Biased_Representation
(T1
, Has_Biased_Representation
(T2
));
28764 if Is_Discrete_Or_Fixed_Point_Type
(T1
)
28766 Is_Discrete_Or_Fixed_Point_Type
(T2
)
28768 Set_Is_Unsigned_Type
(T1
, Is_Unsigned_Type
(T2
));
28771 Copy_Alignment
(To
=> T1
, From
=> T2
);
28774 ------------------------------
28775 -- Should_Ignore_Pragma_Par --
28776 ------------------------------
28778 function Should_Ignore_Pragma_Par
(Prag_Name
: Name_Id
) return Boolean is
28779 pragma Assert
(Compiler_State
= Parsing
);
28780 -- This one can't work during semantic analysis, because we don't have a
28781 -- correct Current_Source_File.
28783 Result
: constant Boolean :=
28784 Get_Name_Table_Boolean3
(Prag_Name
)
28785 and then not Is_Internal_File_Name
28786 (File_Name
(Current_Source_File
));
28789 end Should_Ignore_Pragma_Par
;
28791 ------------------------------
28792 -- Should_Ignore_Pragma_Sem --
28793 ------------------------------
28795 function Should_Ignore_Pragma_Sem
(N
: Node_Id
) return Boolean is
28796 pragma Assert
(Compiler_State
= Analyzing
);
28797 Prag_Name
: constant Name_Id
:= Pragma_Name
(N
);
28798 Result
: constant Boolean :=
28799 Get_Name_Table_Boolean3
(Prag_Name
)
28800 and then not In_Internal_Unit
(N
);
28804 end Should_Ignore_Pragma_Sem
;
28806 --------------------
28807 -- Static_Boolean --
28808 --------------------
28810 function Static_Boolean
(N
: Node_Id
) return Opt_Ubool
is
28812 Analyze_And_Resolve
(N
, Standard_Boolean
);
28815 or else Error_Posted
(N
)
28816 or else Etype
(N
) = Any_Type
28821 if Is_OK_Static_Expression
(N
) then
28822 if not Raises_Constraint_Error
(N
) then
28823 return Expr_Value
(N
);
28828 elsif Etype
(N
) = Any_Type
then
28832 Flag_Non_Static_Expr
28833 ("static boolean expression required here", N
);
28836 end Static_Boolean
;
28838 --------------------
28839 -- Static_Integer --
28840 --------------------
28842 function Static_Integer
(N
: Node_Id
) return Uint
is
28844 Analyze_And_Resolve
(N
, Any_Integer
);
28847 or else Error_Posted
(N
)
28848 or else Etype
(N
) = Any_Type
28853 if Is_OK_Static_Expression
(N
) then
28854 if not Raises_Constraint_Error
(N
) then
28855 return Expr_Value
(N
);
28860 elsif Etype
(N
) = Any_Type
then
28864 Flag_Non_Static_Expr
28865 ("static integer expression required here", N
);
28868 end Static_Integer
;
28870 -------------------------------
28871 -- Statically_Denotes_Entity --
28872 -------------------------------
28874 function Statically_Denotes_Entity
(N
: Node_Id
) return Boolean is
28877 if not Is_Entity_Name
(N
) then
28884 Nkind
(Parent
(E
)) /= N_Object_Renaming_Declaration
28885 or else Is_Prival
(E
)
28886 or else Statically_Denotes_Entity
(Renamed_Object
(E
));
28887 end Statically_Denotes_Entity
;
28889 -------------------------------
28890 -- Statically_Denotes_Object --
28891 -------------------------------
28893 function Statically_Denotes_Object
(N
: Node_Id
) return Boolean is
28895 return Statically_Denotes_Entity
(N
)
28896 and then Is_Object_Reference
(N
);
28897 end Statically_Denotes_Object
;
28899 --------------------------
28900 -- Statically_Different --
28901 --------------------------
28903 function Statically_Different
(E1
, E2
: Node_Id
) return Boolean is
28904 R1
: constant Node_Id
:= Get_Referenced_Object
(E1
);
28905 R2
: constant Node_Id
:= Get_Referenced_Object
(E2
);
28907 return Is_Entity_Name
(R1
)
28908 and then Is_Entity_Name
(R2
)
28909 and then Entity
(R1
) /= Entity
(R2
)
28910 and then not Is_Formal
(Entity
(R1
))
28911 and then not Is_Formal
(Entity
(R2
));
28912 end Statically_Different
;
28914 -----------------------------
28915 -- Statically_Names_Object --
28916 -----------------------------
28918 function Statically_Names_Object
(N
: Node_Id
) return Boolean is
28920 if Statically_Denotes_Object
(N
) then
28922 elsif Is_Entity_Name
(N
) then
28924 E
: constant Entity_Id
:= Entity
(N
);
28926 return Nkind
(Parent
(E
)) = N_Object_Renaming_Declaration
28927 and then Statically_Names_Object
(Renamed_Object
(E
));
28932 when N_Indexed_Component
=>
28933 if Is_Access_Type
(Etype
(Prefix
(N
))) then
28934 -- treat implicit dereference same as explicit
28938 if not Is_Constrained
(Etype
(Prefix
(N
))) then
28943 Indx
: Node_Id
:= First_Index
(Etype
(Prefix
(N
)));
28944 Expr
: Node_Id
:= First
(Expressions
(N
));
28945 Index_Subtype
: Node_Id
;
28948 Index_Subtype
:= Etype
(Indx
);
28950 if not Is_Static_Subtype
(Index_Subtype
) then
28953 if not Is_OK_Static_Expression
(Expr
) then
28958 Index_Value
: constant Uint
:= Expr_Value
(Expr
);
28959 Low_Value
: constant Uint
:=
28960 Expr_Value
(Type_Low_Bound
(Index_Subtype
));
28961 High_Value
: constant Uint
:=
28962 Expr_Value
(Type_High_Bound
(Index_Subtype
));
28964 if (Index_Value
< Low_Value
)
28965 or (Index_Value
> High_Value
)
28972 Expr
:= Next
(Expr
);
28973 pragma Assert
((Present
(Indx
) = Present
(Expr
))
28974 or else (Serious_Errors_Detected
> 0));
28975 exit when not (Present
(Indx
) and Present
(Expr
));
28979 when N_Selected_Component
=>
28980 if Is_Access_Type
(Etype
(Prefix
(N
))) then
28981 -- treat implicit dereference same as explicit
28985 if Ekind
(Entity
(Selector_Name
(N
))) not in
28986 E_Component | E_Discriminant
28992 Comp
: constant Entity_Id
:=
28993 Original_Record_Component
(Entity
(Selector_Name
(N
)));
28995 -- AI12-0373 confirms that we should not call
28996 -- Has_Discriminant_Dependent_Constraint here which would be
28999 if Is_Declared_Within_Variant
(Comp
) then
29004 when others => -- includes N_Slice, N_Explicit_Dereference
29008 pragma Assert
(Present
(Prefix
(N
)));
29010 return Statically_Names_Object
(Prefix
(N
));
29011 end Statically_Names_Object
;
29013 ---------------------------------
29014 -- String_From_Numeric_Literal --
29015 ---------------------------------
29017 function String_From_Numeric_Literal
(N
: Node_Id
) return String_Id
is
29018 Loc
: constant Source_Ptr
:= Sloc
(N
);
29019 Sbuffer
: constant Source_Buffer_Ptr
:=
29020 Source_Text
(Get_Source_File_Index
(Loc
));
29021 Src_Ptr
: Source_Ptr
:= Loc
;
29023 C
: Character := Sbuffer
(Src_Ptr
);
29024 -- Current source program character
29026 function Belongs_To_Numeric_Literal
(C
: Character) return Boolean;
29027 -- Return True if C belongs to the numeric literal
29029 --------------------------------
29030 -- Belongs_To_Numeric_Literal --
29031 --------------------------------
29033 function Belongs_To_Numeric_Literal
(C
: Character) return Boolean is
29036 when '0' .. '9' |
'_' |
'.' |
'e' |
'#' |
'A' .. 'F' =>
29039 -- Make sure '+' or '-' is part of an exponent
29043 Prev_C
: constant Character := Sbuffer
(Src_Ptr
- 1);
29045 return Prev_C
in 'e' |
'E';
29048 -- Other characters cannot belong to a numeric literal
29053 end Belongs_To_Numeric_Literal
;
29055 -- Start of processing for String_From_Numeric_Literal
29059 while Belongs_To_Numeric_Literal
(C
) loop
29060 Store_String_Char
(C
);
29061 Src_Ptr
:= Src_Ptr
+ 1;
29062 C
:= Sbuffer
(Src_Ptr
);
29066 end String_From_Numeric_Literal
;
29068 --------------------------------------
29069 -- Subject_To_Loop_Entry_Attributes --
29070 --------------------------------------
29072 function Subject_To_Loop_Entry_Attributes
(N
: Node_Id
) return Boolean is
29078 -- The expansion mechanism transform a loop subject to at least one
29079 -- 'Loop_Entry attribute into a conditional block. Infinite loops lack
29080 -- the conditional part.
29082 if Nkind
(Stmt
) in N_Block_Statement | N_If_Statement
29083 and then Nkind
(Original_Node
(N
)) = N_Loop_Statement
29085 Stmt
:= Original_Node
(N
);
29089 Nkind
(Stmt
) = N_Loop_Statement
29090 and then Present
(Identifier
(Stmt
))
29091 and then Present
(Entity
(Identifier
(Stmt
)))
29092 and then Has_Loop_Entry_Attributes
(Entity
(Identifier
(Stmt
)));
29093 end Subject_To_Loop_Entry_Attributes
;
29095 -----------------------------
29096 -- Subprogram_Access_Level --
29097 -----------------------------
29099 function Subprogram_Access_Level
(Subp
: Entity_Id
) return Uint
is
29101 if Present
(Alias
(Subp
)) then
29102 return Subprogram_Access_Level
(Alias
(Subp
));
29104 return Scope_Depth
(Enclosing_Dynamic_Scope
(Subp
));
29106 end Subprogram_Access_Level
;
29108 ---------------------
29109 -- Subprogram_Name --
29110 ---------------------
29112 function Subprogram_Name
(N
: Node_Id
) return String is
29113 Buf
: Bounded_String
;
29114 Ent
: Node_Id
:= N
;
29118 while Present
(Ent
) loop
29119 case Nkind
(Ent
) is
29120 when N_Subprogram_Body
=>
29121 Ent
:= Defining_Unit_Name
(Specification
(Ent
));
29124 when N_Subprogram_Declaration
=>
29125 Nod
:= Corresponding_Body
(Ent
);
29127 if Present
(Nod
) then
29130 Ent
:= Defining_Unit_Name
(Specification
(Ent
));
29135 when N_Subprogram_Instantiation
29137 | N_Package_Specification
29139 Ent
:= Defining_Unit_Name
(Ent
);
29142 when N_Protected_Type_Declaration
=>
29143 Ent
:= Corresponding_Body
(Ent
);
29146 when N_Protected_Body
29149 Ent
:= Defining_Identifier
(Ent
);
29156 Ent
:= Parent
(Ent
);
29160 return "unknown subprogram:unknown file:0:0";
29163 -- If the subprogram is a child unit, use its simple name to start the
29164 -- construction of the fully qualified name.
29166 if Nkind
(Ent
) = N_Defining_Program_Unit_Name
then
29167 Ent
:= Defining_Identifier
(Ent
);
29170 Append_Entity_Name
(Buf
, Ent
);
29172 -- Append homonym number if needed
29174 if Nkind
(N
) in N_Entity
and then Has_Homonym
(N
) then
29176 H
: Entity_Id
:= Homonym
(N
);
29180 while Present
(H
) loop
29181 if Scope
(H
) = Scope
(N
) then
29195 -- Append source location of Ent to Buf so that the string will
29196 -- look like "subp:file:line:col".
29199 Loc
: constant Source_Ptr
:= Sloc
(Ent
);
29202 Append
(Buf
, Reference_Name
(Get_Source_File_Index
(Loc
)));
29204 Append
(Buf
, Nat
(Get_Logical_Line_Number
(Loc
)));
29206 Append
(Buf
, Nat
(Get_Column_Number
(Loc
)));
29210 end Subprogram_Name
;
29212 -------------------------------
29213 -- Support_Atomic_Primitives --
29214 -------------------------------
29216 function Support_Atomic_Primitives
(Typ
: Entity_Id
) return Boolean is
29220 -- Verify the alignment of Typ is known
29222 if not Known_Alignment
(Typ
) then
29226 if Known_Static_Esize
(Typ
) then
29227 Size
:= UI_To_Int
(Esize
(Typ
));
29229 -- If the Esize (Object_Size) is unknown at compile time, look at the
29230 -- RM_Size (Value_Size) which may have been set by an explicit rep item.
29232 elsif Known_Static_RM_Size
(Typ
) then
29233 Size
:= UI_To_Int
(RM_Size
(Typ
));
29235 -- Otherwise, the size is considered to be unknown.
29241 -- Check that the size of the component is 8, 16, 32, or 64 bits and
29242 -- that Typ is properly aligned.
29245 when 8 |
16 |
32 |
64 =>
29246 return Size
= UI_To_Int
(Alignment
(Typ
)) * 8;
29251 end Support_Atomic_Primitives
;
29257 procedure Trace_Scope
(N
: Node_Id
; E
: Entity_Id
; Msg
: String) is
29259 if Debug_Flag_W
then
29260 for J
in 0 .. Scope_Stack
.Last
loop
29265 Write_Name
(Chars
(E
));
29266 Write_Str
(" from ");
29267 Write_Location
(Sloc
(N
));
29272 -----------------------
29273 -- Transfer_Entities --
29274 -----------------------
29276 procedure Transfer_Entities
(From
: Entity_Id
; To
: Entity_Id
) is
29277 procedure Set_Public_Status_Of
(Id
: Entity_Id
);
29278 -- Set the Is_Public attribute of arbitrary entity Id by calling routine
29279 -- Set_Public_Status. If successful and Id denotes a record type, set
29280 -- the Is_Public attribute of its fields.
29282 --------------------------
29283 -- Set_Public_Status_Of --
29284 --------------------------
29286 procedure Set_Public_Status_Of
(Id
: Entity_Id
) is
29290 if not Is_Public
(Id
) then
29291 Set_Public_Status
(Id
);
29293 -- When the input entity is a public record type, ensure that all
29294 -- its internal fields are also exposed to the linker. The fields
29295 -- of a class-wide type are never made public.
29298 and then Is_Record_Type
(Id
)
29299 and then not Is_Class_Wide_Type
(Id
)
29301 Field
:= First_Entity
(Id
);
29302 while Present
(Field
) loop
29303 Set_Is_Public
(Field
);
29304 Next_Entity
(Field
);
29308 end Set_Public_Status_Of
;
29312 Full_Id
: Entity_Id
;
29315 -- Start of processing for Transfer_Entities
29318 Id
:= First_Entity
(From
);
29320 if Present
(Id
) then
29322 -- Merge the entity chain of the source scope with that of the
29323 -- destination scope.
29325 if Present
(Last_Entity
(To
)) then
29326 Link_Entities
(Last_Entity
(To
), Id
);
29328 Set_First_Entity
(To
, Id
);
29331 Set_Last_Entity
(To
, Last_Entity
(From
));
29333 -- Inspect the entities of the source scope and update their Scope
29336 while Present
(Id
) loop
29337 Set_Scope
(Id
, To
);
29338 Set_Public_Status_Of
(Id
);
29340 -- Handle an internally generated full view for a private type
29342 if Is_Private_Type
(Id
)
29343 and then Present
(Full_View
(Id
))
29344 and then Is_Itype
(Full_View
(Id
))
29346 Full_Id
:= Full_View
(Id
);
29348 Set_Scope
(Full_Id
, To
);
29349 Set_Public_Status_Of
(Full_Id
);
29355 Set_First_Entity
(From
, Empty
);
29356 Set_Last_Entity
(From
, Empty
);
29358 end Transfer_Entities
;
29360 ------------------------
29361 -- Traverse_More_Func --
29362 ------------------------
29364 function Traverse_More_Func
(Node
: Node_Id
) return Traverse_Final_Result
is
29366 Processing_Itype
: Boolean := False;
29367 -- Set to True while traversing the nodes under an Itype, to prevent
29368 -- looping on Itype handling during that traversal.
29370 function Process_More
(N
: Node_Id
) return Traverse_Result
;
29371 -- Wrapper over the Process callback to handle parts of the AST that
29372 -- are not normally traversed as syntactic children.
29374 function Traverse_Rec
(N
: Node_Id
) return Traverse_Final_Result
;
29375 -- Main recursive traversal implemented as an instantiation of
29376 -- Traverse_Func over a modified Process callback.
29382 function Process_More
(N
: Node_Id
) return Traverse_Result
is
29384 procedure Traverse_More
(N
: Node_Id
;
29385 Res
: in out Traverse_Result
);
29386 procedure Traverse_More
(L
: List_Id
;
29387 Res
: in out Traverse_Result
);
29388 -- Traverse a node or list and update the traversal result to value
29389 -- Abandon when needed.
29391 -------------------
29392 -- Traverse_More --
29393 -------------------
29395 procedure Traverse_More
(N
: Node_Id
;
29396 Res
: in out Traverse_Result
)
29399 -- Do not process any more nodes if Abandon was reached
29401 if Res
= Abandon
then
29405 if Traverse_Rec
(N
) = Abandon
then
29410 procedure Traverse_More
(L
: List_Id
;
29411 Res
: in out Traverse_Result
)
29413 N
: Node_Id
:= First
(L
);
29416 -- Do not process any more nodes if Abandon was reached
29418 if Res
= Abandon
then
29422 while Present
(N
) loop
29423 Traverse_More
(N
, Res
);
29431 Result
: Traverse_Result
;
29433 -- Start of processing for Process_More
29436 -- Initial callback to Process. Return immediately on Skip/Abandon.
29437 -- Otherwise update the value of Node for further processing of
29438 -- non-syntactic children.
29440 Result
:= Process
(N
);
29443 when OK
=> Node
:= N
;
29444 when OK_Orig
=> Node
:= Original_Node
(N
);
29445 when Skip
=> return Skip
;
29446 when Abandon
=> return Abandon
;
29449 -- Process the relevant semantic children which are a logical part of
29450 -- the AST under this node before returning for the processing of
29451 -- syntactic children.
29453 -- Start with all non-syntactic lists of action nodes
29455 case Nkind
(Node
) is
29456 when N_Component_Association
=>
29457 Traverse_More
(Loop_Actions
(Node
), Result
);
29459 when N_Elsif_Part
=>
29460 Traverse_More
(Condition_Actions
(Node
), Result
);
29462 when N_Short_Circuit
=>
29463 Traverse_More
(Actions
(Node
), Result
);
29465 when N_Case_Expression_Alternative
=>
29466 Traverse_More
(Actions
(Node
), Result
);
29468 when N_Iterated_Component_Association
=>
29469 Traverse_More
(Loop_Actions
(Node
), Result
);
29471 when N_Iteration_Scheme
=>
29472 Traverse_More
(Condition_Actions
(Node
), Result
);
29474 when N_If_Expression
=>
29475 Traverse_More
(Then_Actions
(Node
), Result
);
29476 Traverse_More
(Else_Actions
(Node
), Result
);
29478 -- Various nodes have a field Actions as a syntactic node,
29479 -- so it will be traversed in the regular syntactic traversal.
29481 when N_Compilation_Unit_Aux
29482 | N_Compound_Statement
29483 | N_Expression_With_Actions
29492 -- If Process_Itypes is True, process unattached nodes which come
29493 -- from Itypes. This only concerns currently ranges of scalar
29494 -- (possibly as index) types. This traversal is protected against
29495 -- looping with Processing_Itype.
29498 and then not Processing_Itype
29499 and then Nkind
(Node
) in N_Has_Etype
29500 and then Present
(Etype
(Node
))
29501 and then Is_Itype
(Etype
(Node
))
29504 Typ
: constant Entity_Id
:= Etype
(Node
);
29506 Processing_Itype
:= True;
29508 case Ekind
(Typ
) is
29509 when Scalar_Kind
=>
29510 Traverse_More
(Scalar_Range
(Typ
), Result
);
29514 Index
: Node_Id
:= First_Index
(Typ
);
29517 while Present
(Index
) loop
29518 if Nkind
(Index
) in N_Has_Entity
then
29519 Rng
:= Scalar_Range
(Entity
(Index
));
29524 Traverse_More
(Rng
, Result
);
29525 Next_Index
(Index
);
29532 Processing_Itype
:= False;
29539 -- Define Traverse_Rec as a renaming of the instantiation, as an
29540 -- instantiation cannot complete a previous spec.
29542 function Traverse_Recursive
is new Traverse_Func
(Process_More
);
29543 function Traverse_Rec
(N
: Node_Id
) return Traverse_Final_Result
29544 renames Traverse_Recursive
;
29546 -- Start of processing for Traverse_More_Func
29549 return Traverse_Rec
(Node
);
29550 end Traverse_More_Func
;
29552 ------------------------
29553 -- Traverse_More_Proc --
29554 ------------------------
29556 procedure Traverse_More_Proc
(Node
: Node_Id
) is
29557 function Traverse
is new Traverse_More_Func
(Process
, Process_Itypes
);
29558 Discard
: Traverse_Final_Result
;
29559 pragma Warnings
(Off
, Discard
);
29561 Discard
:= Traverse
(Node
);
29562 end Traverse_More_Proc
;
29564 -----------------------
29565 -- Type_Access_Level --
29566 -----------------------
29568 function Type_Access_Level
29570 Allow_Alt_Model
: Boolean := True;
29571 Assoc_Ent
: Entity_Id
:= Empty
) return Uint
29573 Btyp
: Entity_Id
:= Base_Type
(Typ
);
29574 Def_Ent
: Entity_Id
;
29577 -- Ada 2005 (AI-230): For most cases of anonymous access types, we
29578 -- simply use the level where the type is declared. This is true for
29579 -- stand-alone object declarations, and for anonymous access types
29580 -- associated with components the level is the same as that of the
29581 -- enclosing composite type. However, special treatment is needed for
29582 -- the cases of access parameters, return objects of an anonymous access
29583 -- type, and, in Ada 95, access discriminants of limited types.
29585 if Is_Access_Type
(Btyp
) then
29586 if Ekind
(Btyp
) = E_Anonymous_Access_Type
then
29587 -- No_Dynamic_Accessibility_Checks restriction override for
29588 -- alternative accessibility model.
29591 and then No_Dynamic_Accessibility_Checks_Enabled
(Btyp
)
29593 -- In the -gnatd_b model, the level of an anonymous access
29594 -- type is always that of the designated type.
29596 if Debug_Flag_Underscore_B
then
29597 return Type_Access_Level
29598 (Designated_Type
(Btyp
), Allow_Alt_Model
);
29601 -- When an anonymous access type's Assoc_Ent is specified,
29602 -- calculate the result based on the general accessibility
29605 -- We would like to use Associated_Node_For_Itype here instead,
29606 -- but in some cases it is not fine grained enough ???
29608 if Present
(Assoc_Ent
) then
29609 return Static_Accessibility_Level
29610 (Assoc_Ent
, Object_Decl_Level
);
29613 -- Otherwise take the context of the anonymous access type into
29616 -- Obtain the defining entity for the internally generated
29617 -- anonymous access type.
29619 Def_Ent
:= Defining_Entity_Or_Empty
29620 (Associated_Node_For_Itype
(Typ
));
29622 if Present
(Def_Ent
) then
29623 -- When the defining entity is a subprogram then we know the
29624 -- anonymous access type Typ has been generated to either
29625 -- describe an anonymous access type formal or an anonymous
29626 -- access result type.
29628 -- Since we are only interested in the formal case, avoid
29629 -- the anonymous access result type.
29631 if Is_Subprogram
(Def_Ent
)
29632 and then not (Ekind
(Def_Ent
) = E_Function
29633 and then Etype
(Def_Ent
) = Typ
)
29635 -- When the type comes from an anonymous access
29636 -- parameter, the level is that of the subprogram
29639 return Scope_Depth
(Def_Ent
);
29641 -- When the type is an access discriminant, the level is
29642 -- that of the type.
29644 elsif Ekind
(Def_Ent
) = E_Discriminant
then
29645 return Scope_Depth
(Scope
(Def_Ent
));
29649 -- If the type is a nonlocal anonymous access type (such as for
29650 -- an access parameter) we treat it as being declared at the
29651 -- library level to ensure that names such as X.all'access don't
29652 -- fail static accessibility checks.
29654 elsif not Is_Local_Anonymous_Access
(Typ
) then
29655 return Scope_Depth
(Standard_Standard
);
29657 -- If this is a return object, the accessibility level is that of
29658 -- the result subtype of the enclosing function. The test here is
29659 -- little complicated, because we have to account for extended
29660 -- return statements that have been rewritten as blocks, in which
29661 -- case we have to find and the Is_Return_Object attribute of the
29662 -- itype's associated object. It would be nice to find a way to
29663 -- simplify this test, but it doesn't seem worthwhile to add a new
29664 -- flag just for purposes of this test. ???
29666 elsif Ekind
(Scope
(Btyp
)) = E_Return_Statement
29669 and then Nkind
(Associated_Node_For_Itype
(Btyp
)) =
29670 N_Object_Declaration
29671 and then Is_Return_Object
29672 (Defining_Identifier
29673 (Associated_Node_For_Itype
(Btyp
))))
29679 Scop
:= Scope
(Scope
(Btyp
));
29680 while Present
(Scop
) loop
29681 exit when Ekind
(Scop
) = E_Function
;
29682 Scop
:= Scope
(Scop
);
29685 -- Treat the return object's type as having the level of the
29686 -- function's result subtype (as per RM05-6.5(5.3/2)).
29688 return Type_Access_Level
(Etype
(Scop
), Allow_Alt_Model
);
29693 Btyp
:= Root_Type
(Btyp
);
29695 -- The accessibility level of anonymous access types associated with
29696 -- discriminants is that of the current instance of the type, and
29697 -- that's deeper than the type itself (AARM 3.10.2 (12.3.21)).
29699 -- AI-402: access discriminants have accessibility based on the
29700 -- object rather than the type in Ada 2005, so the above paragraph
29703 -- ??? Needs completion with rules from AI-416
29705 if Ada_Version
<= Ada_95
29706 and then Ekind
(Typ
) = E_Anonymous_Access_Type
29707 and then Present
(Associated_Node_For_Itype
(Typ
))
29708 and then Nkind
(Associated_Node_For_Itype
(Typ
)) =
29709 N_Discriminant_Specification
29711 return Scope_Depth
(Enclosing_Dynamic_Scope
(Btyp
)) + 1;
29715 -- Return library level for a generic formal type. This is done because
29716 -- RM(10.3.2) says that "The statically deeper relationship does not
29717 -- apply to ... a descendant of a generic formal type". Rather than
29718 -- checking at each point where a static accessibility check is
29719 -- performed to see if we are dealing with a formal type, this rule is
29720 -- implemented by having Type_Access_Level and Deepest_Type_Access_Level
29721 -- return extreme values for a formal type; Deepest_Type_Access_Level
29722 -- returns Int'Last. By calling the appropriate function from among the
29723 -- two, we ensure that the static accessibility check will pass if we
29724 -- happen to run into a formal type. More specifically, we should call
29725 -- Deepest_Type_Access_Level instead of Type_Access_Level whenever the
29726 -- call occurs as part of a static accessibility check and the error
29727 -- case is the case where the type's level is too shallow (as opposed
29730 if Is_Generic_Type
(Root_Type
(Btyp
)) then
29731 return Scope_Depth
(Standard_Standard
);
29734 return Scope_Depth
(Enclosing_Dynamic_Scope
(Btyp
));
29735 end Type_Access_Level
;
29737 ------------------------------------
29738 -- Type_Without_Stream_Operation --
29739 ------------------------------------
29741 function Type_Without_Stream_Operation
29743 Op
: TSS_Name_Type
:= TSS_Null
) return Entity_Id
29745 BT
: constant Entity_Id
:= Base_Type
(T
);
29746 Op_Missing
: Boolean;
29749 if not Restriction_Active
(No_Default_Stream_Attributes
) then
29753 if Is_Elementary_Type
(T
) then
29754 if Op
= TSS_Null
then
29756 No
(TSS
(BT
, TSS_Stream_Read
))
29757 or else No
(TSS
(BT
, TSS_Stream_Write
));
29760 Op_Missing
:= No
(TSS
(BT
, Op
));
29769 elsif Is_Array_Type
(T
) then
29770 return Type_Without_Stream_Operation
(Component_Type
(T
), Op
);
29772 elsif Is_Record_Type
(T
) then
29778 Comp
:= First_Component
(T
);
29779 while Present
(Comp
) loop
29780 C_Typ
:= Type_Without_Stream_Operation
(Etype
(Comp
), Op
);
29782 if Present
(C_Typ
) then
29786 Next_Component
(Comp
);
29792 elsif Is_Private_Type
(T
) and then Present
(Full_View
(T
)) then
29793 return Type_Without_Stream_Operation
(Full_View
(T
), Op
);
29797 end Type_Without_Stream_Operation
;
29799 ------------------------------
29800 -- Ultimate_Overlaid_Entity --
29801 ------------------------------
29803 function Ultimate_Overlaid_Entity
(E
: Entity_Id
) return Entity_Id
is
29805 Alias
: Entity_Id
:= E
;
29809 -- Currently this routine is only called for stand-alone objects that
29810 -- have been analysed, since the analysis of the Address aspect is often
29813 pragma Assert
(Ekind
(E
) in E_Constant | E_Variable
);
29816 Address
:= Address_Clause
(Alias
);
29817 if Present
(Address
) then
29818 Find_Overlaid_Entity
(Address
, Alias
, Offset
);
29819 if Present
(Alias
) then
29824 elsif Alias
= E
then
29830 end Ultimate_Overlaid_Entity
;
29832 ---------------------
29833 -- Ultimate_Prefix --
29834 ---------------------
29836 function Ultimate_Prefix
(N
: Node_Id
) return Node_Id
is
29841 while Nkind
(Pref
) in N_Explicit_Dereference
29842 | N_Indexed_Component
29843 | N_Selected_Component
29846 Pref
:= Prefix
(Pref
);
29850 end Ultimate_Prefix
;
29852 ----------------------------
29853 -- Unique_Defining_Entity --
29854 ----------------------------
29856 function Unique_Defining_Entity
(N
: Node_Id
) return Entity_Id
is
29858 return Unique_Entity
(Defining_Entity
(N
));
29859 end Unique_Defining_Entity
;
29861 -------------------
29862 -- Unique_Entity --
29863 -------------------
29865 function Unique_Entity
(E
: Entity_Id
) return Entity_Id
is
29866 U
: Entity_Id
:= E
;
29872 if Present
(Full_View
(E
)) then
29873 U
:= Full_View
(E
);
29877 if Nkind
(Parent
(E
)) = N_Entry_Body
then
29879 Prot_Item
: Entity_Id
;
29880 Prot_Type
: Entity_Id
;
29883 if Ekind
(E
) = E_Entry
then
29884 Prot_Type
:= Scope
(E
);
29886 -- Bodies of entry families are nested within an extra scope
29887 -- that contains an entry index declaration.
29890 Prot_Type
:= Scope
(Scope
(E
));
29893 -- A protected type may be declared as a private type, in
29894 -- which case we need to get its full view.
29896 if Is_Private_Type
(Prot_Type
) then
29897 Prot_Type
:= Full_View
(Prot_Type
);
29900 -- Full view may not be present on error, in which case
29901 -- return E by default.
29903 if Present
(Prot_Type
) then
29904 pragma Assert
(Ekind
(Prot_Type
) = E_Protected_Type
);
29906 -- Traverse the entity list of the protected type and
29907 -- locate an entry declaration which matches the entry
29910 Prot_Item
:= First_Entity
(Prot_Type
);
29911 while Present
(Prot_Item
) loop
29912 if Ekind
(Prot_Item
) in Entry_Kind
29913 and then Corresponding_Body
(Parent
(Prot_Item
)) = E
29919 Next_Entity
(Prot_Item
);
29925 when Formal_Kind
=>
29926 if Present
(Spec_Entity
(E
)) then
29927 U
:= Spec_Entity
(E
);
29930 when E_Package_Body
=>
29933 if Nkind
(P
) = N_Defining_Program_Unit_Name
then
29937 if Nkind
(P
) = N_Package_Body
29938 and then Present
(Corresponding_Spec
(P
))
29940 U
:= Corresponding_Spec
(P
);
29942 elsif Nkind
(P
) = N_Package_Body_Stub
29943 and then Present
(Corresponding_Spec_Of_Stub
(P
))
29945 U
:= Corresponding_Spec_Of_Stub
(P
);
29948 when E_Protected_Body
=>
29951 if Nkind
(P
) = N_Protected_Body
29952 and then Present
(Corresponding_Spec
(P
))
29954 U
:= Corresponding_Spec
(P
);
29956 elsif Nkind
(P
) = N_Protected_Body_Stub
29957 and then Present
(Corresponding_Spec_Of_Stub
(P
))
29959 U
:= Corresponding_Spec_Of_Stub
(P
);
29961 if Is_Single_Protected_Object
(U
) then
29966 if Is_Private_Type
(U
) then
29967 U
:= Full_View
(U
);
29970 when E_Subprogram_Body
=>
29973 if Nkind
(P
) = N_Defining_Program_Unit_Name
then
29979 if Nkind
(P
) = N_Subprogram_Body
29980 and then Present
(Corresponding_Spec
(P
))
29982 U
:= Corresponding_Spec
(P
);
29984 elsif Nkind
(P
) = N_Subprogram_Body_Stub
29985 and then Present
(Corresponding_Spec_Of_Stub
(P
))
29987 U
:= Corresponding_Spec_Of_Stub
(P
);
29989 elsif Nkind
(P
) = N_Subprogram_Renaming_Declaration
then
29990 U
:= Corresponding_Spec
(P
);
29993 when E_Task_Body
=>
29996 if Nkind
(P
) = N_Task_Body
29997 and then Present
(Corresponding_Spec
(P
))
29999 U
:= Corresponding_Spec
(P
);
30001 elsif Nkind
(P
) = N_Task_Body_Stub
30002 and then Present
(Corresponding_Spec_Of_Stub
(P
))
30004 U
:= Corresponding_Spec_Of_Stub
(P
);
30006 if Is_Single_Task_Object
(U
) then
30011 if Is_Private_Type
(U
) then
30012 U
:= Full_View
(U
);
30016 if Present
(Full_View
(E
)) then
30017 U
:= Full_View
(E
);
30031 function Unique_Name
(E
: Entity_Id
) return String is
30033 -- Local subprograms
30035 function Add_Homonym_Suffix
(E
: Entity_Id
) return String;
30037 function This_Name
return String;
30039 ------------------------
30040 -- Add_Homonym_Suffix --
30041 ------------------------
30043 function Add_Homonym_Suffix
(E
: Entity_Id
) return String is
30045 -- Names in E_Subprogram_Body or E_Package_Body entities are not
30046 -- reliable, as they may not include the overloading suffix.
30047 -- Instead, when looking for the name of E or one of its enclosing
30048 -- scope, we get the name of the corresponding Unique_Entity.
30050 U
: constant Entity_Id
:= Unique_Entity
(E
);
30051 Nam
: constant String := Get_Name_String
(Chars
(U
));
30054 -- If E has homonyms but is not fully qualified, as done in
30055 -- GNATprove mode, append the homonym number on the fly. Strip the
30056 -- leading space character in the image of natural numbers. Also do
30057 -- not print the homonym value of 1.
30059 if Has_Homonym
(U
) then
30061 N
: constant Pos
:= Homonym_Number
(U
);
30062 S
: constant String := N
'Img;
30065 return Nam
& "__" & S
(2 .. S
'Last);
30071 end Add_Homonym_Suffix
;
30077 function This_Name
return String is
30079 return Add_Homonym_Suffix
(E
);
30084 U
: constant Entity_Id
:= Unique_Entity
(E
);
30086 -- Start of processing for Unique_Name
30089 if E
= Standard_Standard
30090 or else Has_Fully_Qualified_Name
(E
)
30094 elsif Ekind
(E
) = E_Enumeration_Literal
then
30095 return Unique_Name
(Etype
(E
)) & "__" & This_Name
;
30099 S
: constant Entity_Id
:= Scope
(U
);
30100 pragma Assert
(Present
(S
));
30103 -- Prefix names of predefined types with standard__, but leave
30104 -- names of user-defined packages and subprograms without prefix
30105 -- (even if technically they are nested in the Standard package).
30107 if S
= Standard_Standard
then
30108 if Ekind
(U
) = E_Package
or else Is_Subprogram
(U
) then
30111 return Unique_Name
(S
) & "__" & This_Name
;
30114 -- For intances of generic subprograms use the name of the related
30115 -- instance and skip the scope of its wrapper package.
30117 elsif Is_Wrapper_Package
(S
) then
30118 pragma Assert
(Scope
(S
) = Scope
(Related_Instance
(S
)));
30119 -- Wrapper package and the instantiation are in the same scope
30122 Related_Name
: constant String :=
30123 Add_Homonym_Suffix
(Related_Instance
(S
));
30124 Enclosing_Name
: constant String :=
30125 Unique_Name
(Scope
(S
)) & "__" & Related_Name
;
30128 if Is_Subprogram
(U
)
30129 and then not Is_Generic_Actual_Subprogram
(U
)
30131 return Enclosing_Name
;
30133 return Enclosing_Name
& "__" & This_Name
;
30137 elsif Is_Child_Unit
(U
) then
30138 return Child_Prefix
& Unique_Name
(S
) & "__" & This_Name
;
30140 return Unique_Name
(S
) & "__" & This_Name
;
30146 ---------------------
30147 -- Unit_Is_Visible --
30148 ---------------------
30150 function Unit_Is_Visible
(U
: Entity_Id
) return Boolean is
30151 Curr
: constant Node_Id
:= Cunit
(Current_Sem_Unit
);
30152 Curr_Entity
: constant Entity_Id
:= Cunit_Entity
(Current_Sem_Unit
);
30154 function Unit_In_Parent_Context
(Par_Unit
: Node_Id
) return Boolean;
30155 -- For a child unit, check whether unit appears in a with_clause
30158 function Unit_In_Context
(Comp_Unit
: Node_Id
) return Boolean;
30159 -- Scan the context clause of one compilation unit looking for a
30160 -- with_clause for the unit in question.
30162 ----------------------------
30163 -- Unit_In_Parent_Context --
30164 ----------------------------
30166 function Unit_In_Parent_Context
(Par_Unit
: Node_Id
) return Boolean is
30168 if Unit_In_Context
(Par_Unit
) then
30171 elsif Is_Child_Unit
(Defining_Entity
(Unit
(Par_Unit
))) then
30172 return Unit_In_Parent_Context
(Parent_Spec
(Unit
(Par_Unit
)));
30177 end Unit_In_Parent_Context
;
30179 ---------------------
30180 -- Unit_In_Context --
30181 ---------------------
30183 function Unit_In_Context
(Comp_Unit
: Node_Id
) return Boolean is
30187 Clause
:= First
(Context_Items
(Comp_Unit
));
30188 while Present
(Clause
) loop
30189 if Nkind
(Clause
) = N_With_Clause
then
30190 if Library_Unit
(Clause
) = U
then
30193 -- The with_clause may denote a renaming of the unit we are
30194 -- looking for, eg. Text_IO which renames Ada.Text_IO.
30197 Renamed_Entity
(Entity
(Name
(Clause
))) =
30198 Defining_Entity
(Unit
(U
))
30208 end Unit_In_Context
;
30210 -- Start of processing for Unit_Is_Visible
30213 -- The currrent unit is directly visible
30218 elsif Unit_In_Context
(Curr
) then
30221 -- If the current unit is a body, check the context of the spec
30223 elsif Nkind
(Unit
(Curr
)) = N_Package_Body
30225 (Nkind
(Unit
(Curr
)) = N_Subprogram_Body
30226 and then not Acts_As_Spec
(Unit
(Curr
)))
30228 if Unit_In_Context
(Library_Unit
(Curr
)) then
30233 -- If the spec is a child unit, examine the parents
30235 if Is_Child_Unit
(Curr_Entity
) then
30236 if Nkind
(Unit
(Curr
)) in N_Unit_Body
then
30238 Unit_In_Parent_Context
30239 (Parent_Spec
(Unit
(Library_Unit
(Curr
))));
30241 return Unit_In_Parent_Context
(Parent_Spec
(Unit
(Curr
)));
30247 end Unit_Is_Visible
;
30249 ------------------------------
30250 -- Universal_Interpretation --
30251 ------------------------------
30253 function Universal_Interpretation
(Opnd
: Node_Id
) return Entity_Id
is
30254 Index
: Interp_Index
;
30258 -- The argument may be a formal parameter of an operator or subprogram
30259 -- with multiple interpretations, or else an expression for an actual.
30261 if Nkind
(Opnd
) = N_Defining_Identifier
30262 or else not Is_Overloaded
(Opnd
)
30264 if Is_Universal_Numeric_Type
(Etype
(Opnd
)) then
30265 return Etype
(Opnd
);
30271 Get_First_Interp
(Opnd
, Index
, It
);
30272 while Present
(It
.Typ
) loop
30273 if Is_Universal_Numeric_Type
(It
.Typ
) then
30277 Get_Next_Interp
(Index
, It
);
30282 end Universal_Interpretation
;
30288 function Unqualify
(Expr
: Node_Id
) return Node_Id
is
30290 -- Recurse to handle unlikely case of multiple levels of qualification
30292 if Nkind
(Expr
) = N_Qualified_Expression
then
30293 return Unqualify
(Expression
(Expr
));
30295 -- Normal case, not a qualified expression
30306 function Unqual_Conv
(Expr
: Node_Id
) return Node_Id
is
30308 -- Recurse to handle unlikely case of multiple levels of qualification
30309 -- and/or conversion.
30311 if Nkind
(Expr
) in N_Qualified_Expression
30312 | N_Type_Conversion
30313 | N_Unchecked_Type_Conversion
30315 return Unqual_Conv
(Expression
(Expr
));
30317 -- Normal case, not a qualified expression
30324 --------------------
30325 -- Validated_View --
30326 --------------------
30328 function Validated_View
(Typ
: Entity_Id
) return Entity_Id
is
30330 -- Scalar types can be always validated. In fast, switiching to the base
30331 -- type would drop the range constraints and force validation to use a
30332 -- larger type than necessary.
30334 if Is_Scalar_Type
(Typ
) then
30337 -- Array types can be validated even when they are derived, because
30338 -- validation only requires their bounds and component types to be
30339 -- accessible. In fact, switching to the parent type would pollute
30340 -- expansion of attribute Valid_Scalars with unnecessary conversion
30341 -- that might not be eliminated by the frontend.
30343 elsif Is_Array_Type
(Typ
) then
30346 -- For other types, in particular for record subtypes, we switch to the
30349 elsif not Is_Base_Type
(Typ
) then
30350 return Validated_View
(Base_Type
(Typ
));
30352 -- Obtain the full view of the input type by stripping away concurrency,
30353 -- derivations, and privacy.
30355 elsif Is_Concurrent_Type
(Typ
) then
30356 if Present
(Corresponding_Record_Type
(Typ
)) then
30357 return Corresponding_Record_Type
(Typ
);
30362 elsif Is_Derived_Type
(Typ
) then
30363 return Validated_View
(Etype
(Typ
));
30365 elsif Is_Private_Type
(Typ
) then
30366 if Present
(Underlying_Full_View
(Typ
)) then
30367 return Validated_View
(Underlying_Full_View
(Typ
));
30369 elsif Present
(Full_View
(Typ
)) then
30370 return Validated_View
(Full_View
(Typ
));
30378 end Validated_View
;
30380 -----------------------
30381 -- Visible_Ancestors --
30382 -----------------------
30384 function Visible_Ancestors
(Typ
: Entity_Id
) return Elist_Id
is
30390 pragma Assert
(Is_Record_Type
(Typ
) and then Is_Tagged_Type
(Typ
));
30392 -- Collect all the parents and progenitors of Typ. If the full-view of
30393 -- private parents and progenitors is available then it is used to
30394 -- generate the list of visible ancestors; otherwise their partial
30395 -- view is added to the resulting list.
30400 Use_Full_View
=> True);
30404 Ifaces_List
=> List_2
,
30405 Exclude_Parents
=> True,
30406 Use_Full_View
=> True);
30408 -- Join the two lists. Avoid duplications because an interface may
30409 -- simultaneously be parent and progenitor of a type.
30411 Elmt
:= First_Elmt
(List_2
);
30412 while Present
(Elmt
) loop
30413 Append_Unique_Elmt
(Node
(Elmt
), List_1
);
30418 end Visible_Ancestors
;
30420 ---------------------------
30421 -- Warn_On_Hiding_Entity --
30422 ---------------------------
30424 procedure Warn_On_Hiding_Entity
30426 Hidden
, Visible
: Entity_Id
;
30427 On_Use_Clause
: Boolean)
30430 -- Don't warn for record components since they always have a well
30431 -- defined scope which does not confuse other uses. Note that in
30432 -- some cases, Ekind has not been set yet.
30434 if Ekind
(Hidden
) /= E_Component
30435 and then Ekind
(Hidden
) /= E_Discriminant
30436 and then Nkind
(Parent
(Hidden
)) /= N_Component_Declaration
30437 and then Ekind
(Visible
) /= E_Component
30438 and then Ekind
(Visible
) /= E_Discriminant
30439 and then Nkind
(Parent
(Visible
)) /= N_Component_Declaration
30441 -- Don't warn for one character variables. It is too common to use
30442 -- such variables as locals and will just cause too many false hits.
30444 and then Length_Of_Name
(Chars
(Hidden
)) /= 1
30446 -- Don't warn for non-source entities
30448 and then Comes_From_Source
(Hidden
)
30449 and then Comes_From_Source
(Visible
)
30451 -- Don't warn within a generic instantiation
30453 and then not In_Instance
30455 -- Don't warn unless entity in question is in extended main source
30457 and then In_Extended_Main_Source_Unit
(Visible
)
30459 -- Finally, in the case of a declaration, the hidden entity must
30460 -- be either immediately visible or use visible (i.e. from a used
30461 -- package). In the case of a use clause, the visible entity must
30462 -- be immediately visible.
30465 (if On_Use_Clause
then
30466 Is_Immediately_Visible
(Visible
)
30468 (Is_Immediately_Visible
(Hidden
)
30470 Is_Potentially_Use_Visible
(Hidden
)))
30472 if On_Use_Clause
then
30473 Error_Msg_Sloc
:= Sloc
(Visible
);
30474 Error_Msg_NE
("visible declaration of&# hides homonym "
30475 & "from use clause?h?", N
, Hidden
);
30477 Error_Msg_Sloc
:= Sloc
(Hidden
);
30478 Error_Msg_NE
("declaration hides &#?h?", N
, Visible
);
30481 end Warn_On_Hiding_Entity
;
30483 ----------------------
30484 -- Within_Init_Proc --
30485 ----------------------
30487 function Within_Init_Proc
return Boolean is
30491 S
:= Current_Scope
;
30492 while not Is_Overloadable
(S
) loop
30493 if S
= Standard_Standard
then
30500 return Is_Init_Proc
(S
);
30501 end Within_Init_Proc
;
30503 ---------------------------
30504 -- Within_Protected_Type --
30505 ---------------------------
30507 function Within_Protected_Type
(E
: Entity_Id
) return Boolean is
30508 Scop
: Entity_Id
:= Scope
(E
);
30511 while Present
(Scop
) loop
30512 if Ekind
(Scop
) = E_Protected_Type
then
30516 Scop
:= Scope
(Scop
);
30520 end Within_Protected_Type
;
30526 function Within_Scope
(E
: Entity_Id
; S
: Entity_Id
) return Boolean is
30528 return Scope_Within_Or_Same
(Scope
(E
), S
);
30535 procedure Wrong_Type
(Expr
: Node_Id
; Expected_Type
: Entity_Id
) is
30536 Found_Type
: constant Entity_Id
:= First_Subtype
(Etype
(Expr
));
30537 Expec_Type
: constant Entity_Id
:= First_Subtype
(Expected_Type
);
30539 Err_Msg_Exp_Typ
: Entity_Id
:= Expected_Type
;
30540 -- Type entity used when printing errors concerning the expected type
30542 Matching_Field
: Entity_Id
;
30543 -- Entity to give a more precise suggestion on how to write a one-
30544 -- element positional aggregate.
30546 function Has_One_Matching_Field
return Boolean;
30547 -- Determines if Expec_Type is a record type with a single component or
30548 -- discriminant whose type matches the found type or is one dimensional
30549 -- array whose component type matches the found type. In the case of
30550 -- one discriminant, we ignore the variant parts. That's not accurate,
30551 -- but good enough for the warning.
30553 ----------------------------
30554 -- Has_One_Matching_Field --
30555 ----------------------------
30557 function Has_One_Matching_Field
return Boolean is
30561 Matching_Field
:= Empty
;
30563 if Is_Array_Type
(Expec_Type
)
30564 and then Number_Dimensions
(Expec_Type
) = 1
30565 and then Covers
(Etype
(Component_Type
(Expec_Type
)), Found_Type
)
30567 -- Use type name if available. This excludes multidimensional
30568 -- arrays and anonymous arrays.
30570 if Comes_From_Source
(Expec_Type
) then
30571 Matching_Field
:= Expec_Type
;
30573 -- For an assignment, use name of target
30575 elsif Nkind
(Parent
(Expr
)) = N_Assignment_Statement
30576 and then Is_Entity_Name
(Name
(Parent
(Expr
)))
30578 Matching_Field
:= Entity
(Name
(Parent
(Expr
)));
30583 elsif not Is_Record_Type
(Expec_Type
) then
30587 E
:= First_Entity
(Expec_Type
);
30592 elsif Ekind
(E
) not in E_Discriminant | E_Component
30593 or else Chars
(E
) in Name_uTag | Name_uParent
30602 if not Covers
(Etype
(E
), Found_Type
) then
30605 elsif Present
(Next_Entity
(E
))
30606 and then (Ekind
(E
) = E_Component
30607 or else Ekind
(Next_Entity
(E
)) = E_Discriminant
)
30612 Matching_Field
:= E
;
30616 end Has_One_Matching_Field
;
30618 -- Start of processing for Wrong_Type
30621 -- Don't output message if either type is Any_Type, or if a message
30622 -- has already been posted for this node. We need to do the latter
30623 -- check explicitly (it is ordinarily done in Errout), because we
30624 -- are using ! to force the output of the error messages.
30626 if Expec_Type
= Any_Type
30627 or else Found_Type
= Any_Type
30628 or else Error_Posted
(Expr
)
30632 -- If one of the types is a Taft-Amendment type and the other it its
30633 -- completion, it must be an illegal use of a TAT in the spec, for
30634 -- which an error was already emitted. Avoid cascaded errors.
30636 elsif Is_Incomplete_Type
(Expec_Type
)
30637 and then Has_Completion_In_Body
(Expec_Type
)
30638 and then Full_View
(Expec_Type
) = Etype
(Expr
)
30642 elsif Is_Incomplete_Type
(Etype
(Expr
))
30643 and then Has_Completion_In_Body
(Etype
(Expr
))
30644 and then Full_View
(Etype
(Expr
)) = Expec_Type
30648 -- In an instance, there is an ongoing problem with completion of
30649 -- types derived from private types. Their structure is what Gigi
30650 -- expects, but the Etype is the parent type rather than the derived
30651 -- private type itself. Do not flag error in this case. The private
30652 -- completion is an entity without a parent, like an Itype. Similarly,
30653 -- full and partial views may be incorrect in the instance.
30654 -- There is no simple way to insure that it is consistent ???
30656 -- A similar view discrepancy can happen in an inlined body, for the
30657 -- same reason: inserted body may be outside of the original package
30658 -- and only partial views are visible at the point of insertion.
30660 -- If In_Generic_Actual (Expr) is True then we cannot assume that
30661 -- the successful semantic analysis of the generic guarantees anything
30662 -- useful about type checking of this instance, so we ignore
30663 -- In_Instance in that case. There may be cases where this is not
30664 -- right (the symptom would probably be rejecting something
30665 -- that ought to be accepted) but we don't currently have any
30666 -- concrete examples of this.
30668 elsif (In_Instance
and then not In_Generic_Actual
(Expr
))
30669 or else In_Inlined_Body
30671 if Etype
(Etype
(Expr
)) = Etype
(Expected_Type
)
30673 (Has_Private_Declaration
(Expected_Type
)
30674 or else Has_Private_Declaration
(Etype
(Expr
)))
30675 and then No
(Parent
(Expected_Type
))
30679 elsif Nkind
(Parent
(Expr
)) = N_Qualified_Expression
30680 and then Entity
(Subtype_Mark
(Parent
(Expr
))) = Expected_Type
30684 elsif Is_Private_Type
(Expected_Type
)
30685 and then Present
(Full_View
(Expected_Type
))
30686 and then Covers
(Full_View
(Expected_Type
), Etype
(Expr
))
30690 -- Conversely, type of expression may be the private one
30692 elsif Is_Private_Type
(Base_Type
(Etype
(Expr
)))
30693 and then Full_View
(Base_Type
(Etype
(Expr
))) = Expected_Type
30699 -- Avoid printing internally generated subtypes in error messages and
30700 -- instead use the corresponding first subtype in such cases.
30702 if not Comes_From_Source
(Err_Msg_Exp_Typ
)
30703 or else not Comes_From_Source
(Declaration_Node
(Err_Msg_Exp_Typ
))
30705 Err_Msg_Exp_Typ
:= First_Subtype
(Err_Msg_Exp_Typ
);
30708 -- An interesting special check. If the expression is parenthesized
30709 -- and its type corresponds to the type of the sole component of the
30710 -- expected record type, or to the component type of the expected one
30711 -- dimensional array type, then assume we have a bad aggregate attempt.
30713 if Nkind
(Expr
) in N_Subexpr
30714 and then Paren_Count
(Expr
) /= 0
30715 and then Has_One_Matching_Field
30717 Error_Msg_N
("positional aggregate cannot have one component", Expr
);
30719 if Present
(Matching_Field
) then
30720 if Is_Array_Type
(Expec_Type
) then
30722 ("\write instead `&''First ='> ...`", Expr
, Matching_Field
);
30725 ("\write instead `& ='> ...`", Expr
, Matching_Field
);
30729 -- Another special check, if we are looking for a pool-specific access
30730 -- type and we found an E_Access_Attribute_Type, then we have the case
30731 -- of an Access attribute being used in a context which needs a pool-
30732 -- specific type, which is never allowed. The one extra check we make
30733 -- is that the expected designated type covers the Found_Type.
30735 elsif Is_Access_Type
(Expec_Type
)
30736 and then Ekind
(Found_Type
) = E_Access_Attribute_Type
30737 and then Ekind
(Base_Type
(Expec_Type
)) /= E_General_Access_Type
30738 and then Ekind
(Base_Type
(Expec_Type
)) /= E_Anonymous_Access_Type
30740 (Designated_Type
(Expec_Type
), Designated_Type
(Found_Type
))
30743 ("result must be general access type!", Expr
);
30744 Error_Msg_NE
-- CODEFIX
30745 ("\add ALL to }!", Expr
, Err_Msg_Exp_Typ
);
30747 -- Another special check, if the expected type is an integer type,
30748 -- but the expression is of type System.Address, and the parent is
30749 -- an addition or subtraction operation whose left operand is the
30750 -- expression in question and whose right operand is of an integral
30751 -- type, then this is an attempt at address arithmetic, so give
30752 -- appropriate message.
30754 elsif Is_Integer_Type
(Expec_Type
)
30755 and then Is_RTE
(Found_Type
, RE_Address
)
30756 and then Nkind
(Parent
(Expr
)) in N_Op_Add | N_Op_Subtract
30757 and then Expr
= Left_Opnd
(Parent
(Expr
))
30758 and then Is_Integer_Type
(Etype
(Right_Opnd
(Parent
(Expr
))))
30761 ("address arithmetic not predefined in package System",
30764 ("\possible missing with/use of System.Storage_Elements",
30768 -- If the expected type is an anonymous access type, as for access
30769 -- parameters and discriminants, the error is on the designated types.
30771 elsif Ekind
(Expec_Type
) = E_Anonymous_Access_Type
then
30772 if Comes_From_Source
(Expec_Type
) then
30773 Error_Msg_NE
("expected}!", Expr
, Expec_Type
);
30776 ("expected an access type with designated}",
30777 Expr
, Designated_Type
(Expec_Type
));
30780 if Is_Access_Type
(Found_Type
)
30781 and then not Comes_From_Source
(Found_Type
)
30784 ("\\found an access type with designated}!",
30785 Expr
, Designated_Type
(Found_Type
));
30787 if From_Limited_With
(Found_Type
) then
30788 Error_Msg_NE
("\\found incomplete}!", Expr
, Found_Type
);
30789 Error_Msg_Qual_Level
:= 99;
30790 Error_Msg_NE
-- CODEFIX
30791 ("\\missing `WITH &;", Expr
, Scope
(Found_Type
));
30792 Error_Msg_Qual_Level
:= 0;
30794 Error_Msg_NE
("found}!", Expr
, Found_Type
);
30798 -- Normal case of one type found, some other type expected
30801 -- If the names of the two types are the same, see if some number
30802 -- of levels of qualification will help. Don't try more than three
30803 -- levels, and if we get to standard, it's no use (and probably
30804 -- represents an error in the compiler) Also do not bother with
30805 -- internal scope names.
30808 Expec_Scope
: Entity_Id
;
30809 Found_Scope
: Entity_Id
;
30812 Expec_Scope
:= Expec_Type
;
30813 Found_Scope
:= Found_Type
;
30815 for Levels
in Nat
range 0 .. 3 loop
30816 if Chars
(Expec_Scope
) /= Chars
(Found_Scope
) then
30817 Error_Msg_Qual_Level
:= Levels
;
30821 Expec_Scope
:= Scope
(Expec_Scope
);
30822 Found_Scope
:= Scope
(Found_Scope
);
30824 exit when Expec_Scope
= Standard_Standard
30825 or else Found_Scope
= Standard_Standard
30826 or else not Comes_From_Source
(Expec_Scope
)
30827 or else not Comes_From_Source
(Found_Scope
);
30831 if Is_Record_Type
(Expec_Type
)
30832 and then Present
(Corresponding_Remote_Type
(Expec_Type
))
30834 Error_Msg_NE
("expected}!", Expr
,
30835 Corresponding_Remote_Type
(Expec_Type
));
30837 Error_Msg_NE
("expected}!", Expr
, Err_Msg_Exp_Typ
);
30840 if Is_Entity_Name
(Expr
)
30841 and then Is_Package_Or_Generic_Package
(Entity
(Expr
))
30843 Error_Msg_N
("\\found package name!", Expr
);
30845 elsif Is_Entity_Name
(Expr
)
30846 and then Ekind
(Entity
(Expr
)) in E_Procedure | E_Generic_Procedure
30848 if Ekind
(Expec_Type
) = E_Access_Subprogram_Type
then
30850 ("found procedure name, possibly missing Access attribute!",
30854 ("\\found procedure name instead of function!", Expr
);
30857 elsif Nkind
(Expr
) = N_Function_Call
30858 and then Ekind
(Expec_Type
) = E_Access_Subprogram_Type
30859 and then Etype
(Designated_Type
(Expec_Type
)) = Etype
(Expr
)
30860 and then No
(Parameter_Associations
(Expr
))
30863 ("found function name, possibly missing Access attribute!",
30866 -- Catch common error: a prefix or infix operator which is not
30867 -- directly visible because the type isn't.
30869 elsif Nkind
(Expr
) in N_Op
30870 and then Is_Overloaded
(Expr
)
30871 and then not Is_Immediately_Visible
(Expec_Type
)
30872 and then not Is_Potentially_Use_Visible
(Expec_Type
)
30873 and then not In_Use
(Expec_Type
)
30874 and then Has_Compatible_Type
(Right_Opnd
(Expr
), Expec_Type
)
30877 ("operator of the type is not directly visible!", Expr
);
30879 elsif Ekind
(Found_Type
) = E_Void
30880 and then Present
(Parent
(Found_Type
))
30881 and then Nkind
(Parent
(Found_Type
)) = N_Full_Type_Declaration
30883 Error_Msg_NE
("\\found premature usage of}!", Expr
, Found_Type
);
30886 Error_Msg_NE
("\\found}!", Expr
, Found_Type
);
30889 -- A special check for cases like M1 and M2 = 0 where M1 and M2 are
30890 -- of the same modular type, and (M1 and M2) = 0 was intended.
30892 if Expec_Type
= Standard_Boolean
30893 and then Is_Modular_Integer_Type
(Found_Type
)
30894 and then Nkind
(Parent
(Expr
)) in N_Op_And | N_Op_Or | N_Op_Xor
30895 and then Nkind
(Right_Opnd
(Parent
(Expr
))) in N_Op_Compare
30898 Op
: constant Node_Id
:= Right_Opnd
(Parent
(Expr
));
30899 L
: constant Node_Id
:= Left_Opnd
(Op
);
30900 R
: constant Node_Id
:= Right_Opnd
(Op
);
30903 -- The case for the message is when the left operand of the
30904 -- comparison is the same modular type, or when it is an
30905 -- integer literal (or other universal integer expression),
30906 -- which would have been typed as the modular type if the
30907 -- parens had been there.
30909 if (Etype
(L
) = Found_Type
30911 Etype
(L
) = Universal_Integer
)
30912 and then Is_Integer_Type
(Etype
(R
))
30915 ("\\possible missing parens for modular operation", Expr
);
30920 -- Reset error message qualification indication
30922 Error_Msg_Qual_Level
:= 0;
30926 --------------------------------
30927 -- Yields_Synchronized_Object --
30928 --------------------------------
30930 function Yields_Synchronized_Object
(Typ
: Entity_Id
) return Boolean is
30931 Has_Sync_Comp
: Boolean := False;
30935 -- An array type yields a synchronized object if its component type
30936 -- yields a synchronized object.
30938 if Is_Array_Type
(Typ
) then
30939 return Yields_Synchronized_Object
(Component_Type
(Typ
));
30941 -- A descendant of type Ada.Synchronous_Task_Control.Suspension_Object
30942 -- yields a synchronized object by default.
30944 elsif Is_Descendant_Of_Suspension_Object
(Typ
) then
30947 -- A protected type yields a synchronized object by default
30949 elsif Is_Protected_Type
(Typ
) then
30952 -- A record type or type extension yields a synchronized object when its
30953 -- discriminants (if any) lack default values and all components are of
30954 -- a type that yields a synchronized object.
30956 elsif Is_Record_Type
(Typ
) then
30958 -- Inspect all entities defined in the scope of the type, looking for
30959 -- components of a type that does not yield a synchronized object or
30960 -- for discriminants with default values.
30962 Id
:= First_Entity
(Typ
);
30963 while Present
(Id
) loop
30964 if Comes_From_Source
(Id
) then
30965 if Ekind
(Id
) = E_Component
then
30966 if Yields_Synchronized_Object
(Etype
(Id
)) then
30967 Has_Sync_Comp
:= True;
30969 -- The component does not yield a synchronized object
30975 elsif Ekind
(Id
) = E_Discriminant
30976 and then Present
(Expression
(Parent
(Id
)))
30985 -- Ensure that the parent type of a type extension yields a
30986 -- synchronized object.
30988 if Etype
(Typ
) /= Typ
30989 and then not Is_Private_Type
(Etype
(Typ
))
30990 and then not Yields_Synchronized_Object
(Etype
(Typ
))
30995 -- If we get here, then all discriminants lack default values and all
30996 -- components are of a type that yields a synchronized object.
30998 return Has_Sync_Comp
;
31000 -- A synchronized interface type yields a synchronized object by default
31002 elsif Is_Synchronized_Interface
(Typ
) then
31005 -- A task type yields a synchronized object by default
31007 elsif Is_Task_Type
(Typ
) then
31010 -- A private type yields a synchronized object if its underlying type
31013 elsif Is_Private_Type
(Typ
)
31014 and then Present
(Underlying_Type
(Typ
))
31016 return Yields_Synchronized_Object
(Underlying_Type
(Typ
));
31018 -- Otherwise the type does not yield a synchronized object
31023 end Yields_Synchronized_Object
;
31025 ---------------------------
31026 -- Yields_Universal_Type --
31027 ---------------------------
31029 function Yields_Universal_Type
(N
: Node_Id
) return Boolean is
31031 -- Integer and real literals are of a universal type
31033 if Nkind
(N
) in N_Integer_Literal | N_Real_Literal
then
31036 -- The values of certain attributes are of a universal type
31038 elsif Nkind
(N
) = N_Attribute_Reference
then
31040 Universal_Type_Attribute
(Get_Attribute_Id
(Attribute_Name
(N
)));
31042 -- ??? There are possibly other cases to consider
31047 end Yields_Universal_Type
;
31049 package body Interval_Lists
is
31051 procedure Check_Consistency
(Intervals
: Discrete_Interval_List
);
31052 -- Check that list is sorted, lacks null intervals, and has gaps
31053 -- between intervals.
31055 function Chosen_Interval
(Choice
: Node_Id
) return Discrete_Interval
;
31056 -- Given an element of a Discrete_Choices list, a
31057 -- Static_Discrete_Predicate list, or an Others_Discrete_Choices
31058 -- list (but not an N_Others_Choice node) return the corresponding
31059 -- interval. If an element that does not represent a single
31060 -- contiguous interval due to a static predicate (or which
31061 -- represents a single contiguous interval whose bounds depend on
31062 -- a static predicate) is encountered, then that is an error on the
31063 -- part of whoever built the list in question.
31065 function In_Interval
31066 (Value
: Uint
; Interval
: Discrete_Interval
) return Boolean;
31067 -- Does the given value lie within the given interval?
31069 procedure Normalize_Interval_List
31070 (List
: in out Discrete_Interval_List
; Last
: out Nat
);
31071 -- Perform sorting and merging as required by Check_Consistency
31073 -------------------------
31074 -- Aggregate_Intervals --
31075 -------------------------
31077 function Aggregate_Intervals
(N
: Node_Id
) return Discrete_Interval_List
31079 pragma Assert
(Nkind
(N
) = N_Aggregate
31080 and then Is_Array_Type
(Etype
(N
)));
31082 function Unmerged_Intervals_Count
return Nat
;
31083 -- Count the number of intervals given in the aggregate N; the others
31084 -- choice (if present) is not taken into account.
31086 ------------------------------
31087 -- Unmerged_Intervals_Count --
31088 ------------------------------
31090 function Unmerged_Intervals_Count
return Nat
is
31095 Comp
:= First
(Component_Associations
(N
));
31096 while Present
(Comp
) loop
31097 Choice
:= First
(Choices
(Comp
));
31099 while Present
(Choice
) loop
31100 if Nkind
(Choice
) /= N_Others_Choice
then
31101 Count
:= Count
+ 1;
31111 end Unmerged_Intervals_Count
;
31116 Max_I
: constant Nat
:= Unmerged_Intervals_Count
;
31117 Intervals
: Discrete_Interval_List
(1 .. Max_I
);
31120 -- Start of processing for Aggregate_Intervals
31123 -- No action needed if there are no intervals
31129 -- Internally store all the unsorted intervals
31131 Comp
:= First
(Component_Associations
(N
));
31132 while Present
(Comp
) loop
31134 Choice_Intervals
: constant Discrete_Interval_List
31135 := Choice_List_Intervals
(Choices
(Comp
));
31137 for J
in Choice_Intervals
'Range loop
31138 Num_I
:= Num_I
+ 1;
31139 Intervals
(Num_I
) := Choice_Intervals
(J
);
31146 -- Normalize the lists sorting and merging the intervals
31149 Aggr_Intervals
: Discrete_Interval_List
(1 .. Num_I
)
31150 := Intervals
(1 .. Num_I
);
31152 Normalize_Interval_List
(Aggr_Intervals
, Num_I
);
31153 Check_Consistency
(Aggr_Intervals
(1 .. Num_I
));
31154 return Aggr_Intervals
(1 .. Num_I
);
31156 end Aggregate_Intervals
;
31158 ------------------------
31159 -- Check_Consistency --
31160 ------------------------
31162 procedure Check_Consistency
(Intervals
: Discrete_Interval_List
) is
31164 if Serious_Errors_Detected
> 0 then
31168 -- low bound is 1 and high bound equals length
31169 pragma Assert
(Intervals
'First = 1 and Intervals
'Last >= 0);
31170 for Idx
in Intervals
'Range loop
31171 -- each interval is non-null
31172 pragma Assert
(Intervals
(Idx
).Low
<= Intervals
(Idx
).High
);
31173 if Idx
/= Intervals
'First then
31174 -- intervals are sorted with non-empty gaps between them
31176 (Intervals
(Idx
- 1).High
< (Intervals
(Idx
).Low
- 1));
31180 end Check_Consistency
;
31182 ---------------------------
31183 -- Choice_List_Intervals --
31184 ---------------------------
31186 function Choice_List_Intervals
31187 (Discrete_Choices
: List_Id
) return Discrete_Interval_List
31189 function Unmerged_Choice_Count
return Nat
;
31190 -- The number of intervals before adjacent intervals are merged
31192 ---------------------------
31193 -- Unmerged_Choice_Count --
31194 ---------------------------
31196 function Unmerged_Choice_Count
return Nat
is
31197 Choice
: Node_Id
:= First
(Discrete_Choices
);
31200 while Present
(Choice
) loop
31201 -- Non-contiguous choices involving static predicates
31202 -- have already been normalized away.
31204 if Nkind
(Choice
) = N_Others_Choice
then
31206 Count
+ List_Length
(Others_Discrete_Choices
(Choice
));
31208 Count
:= Count
+ 1; -- an ordinary expression or range
31214 end Unmerged_Choice_Count
;
31218 Choice
: Node_Id
:= First
(Discrete_Choices
);
31219 Result
: Discrete_Interval_List
(1 .. Unmerged_Choice_Count
);
31222 -- Start of processing for Choice_List_Intervals
31225 while Present
(Choice
) loop
31226 if Nkind
(Choice
) = N_Others_Choice
then
31228 Others_Choice
: Node_Id
31229 := First
(Others_Discrete_Choices
(Choice
));
31231 while Present
(Others_Choice
) loop
31232 Count
:= Count
+ 1;
31233 Result
(Count
) := Chosen_Interval
(Others_Choice
);
31234 Next
(Others_Choice
);
31238 Count
:= Count
+ 1;
31239 Result
(Count
) := Chosen_Interval
(Choice
);
31245 pragma Assert
(Count
= Result
'Last);
31246 Normalize_Interval_List
(Result
, Count
);
31247 Check_Consistency
(Result
(1 .. Count
));
31248 return Result
(1 .. Count
);
31249 end Choice_List_Intervals
;
31251 ---------------------
31252 -- Chosen_Interval --
31253 ---------------------
31255 function Chosen_Interval
(Choice
: Node_Id
) return Discrete_Interval
is
31257 case Nkind
(Choice
) is
31259 return (Low
=> Expr_Value
(Low_Bound
(Choice
)),
31260 High
=> Expr_Value
(High_Bound
(Choice
)));
31262 when N_Subtype_Indication
=>
31264 Range_Exp
: constant Node_Id
31265 := Range_Expression
(Constraint
(Choice
));
31267 return (Low
=> Expr_Value
(Low_Bound
(Range_Exp
)),
31268 High
=> Expr_Value
(High_Bound
(Range_Exp
)));
31271 when N_Others_Choice
=>
31272 raise Program_Error
;
31275 if Is_Entity_Name
(Choice
) and then Is_Type
(Entity
(Choice
))
31278 (Low
=> Expr_Value
(Type_Low_Bound
(Entity
(Choice
))),
31279 High
=> Expr_Value
(Type_High_Bound
(Entity
(Choice
))));
31282 return (Low | High
=> Expr_Value
(Choice
));
31285 end Chosen_Interval
;
31291 function In_Interval
31292 (Value
: Uint
; Interval
: Discrete_Interval
) return Boolean is
31294 return Value
>= Interval
.Low
and then Value
<= Interval
.High
;
31302 (Subset
, Of_Set
: Discrete_Interval_List
) return Boolean
31304 -- Returns True iff for each interval of Subset we can find
31305 -- a single interval of Of_Set which contains the Subset interval.
31307 if Of_Set
'Length = 0 then
31308 return Subset
'Length = 0;
31312 Set_Index
: Pos
range Of_Set
'Range := Of_Set
'First;
31315 for Ss_Idx
in Subset
'Range loop
31316 while not In_Interval
31317 (Value
=> Subset
(Ss_Idx
).Low
,
31318 Interval
=> Of_Set
(Set_Index
))
31320 if Set_Index
= Of_Set
'Last then
31324 Set_Index
:= Set_Index
+ 1;
31328 (Value
=> Subset
(Ss_Idx
).High
,
31329 Interval
=> Of_Set
(Set_Index
))
31339 -----------------------------
31340 -- Normalize_Interval_List --
31341 -----------------------------
31343 procedure Normalize_Interval_List
31344 (List
: in out Discrete_Interval_List
; Last
: out Nat
)
31346 Temp_0
: Discrete_Interval
:= (others => Uint_0
);
31347 -- Cope with Heap_Sort_G idiosyncrasies.
31349 function Is_Null
(Idx
: Pos
) return Boolean;
31350 -- True iff List (Idx) defines a null range
31352 function Lt_Interval
(Idx1
, Idx2
: Natural) return Boolean;
31353 -- Compare two list elements
31355 procedure Merge_Intervals
(Null_Interval_Count
: out Nat
);
31356 -- Merge contiguous ranges by replacing one with merged range and
31357 -- the other with a null value. Return a count of the null intervals,
31358 -- both preexisting and those introduced by merging.
31360 procedure Move_Interval
(From
, To
: Natural);
31361 -- Copy interval from one location to another
31363 function Read_Interval
(From
: Natural) return Discrete_Interval
;
31364 -- Normal array indexing unless From = 0
31366 ----------------------
31367 -- Interval_Sorting --
31368 ----------------------
31370 package Interval_Sorting
is
31371 new Gnat
.Heap_Sort_G
(Move_Interval
, Lt_Interval
);
31377 function Is_Null
(Idx
: Pos
) return Boolean is
31379 return List
(Idx
).Low
> List
(Idx
).High
;
31386 function Lt_Interval
(Idx1
, Idx2
: Natural) return Boolean is
31387 Elem1
: constant Discrete_Interval
:= Read_Interval
(Idx1
);
31388 Elem2
: constant Discrete_Interval
:= Read_Interval
(Idx2
);
31389 Null_1
: constant Boolean := Elem1
.Low
> Elem1
.High
;
31390 Null_2
: constant Boolean := Elem2
.Low
> Elem2
.High
;
31392 if Null_1
/= Null_2
then
31393 -- So that sorting moves null intervals to high end
31396 elsif Elem1
.Low
/= Elem2
.Low
then
31397 return Elem1
.Low
< Elem2
.Low
;
31400 return Elem1
.High
< Elem2
.High
;
31404 ---------------------
31405 -- Merge_Intervals --
31406 ---------------------
31408 procedure Merge_Intervals
(Null_Interval_Count
: out Nat
) is
31409 Not_Null
: Pos
range List
'Range;
31410 -- Index of the most recently examined non-null interval
31412 Null_Interval
: constant Discrete_Interval
31413 := (Low
=> Uint_1
, High
=> Uint_0
); -- any null range ok here
31415 if List
'Length = 0 or else Is_Null
(List
'First) then
31416 Null_Interval_Count
:= List
'Length;
31417 -- no non-null elements, so no merge candidates
31421 Null_Interval_Count
:= 0;
31422 Not_Null
:= List
'First;
31424 for Idx
in List
'First + 1 .. List
'Last loop
31425 if Is_Null
(Idx
) then
31427 -- all remaining elements are null
31429 Null_Interval_Count
:=
31430 Null_Interval_Count
+ List
(Idx
.. List
'Last)'Length;
31433 elsif List
(Idx
).Low
= List
(Not_Null
).High
+ 1 then
31435 -- Merge the two intervals into one; discard the other
31437 List
(Not_Null
).High
:= List
(Idx
).High
;
31438 List
(Idx
) := Null_Interval
;
31439 Null_Interval_Count
:= Null_Interval_Count
+ 1;
31442 if List
(Idx
).Low
<= List
(Not_Null
).High
then
31443 raise Intervals_Error
;
31446 pragma Assert
(List
(Idx
).Low
> List
(Not_Null
).High
);
31450 end Merge_Intervals
;
31452 -------------------
31453 -- Move_Interval --
31454 -------------------
31456 procedure Move_Interval
(From
, To
: Natural) is
31457 Rhs
: constant Discrete_Interval
:= Read_Interval
(From
);
31462 List
(Pos
(To
)) := Rhs
;
31466 -------------------
31467 -- Read_Interval --
31468 -------------------
31470 function Read_Interval
(From
: Natural) return Discrete_Interval
is
31475 return List
(Pos
(From
));
31479 -- Start of processing for Normalize_Interval_Lists
31482 Interval_Sorting
.Sort
(Natural (List
'Last));
31485 Null_Interval_Count
: Nat
;
31488 Merge_Intervals
(Null_Interval_Count
);
31489 Last
:= List
'Last - Null_Interval_Count
;
31491 if Null_Interval_Count
/= 0 then
31492 -- Move null intervals introduced during merging to high end
31493 Interval_Sorting
.Sort
(Natural (List
'Last));
31496 end Normalize_Interval_List
;
31498 --------------------
31499 -- Type_Intervals --
31500 --------------------
31502 function Type_Intervals
(Typ
: Entity_Id
) return Discrete_Interval_List
31505 if Has_Static_Predicate
(Typ
) then
31507 -- No sorting or merging needed
31508 SDP_List
: constant List_Id
:= Static_Discrete_Predicate
(Typ
);
31509 Range_Or_Expr
: Node_Id
:= First
(SDP_List
);
31510 Result
: Discrete_Interval_List
(1 .. List_Length
(SDP_List
));
31513 for Idx
in Result
'Range loop
31514 Result
(Idx
) := Chosen_Interval
(Range_Or_Expr
);
31515 Next
(Range_Or_Expr
);
31518 pragma Assert
(not Present
(Range_Or_Expr
));
31519 Check_Consistency
(Result
);
31524 Low
: constant Uint
:= Expr_Value
(Type_Low_Bound
(Typ
));
31525 High
: constant Uint
:= Expr_Value
(Type_High_Bound
(Typ
));
31529 Null_Array
: Discrete_Interval_List
(1 .. 0);
31534 return (1 => (Low
=> Low
, High
=> High
));
31538 end Type_Intervals
;
31540 end Interval_Lists
;
31542 package body Old_Attr_Util
is
31543 package body Conditional_Evaluation
is
31544 type Determining_Expr_Context
is
31545 (No_Context
, If_Expr
, Case_Expr
, Short_Circuit_Op
, Membership_Test
);
31547 -- Determining_Expr_Context enumeration elements (except for
31548 -- No_Context) correspond to the list items in RM 6.1.1 definition
31549 -- of "determining expression".
31551 type Determining_Expr
31552 (Context
: Determining_Expr_Context
:= No_Context
)
31554 Expr
: Node_Id
:= Empty
;
31556 when Short_Circuit_Op
=>
31557 Is_And_Then
: Boolean;
31559 Is_Then_Part
: Boolean;
31561 Alternatives
: Node_Id
;
31562 when Membership_Test
=>
31563 -- Given a subexpression of <exp4> in a membership test
31564 -- <exp1> in <exp2> | <exp3> | <exp4> | <exp5>
31565 -- the corresponding determining expression value would
31566 -- have First_Non_Preceding = <exp4> (See RM 6.1.1).
31567 First_Non_Preceding
: Node_Id
;
31573 type Determining_Expression_List
is
31574 array (Positive range <>) of Determining_Expr
;
31576 function Determining_Condition
(Det
: Determining_Expr
)
31578 -- Given a determining expression, build a Boolean-valued
31579 -- condition that incorporates that expression into condition
31580 -- suitable for deciding whether to initialize a 'Old constant.
31581 -- Polarity is "True => initialize the constant".
31583 function Determining_Expressions
31584 (Expr
: Node_Id
; Expr_Trailer
: Node_Id
:= Empty
)
31585 return Determining_Expression_List
;
31586 -- Given a conditionally evaluated expression, return its
31587 -- determining expressions.
31588 -- See RM 6.1.1 for definition of term "determining expressions".
31589 -- Tests should be performed in the order they occur in the
31590 -- array, with short circuiting.
31591 -- A determining expression need not be of a boolean type (e.g.,
31592 -- it might be the determining expression of a case expression).
31593 -- The Expr_Trailer parameter should be defaulted for nonrecursive
31596 function Is_Conditionally_Evaluated
(Expr
: Node_Id
) return Boolean;
31597 -- See RM 6.1.1 for definition of term "conditionally evaluated".
31599 function Is_Known_On_Entry
(Expr
: Node_Id
) return Boolean;
31600 -- See RM 6.1.1 for definition of term "known on entry".
31602 --------------------------------------
31603 -- Conditional_Evaluation_Condition --
31604 --------------------------------------
31606 function Conditional_Evaluation_Condition
31607 (Expr
: Node_Id
) return Node_Id
31609 Determiners
: constant Determining_Expression_List
:=
31610 Determining_Expressions
(Expr
);
31611 Loc
: constant Source_Ptr
:= Sloc
(Expr
);
31612 Result
: Node_Id
:=
31613 New_Occurrence_Of
(Standard_True
, Loc
);
31615 pragma Assert
(Determiners
'Length > 0 or else
31616 Is_Anonymous_Access_Type
(Etype
(Expr
)));
31618 for I
in Determiners
'Range loop
31619 Result
:= Make_And_Then
31621 Left_Opnd
=> Result
,
31623 Determining_Condition
(Determiners
(I
)));
31626 end Conditional_Evaluation_Condition
;
31628 ---------------------------
31629 -- Determining_Condition --
31630 ---------------------------
31632 function Determining_Condition
(Det
: Determining_Expr
) return Node_Id
31634 Loc
: constant Source_Ptr
:= Sloc
(Det
.Expr
);
31636 case Det
.Context
is
31637 when Short_Circuit_Op
=>
31638 if Det
.Is_And_Then
then
31639 return New_Copy_Tree
(Det
.Expr
);
31641 return Make_Op_Not
(Loc
, New_Copy_Tree
(Det
.Expr
));
31645 if Det
.Is_Then_Part
then
31646 return New_Copy_Tree
(Det
.Expr
);
31648 return Make_Op_Not
(Loc
, New_Copy_Tree
(Det
.Expr
));
31653 Alts
: List_Id
:= Discrete_Choices
(Det
.Alternatives
);
31655 if Nkind
(First
(Alts
)) = N_Others_Choice
then
31656 Alts
:= Others_Discrete_Choices
(First
(Alts
));
31659 return Make_In
(Loc
,
31660 Left_Opnd
=> New_Copy_Tree
(Det
.Expr
),
31661 Right_Opnd
=> Empty
,
31662 Alternatives
=> New_Copy_List
(Alts
));
31665 when Membership_Test
=>
31667 function Copy_Prefix
31668 (List
: List_Id
; Suffix_Start
: Node_Id
)
31670 -- Given a list and a member of that list, returns
31671 -- a copy (similar to Nlists.New_Copy_List) of the
31672 -- prefix of the list up to but not including
31679 function Copy_Prefix
31680 (List
: List_Id
; Suffix_Start
: Node_Id
)
31683 Result
: constant List_Id
:= New_List
;
31684 Elem
: Node_Id
:= First
(List
);
31686 while Elem
/= Suffix_Start
loop
31687 Append
(New_Copy
(Elem
), Result
);
31689 pragma Assert
(Present
(Elem
));
31695 return Make_In
(Loc
,
31696 Left_Opnd
=> New_Copy_Tree
(Left_Opnd
(Det
.Expr
)),
31697 Right_Opnd
=> Empty
,
31698 Alternatives
=> Copy_Prefix
31699 (Alternatives
(Det
.Expr
),
31700 Det
.First_Non_Preceding
));
31704 raise Program_Error
;
31706 end Determining_Condition
;
31708 -----------------------------
31709 -- Determining_Expressions --
31710 -----------------------------
31712 function Determining_Expressions
31713 (Expr
: Node_Id
; Expr_Trailer
: Node_Id
:= Empty
)
31714 return Determining_Expression_List
31716 Par
: Node_Id
:= Expr
;
31717 Trailer
: Node_Id
:= Expr_Trailer
;
31718 Next_Element
: Determining_Expr
;
31720 -- We want to stop climbing up the tree when we reach the
31721 -- postcondition expression. An aspect_specification is
31722 -- transformed into a pragma, so reaching a pragma is our
31723 -- termination condition. This relies on the fact that
31724 -- pragmas are not allowed in declare expressions (or any
31725 -- other kind of expression).
31728 Next_Element
.Expr
:= Empty
;
31730 case Nkind
(Par
) is
31731 when N_Short_Circuit
=>
31732 if Trailer
= Right_Opnd
(Par
) then
31734 (Expr
=> Left_Opnd
(Par
),
31735 Context
=> Short_Circuit_Op
,
31736 Is_And_Then
=> Nkind
(Par
) = N_And_Then
);
31739 when N_If_Expression
=>
31740 -- For an expression like
31741 -- (if C1 then ... elsif C2 then ... else Foo'Old)
31742 -- the RM says are two determining expressions,
31743 -- C1 and C2. Our treatment here (where we only add
31744 -- one determining expression to the list) is ok because
31745 -- we will see two if-expressions, one within the other.
31747 if Trailer
/= First
(Expressions
(Par
)) then
31749 (Expr
=> First
(Expressions
(Par
)),
31750 Context
=> If_Expr
,
31752 Trailer
= Next
(First
(Expressions
(Par
))));
31755 when N_Case_Expression_Alternative
=>
31756 pragma Assert
(Nkind
(Parent
(Par
)) = N_Case_Expression
);
31759 (Expr
=> Expression
(Parent
(Par
)),
31760 Context
=> Case_Expr
,
31761 Alternatives
=> Par
);
31763 when N_Membership_Test
=>
31764 if Trailer
/= Left_Opnd
(Par
)
31765 and then Is_Non_Empty_List
(Alternatives
(Par
))
31766 and then Trailer
/= First
(Alternatives
(Par
))
31768 pragma Assert
(not Present
(Right_Opnd
(Par
)));
31770 (Is_List_Member
(Trailer
)
31771 and then List_Containing
(Trailer
)
31772 = Alternatives
(Par
));
31774 -- This one is different than the others
31775 -- because one element in the array result
31776 -- may represent multiple determining
31777 -- expressions (i.e. every member of the list
31778 -- Alternatives (Par)
31779 -- up to but not including Trailer).
31783 Context
=> Membership_Test
,
31784 First_Non_Preceding
=> Trailer
);
31789 Previous
: constant Node_Id
:= Prev
(Par
);
31790 Prev_Expr
: Node_Id
;
31792 if Nkind
(Previous
) = N_Pragma
and then
31793 Split_PPC
(Previous
)
31795 -- A source-level postcondition of
31796 -- A and then B and then C
31798 -- pragma Postcondition (A);
31799 -- pragma Postcondition (B);
31800 -- pragma Postcondition (C);
31801 -- with Split_PPC set to True on all but the
31802 -- last pragma. We account for that here.
31806 (Pragma_Argument_Associations
(Previous
)));
31808 -- This Analyze call is needed in the case when
31809 -- Sem_Attr.Analyze_Attribute calls
31810 -- Eligible_For_Conditional_Evaluation. Without
31811 -- it, we end up passing an unanalyzed expression
31812 -- to Is_Known_On_Entry and that doesn't work.
31814 Analyze
(Prev_Expr
);
31817 (Expr
=> Prev_Expr
,
31818 Context
=> Short_Circuit_Op
,
31819 Is_And_Then
=> True);
31821 return Determining_Expressions
(Prev_Expr
)
31825 (Get_Pragma_Id
(Pragma_Name
(Par
)) in
31826 Pragma_Post | Pragma_Postcondition
31827 | Pragma_Post_Class | Pragma_Refined_Post
31828 | Pragma_Check | Pragma_Contract_Cases
);
31830 return (1 .. 0 => <>); -- recursion terminates here
31835 -- This case should be impossible, but if it does
31836 -- happen somehow then we don't want an infinite loop.
31837 raise Program_Error
;
31844 Par
:= Parent
(Par
);
31846 if Present
(Next_Element
.Expr
) then
31847 return Determining_Expressions
31848 (Expr
=> Par
, Expr_Trailer
=> Trailer
)
31852 end Determining_Expressions
;
31854 -----------------------------------------
31855 -- Eligible_For_Conditional_Evaluation --
31856 -----------------------------------------
31858 function Eligible_For_Conditional_Evaluation
31859 (Expr
: Node_Id
) return Boolean
31862 if Is_Anonymous_Access_Type
(Etype
(Expr
)) then
31863 -- The code in exp_attr.adb that also builds declarations
31864 -- for 'Old constants doesn't handle the anonymous access
31865 -- type case correctly, so we avoid that problem by
31866 -- returning True here.
31869 elsif Ada_Version
< Ada_2022
then
31872 elsif Inside_Class_Condition_Preanalysis
then
31873 -- No need to evaluate it during preanalysis of a class-wide
31874 -- pre/postcondition since the expression is not installed yet
31875 -- on its definite context.
31878 elsif not Is_Conditionally_Evaluated
(Expr
) then
31882 Determiners
: constant Determining_Expression_List
:=
31883 Determining_Expressions
(Expr
);
31885 pragma Assert
(Determiners
'Length > 0);
31887 for Idx
in Determiners
'Range loop
31888 if not Is_Known_On_Entry
(Determiners
(Idx
).Expr
) then
31895 end Eligible_For_Conditional_Evaluation
;
31897 --------------------------------
31898 -- Is_Conditionally_Evaluated --
31899 --------------------------------
31901 function Is_Conditionally_Evaluated
(Expr
: Node_Id
) return Boolean
31903 -- There are three possibilities - the expression is
31904 -- unconditionally evaluated, repeatedly evaluated, or
31905 -- conditionally evaluated (see RM 6.1.1). So we implement
31906 -- this test by testing for the other two.
31908 function Is_Repeatedly_Evaluated
(Expr
: Node_Id
) return Boolean;
31909 -- See RM 6.1.1 for definition of "repeatedly evaluated".
31911 -----------------------------
31912 -- Is_Repeatedly_Evaluated --
31913 -----------------------------
31915 function Is_Repeatedly_Evaluated
(Expr
: Node_Id
) return Boolean is
31916 Par
: Node_Id
:= Expr
;
31917 Trailer
: Node_Id
:= Empty
;
31919 -- There are three ways that an expression can be repeatedly
31922 -- An aspect_specification is transformed into a pragma, so
31923 -- reaching a pragma is our termination condition. We want to
31924 -- stop when we reach the postcondition expression.
31926 while Nkind
(Par
) /= N_Pragma
loop
31927 pragma Assert
(Present
(Par
));
31929 -- test for case 1:
31930 -- A subexpression of a predicate of a
31931 -- quantified_expression.
31933 if Nkind
(Par
) = N_Quantified_Expression
31934 and then Trailer
= Condition
(Par
)
31937 elsif Nkind
(Par
) = N_Expression_With_Actions
31939 Nkind
(Original_Node
(Par
)) = N_Quantified_Expression
31944 -- test for cases 2 and 3:
31945 -- A subexpression of the expression of an
31946 -- array_component_association or of
31947 -- a container_element_associatiation.
31949 if Nkind
(Par
) = N_Component_Association
31950 and then Trailer
= Expression
(Par
)
31952 -- determine whether Par is part of an array aggregate
31953 -- or a container aggregate
31955 Rover
: Node_Id
:= Par
;
31957 while Nkind
(Rover
) not in N_Has_Etype
loop
31958 pragma Assert
(Present
(Rover
));
31959 Rover
:= Parent
(Rover
);
31961 if Present
(Etype
(Rover
)) then
31962 if Is_Array_Type
(Etype
(Rover
))
31963 or else Is_Container_Aggregate
(Rover
)
31972 Par
:= Parent
(Par
);
31976 end Is_Repeatedly_Evaluated
;
31979 if not Is_Potentially_Unevaluated
(Expr
) then
31980 -- the expression is unconditionally evaluated
31982 elsif Is_Repeatedly_Evaluated
(Expr
) then
31987 end Is_Conditionally_Evaluated
;
31989 -----------------------
31990 -- Is_Known_On_Entry --
31991 -----------------------
31993 function Is_Known_On_Entry
(Expr
: Node_Id
) return Boolean is
31994 -- ??? This implementation is incomplete. See RM 6.1.1
31995 -- for details. In particular, this function *should* return
31996 -- True for a function call (or a user-defined literal, which
31997 -- is equivalent to a function call) if all actual parameters
31998 -- (including defaulted params) are known on entry and the
31999 -- function has "Globals => null" specified; the current
32000 -- implementation will incorrectly return False in this case.
32002 function All_Exps_Known_On_Entry
32003 (Expr_List
: List_Id
) return Boolean;
32004 -- Given a list of expressions, returns False iff
32005 -- Is_Known_On_Entry is False for at least one list element.
32007 -----------------------------
32008 -- All_Exps_Known_On_Entry --
32009 -----------------------------
32011 function All_Exps_Known_On_Entry
32012 (Expr_List
: List_Id
) return Boolean
32014 Expr
: Node_Id
:= First
(Expr_List
);
32016 while Present
(Expr
) loop
32017 if not Is_Known_On_Entry
(Expr
) then
32023 end All_Exps_Known_On_Entry
;
32026 if Is_Static_Expression
(Expr
) then
32030 if Is_Attribute_Old
(Expr
) then
32035 Pref
: Node_Id
:= Expr
;
32038 case Nkind
(Pref
) is
32039 when N_Selected_Component
=>
32042 when N_Indexed_Component
=>
32043 if not All_Exps_Known_On_Entry
(Expressions
(Pref
))
32049 return False; -- just to be clear about this case
32055 Pref
:= Prefix
(Pref
);
32058 if Is_Entity_Name
(Pref
)
32059 and then Is_Constant_Object
(Entity
(Pref
))
32062 Obj
: constant Entity_Id
:= Entity
(Pref
);
32063 Obj_Typ
: constant Entity_Id
:= Etype
(Obj
);
32065 case Ekind
(Obj
) is
32066 when E_In_Parameter
=>
32067 if not Is_Elementary_Type
(Obj_Typ
) then
32069 elsif Is_Aliased
(Obj
) then
32074 -- return False for a deferred constant
32075 if Present
(Full_View
(Obj
)) then
32079 -- return False if not "all views are constant".
32080 if Is_Immutably_Limited_Type
(Obj_Typ
)
32081 or Needs_Finalization
(Obj_Typ
)
32094 -- ??? Cope with a malformed tree. Code to cope with a
32095 -- nonstatic use of an enumeration literal should not be
32097 if Is_Entity_Name
(Pref
)
32098 and then Ekind
(Entity
(Pref
)) = E_Enumeration_Literal
32104 case Nkind
(Expr
) is
32106 return Is_Known_On_Entry
(Right_Opnd
(Expr
));
32108 when N_Binary_Op
=>
32109 return Is_Known_On_Entry
(Left_Opnd
(Expr
))
32110 and then Is_Known_On_Entry
(Right_Opnd
(Expr
));
32112 when N_Type_Conversion | N_Qualified_Expression
=>
32113 return Is_Known_On_Entry
(Expression
(Expr
));
32115 when N_If_Expression
=>
32116 if not All_Exps_Known_On_Entry
(Expressions
(Expr
)) then
32120 when N_Case_Expression
=>
32121 if not Is_Known_On_Entry
(Expression
(Expr
)) then
32126 Alt
: Node_Id
:= First
(Alternatives
(Expr
));
32128 while Present
(Alt
) loop
32129 if not Is_Known_On_Entry
(Expression
(Alt
)) then
32143 end Is_Known_On_Entry
;
32145 end Conditional_Evaluation
;
32147 package body Indirect_Temps
is
32149 Indirect_Temp_Access_Type_Char
: constant Character := 'K';
32150 -- The character passed to Make_Temporary when declaring
32151 -- the access type that is used in the implementation of an
32152 -- indirect temporary.
32154 --------------------------
32155 -- Indirect_Temp_Needed --
32156 --------------------------
32158 function Indirect_Temp_Needed
(Typ
: Entity_Id
) return Boolean is
32160 -- There should be no correctness issues if the only cases where
32161 -- this function returns False are cases where Typ is an
32162 -- anonymous access type and we need to generate a saooaaat (a
32163 -- stand-alone object of an anonymous access type) in order get
32164 -- accessibility right. In other cases where this function
32165 -- returns False, there would be no correctness problems with
32166 -- returning True instead; however, returning False when we can
32167 -- generally results in simpler code.
32171 -- If Typ is not definite, then we cannot generate
32174 or else not Is_Definite_Subtype
(Typ
)
32176 -- If Typ is tagged, then generating
32178 -- might generate an object with the wrong tag. If we had
32179 -- a predicate that indicated whether the nominal tag is
32180 -- trustworthy, we could use that predicate here.
32182 or else Is_Tagged_Type
(Typ
)
32184 -- If Typ needs finalization, then generating an implicit
32186 -- declaration could have user-visible side effects.
32188 or else Needs_Finalization
(Typ
)
32190 -- In the anonymous access type case, we need to
32191 -- generate a saooaaat. We don't want the code in
32192 -- in exp_attr.adb that deals with the case where this
32193 -- function returns False to have to deal with that case
32194 -- (just to avoid code duplication). So we cheat a little
32195 -- bit and return True here for an anonymous access type.
32197 or else Is_Anonymous_Access_Type
(Typ
);
32199 -- ??? Unimplemented - spec description says:
32200 -- For an unconstrained-but-definite discriminated subtype,
32201 -- returns True if the potential difference in size between an
32202 -- unconstrained object and a constrained object is large.
32205 -- type Typ (Len : Natural := 0) is
32206 -- record F : String (1 .. Len); end record;
32208 -- See Large_Max_Size_Mutable function elsewhere in this file,
32209 -- currently declared inside of Needs_Secondary_Stack, so it
32210 -- would have to be moved if we want it to be callable from here.
32212 end Indirect_Temp_Needed
;
32214 ---------------------------
32215 -- Declare_Indirect_Temp --
32216 ---------------------------
32218 procedure Declare_Indirect_Temp
32219 (Attr_Prefix
: Node_Id
; Indirect_Temp
: out Entity_Id
)
32221 Loc
: constant Source_Ptr
:= Sloc
(Attr_Prefix
);
32222 Prefix_Type
: constant Entity_Id
:= Etype
(Attr_Prefix
);
32223 Temp_Id
: constant Entity_Id
:=
32224 Make_Temporary
(Loc
, 'P', Attr_Prefix
);
32226 procedure Declare_Indirect_Temp_Via_Allocation
;
32227 -- Handle the usual case.
32229 -------------------------------------------
32230 -- Declare_Indirect_Temp_Via_Allocation --
32231 -------------------------------------------
32233 procedure Declare_Indirect_Temp_Via_Allocation
is
32234 Access_Type_Id
: constant Entity_Id
32236 (Loc
, Indirect_Temp_Access_Type_Char
, Attr_Prefix
);
32238 Temp_Decl
: constant Node_Id
:=
32239 Make_Object_Declaration
(Loc
,
32240 Defining_Identifier
=> Temp_Id
,
32241 Object_Definition
=>
32242 New_Occurrence_Of
(Access_Type_Id
, Loc
));
32244 Allocate_Class_Wide
: constant Boolean :=
32245 Is_Specific_Tagged_Type
(Prefix_Type
);
32246 -- If True then access type designates the class-wide type in
32247 -- order to preserve (at run time) the value of the underlying
32249 -- ??? We could do better here (in the case where Prefix_Type
32250 -- is tagged and specific) if we had a predicate which takes an
32251 -- expression and returns True iff the expression is of
32252 -- a specific tagged type and the underlying tag (at run time)
32253 -- is statically known to match that of the specific type.
32254 -- In that case, Allocate_Class_Wide could safely be False.
32256 function Designated_Subtype_Mark
return Node_Id
;
32257 -- Usually, a subtype mark indicating the subtype of the
32258 -- attribute prefix. If that subtype is a specific tagged
32259 -- type, then returns the corresponding class-wide type.
32260 -- If the prefix is of an anonymous access type, then returns
32261 -- the designated type of that type.
32263 -----------------------------
32264 -- Designated_Subtype_Mark --
32265 -----------------------------
32267 function Designated_Subtype_Mark
return Node_Id
is
32268 Typ
: Entity_Id
:= Prefix_Type
;
32270 if Allocate_Class_Wide
then
32271 if Is_Private_Type
(Typ
)
32272 and then Present
(Full_View
(Typ
))
32274 Typ
:= Full_View
(Typ
);
32276 Typ
:= Class_Wide_Type
(Typ
);
32279 return New_Occurrence_Of
(Typ
, Loc
);
32280 end Designated_Subtype_Mark
;
32282 Access_Type_Def
: constant Node_Id
32283 := Make_Access_To_Object_Definition
32284 (Loc
, Subtype_Indication
=> Designated_Subtype_Mark
);
32286 Access_Type_Decl
: constant Node_Id
32287 := Make_Full_Type_Declaration
32288 (Loc
, Access_Type_Id
,
32289 Type_Definition
=> Access_Type_Def
);
32291 Mutate_Ekind
(Temp_Id
, E_Variable
);
32292 Set_Etype
(Temp_Id
, Access_Type_Id
);
32293 Mutate_Ekind
(Access_Type_Id
, E_Access_Type
);
32295 if Append_Decls_In_Reverse_Order
then
32296 Append_Item
(Temp_Decl
, Is_Eval_Stmt
=> False);
32297 Append_Item
(Access_Type_Decl
, Is_Eval_Stmt
=> False);
32299 Append_Item
(Access_Type_Decl
, Is_Eval_Stmt
=> False);
32300 Append_Item
(Temp_Decl
, Is_Eval_Stmt
=> False);
32303 -- When a type associated with an indirect temporary gets
32304 -- created for a 'Old attribute reference we need to mark
32305 -- the type as such. This allows, for example, finalization
32306 -- masters associated with them to be finalized in the correct
32307 -- order after postcondition checks.
32309 if Attribute_Name
(Parent
(Attr_Prefix
)) = Name_Old
then
32310 Set_Stores_Attribute_Old_Prefix
(Access_Type_Id
);
32313 Analyze
(Access_Type_Decl
);
32314 Analyze
(Temp_Decl
);
32317 (Is_Access_Type_For_Indirect_Temp
(Access_Type_Id
));
32320 Expression
: Node_Id
:= Attr_Prefix
;
32321 Allocator
: Node_Id
;
32323 if Allocate_Class_Wide
then
32324 -- generate T'Class'(T'Class (<prefix>))
32326 Make_Type_Conversion
(Loc
,
32327 Subtype_Mark
=> Designated_Subtype_Mark
,
32328 Expression
=> Expression
);
32332 Make_Allocator
(Loc
,
32333 Make_Qualified_Expression
32335 Subtype_Mark
=> Designated_Subtype_Mark
,
32336 Expression
=> Expression
));
32338 -- Allocate saved prefix value on the secondary stack
32339 -- in order to avoid introducing a storage leak. This
32340 -- allocated object is never explicitly reclaimed.
32342 -- ??? Emit storage leak warning if RE_SS_Pool
32345 if RTE_Available
(RE_SS_Pool
) then
32346 Set_Storage_Pool
(Allocator
, RTE
(RE_SS_Pool
));
32347 Set_Procedure_To_Call
32348 (Allocator
, RTE
(RE_SS_Allocate
));
32349 Set_Uses_Sec_Stack
(Current_Scope
);
32353 (Make_Assignment_Statement
(Loc
,
32354 Name
=> New_Occurrence_Of
(Temp_Id
, Loc
),
32355 Expression
=> Allocator
),
32356 Is_Eval_Stmt
=> True);
32358 end Declare_Indirect_Temp_Via_Allocation
;
32361 Indirect_Temp
:= Temp_Id
;
32363 if Is_Anonymous_Access_Type
(Prefix_Type
) then
32364 -- In the anonymous access type case, we do not want a level
32365 -- indirection (which would result in declaring an
32366 -- access-to-access type); that would result in correctness
32367 -- problems - the accessibility level of the type of the
32368 -- 'Old constant would be wrong (See 6.1.1.). So in that case,
32369 -- we do not generate an allocator. Instead we generate
32370 -- Temp : access Designated := null;
32371 -- which is unconditionally elaborated and then
32372 -- Temp := <attribute prefix>;
32373 -- which is conditionally executed.
32376 Temp_Decl
: constant Node_Id
:=
32377 Make_Object_Declaration
(Loc
,
32378 Defining_Identifier
=> Temp_Id
,
32379 Object_Definition
=>
32380 Make_Access_Definition
32382 Constant_Present
=>
32383 Is_Access_Constant
(Prefix_Type
),
32386 (Designated_Type
(Prefix_Type
), Loc
)));
32388 Append_Item
(Temp_Decl
, Is_Eval_Stmt
=> False);
32389 Analyze
(Temp_Decl
);
32391 (Make_Assignment_Statement
(Loc
,
32392 Name
=> New_Occurrence_Of
(Temp_Id
, Loc
),
32393 Expression
=> Attr_Prefix
),
32394 Is_Eval_Stmt
=> True);
32398 Declare_Indirect_Temp_Via_Allocation
;
32400 end Declare_Indirect_Temp
;
32402 -------------------------
32403 -- Indirect_Temp_Value --
32404 -------------------------
32406 function Indirect_Temp_Value
32409 Loc
: Source_Ptr
) return Node_Id
32413 if Is_Anonymous_Access_Type
(Typ
) then
32414 -- No indirection in this case; just evaluate the temp.
32415 Result
:= New_Occurrence_Of
(Temp
, Loc
);
32416 Set_Etype
(Result
, Etype
(Temp
));
32419 Result
:= Make_Explicit_Dereference
(Loc
,
32420 New_Occurrence_Of
(Temp
, Loc
));
32422 Set_Etype
(Result
, Designated_Type
(Etype
(Temp
)));
32424 if Is_Specific_Tagged_Type
(Typ
) then
32425 -- The designated type of the access type is class-wide, so
32426 -- convert to the specific type.
32429 Make_Type_Conversion
(Loc
,
32430 Subtype_Mark
=> New_Occurrence_Of
(Typ
, Loc
),
32431 Expression
=> Result
);
32433 Set_Etype
(Result
, Typ
);
32438 end Indirect_Temp_Value
;
32440 function Is_Access_Type_For_Indirect_Temp
32441 (T
: Entity_Id
) return Boolean is
32443 if Is_Access_Type
(T
)
32444 and then not Comes_From_Source
(T
)
32445 and then Is_Internal_Name
(Chars
(T
))
32446 and then Nkind
(Scope
(T
)) in N_Entity
32447 and then Ekind
(Scope
(T
))
32448 in E_Entry | E_Entry_Family | E_Function | E_Procedure
32450 (Present
(Postconditions_Proc
(Scope
(T
)))
32451 or else Present
(Contract
(Scope
(T
))))
32453 -- ??? Should define a flag for this. We could incorrectly
32454 -- return True if other clients of Make_Temporary happen to
32455 -- pass in the same character.
32457 Name
: constant String := Get_Name_String
(Chars
(T
));
32459 if Name
(Name
'First) = Indirect_Temp_Access_Type_Char
then
32466 end Is_Access_Type_For_Indirect_Temp
;
32468 end Indirect_Temps
;
32471 package body Storage_Model_Support
is
32473 -----------------------------------------
32474 -- Has_Designated_Storage_Model_Aspect --
32475 -----------------------------------------
32477 function Has_Designated_Storage_Model_Aspect
32478 (Typ
: Entity_Id
) return Boolean
32481 return Present
(Find_Aspect
(Typ
, Aspect_Designated_Storage_Model
));
32482 end Has_Designated_Storage_Model_Aspect
;
32484 -----------------------------------
32485 -- Has_Storage_Model_Type_Aspect --
32486 -----------------------------------
32488 function Has_Storage_Model_Type_Aspect
(Typ
: Entity_Id
) return Boolean
32491 return Present
(Find_Aspect
(Typ
, Aspect_Storage_Model_Type
));
32492 end Has_Storage_Model_Type_Aspect
;
32494 --------------------------
32495 -- Storage_Model_Object --
32496 --------------------------
32498 function Storage_Model_Object
(Typ
: Entity_Id
) return Entity_Id
is
32500 pragma Assert
(Has_Designated_Storage_Model_Aspect
(Typ
));
32504 (Find_Value_Of_Aspect
(Typ
, Aspect_Designated_Storage_Model
));
32505 end Storage_Model_Object
;
32507 ------------------------
32508 -- Storage_Model_Type --
32509 ------------------------
32511 function Storage_Model_Type
(Obj
: Entity_Id
) return Entity_Id
is
32513 pragma Assert
(Has_Storage_Model_Type_Aspect
(Etype
(Obj
)));
32515 return Etype
(Obj
);
32516 end Storage_Model_Type
;
32518 -----------------------------------
32519 -- Get_Storage_Model_Type_Entity --
32520 -----------------------------------
32522 function Get_Storage_Model_Type_Entity
32523 (SM_Obj_Or_Type
: Entity_Id
;
32524 Nam
: Name_Id
) return Entity_Id
32526 Typ
: constant Entity_Id
:= (if Is_Object
(SM_Obj_Or_Type
) then
32527 Storage_Model_Type
(SM_Obj_Or_Type
)
32533 Nam
in Name_Address_Type
32534 | Name_Null_Address
32539 | Name_Storage_Size
);
32542 SMT_Aspect_Value
: constant Node_Id
:=
32543 Find_Value_Of_Aspect
(Typ
, Aspect_Storage_Model_Type
);
32546 pragma Assert
(Present
(SMT_Aspect_Value
));
32548 Assoc
:= First
(Component_Associations
(SMT_Aspect_Value
));
32549 while Present
(Assoc
) loop
32550 if Chars
(First
(Choices
(Assoc
))) = Nam
then
32551 return Entity
(Expression
(Assoc
));
32558 end Get_Storage_Model_Type_Entity
;
32560 --------------------------------
32561 -- Storage_Model_Address_Type --
32562 --------------------------------
32564 function Storage_Model_Address_Type
32565 (SM_Obj_Or_Type
: Entity_Id
) return Entity_Id
32569 Get_Storage_Model_Type_Entity
(SM_Obj_Or_Type
, Name_Address_Type
);
32570 end Storage_Model_Address_Type
;
32572 --------------------------------
32573 -- Storage_Model_Null_Address --
32574 --------------------------------
32576 function Storage_Model_Null_Address
32577 (SM_Obj_Or_Type
: Entity_Id
) return Entity_Id
32581 Get_Storage_Model_Type_Entity
(SM_Obj_Or_Type
, Name_Null_Address
);
32582 end Storage_Model_Null_Address
;
32584 ----------------------------
32585 -- Storage_Model_Allocate --
32586 ----------------------------
32588 function Storage_Model_Allocate
32589 (SM_Obj_Or_Type
: Entity_Id
) return Entity_Id
32592 return Get_Storage_Model_Type_Entity
(SM_Obj_Or_Type
, Name_Allocate
);
32593 end Storage_Model_Allocate
;
32595 ------------------------------
32596 -- Storage_Model_Deallocate --
32597 ------------------------------
32599 function Storage_Model_Deallocate
32600 (SM_Obj_Or_Type
: Entity_Id
) return Entity_Id
32604 Get_Storage_Model_Type_Entity
(SM_Obj_Or_Type
, Name_Deallocate
);
32605 end Storage_Model_Deallocate
;
32607 -----------------------------
32608 -- Storage_Model_Copy_From --
32609 -----------------------------
32611 function Storage_Model_Copy_From
32612 (SM_Obj_Or_Type
: Entity_Id
) return Entity_Id
32615 return Get_Storage_Model_Type_Entity
(SM_Obj_Or_Type
, Name_Copy_From
);
32616 end Storage_Model_Copy_From
;
32618 ---------------------------
32619 -- Storage_Model_Copy_To --
32620 ---------------------------
32622 function Storage_Model_Copy_To
32623 (SM_Obj_Or_Type
: Entity_Id
) return Entity_Id
32626 return Get_Storage_Model_Type_Entity
(SM_Obj_Or_Type
, Name_Copy_To
);
32627 end Storage_Model_Copy_To
;
32629 --------------------------------
32630 -- Storage_Model_Storage_Size --
32631 --------------------------------
32633 function Storage_Model_Storage_Size
32634 (SM_Obj_Or_Type
: Entity_Id
) return Entity_Id
32638 Get_Storage_Model_Type_Entity
(SM_Obj_Or_Type
, Name_Storage_Size
);
32639 end Storage_Model_Storage_Size
;
32641 end Storage_Model_Support
;
32644 Erroutc
.Subprogram_Name_Ptr
:= Subprogram_Name
'Access;